X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=d2f53dec1d4a9e415215f586f521f1d88e59e063;hb=ac10f8408520a30e8437496d320b8b86afda2e8f;hp=b008bbe248cb9aefc91adce80d673f430c00194c;hpb=e6d89fbd617bbdd60544c752835c2e1f8d146b57;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index b008bbe..d2f53de 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -11,50 +11,57 @@ module TcTyClsDecls ( #include "HsVersions.h" import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..), - ConDecl(..), Sig(..), , NewOrData(..), - tyClDeclTyVars, isSynDecl, LConDecl, - LTyClDecl, tcdName, LHsTyVarBndr, LHsContext + ConDecl(..), Sig(..), , NewOrData(..), ResType(..), + tyClDeclTyVars, isSynDecl, hsConArgs, + LTyClDecl, tcdName, hsTyVarName, LHsTyVarBndr ) import HsTypes ( HsBang(..), getBangStrictness ) import BasicTypes ( RecFlag(..), StrictnessMark(..) ) -import HscTypes ( implicitTyThings ) +import HscTypes ( implicitTyThings, ModDetails ) import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon, mkDataTyConRhs, mkNewTyConRhs ) import TcRnMonad import TcEnv ( TyThing(..), tcLookupLocated, tcLookupLocatedGlobal, - tcExtendGlobalEnv, tcExtendKindEnv, + tcExtendGlobalEnv, tcExtendKindEnv, tcExtendKindEnvTvs, tcExtendRecEnv, tcLookupTyVar ) import TcTyDecls ( calcTyConArgVrcs, calcRecFlags, calcClassCycles, calcSynCycles ) import TcClassDcl ( tcClassSigs, tcAddDeclCtxt ) import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType, kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext, - kcHsSigType, tcHsBangType, tcLHsConSig, tcDataKindSig ) -import TcMType ( newKindVar, checkValidTheta, checkValidType, checkFreeness, + kcHsSigType, tcHsBangType, tcLHsConResTy, tcDataKindSig ) +import TcMType ( newKindVar, checkValidTheta, checkValidType, + -- checkFreeness, UserTypeCtxt(..), SourceTyCtxt(..) ) -import TcUnify ( unifyKind ) -import TcType ( TcKind, ThetaType, TcType, tyVarsOfType, - mkArrowKind, liftedTypeKind, mkTyVarTys, tcEqTypes, - tcSplitSigmaTy, tcEqType ) -import Type ( splitTyConApp_maybe, pprThetaArrow, pprParendType ) +import TcType ( TcKind, TcType, tyVarsOfType, mkPhiTy, + mkArrowKind, liftedTypeKind, mkTyVarTys, + tcSplitSigmaTy, tcEqTypes, tcGetTyVar_maybe ) +import Type ( splitTyConApp_maybe, + -- pprParendType, pprThetaArrow + ) +import Kind ( mkArrowKinds, splitKindFunTys ) import Generics ( validGenericMethodType, canDoGenerics ) import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars ) -import TyCon ( TyCon, ArgVrcs, +import TyCon ( TyCon, ArgVrcs, AlgTyConRhs( AbstractTyCon ), tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon, - tyConStupidTheta, getSynTyConDefn, isSynTyCon, tyConName ) -import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig, - dataConFieldLabels, dataConOrigArgTys, dataConTyCon ) -import Type ( zipTopTvSubst, substTys ) + tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName ) +import DataCon ( DataCon, dataConWrapId, dataConName, + dataConFieldLabels, dataConTyCon, + dataConTyVars, dataConFieldType, dataConResTys ) import Var ( TyVar, idType, idName ) -import VarSet ( elemVarSet ) -import Name ( Name ) +import VarSet ( elemVarSet, mkVarSet ) +import Name ( Name, getSrcLoc ) import Outputable +import Maybe ( isJust, fromJust ) +import Unify ( tcMatchTys, tcMatchTyX ) import Util ( zipLazy, isSingleton, notNull, sortLe ) import List ( partition ) -import SrcLoc ( Located(..), unLoc, getLoc ) +import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan ) import ListSetOps ( equivClasses ) +import List ( delete ) import Digraph ( SCC(..) ) -import CmdLineOpts ( DynFlag( Opt_GlasgowExts, Opt_Generics, Opt_UnboxStrictFields ) ) +import DynFlags ( DynFlag( Opt_GlasgowExts, Opt_Generics, + Opt_UnboxStrictFields ) ) \end{code} @@ -108,15 +115,15 @@ The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to @TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s. \begin{code} -tcTyAndClassDecls :: [Name] -> [LTyClDecl Name] +tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name] -> TcM TcGblEnv -- Input env extended by types and classes -- and their implicit Ids,DataCons -tcTyAndClassDecls boot_names decls +tcTyAndClassDecls boot_details decls = do { -- First check for cyclic type synonysm or classes -- See notes with checkCycleErrs checkCycleErrs decls ; mod <- getModule - ; traceTc (text "tcTyAndCl" <+> ppr mod <+> ppr boot_names) + ; traceTc (text "tcTyAndCl" <+> ppr mod) ; (syn_tycons, alg_tyclss) <- fixM (\ ~(rec_syn_tycons, rec_alg_tyclss) -> do { let { -- Calculate variances and rec-flag ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls } @@ -134,7 +141,7 @@ tcTyAndClassDecls boot_names decls { (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls ; let { calc_vrcs = calcTyConArgVrcs (rec_syn_tycons ++ rec_alg_tyclss) - ; calc_rec = calcRecFlags boot_names rec_alg_tyclss + ; calc_rec = calcRecFlags boot_details rec_alg_tyclss ; tc_decl = addLocM (tcTyClDecl calc_vrcs calc_rec) } -- Type-check the type synonyms, and extend the envt ; syn_tycons <- tcSynDecls calc_vrcs kc_syn_decls @@ -228,10 +235,22 @@ kcTyClDecls syn_decls alg_decls ------------------------------------------------------------------------ getInitialKind :: LTyClDecl Name -> TcM (Name, TcKind) +-- Only for data type and class declarations +-- Get as much info as possible from the data or class decl, +-- so as to maximise usefulness of error messages +getInitialKind (L _ decl) + = do { arg_kinds <- mapM (mk_arg_kind . unLoc) (tyClDeclTyVars decl) + ; res_kind <- mk_res_kind decl + ; return (tcdName decl, mkArrowKinds arg_kinds res_kind) } + where + mk_arg_kind (UserTyVar _) = newKindVar + mk_arg_kind (KindedTyVar _ kind) = return kind + + mk_res_kind (TyData { tcdKindSig = Just kind }) = return kind + -- On GADT-style declarations we allow a kind signature + -- data T :: *->* where { ... } + mk_res_kind other = return liftedTypeKind -getInitialKind decl - = newKindVar `thenM` \ kind -> - returnM (unLoc (tcdLName (unLoc decl)), kind) ---------------- kcSynDecls :: [SCC (LTyClDecl Name)] @@ -263,6 +282,8 @@ kcSynDecl (CyclicSCC decls) = do { recSynErr decls; failM } -- Fail here to avoid error cascade -- of out-of-scope tycons +kindedTyVarKind (L _ (KindedTyVar _ k)) = k + ------------------------------------------------------------------------ kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name) -- Not used for type synonyms (see kcSynDecl) @@ -273,14 +294,14 @@ kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) ; cons' <- mappM (wrapLocM kc_con_decl) cons ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdCons = cons'}) } where - kc_con_decl (ConDecl name ex_tvs ex_ctxt details) - = kcHsTyVars ex_tvs $ \ ex_tvs' -> - do { ex_ctxt' <- kcHsContext ex_ctxt - ; details' <- kc_con_details details - ; return (ConDecl name ex_tvs' ex_ctxt' details')} - kc_con_decl (GadtDecl name ty) - = do { ty' <- kcHsSigType ty - ; return (GadtDecl name ty') } + kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res) = do + kcHsTyVars ex_tvs $ \ex_tvs' -> do + ex_ctxt' <- kcHsContext ex_ctxt + details' <- kc_con_details details + res' <- case res of + ResTyH98 -> return ResTyH98 + ResTyGADT ty -> return . ResTyGADT =<< kcHsSigType ty + return (ConDecl name expl ex_tvs' ex_ctxt' details' res') kc_con_details (PrefixCon btys) = do { btys' <- mappM kc_larg_ty btys ; return (PrefixCon btys') } @@ -300,12 +321,14 @@ kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs}) = kcTyClDeclBody decl $ \ tvs' -> - do { ctxt' <- kcHsContext ctxt + do { is_boot <- tcIsHsBoot + ; checkTc (not is_boot) badBootClassDeclErr + ; ctxt' <- kcHsContext ctxt ; sigs' <- mappM (wrapLocM kc_sig) sigs ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs'}) } where - kc_sig (Sig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty - ; return (Sig nm op_ty') } + kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty + ; return (TypeSig nm op_ty') } kc_sig other_sig = return other_sig kcTyClDecl decl@(ForeignType {}) @@ -314,25 +337,21 @@ kcTyClDecl decl@(ForeignType {}) kcTyClDeclBody :: TyClDecl Name -> ([LHsTyVarBndr Name] -> TcM a) -> TcM a - -- Extend the env with bindings for the tyvars, taken from - -- the kind of the tycon/class. Give it to the thing inside, and - -- check the result kind matches +-- getInitialKind has made a suitably-shaped kind for the type or class +-- Unpack it, and attribute those kinds to the type variables +-- Extend the env with bindings for the tyvars, taken from +-- the kind of the tycon/class. Give it to the thing inside, and + -- check the result kind matches kcTyClDeclBody decl thing_inside = tcAddDeclCtxt decl $ - kcHsTyVars (tyClDeclTyVars decl) $ \ kinded_tvs -> do { tc_ty_thing <- tcLookupLocated (tcdLName decl) - ; let tc_kind = case tc_ty_thing of { AThing k -> k } - ; unifyKind tc_kind (foldr (mkArrowKind . kindedTyVarKind) - (result_kind decl) - kinded_tvs) - ; thing_inside kinded_tvs } - where - result_kind (TyData { tcdKindSig = Just kind }) = kind - result_kind other = liftedTypeKind - -- On GADT-style declarations we allow a kind signature - -- data T :: *->* where { ... } - -kindedTyVarKind (L _ (KindedTyVar _ k)) = k + ; let tc_kind = case tc_ty_thing of { AThing k -> k } + (kinds, _) = splitKindFunTys tc_kind + hs_tvs = tcdTyVars decl + kinded_tvs = ASSERT( length kinds >= length hs_tvs ) + [ L loc (KindedTyVar (hsTyVarName tv) k) + | (L loc tv, k) <- zip hs_tvs kinds] + ; tcExtendKindEnvTvs kinded_tvs (thing_inside kinded_tvs) } \end{code} @@ -370,19 +389,37 @@ tcTyClDecl1 calc_vrcs calc_isrec = tcTyVarBndrs tvs $ \ tvs' -> do { extra_tvs <- tcDataKindSig mb_ksig ; let final_tvs = tvs' ++ extra_tvs - ; stupid_theta <- tcStupidTheta ctxt cons + ; stupid_theta <- tcHsKindedContext ctxt ; want_generic <- doptM Opt_Generics - ; tycon <- fixM (\ tycon -> do - { unbox_strict <- doptM Opt_UnboxStrictFields - ; gla_exts <- doptM Opt_GlasgowExts - ; checkTc (gla_exts || h98_syntax) (badGadtDecl tc_name) + ; unbox_strict <- doptM Opt_UnboxStrictFields + ; gla_exts <- doptM Opt_GlasgowExts + ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? + + -- Check that we don't use GADT syntax in H98 world + ; checkTc (gla_exts || h98_syntax) (badGadtDecl tc_name) + + -- Check that there's at least one condecl, + -- or else we're reading an interface file, or -fglasgow-exts + ; checkTc (not (null cons) || gla_exts || is_boot) + (emptyConDeclsErr tc_name) + + -- Check that a newtype has exactly one constructor + ; checkTc (new_or_data == DataType || isSingleton cons) + (newtypeConError tc_name (length cons)) - ; data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data tycon final_tvs)) cons - ; let tc_rhs = case new_or_data of - DataType -> mkDataTyConRhs stupid_theta data_cons + ; tycon <- fixM (\ tycon -> do + { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data + tycon final_tvs)) + cons + ; let tc_rhs + | null cons && is_boot -- In a hs-boot file, empty cons means + = AbstractTyCon -- "don't know"; hence Abstract + | otherwise + = case new_or_data of + DataType -> mkDataTyConRhs data_cons NewType -> ASSERT( isSingleton data_cons ) mkNewTyConRhs tycon (head data_cons) - ; buildAlgTyCon tc_name final_tvs tc_rhs arg_vrcs is_rec + ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs arg_vrcs is_rec (want_generic && canDoGenerics data_cons) }) ; return (ATyCon tycon) @@ -391,7 +428,7 @@ tcTyClDecl1 calc_vrcs calc_isrec arg_vrcs = calc_vrcs tc_name is_rec = calc_isrec tc_name h98_syntax = case cons of -- All constructors have same shape - L _ (GadtDecl {}) : _ -> False + L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False other -> True tcTyClDecl1 calc_vrcs calc_isrec @@ -429,80 +466,76 @@ tcConDecl :: Bool -- True <=> -funbox-strict_fields -> ConDecl Name -> TcM DataCon tcConDecl unbox_strict NewType tycon tc_tvs -- Newtypes - (ConDecl name ex_tvs ex_ctxt details) - = ASSERT( null ex_tvs && null (unLoc ex_ctxt) ) - do { let tc_datacon field_lbls arg_ty + (ConDecl name _ ex_tvs ex_ctxt details ResTyH98) + = do { let tc_datacon field_lbls arg_ty = do { arg_ty' <- tcHsKindedType arg_ty -- No bang on newtype ; buildDataCon (unLoc name) False {- Prefix -} True {- Vanilla -} [NotMarkedStrict] (map unLoc field_lbls) tc_tvs [] [arg_ty'] tycon (mkTyVarTys tc_tvs) } + + -- Check that a newtype has no existential stuff + ; checkTc (null ex_tvs && null (unLoc ex_ctxt)) (newtypeExError name) + ; case details of PrefixCon [arg_ty] -> tc_datacon [] arg_ty - RecCon [(field_lbl, arg_ty)] -> tc_datacon [field_lbl] arg_ty } + RecCon [(field_lbl, arg_ty)] -> tc_datacon [field_lbl] arg_ty + other -> failWithTc (newtypeFieldErr name (length (hsConArgs details))) + -- Check that the constructor has exactly one field + } -tcConDecl unbox_strict DataType tycon tc_tvs -- Ordinary data types - (ConDecl name ex_tvs ex_ctxt details) - = tcTyVarBndrs ex_tvs $ \ ex_tvs' -> do - { ex_ctxt' <- tcHsKindedContext ex_ctxt +tcConDecl unbox_strict DataType tycon tc_tvs -- Data types + (ConDecl name _ tvs ctxt details res_ty) + = tcTyVarBndrs tvs $ \ tvs' -> do + { ctxt' <- tcHsKindedContext ctxt + ; (data_tc, res_ty_args) <- tcResultType tycon tc_tvs res_ty ; let - is_vanilla = null ex_tvs && null (unLoc ex_ctxt) - -- Vanilla iff no ex_tvs and no context - -- Must check the context too because of - -- implicit params; e.g. - -- data T = (?x::Int) => MkT Int + con_tvs = case res_ty of + ResTyH98 -> tc_tvs ++ tvs' + ResTyGADT _ -> tryVanilla tvs' res_ty_args + + -- Vanilla iff result type matches the quantified vars exactly, + -- and there is no existential context + -- Must check the context too because of implicit params; e.g. + -- data T = (?x::Int) => MkT Int + is_vanilla = res_ty_args `tcEqTypes` mkTyVarTys con_tvs + && null (unLoc ctxt) tc_datacon is_infix field_lbls btys - = do { let { bangs = map getBangStrictness btys } + = do { let bangs = map getBangStrictness btys ; arg_tys <- mappM tcHsBangType btys ; buildDataCon (unLoc name) is_infix is_vanilla (argStrictness unbox_strict tycon bangs arg_tys) (map unLoc field_lbls) - (tc_tvs ++ ex_tvs') - ex_ctxt' - arg_tys - tycon (mkTyVarTys tc_tvs) } + con_tvs ctxt' arg_tys + data_tc res_ty_args } + -- NB: we put data_tc, the type constructor gotten from the constructor + -- type signature into the data constructor; that way + -- checkValidDataCon can complain if it's wrong. + ; case details of PrefixCon btys -> tc_datacon False [] btys - InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2] - RecCon fields -> do { checkTc (null ex_tvs) (exRecConErr name) - -- It's ok to have an implicit-parameter context - -- for the data constructor, provided it binds - -- no type variables - ; let { (field_names, btys) = unzip fields } - ; tc_datacon False field_names btys } } - -tcConDecl unbox_strict DataType tycon tc_tvs -- GADTs - decl@(GadtDecl name con_ty) - = do { traceTc (text "tcConDecl" <+> ppr name) - ; (tvs, theta, bangs, arg_tys, tc, res_tys) <- tcLHsConSig con_ty - - ; traceTc (text "tcConDecl1" <+> ppr name) - ; let -- Now dis-assemble the type, and check its form - is_vanilla = null theta && mkTyVarTys tvs `tcEqTypes` res_tys - - -- Vanilla datacons guarantee to use the same - -- type variables as the parent tycon - (tvs', arg_tys', res_tys') - | is_vanilla = (tc_tvs, substTys subst arg_tys, substTys subst res_tys) - | otherwise = (tvs, arg_tys, res_tys) - subst = zipTopTvSubst tvs (mkTyVarTys tc_tvs) - - ; traceTc (text "tcConDecl3" <+> ppr name) - ; buildDataCon (unLoc name) False {- Not infix -} is_vanilla - (argStrictness unbox_strict tycon bangs arg_tys) - [{- No field labels -}] - tvs' theta arg_tys' tycon res_tys' } + InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2] + RecCon fields -> tc_datacon False field_names btys + where + (field_names, btys) = unzip fields + + } + +tcResultType :: TyCon -> [TyVar] -> ResType Name -> TcM (TyCon, [TcType]) +tcResultType tycon tvs ResTyH98 = return (tycon, mkTyVarTys tvs) +tcResultType _ _ (ResTyGADT res_ty) = tcLHsConResTy res_ty + +tryVanilla :: [TyVar] -> [TcType] -> [TyVar] +-- (tryVanilla tvs tys) returns a permutation of tvs. +-- It tries to re-order the tvs so that it exactly +-- matches the [Type], if that is possible +tryVanilla tvs (ty:tys) | Just tv <- tcGetTyVar_maybe ty -- The type is a tyvar + , tv `elem` tvs -- That tyvar is in the list + = tv : tryVanilla (delete tv tvs) tys +tryVanilla tvs tys = tvs -- Fall through case -------------------- -tcStupidTheta :: LHsContext Name -> [LConDecl Name] -> TcM (Maybe ThetaType) --- For GADTs we don't allow a context on the data declaration --- whereas for standard Haskell style data declarations, we do -tcStupidTheta ctxt (L _ (ConDecl _ _ _ _) : _) - = do { theta <- tcHsKindedContext ctxt; return (Just theta) } -tcStupidTheta ctxt other -- Includes an empty constructor list - = ASSERT( null (unLoc ctxt) ) return Nothing ------------------- argStrictness :: Bool -- True <=> -funbox-strict_fields @@ -565,6 +598,13 @@ checkValidTyCl decl } ------------------------- +-- For data types declared with record syntax, we require +-- that each constructor that has a field 'f' +-- (a) has the same result type +-- (b) has the same type for 'f' +-- module alpha conversion of the quantified type variables +-- of the constructor. + checkValidTyCon :: TyCon -> TcM () checkValidTyCon tc | isSynTyCon tc @@ -580,29 +620,56 @@ checkValidTyCon tc mappM_ check_fields groups where - syn_ctxt = TySynCtxt name - name = tyConName tc - (_, syn_rhs) = getSynTyConDefn tc - data_cons = tyConDataCons tc + syn_ctxt = TySynCtxt name + name = tyConName tc + syn_rhs = synTyConRhs tc + data_cons = tyConDataCons tc groups = equivClasses cmp_fld (concatMap get_fields data_cons) cmp_fld (f1,_) (f2,_) = f1 `compare` f2 - get_fields con = dataConFieldLabels con `zip` dataConOrigArgTys con + get_fields con = dataConFieldLabels con `zip` repeat con -- dataConFieldLabels may return the empty list, which is fine - check_fields fields@((first_field_label, field_ty) : other_fields) + -- XXX - autrijus - Make this far more complex to acommodate + -- for different return types. Add res_ty to the mix, + -- comparing them in two steps, all for good error messages. + -- Plan: Use Unify.tcMatchTys to compare the first candidate's + -- result type against other candidates' types (check bothways). + -- If they magically agrees, take the substitution and + -- apply them to the latter ones, and see if they match perfectly. + -- check_fields fields@((first_field_label, field_ty) : other_fields) + check_fields fields@((label, con1) : other_fields) -- These fields all have the same name, but are from -- different constructors in the data type - = -- Check that all the fields in the group have the same type + = recoverM (return ()) $ mapM_ checkOne other_fields + -- Check that all the fields in the group have the same type -- NB: this check assumes that all the constructors of a given -- data type use the same type variables - checkTc (all (tcEqType field_ty . snd) other_fields) - (fieldTypeMisMatch first_field_label) + where + tvs1 = mkVarSet (dataConTyVars con1) + res1 = dataConResTys con1 + fty1 = dataConFieldType con1 label + + checkOne (_, con2) -- Do it bothways to ensure they are structurally identical + = do { checkFieldCompat label con1 con2 tvs1 res1 res2 fty1 fty2 + ; checkFieldCompat label con2 con1 tvs2 res2 res1 fty2 fty1 } + where + tvs2 = mkVarSet (dataConTyVars con2) + res2 = dataConResTys con2 + fty2 = dataConFieldType con2 label + +checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2 + = do { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2) + ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) } + where + mb_subst1 = tcMatchTys tvs1 res1 res2 + mb_subst2 = tcMatchTyX tvs1 (fromJust mb_subst1) fty1 fty2 ------------------------------- checkValidDataCon :: TyCon -> DataCon -> TcM () checkValidDataCon tc con - = addErrCtxt (dataConCtxt con) $ + = setSrcSpan (srcLocSpan (getSrcLoc con)) $ + addErrCtxt (dataConCtxt con) $ do { checkTc (dataConTyCon con == tc) (badDataConTyCon con) ; checkValidType ctxt (idType (dataConWrapId con)) } @@ -631,7 +698,7 @@ checkValidClass cls ; checkValidTheta (ClassSCCtxt (className cls)) theta -- Check the class operations - ; mappM_ check_op op_stuff + ; mappM_ (check_op gla_exts) op_stuff -- Check that if the class has generic methods, then the -- class has only one parameter. We can't do generic @@ -643,7 +710,7 @@ checkValidClass cls unary = isSingleton tyvars no_generics = null [() | (_, GenDefMeth) <- op_stuff] - check_op (sel_id, dm) + check_op gla_exts (sel_id, dm) = addErrCtxt (classOpCtxt sel_id tau) $ do { checkValidTheta SigmaCtxt (tail theta) -- The 'tail' removes the initial (C a) from the @@ -664,29 +731,28 @@ checkValidClass cls where op_name = idName sel_id op_ty = idType sel_id - (_,theta,tau) = tcSplitSigmaTy op_ty - + (_,theta1,tau1) = tcSplitSigmaTy op_ty + (_,theta2,tau2) = tcSplitSigmaTy tau1 + (theta,tau) | gla_exts = (theta1 ++ theta2, tau2) + | otherwise = (theta1, mkPhiTy (tail theta1) tau1) + -- Ugh! The function might have a type like + -- op :: forall a. C a => forall b. (Eq b, Eq a) => tau2 + -- With -fglasgow-exts, we want to allow this, even though the inner + -- forall has an (Eq a) constraint. Whereas in general, each constraint + -- in the context of a for-all must mention at least one quantified + -- type variable. What a mess! --------------------------------------------------------------------- -fieldTypeMisMatch field_name - = sep [ptext SLIT("Different constructors give different types for field"), quotes (ppr field_name)] +resultTypeMisMatch field_name con1 con2 + = vcat [sep [ptext SLIT("Constructors") <+> ppr con1 <+> ptext SLIT("and") <+> ppr con2, + ptext SLIT("have a common field") <+> quotes (ppr field_name) <> comma], + nest 2 $ ptext SLIT("but have different result types")] +fieldTypeMisMatch field_name con1 con2 + = sep [ptext SLIT("Constructors") <+> ppr con1 <+> ptext SLIT("and") <+> ppr con2, + ptext SLIT("give different types for field"), quotes (ppr field_name)] -dataConCtxt con = sep [ptext SLIT("When checking the data constructor:"), - nest 2 (ex_part <+> pprThetaArrow ex_theta <+> ppr con <+> arg_part)] - where - (ex_tvs, ex_theta, arg_tys, _, _) = dataConSig con - ex_part | null ex_tvs = empty - | otherwise = ptext SLIT("forall") <+> hsep (map ppr ex_tvs) <> dot - -- The 'ex_theta' part could be non-empty, if the user (bogusly) wrote - -- data T a = Eq a => T a a - -- So we make sure to print it - - fields = dataConFieldLabels con - arg_part | null fields = sep (map pprParendType arg_tys) - | otherwise = braces (sep (punctuate comma - [ ppr n <+> dcolon <+> ppr ty - | (n,ty) <- fields `zip` arg_tys])) +dataConCtxt con = ptext SLIT("In the definition of data constructor") <+> quotes (ppr con) classOpCtxt sel_id tau = sep [ptext SLIT("When checking the class method:"), nest 2 (ppr sel_id <+> dcolon <+> ppr tau)] @@ -733,16 +799,30 @@ sortLocated things = sortLe le things where le (L l1 _) (L l2 _) = l1 <= l2 -exRecConErr name - = ptext SLIT("Can't combine named fields with locally-quantified type variables or context") - $$ - (ptext SLIT("In the declaration of data constructor") <+> ppr name) - badDataConTyCon data_con - = hang (ptext SLIT("Data constructor does not return its parent type:")) - 2 (ppr data_con) + = hang (ptext SLIT("Data constructor") <+> quotes (ppr data_con) <+> + ptext SLIT("returns type") <+> quotes (ppr (dataConTyCon data_con))) + 2 (ptext SLIT("instead of its parent type")) badGadtDecl tc_name = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name) , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow GADTs")) ] + +newtypeConError tycon n + = sep [ptext SLIT("A newtype must have exactly one constructor,"), + nest 2 $ ptext SLIT("but") <+> quotes (ppr tycon) <+> ptext SLIT("has") <+> speakN n ] + +newtypeExError con + = sep [ptext SLIT("A newtype constructor cannot have an existential context,"), + nest 2 $ ptext SLIT("but") <+> quotes (ppr con) <+> ptext SLIT("does")] + +newtypeFieldErr con_name n_flds + = sep [ptext SLIT("The constructor of a newtype must have exactly one field"), + nest 2 $ ptext SLIT("but") <+> quotes (ppr con_name) <+> ptext SLIT("has") <+> speakN n_flds] + +emptyConDeclsErr tycon + = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"), + nest 2 $ ptext SLIT("(-fglasgow-exts permits this)")] + +badBootClassDeclErr = ptext SLIT("Illegal class declaration in hs-boot file") \end{code}