X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=f4d0e86f7c75cea38837ce7cc68142dcc7e252b3;hp=4d0030ecabe7882c7b3bff70363310ff2acc70cb;hb=ad94d40948668032189ad22a0ad741ac1f645f50;hpb=e3dd39bf230380f02d73efc287226117bb2eb47f diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 4d0030e..f4d0e86 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -6,6 +6,13 @@ 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/CodingStyle#Warnings +-- for details + module TcTyClsDecls ( tcTyAndClassDecls, tcFamInstDecl ) where @@ -17,6 +24,7 @@ import HsTypes import BasicTypes import HscTypes import BuildTyCl +import TcUnify import TcRnMonad import TcEnv import TcTyDecls @@ -44,7 +52,7 @@ import ListSetOps import Digraph import DynFlags -import Data.List ( partition, elemIndex ) +import Data.List import Control.Monad ( mplus ) \end{code} @@ -133,7 +141,7 @@ tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name] -> TcM TcGblEnv -- Input env extended by types and classes -- and their implicit Ids,DataCons tcTyAndClassDecls boot_details allDecls - = do { -- Omit instances of indexed types; they are handled together + = do { -- Omit instances of type families; they are handled together -- with the *heads* of class instances ; let decls = filter (not . isFamInstDecl . unLoc) allDecls @@ -239,11 +247,11 @@ tcFamInstDecl (L loc decl) recoverM (returnM Nothing) $ setSrcSpan loc $ tcAddDeclCtxt decl $ - do { -- type families require -findexed-types and can't be in an + do { -- type families require -ftype-families and can't be in an -- hs-boot file - ; gla_exts <- doptM Opt_IndexedTypes + ; type_families <- doptM Opt_TypeFamilies ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? - ; checkTc gla_exts $ badFamInstDecl (tcdLName decl) + ; checkTc type_families $ badFamInstDecl (tcdLName decl) ; checkTc (not is_boot) $ badBootFamInstDeclErr -- perform kind and type checking @@ -252,30 +260,45 @@ tcFamInstDecl (L loc decl) tcFamInstDecl1 :: TyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error -tcFamInstDecl1 (decl@TySynonym {}) + -- "type instance" +tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> do { -- check that the family declaration is for a synonym unless (isSynTyCon family) $ addErr (wrongKindOfFamily family) - ; -- (1) kind check the right hand side of the type equation + ; -- (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_rhs <- tcHsKindedType k_rhs - -- !!!of the form: forall t_tvs. (tcdLName decl) t_typats = t_rhs - ; return Nothing -- !!!TODO: need TyThing for indexed synonym + -- (3) check that + -- - 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) }} - + + -- "newtype instance" and "data instance" tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, tcdCons = cons}) = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> do { -- check that the family declaration is for the right kind - unless (new_or_data == NewType && isNewTyCon family || - new_or_data == DataType && isDataTyCon family) $ + unless (isAlgTyCon family) $ addErr (wrongKindOfFamily family) ; -- (1) kind check the data declaration as usual @@ -284,32 +307,39 @@ 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 - -- Check that we don't use GADT syntax for indexed types + -- kind check the type indexes and the context + ; t_typats <- mappM tcHsKindedType k_typats + ; stupid_theta <- tcHsKindedContext k_ctxt + + -- (3) Check that + -- - left-hand side contains no type family applications + -- (vanilla synonyms are fine, though, and we checked for + -- foralls earlier) + ; mappM_ checkTyFamFreeness t_typats + + -- - we don't use GADT syntax for indexed types ; checkTc h98_syntax (badGadtIdxTyDecl tc_name) - -- Check that a newtype has exactly one constructor + -- - a newtype has exactly one constructor ; checkTc (new_or_data == DataType || isSingleton k_cons) $ newtypeConError tc_name (length k_cons) - ; t_typats <- mappM tcHsKindedType k_typats - ; stupid_theta <- tcHsKindedContext k_ctxt - - ; rep_tc_name <- newFamInstTyConName tc_name (srcSpanStart loc) + -- (4) construct representation tycon + ; rep_tc_name <- newFamInstTyConName tc_name loc ; tycon <- fixM (\ tycon -> do - { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data - tycon t_tvs)) + { data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon t_tvs)) k_cons ; tc_rhs <- case new_or_data of DataType -> return (mkDataTyConRhs data_cons) - NewType -> ASSERT( isSingleton data_cons ) - mkNewTyConRhs tc_name tycon (head 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)) -- We always assume that indexed types are recursive. Why? @@ -334,7 +364,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, -- -- * Here we check that a type instance matches its kind signature, but we do -- not check whether there is a pattern for each type index; the latter --- check is only required for type functions. +-- check is only required for type synonym instances. -- kcIdxTyPats :: TyClDecl Name -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a) @@ -387,7 +417,7 @@ So we must infer their kinds from their right-hand sides *first* and then use them, whereas for the mutually recursive data types D we bring into scope kind bindings D -> k, where k is a kind variable, and do inference. -Indexed Types +Type families ~~~~~~~~~~~~~ This treatment of type synonyms only applies to Haskell 98-style synonyms. General type functions can be recursive, and hence, appear in `alg_decls'. @@ -494,18 +524,15 @@ kcTyClDecl decl@(TyData {}) kcTyClDeclBody decl $ kcDataDecl decl -kcTyClDecl decl@(TyFamily {tcdKind = kind}) - = kcTyClDeclBody decl $ \ tvs' -> - return (decl {tcdTyVars = tvs', - tcdKind = kind `mplus` Just liftedTypeKind}) - -- default result kind is '*' +kcTyClDecl decl@(TyFamily {}) + = kcFamilyDecl [] decl -- the empty list signals a toplevel decl kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) = kcTyClDeclBody decl $ \ tvs' -> do { is_boot <- tcIsHsBoot ; ctxt' <- kcHsContext ctxt - ; ats' <- mappM (wrapLocM kcTyClDecl) ats - ; sigs' <- mappM (wrapLocM kc_sig ) sigs + ; ats' <- mappM (wrapLocM (kcFamilyDecl tvs')) ats + ; sigs' <- mappM (wrapLocM kc_sig) sigs ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs', tcdATs = ats'}) } where @@ -557,13 +584,18 @@ 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 ; return (PrefixCon btys') } + = do { btys' <- mappM 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') } + = 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; return (RecCon fields') } + = do { fields' <- mappM kc_field fields + ; return (RecCon fields') } - kc_field (HsRecField fld bty d) = do { bty' <- kc_larg_ty bty ; return (HsRecField fld bty' d) } + kc_field (ConDeclField fld bty d) = do { bty' <- kc_larg_ty bty + ; return (ConDeclField fld bty' d) } kc_larg_ty bty = case new_or_data of DataType -> kcHsSigType bty @@ -571,6 +603,25 @@ 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 + +-- Kind check a family declaration or type family default declaration. +-- +kcFamilyDecl :: [LHsTyVarBndr Name] -- tyvars of enclosing class decl if any + -> TyClDecl Name -> TcM (TyClDecl Name) +kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind}) + = kcTyClDeclBody decl $ \tvs' -> + do { mapM_ unifyClassParmKinds tvs' + ; return (decl {tcdTyVars = tvs', + tcdKind = kind `mplus` Just liftedTypeKind}) + -- default result kind is '*' + } + where + unifyClassParmKinds (L _ (KindedTyVar n k)) + | Just classParmKind <- lookup n classTyKinds = unifyKind k classParmKind + | otherwise = return () + classTyKinds = [(n, k) | L _ (KindedTyVar n k) <- classTvs] +kcFamilyDecl _ decl@(TySynonym {}) -- type family defaults + = panic "TcTyClsDecls.kcFamilyDecl: not implemented yet" \end{code} @@ -588,12 +639,15 @@ tcSynDecls (decl : decls) ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls decls) ; return (syn_tc : syn_tcs) } + -- "type" 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 - ; return (ATyCon (buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty'))) } + ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') Nothing + ; return (ATyCon tycon) + } -------------------- tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] @@ -610,37 +664,35 @@ tcTyClDecl1 _calc_isrec -- kind checking = tcTyVarBndrs tvs $ \ tvs' -> do { traceTc (text "type family: " <+> ppr tc_name) - ; idx_tys <- doptM Opt_IndexedTypes + ; idx_tys <- doptM Opt_TypeFamilies - -- Check that we don't use families without -findexed-types + -- Check that we don't use families without -ftype-families ; checkTc idx_tys $ badFamInstDecl tc_name - ; return [ATyCon $ buildSynTyCon tc_name tvs' (OpenSynTyCon kind)] + ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) Nothing + ; return [ATyCon tycon] } -- "newtype family" or "data family" declaration tcTyClDecl1 _calc_isrec - (TyFamily {tcdFlavour = DataFamily new_or_data, + (TyFamily {tcdFlavour = DataFamily, tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind}) = tcTyVarBndrs tvs $ \ tvs' -> do - { traceTc (text "data/newtype family: " <+> ppr tc_name) + { traceTc (text "data family: " <+> ppr tc_name) ; extra_tvs <- tcDataKindSig mb_kind ; let final_tvs = tvs' ++ extra_tvs -- we may not need these - ; idx_tys <- doptM Opt_IndexedTypes + ; idx_tys <- doptM Opt_TypeFamilies - -- Check that we don't use families without -findexed-types + -- Check that we don't use families without -ftype-families ; checkTc idx_tys $ badFamInstDecl tc_name ; tycon <- buildAlgTyCon tc_name final_tvs [] - (case new_or_data of - DataType -> OpenDataTyCon - NewType -> OpenNewTyCon) - Recursive False True Nothing + mkOpenDataTyConRhs Recursive False True Nothing ; return [ATyCon tycon] } - -- "newtype", "data", "newtype instance", "data instance" + -- "newtype" and "data" tcTyClDecl1 calc_isrec (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons}) @@ -650,21 +702,23 @@ tcTyClDecl1 calc_isrec ; stupid_theta <- tcHsKindedContext ctxt ; want_generic <- doptM Opt_Generics ; unbox_strict <- doptM Opt_UnboxStrictFields - ; gla_exts <- doptM Opt_GlasgowExts + ; empty_data_decls <- doptM Opt_EmptyDataDecls + ; kind_signatures <- doptM Opt_KindSignatures + ; gadt_ok <- doptM Opt_GADTs ; 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) + ; checkTc (gadt_ok || h98_syntax) (badGadtDecl tc_name) -- Check that we don't use kind signatures without Glasgow extensions - ; checkTc (gla_exts || isNothing mb_ksig) (badSigTyDecl tc_name) + ; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name) -- Check that the stupid theta is empty for a GADT-style declaration ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name) -- Check that there's at least one condecl, - -- or else we're reading an hs-boot file, or -fglasgow-exts - ; checkTc (not (null cons) || gla_exts || is_boot) + -- 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 @@ -672,8 +726,7 @@ tcTyClDecl1 calc_isrec (newtypeConError tc_name (length cons)) ; tycon <- fixM (\ tycon -> do - { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data - tycon final_tvs)) + { data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon final_tvs)) cons ; tc_rhs <- if null cons && is_boot -- In a hs-boot file, empty cons means @@ -681,7 +734,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 @@ -742,35 +795,11 @@ tcTyClDecl1 calc_isrec ----------------------------------- tcConDecl :: Bool -- True <=> -funbox-strict_fields - -> NewOrData -> TyCon -> [TyVar] -> ConDecl Name -> TcM DataCon -tcConDecl unbox_strict NewType tycon tc_tvs -- Newtypes - (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 -} - [NotMarkedStrict] - (map unLoc field_lbls) - tc_tvs [] -- No existentials - [] [] -- No equalities, predicates - [arg_ty'] - tycon } - - -- 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 [HsRecField 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 -- Data types +tcConDecl unbox_strict tycon tc_tvs -- Data types (ConDecl name _ tvs ctxt details res_ty _) = tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt @@ -794,8 +823,8 @@ tcConDecl unbox_strict DataType tycon tc_tvs -- Data types InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2] RecCon fields -> tc_datacon False field_names btys where - (field_names, btys) = unzip [ (n, t) | HsRecField n t _ <- fields ] - + field_names = map cd_fld_name fields + btys = map cd_fld_type fields } tcResultType :: TyCon @@ -942,8 +971,8 @@ checkValidTyCon :: TyCon -> TcM () checkValidTyCon tc | isSynTyCon tc = case synTyConRhs tc of - OpenSynTyCon _ -> return () - SynonymTyCon ty -> checkValidType syn_ctxt ty + OpenSynTyCon _ _ -> return () + SynonymTyCon ty -> checkValidType syn_ctxt ty | otherwise = -- Check the context on the data decl checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) `thenM_` @@ -986,23 +1015,23 @@ checkValidTyCon tc -- NB: this check assumes that all the constructors of a given -- data type use the same type variables where - tvs1 = mkVarSet (dataConAllTyVars con1) - res1 = dataConResTys con1 + (tvs1, _, _, res1) = dataConSig con1 + ts1 = mkVarSet tvs1 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 } + = do { checkFieldCompat label con1 con2 ts1 res1 res2 fty1 fty2 + ; checkFieldCompat label con2 con1 ts2 res2 res1 fty2 fty1 } where - tvs2 = mkVarSet (dataConAllTyVars con2) - res2 = dataConResTys con2 + (tvs2, _, _, res2) = dataConSig con2 + ts2 = mkVarSet tvs2 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_subst1 = tcMatchTy tvs1 res1 res2 mb_subst2 = tcMatchTyX tvs1 (expectJust "checkFieldCompat" mb_subst1) fty1 fty2 ------------------------------- @@ -1011,25 +1040,46 @@ checkValidDataCon tc con = setSrcSpan (srcLocSpan (getSrcLoc con)) $ addErrCtxt (dataConCtxt con) $ do { checkTc (dataConTyCon con == tc) (badDataConTyCon con) - ; checkValidType ctxt (dataConUserType con) } + ; checkValidType ctxt (dataConUserType con) + ; ifM (isNewTyCon tc) (checkNewDataCon con) + } where ctxt = ConArgCtxt (dataConName con) ------------------------------- +checkNewDataCon :: DataCon -> TcM () +-- Checks for the data constructor of a newtype +checkNewDataCon con + = do { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys)) + -- One argument + ; checkTc (null eq_spec) (newtypePredError con) + -- Return type is (T a b c) + ; 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, eq_theta, dict_theta, arg_tys, _res_ty) = dataConFullSig con + +------------------------------- checkValidClass :: Class -> TcM () checkValidClass cls - = do { -- CHECK ARITY 1 FOR HASKELL 1.4 - gla_exts <- doptM Opt_GlasgowExts + = do { constrained_class_methods <- doptM Opt_ConstrainedClassMethods + ; multi_param_type_classes <- doptM Opt_MultiParamTypeClasses + ; fundep_classes <- doptM Opt_FunctionalDependencies -- Check that the class is unary, unless GlaExs ; checkTc (notNull tyvars) (nullaryClassErr cls) - ; checkTc (gla_exts || unary) (classArityErr cls) + ; checkTc (multi_param_type_classes || unary) (classArityErr cls) + ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls) -- Check the super-classes ; checkValidTheta (ClassSCCtxt (className cls)) theta -- Check the class operations - ; mappM_ (check_op gla_exts) op_stuff + ; mappM_ (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 @@ -1037,16 +1087,17 @@ checkValidClass cls ; checkTc (unary || no_generics) (genericMultiParamErr cls) } where - (tyvars, theta, _, op_stuff) = classBigSig cls + (tyvars, fundeps, theta, _, _, op_stuff) = classExtraBigSig cls unary = isSingleton tyvars no_generics = null [() | (_, GenDefMeth) <- op_stuff] - check_op gla_exts (sel_id, dm) + check_op constrained_class_methods (sel_id, dm) = addErrCtxt (classOpCtxt sel_id tau) $ do { checkValidTheta SigmaCtxt (tail theta) -- 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 @@ -1069,11 +1120,11 @@ checkValidClass cls op_ty = idType sel_id (_,theta1,tau1) = tcSplitSigmaTy op_ty (_,theta2,tau2) = tcSplitSigmaTy tau1 - (theta,tau) | gla_exts = (theta1 ++ theta2, tau2) - | otherwise = (theta1, mkPhiTy (tail theta1) tau1) + (theta,tau) | constrained_class_methods = (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 + -- With -XConstrainedClassMethods, 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! @@ -1098,7 +1149,11 @@ nullaryClassErr cls classArityErr cls = vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls), - parens (ptext SLIT("Use -fglasgow-exts to allow multi-parameter classes"))] + 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"))] noClassTyVarErr clas op = sep [ptext SLIT("The class method") <+> quotes (ppr op), @@ -1142,7 +1197,7 @@ badDataConTyCon data_con 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")) ] + , nest 2 (parens $ ptext SLIT("Use -XGADTs to allow GADTs")) ] badStupidTheta tc_name = ptext SLIT("A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name) @@ -1155,6 +1210,14 @@ newtypeExError con = 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")] + +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")] + 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] @@ -1162,12 +1225,12 @@ newtypeFieldErr con_name n_flds badSigTyDecl tc_name = vcat [ ptext SLIT("Illegal kind signature") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts 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") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Use -findexed-types 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") <+> @@ -1178,9 +1241,13 @@ tooManyParmsErr tc_name = 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 + = ptext SLIT("Family instance has too few parameters; expected") <+> + ppr arity + +wrongNumberOfParmsErr exp_arity + = ptext SLIT("Number of parameters must match family declaration; expected") + <+> ppr exp_arity badBootFamInstDeclErr = ptext SLIT("Illegal family instance in hs-boot file") @@ -1189,11 +1256,11 @@ wrongKindOfFamily family = ptext SLIT("Wrong category of family instance; declaration was for a") <+> kindOfFamily where - kindOfFamily | isSynTyCon family = ptext SLIT("type synonym") - | isDataTyCon family = ptext SLIT("data type") - | isNewTyCon family = ptext SLIT("newtype") + 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("(-fglasgow-exts permits this)")] + nest 2 $ ptext SLIT("(-XEmptyDataDecls permits this)")] \end{code}