X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=c959233d6e45eef86d75f156e530fc879dddc75d;hp=f3abbe94f826d796f64741990a9c13d07a21c290;hb=1fa3580c54985d73178d1d396b897176a57cd7f3;hpb=f59d6c9d6ead47a61681b1086b313c2fad225912 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index f3abbe9..c959233 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -6,13 +6,6 @@ TcTyClsDecls: Typecheck type and class declarations \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module TcTyClsDecls ( tcTyAndClassDecls, tcFamInstDecl ) where @@ -38,6 +31,7 @@ import Generics import Class import TyCon import DataCon +import Id import Var import VarSet import Name @@ -51,6 +45,7 @@ import SrcLoc import ListSetOps import Digraph import DynFlags +import FastString import Data.List import Control.Monad ( mplus ) @@ -154,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 @@ -230,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} @@ -258,11 +257,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}) @@ -285,16 +287,13 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) ; t_typats <- mapM tcHsKindedType k_typats ; t_rhs <- tcHsKindedType k_rhs - -- (3) check that - -- - check the well-formedness of the instance + -- (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" @@ -337,7 +336,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,14 +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 + _ -> True + +tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d) -- Kind checking of indexed types -- - @@ -435,6 +433,8 @@ 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 @@ -485,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 ---------------- @@ -503,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)) @@ -518,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) @@ -534,8 +536,7 @@ kcTyClDecl decl@(TyFamily {}) kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) = kcTyClDeclBody decl $ \ tvs' -> - do { is_boot <- tcIsHsBoot - ; ctxt' <- kcHsContext ctxt + do { ctxt' <- kcHsContext ctxt ; ats' <- mapM (wrapLocM (kcFamilyDecl tvs')) ats ; sigs' <- mapM (wrapLocM kc_sig) sigs ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs', @@ -548,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 @@ -559,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 ) @@ -608,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. -- @@ -624,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} @@ -645,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] @@ -661,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}) @@ -674,7 +686,7 @@ tcTyClDecl1 _calc_isrec -- 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] } @@ -724,15 +736,17 @@ 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 <- mapM (addLocM (tcConDecl unbox_strict ex_ok tycon final_tvs)) cons @@ -753,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, @@ -774,7 +788,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 @@ -799,10 +814,12 @@ tcTyClDecl1 calc_isrec ATyCon (setTyConArgPoss tycon poss) setTyThingPoss _ _ = panic "TcTyClsDecls.setTyThingPoss" -tcTyClDecl1 calc_isrec +tcTyClDecl1 _ (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name}) = 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 @@ -876,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) @@ -889,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')) @@ -917,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 @@ -970,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) } @@ -1021,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 @@ -1040,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) } @@ -1148,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 @@ -1207,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")) + = 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 :: Arity -> SDoc tooFewParmsErr arity - = ptext SLIT("Family instance has too few parameters; expected") <+> + = 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") + = 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) +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}