X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=35c74709f60d0828bd5aa0b958d023686e360e2b;hb=2058d7802ae1f054d8bb0b34a72ce69b4b63bf56;hp=6657e16a44439fc1fd65da2d162d2f0c08098ca3;hpb=563f7c305f30c1fbcecbdd692ca7b6693525ee31;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 6657e16..35c7470 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -51,6 +51,7 @@ import SrcLoc import ListSetOps import Digraph import DynFlags +import FastString import Data.List import Control.Monad ( mplus ) @@ -258,11 +259,14 @@ tcFamInstDecl (L loc decl) ; 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}) @@ -291,10 +295,8 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) -- (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) + (Just (family, t_typats)) }} -- "newtype instance" and "data instance" @@ -337,7 +339,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, -- (4) construct representation tycon ; rep_tc_name <- newFamInstTyConName tc_name loc ; let ex_ok = True -- Existentials ok for type families! - ; tycon <- fixM (\ tycon -> do + ; fixM (\ tycon -> do { data_cons <- mapM (addLocM (tcConDecl unbox_strict ex_ok tycon t_tvs)) k_cons ; tc_rhs <- @@ -353,9 +355,6 @@ 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 @@ -776,7 +775,8 @@ 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 @@ -1151,46 +1151,46 @@ checkValidClass cls --------------------------------------------------------------------- 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 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 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 sel_id tau = sep [ptext (sLit "When checking the class method:"), nest 2 (ppr sel_id <+> dcolon <+> ppr tau)] nullaryClassErr cls - = ptext SLIT("No parameters for class") <+> quotes (ppr cls) + = ptext (sLit "No parameters for class") <+> quotes (ppr cls) 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 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 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 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 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 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 @@ -1198,7 +1198,7 @@ recSynErr syn_decls 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 @@ -1210,81 +1210,81 @@ sortLocated things = sortLe le things le (L l1 _) (L l2 _) = l1 <= l2 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 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 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")) + = 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 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 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 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 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 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 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 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 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 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 tc_name - = ptext SLIT("Family instance has too many parameters:") <+> + = ptext (sLit "Family instance has too many parameters:") <+> quotes (ppr tc_name) tooFewParmsErr arity - = ptext SLIT("Family instance has too few parameters; expected") <+> + = ptext (sLit "Family instance has too few parameters; expected") <+> ppr arity wrongNumberOfParmsErr exp_arity - = ptext SLIT("Number of parameters must match family declaration; expected") + = ptext (sLit "Number of parameters must match family declaration; expected") <+> ppr exp_arity badBootFamInstDeclErr = - ptext SLIT("Illegal family instance in hs-boot file") + ptext (sLit "Illegal family instance in hs-boot file") 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) 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}