X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=c959233d6e45eef86d75f156e530fc879dddc75d;hp=8af4e852aff5869f297e8d306d3cd2d4b20c2adb;hb=1fa3580c54985d73178d1d396b897176a57cd7f3;hpb=e32edb4c18349c30c91c6db189ff345840bce322 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 8af4e85..c959233 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -31,6 +31,7 @@ import Generics import Class import TyCon import DataCon +import Id import Var import VarSet import Name @@ -44,6 +45,7 @@ import SrcLoc import ListSetOps import Digraph import DynFlags +import FastString import Data.List import Control.Monad ( mplus ) @@ -133,8 +135,12 @@ indeed type families). I think. tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name] -> TcM TcGblEnv -- Input env extended by types and classes -- and their implicit Ids,DataCons +-- Fails if there are any errors + tcTyAndClassDecls boot_details allDecls - = do { -- Omit instances of type families; they are handled together + = checkNoErrs $ -- The code recovers internally, but if anything gave rise to + -- an error we'd better stop now, to avoid a cascade + do { -- Omit instances of type families; they are handled together -- with the *heads* of class instances ; let decls = filter (not . isFamInstDecl . unLoc) allDecls @@ -143,7 +149,7 @@ tcTyAndClassDecls boot_details allDecls ; checkCycleErrs decls ; mod <- getModule ; traceTc (text "tcTyAndCl" <+> ppr mod) - ; (syn_tycons, alg_tyclss) <- fixM (\ ~(rec_syn_tycons, rec_alg_tyclss) -> + ; (syn_tycons, alg_tyclss) <- fixM (\ ~(_rec_syn_tycons, rec_alg_tyclss) -> do { let { -- Seperate ordinary synonyms from all other type and -- class declarations and add all associated type -- declarations from type classes. The latter is @@ -175,7 +181,7 @@ tcTyAndClassDecls boot_details allDecls ; tcExtendGlobalEnv syn_tycons $ do -- Type-check the data types and classes - { alg_tyclss <- mappM tc_decl kc_alg_decls + { alg_tyclss <- mapM tc_decl kc_alg_decls ; return (syn_tycons, concat alg_tyclss) }}}) -- Finished with knot-tying now @@ -184,7 +190,7 @@ tcTyAndClassDecls boot_details allDecls -- Perform the validity check { traceTc (text "ready for validity check") - ; mappM_ (addLocM checkValidTyCl) decls + ; mapM_ (addLocM checkValidTyCl) decls ; traceTc (text "done") -- Add the implicit things; @@ -219,6 +225,10 @@ mkGlobalThings decls things = (name, AClass cl) mk_thing (L _ decl, ~(ATyCon tc)) = (tcdName decl, ATyCon tc) +#if __GLASGOW_HASKELL__ < 605 +-- Old GHCs don't understand that ~... matches anything + mk_thing _ = panic "mkGlobalThings: Can't happen" +#endif \end{code} @@ -237,21 +247,24 @@ GADTs). tcFamInstDecl :: LTyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error tcFamInstDecl (L loc decl) = -- Prime error recovery, set source location - recoverM (returnM Nothing) $ + recoverM (return Nothing) $ setSrcSpan loc $ tcAddDeclCtxt decl $ - do { -- type families require -ftype-families and can't be in an + do { -- type families require -XTypeFamilies and can't be in an -- hs-boot file ; type_families <- doptM Opt_TypeFamilies ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? ; checkTc type_families $ badFamInstDecl (tcdLName decl) ; checkTc (not is_boot) $ badBootFamInstDeclErr - -- perform kind and type checking - ; tcFamInstDecl1 decl + -- Perform kind and type checking + ; tc <- tcFamInstDecl1 decl + ; checkValidTyCon tc -- Remember to check validity; + -- no recursion to worry about here + ; return (Just (ATyCon tc)) } -tcFamInstDecl1 :: TyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error +tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon -- "type instance" tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) @@ -263,26 +276,24 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) ; -- (1) kind check the right-hand side of the type equation ; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind + -- we need the exact same number of type parameters as the family + -- declaration + ; let famArity = tyConArity family + ; checkTc (length k_typats == famArity) $ + wrongNumberOfParmsErr famArity + -- (2) type check type equation ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars - ; t_typats <- mappM tcHsKindedType k_typats + ; t_typats <- mapM tcHsKindedType k_typats ; t_rhs <- tcHsKindedType k_rhs - -- (3) check that - -- - left-hand side contains no type family applications - -- (vanilla synonyms are fine, though) - ; mappM_ checkTyFamFreeness t_typats - - -- - the right-hand side is a tau type - ; unless (isTauTy t_rhs) $ - addErr (polyTyErr t_rhs) + -- (3) check the well-formedness of the instance + ; checkValidTypeInst t_typats t_rhs -- (4) construct representation tycon ; rep_tc_name <- newFamInstTyConName tc_name loc - ; tycon <- buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) - (Just (family, t_typats)) - - ; return $ Just (ATyCon tycon) + ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) + (typeKind t_rhs) (Just (family, t_typats)) }} -- "newtype instance" and "data instance" @@ -299,20 +310,21 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, k_cons = tcdCons k_decl -- result kind must be '*' (otherwise, we have too few patterns) - ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr tc_name + ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity family) -- (2) type check indexed data type declaration ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars ; unbox_strict <- doptM Opt_UnboxStrictFields -- kind check the type indexes and the context - ; t_typats <- mappM tcHsKindedType k_typats + ; t_typats <- mapM tcHsKindedType k_typats ; stupid_theta <- tcHsKindedContext k_ctxt -- (3) Check that -- - left-hand side contains no type family applications - -- (vanilla synonyms are fine, though) - ; mappM_ checkTyFamFreeness t_typats + -- (vanilla synonyms are fine, though, and we checked for + -- foralls earlier) + ; mapM_ checkTyFamFreeness t_typats -- - we don't use GADT syntax for indexed types ; checkTc h98_syntax (badGadtIdxTyDecl tc_name) @@ -323,13 +335,14 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, -- (4) construct representation tycon ; rep_tc_name <- newFamInstTyConName tc_name loc - ; tycon <- fixM (\ tycon -> do - { data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon t_tvs)) + ; let ex_ok = True -- Existentials ok for type families! + ; fixM (\ tycon -> do + { data_cons <- mapM (addLocM (tcConDecl unbox_strict ex_ok tycon t_tvs)) k_cons ; tc_rhs <- case new_or_data of DataType -> return (mkDataTyConRhs data_cons) - NewType -> ASSERT( isSingleton data_cons ) + NewType -> ASSERT( not (null data_cons) ) mkNewTyConRhs rep_tc_name tycon (head data_cons) ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive False h98_syntax (Just (family, t_typats)) @@ -339,35 +352,13 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, -- dependency. (2) They are always valid loop breakers as -- they involve a coercion. }) - - -- construct result - ; return $ Just (ATyCon tycon) }} where h98_syntax = case cons of -- All constructors have same shape L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False - other -> True - --- Check that a type index does not contain any type family applications --- --- * Earlier phases have already checked that there are no foralls in the --- type; we also cannot have PredTys and NoteTys are being skipped by using --- the core view. --- -checkTyFamFreeness :: Type -> TcM () -checkTyFamFreeness ty | Just (tycon, tys) <- splitTyConApp_maybe ty - = if isSynTyCon tycon - then addErr $ tyFamAppInIndexErr ty - else mappM_ checkTyFamFreeness tys - -- splitTyConApp_maybe uses the core view; hence, - -- any synonym tycon must be a family tycon - - | Just (ty1, ty2) <- splitAppTy_maybe ty - = checkTyFamFreeness ty1 >> checkTyFamFreeness ty2 - - | otherwise -- only vars remaining - = return () + _ -> True +tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d) -- Kind checking of indexed types -- - @@ -394,7 +385,7 @@ kcIdxTyPats decl thing_inside -- type functions can have a higher-kinded result ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind - ; typats <- TcRnMonad.zipWithM kcCheckHsType hs_typats kinds + ; typats <- zipWithM kcCheckHsType hs_typats kinds ; thing_inside tvs typats resultKind family } where @@ -442,11 +433,13 @@ include the kinds of associated families into the construction of the initial kind environment. (This is handled by `allDecls'). \begin{code} +kcTyClDecls :: [LTyClDecl Name] -> [Located (TyClDecl Name)] + -> TcM ([LTyClDecl Name], [Located (TyClDecl Name)]) kcTyClDecls syn_decls alg_decls = do { -- First extend the kind env with each data type, class, and -- indexed type, mapping them to a type variable let initialKindDecls = concat [allDecls decl | L _ decl <- alg_decls] - ; alg_kinds <- mappM getInitialKind initialKindDecls + ; alg_kinds <- mapM getInitialKind initialKindDecls ; tcExtendKindEnv alg_kinds $ do -- Now kind-check the type synonyms, in dependency order @@ -462,7 +455,7 @@ kcTyClDecls syn_decls alg_decls -- returning kind-annotated decls; we don't kind-check -- instances of indexed types yet, but leave this to -- `tcInstDecls1' - { kc_alg_decls <- mappM (wrapLocM kcTyClDecl) + { kc_alg_decls <- mapM (wrapLocM kcTyClDecl) (filter (not . isFamInstDecl . unLoc) alg_decls) ; return (kc_syn_decls, kc_alg_decls) }}} @@ -492,7 +485,7 @@ getInitialKind decl 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 + mk_res_kind _ = return liftedTypeKind ---------------- @@ -510,7 +503,7 @@ kcSynDecls (group : groups) kcSynDecl :: SCC (LTyClDecl Name) -> TcM (LTyClDecl Name, -- Kind-annotated decls (Name,TcKind)) -- Kind bindings -kcSynDecl (AcyclicSCC ldecl@(L loc decl)) +kcSynDecl (AcyclicSCC (L loc decl)) = tcAddDeclCtxt decl $ kcHsTyVars (tcdTyVars decl) (\ k_tvs -> do { traceTc (text "kcd1" <+> ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl)) @@ -525,7 +518,9 @@ kcSynDecl (CyclicSCC decls) = do { recSynErr decls; failM } -- Fail here to avoid error cascade -- of out-of-scope tycons +kindedTyVarKind :: LHsTyVarBndr Name -> Kind kindedTyVarKind (L _ (KindedTyVar _ k)) = k +kindedTyVarKind x = pprPanic "kindedTyVarKind" (ppr x) ------------------------------------------------------------------------ kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name) @@ -541,10 +536,9 @@ kcTyClDecl decl@(TyFamily {}) kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) = kcTyClDeclBody decl $ \ tvs' -> - do { is_boot <- tcIsHsBoot - ; ctxt' <- kcHsContext ctxt - ; ats' <- mappM (wrapLocM (kcFamilyDecl tvs')) ats - ; sigs' <- mappM (wrapLocM kc_sig) sigs + do { ctxt' <- kcHsContext ctxt + ; ats' <- mapM (wrapLocM (kcFamilyDecl tvs')) ats + ; sigs' <- mapM (wrapLocM kc_sig) sigs ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs', tcdATs = ats'}) } where @@ -555,6 +549,8 @@ kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) kcTyClDecl decl@(ForeignType {}) = return decl +kcTyClDecl (TySynonym {}) = panic "kcTyClDecl TySynonym" + kcTyClDeclBody :: TyClDecl Name -> ([LHsTyVarBndr Name] -> TcM a) -> TcM a @@ -566,7 +562,9 @@ kcTyClDeclBody :: TyClDecl Name kcTyClDeclBody decl thing_inside = tcAddDeclCtxt decl $ do { tc_ty_thing <- tcLookupLocated (tcdLName decl) - ; let tc_kind = case tc_ty_thing of { AThing k -> k } + ; let tc_kind = case tc_ty_thing of + AThing k -> k + _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing) (kinds, _) = splitKindFunTys tc_kind hs_tvs = tcdTyVars decl kinded_tvs = ASSERT( length kinds >= length hs_tvs ) @@ -582,7 +580,7 @@ kcDataDecl :: TyClDecl Name -> [LHsTyVarBndr Name] -> TcM (TyClDecl Name) kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) tvs = do { ctxt' <- kcHsContext ctxt - ; cons' <- mappM (wrapLocM kc_con_decl) cons + ; cons' <- mapM (wrapLocM kc_con_decl) cons ; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) } where -- doc comments are typechecked to Nothing here @@ -596,14 +594,14 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) return (ConDecl name expl ex_tvs' ex_ctxt' details' res' Nothing) kc_con_details (PrefixCon btys) - = do { btys' <- mappM kc_larg_ty btys + = do { btys' <- mapM kc_larg_ty btys ; return (PrefixCon btys') } kc_con_details (InfixCon bty1 bty2) = do { bty1' <- kc_larg_ty bty1 ; bty2' <- kc_larg_ty bty2 ; return (InfixCon bty1' bty2') } kc_con_details (RecCon fields) - = do { fields' <- mappM kc_field fields + = do { fields' <- mapM kc_field fields ; return (RecCon fields') } kc_field (ConDeclField fld bty d) = do { bty' <- kc_larg_ty bty @@ -615,6 +613,7 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) -- Can't allow an unlifted type for newtypes, because we're effectively -- going to remove the constructor while coercing it to a lifted type. -- And newtypes can't be bang'd +kcDataDecl d _ = pprPanic "kcDataDecl" (ppr d) -- Kind check a family declaration or type family default declaration. -- @@ -631,9 +630,11 @@ kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind}) unifyClassParmKinds (L _ (KindedTyVar n k)) | Just classParmKind <- lookup n classTyKinds = unifyKind k classParmKind | otherwise = return () + unifyClassParmKinds x = pprPanic "kcFamilyDecl/unifyClassParmKinds" (ppr x) classTyKinds = [(n, k) | L _ (KindedTyVar n k) <- classTvs] -kcFamilyDecl _ decl@(TySynonym {}) -- type family defaults +kcFamilyDecl _ (TySynonym {}) -- type family defaults = panic "TcTyClsDecls.kcFamilyDecl: not implemented yet" +kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d) \end{code} @@ -652,14 +653,17 @@ tcSynDecls (decl : decls) ; return (syn_tc : syn_tcs) } -- "type" +tcSynDecl :: TyClDecl Name -> TcM TyThing tcSynDecl (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) = tcTyVarBndrs tvs $ \ tvs' -> do { traceTc (text "tcd1" <+> ppr tc_name) ; rhs_ty' <- tcHsKindedType rhs_ty - ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') Nothing + ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') + (typeKind rhs_ty') Nothing ; return (ATyCon tycon) } +tcSynDecl d = pprPanic "tcSynDecl" (ppr d) -------------------- tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] @@ -668,6 +672,7 @@ tcTyClDecl calc_isrec decl = tcAddDeclCtxt decl (tcTyClDecl1 calc_isrec decl) -- "type family" declarations +tcTyClDecl1 :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] tcTyClDecl1 _calc_isrec (TyFamily {tcdFlavour = TypeFamily, tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = Just kind}) @@ -678,14 +683,14 @@ tcTyClDecl1 _calc_isrec { traceTc (text "type family: " <+> ppr tc_name) ; idx_tys <- doptM Opt_TypeFamilies - -- Check that we don't use families without -ftype-families + -- Check that we don't use families without -XTypeFamilies ; checkTc idx_tys $ badFamInstDecl tc_name - ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) Nothing + ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) kind Nothing ; return [ATyCon tycon] } - -- "newtype family" or "data family" declaration + -- "data family" declaration tcTyClDecl1 _calc_isrec (TyFamily {tcdFlavour = DataFamily, tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind}) @@ -696,7 +701,7 @@ tcTyClDecl1 _calc_isrec ; idx_tys <- doptM Opt_TypeFamilies - -- Check that we don't use families without -ftype-families + -- Check that we don't use families without -XTypeFamilies ; checkTc idx_tys $ badFamInstDecl tc_name ; tycon <- buildAlgTyCon tc_name final_tvs [] @@ -705,6 +710,7 @@ tcTyClDecl1 _calc_isrec } -- "newtype" and "data" + -- NB: not used for newtype/data instances (whether associated or not) tcTyClDecl1 calc_isrec (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons}) @@ -716,8 +722,10 @@ tcTyClDecl1 calc_isrec ; unbox_strict <- doptM Opt_UnboxStrictFields ; empty_data_decls <- doptM Opt_EmptyDataDecls ; kind_signatures <- doptM Opt_KindSignatures + ; existential_ok <- doptM Opt_ExistentialQuantification ; gadt_ok <- doptM Opt_GADTs ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? + ; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context -- Check that we don't use GADT syntax in H98 world ; checkTc (gadt_ok || h98_syntax) (badGadtDecl tc_name) @@ -728,17 +736,19 @@ tcTyClDecl1 calc_isrec -- Check that the stupid theta is empty for a GADT-style declaration ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name) + -- Check that a newtype has exactly one constructor + -- Do this before checking for empty data decls, so that + -- we don't suggest -XEmptyDataDecls for newtypes + ; checkTc (new_or_data == DataType || isSingleton cons) + (newtypeConError tc_name (length cons)) + -- Check that there's at least one condecl, -- or else we're reading an hs-boot file, or -XEmptyDataDecls ; checkTc (not (null cons) || empty_data_decls || 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)) - ; tycon <- fixM (\ tycon -> do - { data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon final_tvs)) + { data_cons <- mapM (addLocM (tcConDecl unbox_strict ex_ok tycon final_tvs)) cons ; tc_rhs <- if null cons && is_boot -- In a hs-boot file, empty cons means @@ -746,7 +756,7 @@ tcTyClDecl1 calc_isrec else case new_or_data of DataType -> return (mkDataTyConRhs data_cons) NewType -> - ASSERT( isSingleton data_cons ) + ASSERT( not (null data_cons) ) mkNewTyConRhs tc_name tycon (head data_cons) ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec (want_generic && canDoGenerics data_cons) h98_syntax Nothing @@ -757,7 +767,7 @@ tcTyClDecl1 calc_isrec is_rec = calc_isrec tc_name h98_syntax = case cons of -- All constructors have same shape L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False - other -> True + _ -> True tcTyClDecl1 calc_isrec (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, @@ -765,8 +775,10 @@ tcTyClDecl1 calc_isrec tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} ) = tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt - ; fds' <- mappM (addLocM tc_fundep) fundeps - ; atss <- mappM (addLocM (tcTyClDecl1 (const Recursive))) ats + ; fds' <- mapM (addLocM tc_fundep) fundeps + ; atss <- mapM (addLocM (tcTyClDecl1 (const Recursive))) ats + -- NB: 'ats' only contains "type family" and "data family" + -- declarations as well as type family defaults ; let ats' = zipWith setTyThingPoss atss (map (tcdTyVars . unLoc) ats) ; sig_stuff <- tcClassSigs class_name sigs meths ; clas <- fixM (\ clas -> @@ -776,15 +788,16 @@ tcTyClDecl1 calc_isrec tycon_name = tyConName (classTyCon clas) tc_isrec = calc_isrec tycon_name in - buildClass class_name tvs' ctxt' fds' ats' + buildClass False {- Must include unfoldings for selectors -} + class_name tvs' ctxt' fds' ats' sig_stuff tc_isrec) ; return (AClass clas : ats') -- NB: Order is important due to the call to `mkGlobalThings' when -- tying the the type and class declaration type checking knot. } where - tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ; - ; tvs2' <- mappM tcLookupTyVar tvs2 ; + tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM tcLookupTyVar tvs1 ; + ; tvs2' <- mapM tcLookupTyVar tvs2 ; ; return (tvs1', tvs2') } -- For each AT argument compute the position of the corresponding class @@ -801,26 +814,32 @@ tcTyClDecl1 calc_isrec ATyCon (setTyConArgPoss tycon poss) setTyThingPoss _ _ = panic "TcTyClsDecls.setTyThingPoss" -tcTyClDecl1 calc_isrec +tcTyClDecl1 _ (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name}) - = returnM [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)] + = return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)] + +tcTyClDecl1 _ d = pprPanic "tcTyClDecl1" (ppr d) ----------------------------------- tcConDecl :: Bool -- True <=> -funbox-strict_fields + -> Bool -- True <=> -XExistentialQuantificaton or -XGADTs -> TyCon -> [TyVar] -> ConDecl Name -> TcM DataCon -tcConDecl unbox_strict tycon tc_tvs -- Data types +tcConDecl unbox_strict existential_ok tycon tc_tvs -- Data types (ConDecl name _ tvs ctxt details res_ty _) - = tcTyVarBndrs tvs $ \ tvs' -> do + = addErrCtxt (dataConCtxt name) $ + tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt + ; checkTc (existential_ok || (null tvs && null (unLoc ctxt))) + (badExistential name) ; (univ_tvs, ex_tvs, eq_preds, data_tc) <- tcResultType tycon tc_tvs tvs' res_ty ; let -- Tiresome: tidy the tyvar binders, since tc_tvs and tvs' may have the same OccNames tc_datacon is_infix field_lbls btys = do { let bangs = map getBangStrictness btys - ; arg_tys <- mappM tcHsBangType btys + ; arg_tys <- mapM tcHsBangType btys ; buildDataCon (unLoc name) is_infix (argStrictness unbox_strict bangs arg_tys) (map unLoc field_lbls) @@ -874,7 +893,7 @@ tcResultType _ tc_tvs dc_tvs (ResTyGADT res_ty) where -- choose_univs uses the res_ty itself if it's a type variable -- and hasn't already been used; otherwise it uses one of the tc_tvs - choose_univs used tc_tvs [] + choose_univs _ tc_tvs [] = ASSERT( null tc_tvs ) [] choose_univs used (tc_tv:tc_tvs) (res_ty:res_tys) | Just tv <- tcGetTyVar_maybe res_ty, not (tv `elem` used) @@ -887,6 +906,7 @@ tcResultType _ tc_tvs dc_tvs (ResTyGADT res_ty) -- interface files and general confusion. So rename -- the tc_tvs, since they are not used yet (no -- consequential renaming needed) + choose_univs _ _ _ = panic "tcResultType/choose_univs" init_occ_env = initTidyOccEnv (map getOccName dc_tvs) (_, tidy_tc_tvs) = mapAccumL tidy_one init_occ_env tc_tvs tidy_one env tv = (env', setTyVarName tv (tidyNameOcc name occ')) @@ -915,7 +935,7 @@ chooseBoxingStrategy unbox_strict_fields arg_ty bang HsStrict | unbox_strict_fields && can_unbox arg_ty -> MarkedUnboxed HsUnbox | can_unbox arg_ty -> MarkedUnboxed - other -> MarkedStrict + _ -> MarkedStrict where -- we can unbox if the type is a chain of newtypes with a product tycon -- at the end @@ -952,7 +972,7 @@ checkCycleErrs tyclss | null cls_cycles = return () | otherwise - = do { mappM_ recClsErr cls_cycles + = do { mapM_ recClsErr cls_cycles ; failM } -- Give up now, because later checkValidTyCl -- will loop if the synonym is recursive where @@ -968,6 +988,7 @@ checkValidTyCl decl ; case thing of ATyCon tc -> checkValidTyCon tc AClass cl -> checkValidClass cl + _ -> panic "checkValidTyCl" ; traceTc (text "Done validity of" <+> ppr thing) } @@ -986,14 +1007,14 @@ checkValidTyCon tc OpenSynTyCon _ _ -> return () SynonymTyCon ty -> checkValidType syn_ctxt ty | otherwise - = -- Check the context on the data decl - checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) `thenM_` + = do -- Check the context on the data decl + checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) -- Check arg types of data constructors - mappM_ (checkValidDataCon tc) data_cons `thenM_` + mapM_ (checkValidDataCon tc) data_cons -- Check that fields with the same name share a type - mappM_ check_fields groups + mapM_ check_fields groups where syn_ctxt = TySynCtxt name @@ -1019,7 +1040,7 @@ checkValidTyCon tc -- result type against other candidates' types BOTH WAYS ROUND. -- If they magically agrees, take the substitution and -- apply them to the latter ones, and see if they match perfectly. - check_fields fields@((label, con1) : other_fields) + check_fields ((label, con1) : other_fields) -- These fields all have the same name, but are from -- different constructors in the data type = recoverM (return ()) $ mapM_ checkOne other_fields @@ -1038,7 +1059,10 @@ checkValidTyCon tc (tvs2, _, _, res2) = dataConSig con2 ts2 = mkVarSet tvs2 fty2 = dataConFieldType con2 label + check_fields [] = panic "checkValidTyCon/check_fields []" +checkFieldCompat :: Name -> DataCon -> DataCon -> TyVarSet + -> Type -> Type -> Type -> Type -> TcM () 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) } @@ -1053,7 +1077,10 @@ checkValidDataCon tc con addErrCtxt (dataConCtxt con) $ do { checkTc (dataConTyCon con == tc) (badDataConTyCon con) ; checkValidType ctxt (dataConUserType con) - ; ifM (isNewTyCon tc) (checkNewDataCon con) + ; checkValidMonoType (dataConOrigResTy con) + -- Disallow MkT :: T (forall a. a->a) + -- Reason: it's really the argument of an equality constraint + ; when (isNewTyCon tc) (checkNewDataCon con) } where ctxt = ConArgCtxt (dataConName con) @@ -1066,14 +1093,14 @@ checkNewDataCon con -- One argument ; checkTc (null eq_spec) (newtypePredError con) -- Return type is (T a b c) - ; checkTc (null ex_tvs && null theta) (newtypeExError con) + ; checkTc (null ex_tvs && null eq_theta && null dict_theta) (newtypeExError con) -- No existentials ; checkTc (not (any isMarkedStrict (dataConStrictMarks con))) (newtypeStrictError con) -- No strictness } where - (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con + (_univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _res_ty) = dataConFullSig con ------------------------------- checkValidClass :: Class -> TcM () @@ -1091,7 +1118,7 @@ checkValidClass cls ; checkValidTheta (ClassSCCtxt (className cls)) theta -- Check the class operations - ; mappM_ (check_op constrained_class_methods) op_stuff + ; mapM_ (check_op constrained_class_methods) op_stuff -- Check that if the class has generic methods, then the -- class has only one parameter. We can't do generic @@ -1109,6 +1136,7 @@ checkValidClass cls -- The 'tail' removes the initial (C a) from the -- class itself, leaving just the method type + ; traceTc (text "class op type" <+> ppr op_ty <+> ppr tau) ; checkValidType (FunSigCtxt op_name) tau -- Check that the type mentions at least one of @@ -1142,55 +1170,68 @@ checkValidClass cls --------------------------------------------------------------------- +resultTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc 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")] + = 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 :: Name -> DataCon -> DataCon -> SDoc 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)] + = sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2, + ptext (sLit "give different types for field"), quotes (ppr field_name)] -dataConCtxt con = ptext SLIT("In the definition of data constructor") <+> quotes (ppr con) +dataConCtxt :: Outputable a => a -> SDoc +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:"), +classOpCtxt :: Var -> Type -> SDoc +classOpCtxt sel_id tau = sep [ptext (sLit "When checking the class method:"), nest 2 (ppr sel_id <+> dcolon <+> ppr tau)] +nullaryClassErr :: Class -> SDoc nullaryClassErr cls - = ptext SLIT("No parameters for class") <+> quotes (ppr cls) + = ptext (sLit "No parameters for class") <+> quotes (ppr cls) +classArityErr :: Class -> SDoc classArityErr cls - = vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls), - parens (ptext SLIT("Use -XMultiParamTypeClasses to allow multi-parameter classes"))] + = vcat [ptext (sLit "Too many parameters for class") <+> quotes (ppr cls), + parens (ptext (sLit "Use -XMultiParamTypeClasses to allow multi-parameter classes"))] +classFunDepsErr :: Class -> SDoc classFunDepsErr cls - = vcat [ptext SLIT("Fundeps in class") <+> quotes (ppr cls), - parens (ptext SLIT("Use -XFunctionalDependencies to allow fundeps"))] + = vcat [ptext (sLit "Fundeps in class") <+> quotes (ppr cls), + parens (ptext (sLit "Use -XFunctionalDependencies to allow fundeps"))] +noClassTyVarErr :: Class -> Var -> SDoc noClassTyVarErr clas op - = sep [ptext SLIT("The class method") <+> quotes (ppr op), - ptext SLIT("mentions none of the type variables of the class") <+> + = sep [ptext (sLit "The class method") <+> quotes (ppr op), + ptext (sLit "mentions none of the type variables of the class") <+> ppr clas <+> hsep (map ppr (classTyVars clas))] +genericMultiParamErr :: Class -> SDoc genericMultiParamErr clas - = ptext SLIT("The multi-parameter class") <+> quotes (ppr clas) <+> - ptext SLIT("cannot have generic methods") + = ptext (sLit "The multi-parameter class") <+> quotes (ppr clas) <+> + ptext (sLit "cannot have generic methods") +badGenericMethodType :: Name -> Kind -> SDoc badGenericMethodType op op_ty - = hang (ptext SLIT("Generic method type is too complex")) + = hang (ptext (sLit "Generic method type is too complex")) 4 (vcat [ppr op <+> dcolon <+> ppr op_ty, - ptext SLIT("You can only use type variables, arrows, lists, and tuples")]) + ptext (sLit "You can only use type variables, arrows, lists, and tuples")]) +recSynErr :: [LTyClDecl Name] -> TcRn () recSynErr syn_decls = setSrcSpan (getLoc (head sorted_decls)) $ - addErr (sep [ptext SLIT("Cycle in type synonym declarations:"), + addErr (sep [ptext (sLit "Cycle in type synonym declarations:"), nest 2 (vcat (map ppr_decl sorted_decls))]) where sorted_decls = sortLocated syn_decls ppr_decl (L loc decl) = ppr loc <> colon <+> ppr decl +recClsErr :: [Located (TyClDecl Name)] -> TcRn () recClsErr cls_decls = setSrcSpan (getLoc (head sorted_decls)) $ - addErr (sep [ptext SLIT("Cycle in class declarations (via superclasses):"), + addErr (sep [ptext (sLit "Cycle in class declarations (via superclasses):"), nest 2 (vcat (map ppr_decl sorted_decls))]) where sorted_decls = sortLocated cls_decls @@ -1201,82 +1242,100 @@ sortLocated things = sortLe le things where le (L l1 _) (L l2 _) = l1 <= l2 +badDataConTyCon :: DataCon -> SDoc badDataConTyCon 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")) + = 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 :: Name -> SDoc badGadtDecl tc_name - = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Use -XGADTs to allow GADTs")) ] + = vcat [ ptext (sLit "Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name) + , nest 2 (parens $ ptext (sLit "Use -XGADTs to allow GADTs")) ] +badExistential :: Located Name -> SDoc +badExistential con_name + = hang (ptext (sLit "Data constructor") <+> quotes (ppr con_name) <+> + ptext (sLit "has existential type variables, or a context")) + 2 (parens $ ptext (sLit "Use -XExistentialQuantification or -XGADTs to allow this")) + +badStupidTheta :: Name -> SDoc badStupidTheta tc_name - = ptext SLIT("A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name) + = ptext (sLit "A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name) +newtypeConError :: Name -> Int -> SDoc 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 ] + = sep [ptext (sLit "A newtype must have exactly one constructor,"), + nest 2 $ ptext (sLit "but") <+> quotes (ppr tycon) <+> ptext (sLit "has") <+> speakN n ] +newtypeExError :: DataCon -> SDoc newtypeExError con - = sep [ptext SLIT("A newtype constructor cannot have an existential context,"), - nest 2 $ ptext SLIT("but") <+> quotes (ppr con) <+> ptext SLIT("does")] + = sep [ptext (sLit "A newtype constructor cannot have an existential context,"), + nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does")] +newtypeStrictError :: DataCon -> SDoc newtypeStrictError con - = sep [ptext SLIT("A newtype constructor cannot have a strictness annotation,"), - nest 2 $ ptext SLIT("but") <+> quotes (ppr con) <+> ptext SLIT("does")] + = sep [ptext (sLit "A newtype constructor cannot have a strictness annotation,"), + nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does")] +newtypePredError :: DataCon -> SDoc newtypePredError con - = sep [ptext SLIT("A newtype constructor must have a return type of form T a1 ... an"), - nest 2 $ ptext SLIT("but") <+> quotes (ppr con) <+> ptext SLIT("does not")] + = sep [ptext (sLit "A newtype constructor must have a return type of form T a1 ... an"), + nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does not")] +newtypeFieldErr :: DataCon -> Int -> SDoc 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] + = 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] +badSigTyDecl :: Name -> SDoc badSigTyDecl tc_name - = vcat [ ptext SLIT("Illegal kind signature") <+> + = vcat [ ptext (sLit "Illegal kind signature") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Use -XKindSignatures to allow kind signatures")) ] + , nest 2 (parens $ ptext (sLit "Use -XKindSignatures to allow kind signatures")) ] +badFamInstDecl :: Outputable a => a -> SDoc badFamInstDecl tc_name - = vcat [ ptext SLIT("Illegal family instance for") <+> + = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Use -XTypeFamilies to allow indexed type families")) ] + , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ] +badGadtIdxTyDecl :: Name -> SDoc badGadtIdxTyDecl tc_name - = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> + = vcat [ ptext (sLit "Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Family instances can not yet use GADT declarations")) ] + , nest 2 (parens $ ptext (sLit "Family instances can not yet use GADT declarations")) ] +tooManyParmsErr :: Located Name -> SDoc tooManyParmsErr tc_name - = ptext SLIT("Family instance has too many parameters:") <+> + = ptext (sLit "Family instance has too many parameters:") <+> quotes (ppr tc_name) -tooFewParmsErr tc_name - = ptext SLIT("Family instance has too few parameters:") <+> - quotes (ppr tc_name) +tooFewParmsErr :: Arity -> SDoc +tooFewParmsErr arity + = ptext (sLit "Family instance has too few parameters; expected") <+> + ppr arity +wrongNumberOfParmsErr :: Arity -> SDoc +wrongNumberOfParmsErr exp_arity + = ptext (sLit "Number of parameters must match family declaration; expected") + <+> ppr exp_arity + +badBootFamInstDeclErr :: SDoc badBootFamInstDeclErr = - ptext SLIT("Illegal family instance in hs-boot file") + ptext (sLit "Illegal family instance in hs-boot file") +wrongKindOfFamily :: TyCon -> SDoc wrongKindOfFamily family = - ptext SLIT("Wrong category of family instance; declaration was for a") <+> + ptext (sLit "Wrong category of family instance; declaration was for a") <+> kindOfFamily where - kindOfFamily | isSynTyCon family = ptext SLIT("type synonym") - | isAlgTyCon family = ptext SLIT("data type") + kindOfFamily | isSynTyCon family = ptext (sLit "type synonym") + | isAlgTyCon family = ptext (sLit "data type") | otherwise = pprPanic "wrongKindOfFamily" (ppr family) -polyTyErr ty - = hang (ptext SLIT("Illegal polymorphic type in type instance") <> colon) 4 $ - ppr ty - -tyFamAppInIndexErr ty - = hang (ptext SLIT("Illegal type family application in type instance") <> - colon) 4 $ - ppr ty - +emptyConDeclsErr :: Name -> SDoc emptyConDeclsErr tycon - = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"), - nest 2 $ ptext SLIT("(-XEmptyDataDecls permits this)")] + = sep [quotes (ppr tycon) <+> ptext (sLit "has no constructors"), + nest 2 $ ptext (sLit "(-XEmptyDataDecls permits this)")] \end{code}