X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=633dc52812add6baabc4ba4b2c9b0df470e68fca;hp=e87cd6643c6ef56ffc0c976bfc9d5f7beb780182;hb=432b9c9322181a3644083e3c19b7e240d90659e7;hpb=e8a591c1a3dbdeccec2dd2aacccd7435004b0d51 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index e87cd66..633dc52 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -1,74 +1,58 @@ % +% (c) The University of Glasgow 2006 % (c) The AQUA Project, Glasgow University, 1996-1998 % -\section[TcTyClsDecls]{Typecheck type and class declarations} + +TcTyClsDecls: Typecheck type and class declarations \begin{code} module TcTyClsDecls ( - tcTyAndClassDecls, tcIdxTyInstDecl + tcTyAndClassDecls, tcFamInstDecl, mkAuxBinds ) where #include "HsVersions.h" -import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..), - ConDecl(..), Sig(..), NewOrData(..), ResType(..), - tyClDeclTyVars, isSynDecl, isClassDecl, isIdxTyDecl, - isKindSigDecl, hsConArgs, LTyClDecl, tcdName, - hsTyVarName, LHsTyVarBndr, LHsType - ) -import HsTypes ( HsBang(..), getBangStrictness ) -import BasicTypes ( RecFlag(..), StrictnessMark(..) ) -import HscTypes ( implicitTyThings, ModDetails ) -import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon, - mkDataTyConRhs, mkNewTyConRhs ) +import HsSyn +import HsTypes +import HscTypes +import BuildTyCl +import TcUnify import TcRnMonad -import TcEnv ( TyThing(..), - tcLookupLocated, tcLookupLocatedGlobal, - tcExtendGlobalEnv, tcExtendKindEnv, tcExtendKindEnvTvs, - tcExtendRecEnv, tcLookupTyVar, InstInfo ) -import TcTyDecls ( calcRecFlags, calcClassCycles, calcSynCycles ) -import TcClassDcl ( tcClassSigs, tcAddDeclCtxt ) -import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType, - kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext, - kcHsSigType, tcHsBangType, tcLHsConResTy, - tcDataKindSig, kcCheckHsType ) -import TcMType ( newKindVar, checkValidTheta, checkValidType, - -- checkFreeness, - UserTypeCtxt(..), SourceTyCtxt(..) ) -import TcType ( TcKind, TcType, Type, tyVarsOfType, mkPhiTy, - mkArrowKind, liftedTypeKind, mkTyVarTys, - tcSplitSigmaTy, tcEqTypes, tcGetTyVar_maybe ) -import Type ( PredType(..), splitTyConApp_maybe, mkTyVarTy, - newTyConInstRhs, isLiftedTypeKind, Kind - -- pprParendType, pprThetaArrow - ) -import Generics ( validGenericMethodType, canDoGenerics ) -import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars ) -import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon, OpenDataTyCon, - OpenNewTyCon ), - SynTyConRhs( OpenSynTyCon, SynonymTyCon ), - tyConDataCons, mkForeignTyCon, isProductTyCon, - isRecursiveTyCon, isOpenTyCon, - tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName, - isNewTyCon ) -import DataCon ( DataCon, dataConUserType, dataConName, - dataConFieldLabels, dataConTyCon, dataConAllTyVars, - dataConFieldType, dataConResTys ) -import Var ( TyVar, idType, idName ) -import VarSet ( elemVarSet, mkVarSet ) -import Name ( Name, getSrcLoc ) +import TcEnv +import TcTyDecls +import TcClassDcl +import TcHsType +import TcMType +import TcType +import TysWiredIn ( unitTy ) +import Type +import Generics +import Class +import TyCon +import DataCon +import Id +import MkId ( rEC_SEL_ERROR_ID ) +import IdInfo +import Var +import VarSet +import Name +import OccName import Outputable -import Maybe ( isJust, fromJust, isNothing ) -import Maybes ( expectJust ) -import Unify ( tcMatchTys, tcMatchTyX ) -import Util ( zipLazy, isSingleton, notNull, sortLe ) -import List ( partition ) -import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan ) -import ListSetOps ( equivClasses, minusList ) -import List ( delete ) -import Digraph ( SCC(..) ) -import DynFlags ( DynFlag( Opt_GlasgowExts, Opt_Generics, - Opt_UnboxStrictFields ) ) +import Maybes +import Monad +import Unify +import Util +import SrcLoc +import ListSetOps +import Digraph +import DynFlags +import FastString +import Unique ( mkBuiltinUnique ) +import BasicTypes + +import Bag +import Data.List +import Control.Monad ( mplus ) \end{code} @@ -153,43 +137,57 @@ indeed type families). I think. \begin{code} tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name] - -> TcM TcGblEnv -- Input env extended by types and classes - -- and their implicit Ids,DataCons + -> TcM (TcGblEnv, -- Input env extended by types and classes + -- and their implicit Ids,DataCons + HsValBinds Name) -- Renamed bindings for record selectors +-- Fails if there are any errors + tcTyAndClassDecls boot_details allDecls - = do { -- Omit instances of indexed types; 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 . isIdxTyDecl . unLoc) allDecls + ; let decls = filter (not . isFamInstDecl . unLoc) allDecls -- First check for cyclic type synonysm or classes -- See notes with checkCycleErrs ; checkCycleErrs decls ; mod <- getModule ; traceTc (text "tcTyAndCl" <+> ppr mod) - ; (syn_tycons, alg_tyclss) <- fixM (\ ~(rec_syn_tycons, rec_alg_tyclss) -> - do { let { -- Calculate variances and rec-flag + ; (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 + -- required so that the temporary environment for the + -- knot includes all associated family declarations. ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc) - decls } + decls + ; alg_at_decls = concatMap addATs alg_decls + } -- Extend the global env with the knot-tied results -- for data types and classes -- - -- We must populate the environment with the loop-tied T's right - -- away, because the kind checker may "fault in" some type - -- constructors that recursively mention T - ; let { gbl_things = mkGlobalThings alg_decls rec_alg_tyclss } + -- We must populate the environment with the loop-tied + -- T's right away, because the kind checker may "fault + -- in" some type constructors that recursively + -- mention T + ; let gbl_things = mkGlobalThings alg_at_decls rec_alg_tyclss ; tcExtendRecEnv gbl_things $ do -- Kind-check the declarations { (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls - ; let { calc_rec = calcRecFlags boot_details rec_alg_tyclss + ; let { -- Calculate rec-flag + ; calc_rec = calcRecFlags boot_details rec_alg_tyclss ; tc_decl = addLocM (tcTyClDecl calc_rec) } + -- Type-check the type synonyms, and extend the envt ; syn_tycons <- tcSynDecls kc_syn_decls ; tcExtendGlobalEnv syn_tycons $ do -- Type-check the data types and classes - { alg_tyclss <- mappM tc_decl kc_alg_decls - ; return (syn_tycons, alg_tyclss) + { alg_tyclss <- mapM tc_decl kc_alg_decls + ; return (syn_tycons, concat alg_tyclss) }}}) -- Finished with knot-tying now -- Extend the environment with the finished things @@ -197,16 +195,30 @@ 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; -- we want them in the environment because -- they may be mentioned in interface files - ; let { implicit_things = concatMap implicitTyThings alg_tyclss } - ; traceTc ((text "Adding" <+> ppr alg_tyclss) $$ (text "and" <+> ppr implicit_things)) - ; tcExtendGlobalEnv implicit_things getGblEnv - }} + -- NB: All associated types and their implicit things will be added a + -- second time here. This doesn't matter as the definitions are + -- the same. + ; let { implicit_things = concatMap implicitTyThings alg_tyclss + ; aux_binds = mkAuxBinds alg_tyclss } + ; traceTc ((text "Adding" <+> ppr alg_tyclss) + $$ (text "and" <+> ppr implicit_things)) + ; env <- tcExtendGlobalEnv implicit_things getGblEnv + ; return (env, aux_binds) } + } + where + -- Pull associated types out of class declarations, to tie them into the + -- knot above. + -- NB: We put them in the same place in the list as `tcTyClDecl' will + -- eventually put the matching `TyThing's. That's crucial; otherwise, + -- the two argument lists of `mkGlobalThings' don't match up. + addATs decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats + addATs decl = [decl] mkGlobalThings :: [LTyClDecl Name] -- The decls -> [TyThing] -- Knot-tied, in 1-1 correspondence with the decls @@ -225,102 +237,132 @@ mkGlobalThings decls things %************************************************************************ %* * -\subsection{Type checking instances of indexed types} + Type checking family instances %* * %************************************************************************ -Instances of indexed types are somewhat of a hybrid. They are processed -together with class instance heads, but can contain data constructors and hence -they share a lot of kinding and type checking code with ordinary algebraic -data types (and GADTs). +Family instances are somewhat of a hybrid. They are processed together with +class instance heads, but can contain data constructors and hence they share a +lot of kinding and type checking code with ordinary algebraic data types (and +GADTs). \begin{code} -tcIdxTyInstDecl :: LTyClDecl Name -> TcM (Maybe InstInfo) -- Nothing if error -tcIdxTyInstDecl (L loc decl) +tcFamInstDecl :: LTyClDecl Name -> TcM TyThing +tcFamInstDecl (L loc decl) = -- Prime error recovery, set source location - recoverM (returnM Nothing) $ - setSrcSpan loc $ - tcAddDeclCtxt decl $ - do { -- indexed data types require -fglasgow-exts and can't be in an + setSrcSpan loc $ + tcAddDeclCtxt decl $ + do { -- type families require -XTypeFamilies and can't be in an -- hs-boot file - ; gla_exts <- doptM Opt_GlasgowExts + ; type_families <- doptM Opt_TypeFamilies ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? - ; checkTc gla_exts $ badIdxTyDecl (tcdLName decl) - ; checkTc (not is_boot) $ badBootTyIdxDeclErr - - -- perform kind and type checking - ; tcIdxTyInstDecl1 decl - } + ; checkTc type_families $ badFamInstDecl (tcdLName decl) + ; checkTc (not is_boot) $ badBootFamInstDeclErr + + -- Perform kind and type checking + ; tc <- tcFamInstDecl1 decl + ; checkValidTyCon tc -- Remember to check validity; + -- no recursion to worry about here + ; return (ATyCon tc) } + +tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon + + -- "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 + checkTc (isOpenTyCon family) (notFamily family) + ; checkTc (isSynTyCon family) (wrongKindOfFamily family) + + ; -- (1) kind check the right-hand side of the type equation + ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk) + -- ToDo: the ExpKind could be better + + -- 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 <- mapM tcHsKindedType k_typats + ; t_rhs <- tcHsKindedType k_rhs -tcIdxTyInstDecl1 :: TyClDecl Name -> TcM (Maybe InstInfo) -- Nothing if error + -- (3) check the well-formedness of the instance + ; checkValidTypeInst t_typats t_rhs -tcIdxTyInstDecl1 (decl@TySynonym {}) - = kcIdxTyPats decl $ \k_tvs k_typats resKind -> - do { -- kind check the right hand side of the type equation - ; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind + -- (4) construct representation tycon + ; rep_tc_name <- newFamInstTyConName tc_name loc + ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) + (typeKind t_rhs) (Just (family, t_typats)) + }} - -- type check type equation - ; tcTyVarBndrs k_tvs $ \t_tvs -> do { - ; t_typats <- mappM tcHsKindedType k_typats - ; t_rhs <- tcHsKindedType k_rhs + -- "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 fam_tycon -> + do { -- check that the family declaration is for the right kind + checkTc (isOpenTyCon fam_tycon) (notFamily fam_tycon) + ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon) - -- construct type rewrite rule - -- !!!of the form: forall t_tvs. (tcdLName decl) t_typats = t_rhs - ; return Nothing -- !!!TODO: need InstInfo for indexed types - }} - -tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L _ tc_name, - tcdCons = cons}) - = kcIdxTyPats decl $ \k_tvs k_typats resKind -> - do { -- kind check the data declaration as usual + ; -- (1) kind check the data declaration as usual ; k_decl <- kcDataDecl decl k_tvs - ; k_typats <- mappM tcHsKindedType k_typats - ; let k_ctxt = tcdCtxt decl - k_cons = tcdCons decl + ; let k_ctxt = tcdCtxt k_decl + 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 fam_tycon) - -- type check indexed data type declaration - ; tcTyVarBndrs k_tvs $ \t_tvs -> do { + -- (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 - ; checkTc h98_syntax (badGadtIdxTyDecl tc_name) - - -- Check that a newtype has exactly one constructor - ; checkTc (new_or_data == DataType || isSingleton cons) $ - newtypeConError tc_name (length cons) - + -- kind check the type indexes and the context + ; t_typats <- mapM tcHsKindedType k_typats ; stupid_theta <- tcHsKindedContext k_ctxt - ; tycon <- fixM (\ tycon -> do - { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data - tycon t_tvs)) - k_cons + + -- (3) Check that + -- (a) left-hand side contains no type family applications + -- (vanilla synonyms are fine, though, and we checked for + -- foralls earlier) + ; mapM_ checkTyFamFreeness t_typats + + -- Check that we don't use GADT syntax in H98 world + ; gadt_ok <- doptM Opt_GADTs + ; checkTc (gadt_ok || consUseH98Syntax cons) (badGadtDecl tc_name) + + -- (b) a newtype has exactly one constructor + ; checkTc (new_or_data == DataType || isSingleton k_cons) $ + newtypeConError tc_name (length k_cons) + + -- (4) construct representation tycon + ; rep_tc_name <- newFamInstTyConName tc_name loc + ; let ex_ok = True -- Existentials ok for type families! + ; fixM (\ rep_tycon -> do + { let orig_res_ty = mkTyConApp fam_tycon t_typats + ; data_cons <- tcConDecls unbox_strict ex_ok rep_tycon + (t_tvs, orig_res_ty) 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) - --vvvvvvv !!! need a new derived tc_name here - ; buildAlgTyCon tc_name t_tvs stupid_theta tc_rhs Recursive - False h98_syntax + NewType -> ASSERT( not (null data_cons) ) + mkNewTyConRhs rep_tc_name rep_tycon (head data_cons) + ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive + False h98_syntax (Just (fam_tycon, t_typats)) -- We always assume that indexed types are recursive. Why? -- (1) Due to their open nature, we can never be sure that a -- further instance might not introduce a new recursive -- dependency. (2) They are always valid loop breakers as -- they involve a coercion. }) - - -- construct result - -- !!!twofold: (1) (ATyCon tycon) and (2) an equality axiom - ; return Nothing -- !!!TODO: need InstInfo for indexed types }} 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 -- - @@ -329,18 +371,18 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L _ 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 -> TcM a) + -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a) -- ^^kinded tvs ^^kinded ty pats ^^res kind -> TcM a kcIdxTyPats decl thing_inside = kcHsTyVars (tcdTyVars decl) $ \tvs -> - do { tc_ty_thing <- tcLookupLocated (tcdLName decl) - ; let tc_kind = case tc_ty_thing of { AThing k -> k } - (kinds, resKind) = splitKindFunTys tc_kind - hs_typats = fromJust $ tcdTyPats decl + do { let tc_name = tcdLName decl + ; fam_tycon <- tcLookupLocatedTyCon tc_name + ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon) + ; hs_typats = fromJust $ tcdTyPats decl } -- we may not have more parameters than the kind indicates ; checkTc (length kinds >= length hs_typats) $ @@ -348,8 +390,10 @@ kcIdxTyPats decl thing_inside -- type functions can have a higher-kinded result ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind - ; typats <- zipWithM kcCheckHsType hs_typats kinds - ; thing_inside tvs typats resultKind + ; typats <- zipWithM kcCheckLHsType hs_typats + [ EK kind (EkArg (ppr tc_name) n) + | (kind,n) <- kinds `zip` [1..]] + ; thing_inside tvs typats resultKind fam_tycon } \end{code} @@ -382,24 +426,26 @@ 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'. -The kind of an indexed type is solely determinded by its kind signature; +The kind of a type family is solely determinded by its kind signature; hence, only kind signatures participate in the construction of the initial kind environment (as constructed by `getInitialKind'). In fact, we ignore -instances of indexed types altogether in the following. However, we need to -include the kind signatures of associated types into the construction of the +instances of families altogether in the following. However, we need to +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 @@ -415,8 +461,8 @@ 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) - (filter (not . isIdxTyDecl . unLoc) alg_decls) + { kc_alg_decls <- mapM (wrapLocM kcTyClDecl) + (filter (not . isFamInstDecl . unLoc) alg_decls) ; return (kc_syn_decls, kc_alg_decls) }}} where @@ -424,9 +470,9 @@ kcTyClDecls syn_decls alg_decls -- environment allDecls (decl@ClassDecl {tcdATs = ats}) = decl : [ at | L _ at <- ats - , isKindSigDecl at] - allDecls decl | isIdxTyDecl decl = [] - | otherwise = [decl] + , isFamilyDecl at] + allDecls decl | isFamInstDecl decl = [] + | otherwise = [decl] ------------------------------------------------------------------------ getInitialKind :: TyClDecl Name -> TcM (Name, TcKind) @@ -441,12 +487,11 @@ getInitialKind decl mk_arg_kind (UserTyVar _) = newKindVar mk_arg_kind (KindedTyVar _ kind) = return kind - mk_res_kind (TyFunction { tcdKind = kind }) = return kind - mk_res_kind (TyData { tcdKindSig = Just kind }) = return kind - -- On GADT-style and data signature declarations we allow a kind - -- signature + mk_res_kind (TyFamily { tcdKind = Just kind }) = return kind + mk_res_kind (TyData { tcdKindSig = Just kind }) = return kind + -- On GADT-style declarations we allow a kind signature -- data T :: *->* where { ... } - mk_res_kind other = return liftedTypeKind + mk_res_kind _ = return liftedTypeKind ---------------- @@ -464,12 +509,12 @@ 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)) <+> brackets (ppr k_tvs)) - ; (k_rhs, rhs_kind) <- kcHsType (tcdSynRhs decl) + ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl) ; traceTc (text "kcd2" <+> ppr (unLoc (tcdLName decl))) ; let tc_kind = foldr (mkArrowKind . kindedTyVarKind) rhs_kind k_tvs ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }), @@ -479,27 +524,27 @@ 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) -- Not used for type synonyms (see kcSynDecl) kcTyClDecl decl@(TyData {}) - = ASSERT( not . isJust $ tcdTyPats decl ) -- must not be instance of idx ty + = ASSERT( not . isFamInstDecl $ decl ) -- must not be a family instance kcTyClDeclBody decl $ kcDataDecl decl -kcTyClDecl decl@(TyFunction {}) - = kcTyClDeclBody decl $ \ tvs' -> - return (decl {tcdTyVars = tvs'}) +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 + 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 @@ -510,6 +555,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 @@ -521,7 +568,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 ) @@ -537,26 +586,35 @@ 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 - kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res) = do - kcHsTyVars ex_tvs $ \ex_tvs' -> do - ex_ctxt' <- kcHsContext ex_ctxt - details' <- kc_con_details details - res' <- case res of - ResTyH98 -> return ResTyH98 - ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') } - return (ConDecl name expl ex_tvs' ex_ctxt' details' res') + -- doc comments are typechecked to Nothing here + kc_con_decl con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs + , con_cxt = ex_ctxt, con_details = details, con_res = res }) + = addErrCtxt (dataConCtxt name) $ + kcHsTyVars ex_tvs $ \ex_tvs' -> do + do { ex_ctxt' <- kcHsContext ex_ctxt + ; details' <- kc_con_details details + ; res' <- case res of + ResTyH98 -> return ResTyH98 + ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') } + ; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt' + , con_details = details', con_res = res' }) } kc_con_details (PrefixCon btys) - = do { btys' <- mappM kc_larg_ty btys ; return (PrefixCon 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') } + = 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' <- mapM kc_field fields + ; return (RecCon fields') } - kc_field (fld, bty) = do { bty' <- kc_larg_ty bty ; return (fld, bty') } + 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 @@ -564,6 +622,28 @@ 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. +-- +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 () + unifyClassParmKinds x = pprPanic "kcFamilyDecl/unifyClassParmKinds" (ppr x) + classTyKinds = [(n, k) | L _ (KindedTyVar n k) <- classTvs] +kcFamilyDecl _ (TySynonym {}) -- type family defaults + = panic "TcTyClsDecls.kcFamilyDecl: not implemented yet" +kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d) \end{code} @@ -581,53 +661,69 @@ tcSynDecls (decl : decls) ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls 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 - ; return (ATyCon (buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty'))) } + ; 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 +tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] tcTyClDecl calc_isrec decl = tcAddDeclCtxt decl (tcTyClDecl1 calc_isrec decl) - -- kind signature for a type function + -- "type family" declarations +tcTyClDecl1 :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] tcTyClDecl1 _calc_isrec - (TyFunction {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = kind}) + (TyFamily {tcdFlavour = TypeFamily, + tcdLName = L _ tc_name, tcdTyVars = tvs, + tcdKind = Just kind}) -- NB: kind at latest added during kind checking = tcTyVarBndrs tvs $ \ tvs' -> do - { gla_exts <- doptM Opt_GlasgowExts + { traceTc (text "type family: " <+> ppr tc_name) - -- Check that we don't use kind signatures without Glasgow extensions - ; checkTc gla_exts $ badSigTyDecl tc_name + -- Check that we don't use families without -XTypeFamilies + ; idx_tys <- doptM Opt_TypeFamilies + ; checkTc idx_tys $ badFamInstDecl tc_name - ; return (ATyCon (buildSynTyCon tc_name tvs' (OpenSynTyCon kind))) + -- Check for no type indices + ; checkTc (not (null tvs)) (noIndexTypes tc_name) + + ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) kind Nothing + ; return [ATyCon tycon] } - -- kind signature for an indexed data type + -- "data family" declaration tcTyClDecl1 _calc_isrec - (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, - tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = []}) + (TyFamily {tcdFlavour = DataFamily, + tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind}) = tcTyVarBndrs tvs $ \ tvs' -> do - { extra_tvs <- tcDataKindSig mb_ksig + { traceTc (text "data family: " <+> ppr tc_name) + ; extra_tvs <- tcDataKindSig mb_kind ; let final_tvs = tvs' ++ extra_tvs -- we may not need these - ; checkTc (null . unLoc $ ctxt) $ badKindSigCtxt tc_name - ; gla_exts <- doptM Opt_GlasgowExts - -- Check that we don't use kind signatures without Glasgow extensions - ; checkTc gla_exts $ badSigTyDecl tc_name + -- Check that we don't use families without -XTypeFamilies + ; idx_tys <- doptM Opt_TypeFamilies + ; checkTc idx_tys $ badFamInstDecl tc_name + + -- Check for no type indices + ; checkTc (not (null tvs)) (noIndexTypes tc_name) ; tycon <- buildAlgTyCon tc_name final_tvs [] - (case new_or_data of - DataType -> OpenDataTyCon - NewType -> OpenNewTyCon) - Recursive False True - ; return (ATyCon tycon) + mkOpenDataTyConRhs Recursive False True Nothing + ; return [ATyCon tycon] } + -- "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}) @@ -637,49 +733,52 @@ 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 + ; 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 (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) - (emptyConDeclsErr 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) + ; tycon <- fixM (\ tycon -> do - { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data - tycon final_tvs)) - cons + { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs) + ; data_cons <- tcConDecls unbox_strict ex_ok + tycon (final_tvs, res_ty) cons ; tc_rhs <- if null cons && is_boot -- In a hs-boot file, empty cons means then return AbstractTyCon -- "don't know"; hence Abstract else 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 tc_name tycon (head data_cons) ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec - (want_generic && canDoGenerics data_cons) h98_syntax + (want_generic && canDoGenerics data_cons) h98_syntax Nothing }) - ; return (ATyCon tycon) + ; return [ATyCon tycon] } where is_rec = calc_isrec tc_name - h98_syntax = case cons of -- All constructors have same shape - L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False - other -> True + h98_syntax = consUseH98Syntax cons tcTyClDecl1 calc_isrec (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, @@ -687,9 +786,11 @@ tcTyClDecl1 calc_isrec tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} ) = tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt - ; fds' <- mappM (addLocM tc_fundep) fundeps - ; ats' <- mappM (addLocM (tcTyClDecl1 (const Recursive))) ats - -- ^^^^ !!!TODO: what to do with this? Need to generate FC tyfun decls. + ; 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' = map (setAssocFamilyPermutation tvs') (concat atss) ; sig_stuff <- tcClassSigs class_name sigs meths ; clas <- fixM (\ clas -> let -- This little knot is just so we can get @@ -698,123 +799,146 @@ tcTyClDecl1 calc_isrec tycon_name = tyConName (classTyCon clas) tc_isrec = calc_isrec tycon_name in - buildClass class_name tvs' ctxt' fds' + buildClass False {- Must include unfoldings for selectors -} + class_name tvs' ctxt' fds' ats' sig_stuff tc_isrec) - ; return (AClass clas) } + ; 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') } - -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 - -> 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 [(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 - } +tcConDecls :: Bool -> Bool -> TyCon -> ([TyVar], Type) + -> [LConDecl Name] -> TcM [DataCon] +tcConDecls unbox ex_ok rep_tycon res_tmpl cons + = mapM (addLocM (tcConDecl unbox ex_ok rep_tycon res_tmpl)) cons -tcConDecl unbox_strict DataType tycon tc_tvs -- Data types - (ConDecl name _ tvs ctxt details res_ty) - = tcTyVarBndrs tvs $ \ tvs' -> do +tcConDecl :: Bool -- True <=> -funbox-strict_fields + -> Bool -- True <=> -XExistentialQuantificaton or -XGADTs + -> TyCon -- Representation tycon + -> ([TyVar], Type) -- Return type template (with its template tyvars) + -> ConDecl Name + -> TcM DataCon + +tcConDecl unbox_strict existential_ok rep_tycon res_tmpl -- Data types + (ConDecl {con_name =name, con_qvars = tvs, con_cxt = ctxt + , con_details = details, con_res = res_ty }) + = addErrCtxt (dataConCtxt name) $ + tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt - ; (univ_tvs, ex_tvs, eq_preds, data_tc) <- tcResultType tycon tc_tvs tvs' res_ty + ; checkTc (existential_ok || (null tvs && null (unLoc ctxt))) + (badExistential name) + ; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty ; let tc_datacon is_infix field_lbls btys - = do { let bangs = map getBangStrictness btys - ; arg_tys <- mappM tcHsBangType btys + = do { (arg_tys, stricts) <- mapAndUnzipM (tcConArg unbox_strict) btys ; buildDataCon (unLoc name) is_infix - (argStrictness unbox_strict tycon bangs arg_tys) - (map unLoc field_lbls) + stricts field_lbls univ_tvs ex_tvs eq_preds ctxt' arg_tys - data_tc } - -- NB: we put data_tc, the type constructor gotten from the constructor - -- type signature into the data constructor; that way - -- checkValidDataCon can complain if it's wrong. + res_ty' rep_tycon } + -- NB: we put data_tc, the type constructor gotten from the + -- constructor type signature into the data constructor; + -- that way checkValidDataCon can complain if it's wrong. ; case details of PrefixCon btys -> tc_datacon False [] btys InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2] RecCon fields -> tc_datacon False field_names btys where - (field_names, btys) = unzip fields - + field_names = map (unLoc . cd_fld_name) fields + btys = map cd_fld_type fields } -tcResultType :: TyCon - -> [TyVar] -- data T a b c = ... - -> [TyVar] -- where MkT :: forall a b c. ... +-- Example +-- data instance T (b,c) where +-- TI :: forall e. e -> T (e,e) +-- +-- The representation tycon looks like this: +-- data :R7T b c where +-- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1 +-- In this case orig_res_ty = T (e,e) + +tcResultType :: ([TyVar], Type) -- Template for result type; e.g. + -- data instance T [a] b c = ... + -- gives template ([a,b,c], T [a] b c) + -> [TyVar] -- where MkT :: forall x y z. ... -> ResType Name -> TcM ([TyVar], -- Universal - [TyVar], -- Existential + [TyVar], -- Existential (distinct OccNames from univs) [(TyVar,Type)], -- Equality predicates - TyCon) -- TyCon given in the ResTy + Type) -- Typechecked return type -- We don't check that the TyCon given in the ResTy is -- the same as the parent tycon, becuase we are in the middle -- of a recursive knot; so it's postponed until checkValidDataCon -tcResultType decl_tycon tc_tvs dc_tvs ResTyH98 - = return (tc_tvs, dc_tvs, [], decl_tycon) +tcResultType (tmpl_tvs, res_ty) dc_tvs ResTyH98 + = return (tmpl_tvs, dc_tvs, [], res_ty) -- In H98 syntax the dc_tvs are the existential ones -- data T a b c = forall d e. MkT ... -- The {a,b,c} are tc_tvs, and {d,e} are dc_tvs -tcResultType _ tc_tvs dc_tvs (ResTyGADT res_ty) - -- E.g. data T a b c where - -- MkT :: forall x y z. T (x,y) z z +tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty) + -- E.g. data T [a] b c where + -- MkT :: forall x y z. T [(x,y)] z z -- Then we generate - -- ([a,z,c], [x,y], [a:=:(x,y), c:=:z], T) - - = do { (dc_tycon, res_tys) <- tcLHsConResTy res_ty - -- NB: tc_tvs and dc_tvs are distinct - ; let univ_tvs = choose_univs [] tc_tvs res_tys - -- Each univ_tv is either a dc_tv or a tc_tv + -- Univ tyvars Eq-spec + -- a a~(x,y) + -- b b~z + -- z + -- Existentials are the leftover type vars: [x,y] + -- So we return ([a,b,z], [x,y], [a~(x,y),b~z], T [(x,y)] z z) + = do { res_ty' <- tcHsKindedType res_ty + ; let Just subst = tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty' + + -- /Lazily/ figure out the univ_tvs etc + -- Each univ_tv is either a dc_tv or a tmpl_tv + (univ_tvs, eq_spec) = foldr choose ([], []) tidy_tmpl_tvs + choose tmpl (univs, eqs) + | Just ty <- lookupTyVar subst tmpl + = case tcGetTyVar_maybe ty of + Just tv | not (tv `elem` univs) + -> (tv:univs, eqs) + _other -> (tmpl:univs, (tmpl,ty):eqs) + | otherwise = pprPanic "tcResultType" (ppr res_ty) ex_tvs = dc_tvs `minusList` univ_tvs - eq_spec = [ (tv, ty) | (tv,ty) <- univ_tvs `zip` res_tys, - tv `elem` tc_tvs] - ; return (univ_tvs, ex_tvs, eq_spec, dc_tycon) } + + ; return (univ_tvs, ex_tvs, eq_spec, 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 [] - = 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) - = tv : choose_univs (tv:used) tc_tvs res_tys - | otherwise - = tc_tv : choose_univs used tc_tvs res_tys + -- NB: tmpl_tvs and dc_tvs are distinct, but + -- we want them to be *visibly* distinct, both for + -- interface files and general confusion. So rename + -- the tc_tvs, since they are not used yet (no + -- consequential renaming needed) + (_, tidy_tmpl_tvs) = mapAccumL tidy_one init_occ_env tmpl_tvs + init_occ_env = initTidyOccEnv (map getOccName dc_tvs) + tidy_one env tv = (env', setTyVarName tv (tidyNameOcc name occ')) + where + name = tyVarName tv + (env', occ') = tidyOccName env (getOccName name) + +consUseH98Syntax :: [LConDecl a] -> Bool +consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False +consUseH98Syntax _ = True + -- All constructors have same shape ------------------- -argStrictness :: Bool -- True <=> -funbox-strict_fields - -> TyCon -> [HsBang] - -> [TcType] -> [StrictnessMark] -argStrictness unbox_strict tycon bangs arg_tys - = ASSERT( length bangs == length arg_tys ) - zipWith (chooseBoxingStrategy unbox_strict tycon) arg_tys bangs +tcConArg :: Bool -- True <=> -funbox-strict_fields + -> LHsType Name + -> TcM (TcType, StrictnessMark) +tcConArg unbox_strict bty + = do { arg_ty <- tcHsBangType bty + ; let bang = getBangStrictness bty + ; return (arg_ty, chooseBoxingStrategy unbox_strict arg_ty bang) } -- We attempt to unbox/unpack a strict field when either: -- (i) The field is marked '!!', or @@ -822,30 +946,39 @@ argStrictness unbox_strict tycon bangs arg_tys -- -- We have turned off unboxing of newtypes because coercions make unboxing -- and reboxing more complicated -chooseBoxingStrategy :: Bool -> TyCon -> TcType -> HsBang -> StrictnessMark -chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang +chooseBoxingStrategy :: Bool -> TcType -> HsBang -> StrictnessMark +chooseBoxingStrategy unbox_strict_fields arg_ty bang = case bang of HsNoBang -> NotMarkedStrict 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 can_unbox arg_ty = case splitTyConApp_maybe arg_ty of Nothing -> False Just (arg_tycon, tycon_args) -> - not (isRecursiveTyCon tycon) && + not (isRecursiveTyCon arg_tycon) && -- Note [Recusive unboxing] isProductTyCon arg_tycon && (if isNewTyCon arg_tycon then can_unbox (newTyConInstRhs arg_tycon tycon_args) else True) \end{code} +Note [Recursive unboxing] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Be careful not to try to unbox this! + data T = MkT !T Int +But it's the *argument* type that matters. This is fine: + data S = MkS S !Int +because Int is non-recursive. + + %************************************************************************ %* * -\subsection{Dependency analysis} + Validity checking %* * %************************************************************************ @@ -858,7 +991,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 @@ -874,6 +1007,7 @@ checkValidTyCl decl ; case thing of ATyCon tc -> checkValidTyCon tc AClass cl -> checkValidClass cl + _ -> panic "checkValidTyCl" ; traceTc (text "Done validity of" <+> ppr thing) } @@ -884,22 +1018,29 @@ checkValidTyCl decl -- (b) has the same type for 'f' -- module alpha conversion of the quantified type variables -- of the constructor. +-- +-- Note that we allow existentials to match becuase the +-- fields can never meet. E.g +-- data T where +-- T1 { f1 :: b, f2 :: a, f3 ::Int } :: T +-- T2 { f1 :: c, f2 :: c, f3 ::Int } :: T +-- Here we do not complain about f1,f2 because they are existential 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_` + = 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 @@ -925,7 +1066,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 @@ -933,23 +1074,26 @@ 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 + 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) } where - mb_subst1 = tcMatchTys tvs1 res1 res2 + mb_subst1 = tcMatchTy tvs1 res1 res2 mb_subst2 = tcMatchTyX tvs1 (expectJust "checkFieldCompat" mb_subst1) fty1 fty2 ------------------------------- @@ -957,26 +1101,57 @@ checkValidDataCon :: TyCon -> DataCon -> TcM () checkValidDataCon tc con = setSrcSpan (srcLocSpan (getSrcLoc con)) $ addErrCtxt (dataConCtxt con) $ - do { checkTc (dataConTyCon con == tc) (badDataConTyCon con) - ; checkValidType ctxt (dataConUserType con) } + do { traceTc (ptext (sLit "Validity of data con") <+> ppr con) + ; let tc_tvs = tyConTyVars tc + res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs) + actual_res_ty = dataConOrigResTy con + ; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs) + res_ty_tmpl + actual_res_ty)) + (badDataConTyCon con res_ty_tmpl actual_res_ty) + ; checkValidMonoType (dataConOrigResTy con) + -- Disallow MkT :: T (forall a. a->a) + -- Reason: it's really the argument of an equality constraint + ; checkValidType ctxt (dataConUserType con) + ; when (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 + ; 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 @@ -984,21 +1159,27 @@ 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 - -- the class type variables - ; checkTc (any (`elemVarSet` tyVarsOfType tau) tyvars) + -- the class type variables...or at least one reachable + -- from one of the class variables. Example: tc223 + -- class Error e => Game b mv e | b -> mv e where + -- newBoard :: MonadState b m => m () + -- Here, MonadState has a fundep m->b, so newBoard is fine + ; let grown_tyvars = growThetaTyVars theta (mkVarSet tyvars) + ; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars) (noClassTyVarErr cls sel_id) -- Check that for a generic method, the type of @@ -1011,62 +1192,252 @@ 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! +\end{code} + + +%************************************************************************ +%* * + Building record selectors +%* * +%************************************************************************ + +\begin{code} +mkAuxBinds :: [TyThing] -> HsValBinds Name +-- NB We produce *un-typechecked* bindings, rather like 'deriving' +-- This makes life easier, because the later type checking will add +-- all necessary type abstractions and applications +mkAuxBinds ty_things + = ValBindsOut [(NonRecursive, b) | b <- binds] sigs + where + (sigs, binds) = unzip rec_sels + rec_sels = map mkRecSelBind [ (tc,fld) + | ATyCon tc <- ty_things + , fld <- tyConFields tc ] + +mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name) +mkRecSelBind (tycon, sel_name) + = (L loc (IdSig sel_id), unitBag (L loc sel_bind)) + where + loc = getSrcSpan tycon + sel_id = Var.mkLocalVar rec_details sel_name sel_ty vanillaIdInfo + rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty } + + -- Find a representative constructor, con1 + all_cons = tyConDataCons tycon + cons_w_field = [ con | con <- all_cons + , sel_name `elem` dataConFieldLabels con ] + con1 = ASSERT( not (null cons_w_field) ) head cons_w_field + + -- Selector type; Note [Polymorphic selectors] + field_ty = dataConFieldType con1 sel_name + data_ty = dataConOrigResTy con1 + data_tvs = tyVarsOfType data_ty + is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs) + (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty + sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors] + | otherwise = mkForAllTys (varSetElems data_tvs ++ field_tvs) $ + mkPhiTy (dataConStupidTheta con1) $ -- Urgh! + mkPhiTy field_theta $ -- Urgh! + mkFunTy data_ty field_tau + + -- Make the binding: sel (C2 { fld = x }) = x + -- sel (C7 { fld = x }) = x + -- where cons_w_field = [C2,C7] + sel_bind | is_naughty = mkFunBind sel_lname [mkSimpleMatch [] unit_rhs] + | otherwise = mkFunBind sel_lname (map mk_match cons_w_field ++ deflt) + mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)] + (L loc (HsVar field_var)) + mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) + rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } + rec_field = HsRecField { hsRecFieldId = sel_lname + , hsRecFieldArg = nlVarPat field_var + , hsRecPun = False } + sel_lname = L loc sel_name + field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc + + -- Add catch-all default case unless the case is exhaustive + -- We do this explicitly so that we get a nice error message that + -- mentions this particular record selector + deflt | length cons_w_field == length all_cons = [] + | otherwise = [mkSimpleMatch [nlWildPat] + (nlHsApp (nlHsVar (getName rEC_SEL_ERROR_ID)) + (nlHsLit msg_lit))] + + unit_rhs = L loc $ ExplicitTuple [] Boxed + msg_lit = HsStringPrim $ mkFastString $ + occNameString (getOccName sel_name) + +--------------- +tyConFields :: TyCon -> [FieldLabel] +tyConFields tc + | isAlgTyCon tc = nub (concatMap dataConFieldLabels (tyConDataCons tc)) + | otherwise = [] +\end{code} +Note [Polymorphic selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a record has a polymorphic field, we pull the foralls out to the front. + data T = MkT { f :: forall a. [a] -> a } +Then f :: forall a. T -> [a] -> a +NOT f :: T -> forall a. [a] -> a + +This is horrid. It's only needed in deeply obscure cases, which I hate. +The only case I know is test tc163, which is worth looking at. It's far +from clear that this test should succeed at all! + +Note [Naughty record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A "naughty" field is one for which we can't define a record +selector, because an existential type variable would escape. For example: + data T = forall a. MkT { x,y::a } +We obviously can't define + x (MkT v _) = v +Nevertheless we *do* put a RecSelId into the type environment +so that if the user tries to use 'x' as a selector we can bleat +helpfully, rather than saying unhelpfully that 'x' is not in scope. +Hence the sel_naughty flag, to identify record selectors that don't really exist. + +In general, a field is "naughty" if its type mentions a type variable that +isn't in the result type of the constructor. Note that this *allows* +GADT record selectors (Note [GADT record selectors]) whose types may look +like sel :: T [a] -> a + +For naughty selectors we make a dummy binding + sel = () +for naughty selectors, so that the later type-check will add them to the +environment, and they'll be exported. The function is never called, because +the tyepchecker spots the sel_naughty field. + +Note [GADT record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For GADTs, we require that all constructors with a common field 'f' have the same +result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon] +E.g. + data T where + T1 { f :: Maybe a } :: T [a] + T2 { f :: Maybe a, y :: b } :: T [a] + +and now the selector takes that result type as its argument: + f :: forall a. T [a] -> Maybe a + +Details: the "real" types of T1,T2 are: + T1 :: forall r a. (r~[a]) => a -> T r + T2 :: forall r a b. (r~[a]) => a -> b -> T r + +So the selector loooks like this: + f :: forall a. T [a] -> Maybe a + f (a:*) (t:T [a]) + = case t of + T1 c (g:[a]~[c]) (v:Maybe c) -> v `cast` Maybe (right (sym g)) + T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g)) + +Note the forall'd tyvars of the selector are just the free tyvars +of the result type; there may be other tyvars in the constructor's +type (e.g. 'b' in T2). + +Note the need for casts in the result! + +Note [Selector running example] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's OK to combine GADTs and type families. Here's a running example: + + data instance T [a] where + T1 { fld :: b } :: T [Maybe b] + +The representation type looks like this + data :R7T a where + T1 { fld :: b } :: :R7T (Maybe b) + +and there's coercion from the family type to the representation type + :CoR7T a :: T [a] ~ :R7T a + +The selector we want for fld looks like this: + + fld :: forall b. T [Maybe b] -> b + fld = /\b. \(d::T [Maybe b]). + case d `cast` :CoR7T (Maybe b) of + T1 (x::b) -> x + +The scrutinee of the case has type :R7T (Maybe b), which can be +gotten by appying the eq_spec to the univ_tvs of the data con. ---------------------------------------------------------------------- +%************************************************************************ +%* * + Error messages +%* * +%************************************************************************ + +\begin{code} +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 -fglasgow-exts 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"))] + +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 @@ -1077,61 +1448,104 @@ sortLocated things = sortLe le things where 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")) +badDataConTyCon :: DataCon -> Type -> Type -> SDoc +badDataConTyCon data_con res_ty_tmpl actual_res_ty + = hang (ptext (sLit "Data constructor") <+> quotes (ppr data_con) <+> + ptext (sLit "returns type") <+> quotes (ppr actual_res_ty)) + 2 (ptext (sLit "instead of an instance of its parent type") <+> quotes (ppr res_ty_tmpl)) +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 -fglasgow-exts 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")] +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")] + +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") <+> - quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow indexed types")) ] - -badKindSigCtxt tc_name - = vcat [ ptext SLIT("Illegal context in kind signature") <+> + = vcat [ ptext (sLit "Illegal kind signature") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Currently, kind signatures cannot have a context")) ] + , nest 2 (parens $ ptext (sLit "Use -XKindSignatures to allow kind signatures")) ] -badIdxTyDecl tc_name - = vcat [ ptext SLIT("Illegal indexed type instance for") <+> - quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow indexed types")) ] +noIndexTypes :: Name -> SDoc +noIndexTypes tc_name + = ptext (sLit "Type family constructor") <+> quotes (ppr tc_name) + <+> ptext (sLit "must have at least one type index parameter") -badGadtIdxTyDecl tc_name - = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> +badFamInstDecl :: Outputable a => a -> SDoc +badFamInstDecl tc_name + = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Indexed types cannot use GADT declarations")) ] + , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ] +tooManyParmsErr :: Located Name -> SDoc tooManyParmsErr tc_name - = ptext SLIT("Indexed type instance has too many parameters:") <+> + = ptext (sLit "Family instance has too many parameters:") <+> quotes (ppr tc_name) -tooFewParmsErr tc_name - = ptext SLIT("Indexed type instance has too few parameters:") <+> - quotes (ppr tc_name) - -badBootTyIdxDeclErr = ptext SLIT("Illegal indexed type instance in hs-boot file") +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") + +notFamily :: TyCon -> SDoc +notFamily tycon + = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon) + , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))] + +wrongKindOfFamily :: TyCon -> SDoc +wrongKindOfFamily family + = 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") + | otherwise = pprPanic "wrongKindOfFamily" (ppr family) +emptyConDeclsErr :: Name -> SDoc emptyConDeclsErr tycon - = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"), - nest 2 $ ptext SLIT("(-fglasgow-exts permits this)")] + = sep [quotes (ppr tycon) <+> ptext (sLit "has no constructors"), + nest 2 $ ptext (sLit "(-XEmptyDataDecls permits this)")] \end{code}