X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=ca4f2c5ecd098e9afbd1c105c4faaf1bef78ec94;hp=c1e58161d14f51dfda749061805e0517d98e9df7;hb=HEAD;hpb=cbcc6ec44ae3d8c17a54c0d4e5e6dac622019428 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index c1e5816..ca4f2c5 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -6,22 +6,14 @@ TcTyClsDecls: Typecheck type and class declarations \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module TcTyClsDecls ( - tcTyAndClassDecls, tcFamInstDecl + tcTyAndClassDecls, kcDataDecl, tcConDecls, mkRecSelBinds, + checkValidTyCon, dataDeclChecks, badFamInstDecl ) where #include "HsVersions.h" import HsSyn -import HsTypes -import BasicTypes import HscTypes import BuildTyCl import TcUnify @@ -32,28 +24,33 @@ import TcClassDcl import TcHsType import TcMType import TcType -import FunDeps +import TysWiredIn ( unitTy ) import Type -import Generics import Class import TyCon import DataCon +import Id +import MkCore ( rEC_SEL_ERROR_ID ) +import IdInfo import Var import VarSet import Name -import OccName +import NameEnv import Outputable 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 Control.Monad import Data.List -import Control.Monad ( mplus ) \end{code} @@ -63,342 +60,107 @@ import Control.Monad ( mplus ) %* * %************************************************************************ -Dealing with a group -~~~~~~~~~~~~~~~~~~~~ -Consider a mutually-recursive group, binding -a type constructor T and a class C. - -Step 1: getInitialKind - Construct a KindEnv by binding T and C to a kind variable - -Step 2: kcTyClDecl - In that environment, do a kind check - -Step 3: Zonk the kinds - -Step 4: buildTyConOrClass - Construct an environment binding T to a TyCon and C to a Class. - a) Their kinds comes from zonking the relevant kind variable - b) Their arity (for synonyms) comes direct from the decl - c) The funcional dependencies come from the decl - d) The rest comes a knot-tied binding of T and C, returned from Step 4 - e) The variances of the tycons in the group is calculated from - the knot-tied stuff - -Step 5: tcTyClDecl1 - In this environment, walk over the decls, constructing the TyCons and Classes. - This uses in a strict way items (a)-(c) above, which is why they must - be constructed in Step 4. Feed the results back to Step 4. - For this step, pass the is-recursive flag as the wimp-out flag - to tcTyClDecl1. - - -Step 6: Extend environment - We extend the type environment with bindings not only for the TyCons and Classes, - but also for their "implicit Ids" like data constructors and class selectors - -Step 7: checkValidTyCl - For a recursive group only, check all the decls again, just - to check all the side conditions on validity. We could not - do this before because we were in a mutually recursive knot. - -Identification of recursive TyCons -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to -@TyThing@s. - -Identifying a TyCon as recursive serves two purposes - -1. Avoid infinite types. Non-recursive newtypes are treated as -"transparent", like type synonyms, after the type checker. If we did -this for all newtypes, we'd get infinite types. So we figure out for -each newtype whether it is "recursive", and add a coercion if so. In -effect, we are trying to "cut the loops" by identifying a loop-breaker. - -2. Avoid infinite unboxing. This is nothing to do with newtypes. -Suppose we have - data T = MkT Int T - f (MkT x t) = f t -Well, this function diverges, but we don't want the strictness analyser -to diverge. But the strictness analyser will diverge because it looks -deeper and deeper into the structure of T. (I believe there are -examples where the function does something sane, and the strictness -analyser still diverges, but I can't see one now.) - -Now, concerning (1), the FC2 branch currently adds a coercion for ALL -newtypes. I did this as an experiment, to try to expose cases in which -the coercions got in the way of optimisations. If it turns out that we -can indeed always use a coercion, then we don't risk recursive types, -and don't need to figure out what the loop breakers are. - -For newtype *families* though, we will always have a coercion, so they -are always loop breakers! So you can easily adjust the current -algorithm by simply treating all newtype families as loop breakers (and -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 + +tcTyAndClassDecls :: ModDetails + -> [[LTyClDecl Name]] -- Mutually-recursive groups in dependency order + -> 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 +tcTyAndClassDecls boot_details decls_s = checkNoErrs $ -- The code recovers internally, but if anything gave rise to -- an error we'd better stop now, to avoid a cascade - do { -- Omit instances of type families; they are handled together - -- with the *heads* of class instances - ; let decls = filter (not . isFamInstDecl . unLoc) allDecls + do { let tyclds_s = map (filterOut (isFamInstDecl . unLoc)) decls_s + -- Remove family instance decls altogether + -- They are dealt with by TcInstDcls + + ; tyclss <- fixM $ \ rec_tyclss -> + tcExtendRecEnv (zipRecTyClss tyclds_s rec_tyclss) $ + -- We must populate the environment with the loop-tied + -- T's right away (even before kind checking), because + -- the kind checker may "fault in" some type constructors + -- that recursively mention T + + do { -- Kind-check in dependency order + -- See Note [Kind checking for type and class decls] + kc_decls <- kcTyClDecls tyclds_s + + -- And now build the TyCons/Classes + ; let rec_flags = calcRecFlags boot_details rec_tyclss + ; concatMapM (tcTyClDecl rec_flags) kc_decls } + + ; tcExtendGlobalEnv tyclss $ do + { -- Perform the validity check + -- We can do this now because we are done with the recursive knot + traceTc "ready for validity check" empty + ; mapM_ (addLocM checkValidTyCl) (concat tyclds_s) + ; traceTc "done" empty - -- 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 { -- 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 - ; 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_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 { -- 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 <- mapM tc_decl kc_alg_decls - ; return (syn_tycons, concat alg_tyclss) - }}}) - -- Finished with knot-tying now - -- Extend the environment with the finished things - ; tcExtendGlobalEnv (syn_tycons ++ alg_tyclss) $ do - - -- Perform the validity check - { traceTc (text "ready for validity check") - ; mapM_ (addLocM checkValidTyCl) decls - ; traceTc (text "done") - -- Add the implicit things; - -- we want them in the environment because + -- we want them in the environment because -- they may be mentioned in interface files -- 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 } - ; traceTc ((text "Adding" <+> ppr alg_tyclss) - $$ (text "and" <+> ppr implicit_things)) - ; tcExtendGlobalEnv implicit_things getGblEnv - }} + ; let { implicit_things = concatMap implicitTyThings tyclss + ; rec_sel_binds = mkRecSelBinds [tc | ATyCon tc <- tyclss] + ; dm_ids = mkDefaultMethodIds tyclss } + + ; env <- tcExtendGlobalEnv implicit_things $ + tcExtendGlobalValEnv dm_ids $ + getGblEnv + ; return (env, rec_sel_binds) } } + +zipRecTyClss :: [[LTyClDecl Name]] + -> [TyThing] -- Knot-tied + -> [(Name,TyThing)] +-- Build a name-TyThing mapping for the things bound by decls +-- being careful not to look at the [TyThing] +-- The TyThings in the result list must have a visible ATyCon/AClass, +-- because typechecking types (in, say, tcTyClDecl) looks at this outer constructor +zipRecTyClss decls_s rec_things + = [ get decl | decls <- decls_s, L _ decl <- flattenATs decls ] 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 - -> [(Name,TyThing)] --- Driven by the Decls, and treating the TyThings lazily --- make a TypeEnv for the new things -mkGlobalThings decls things - = map mk_thing (decls `zipLazy` things) - where - mk_thing (L _ (ClassDecl {tcdLName = L _ name}), ~(AClass cl)) - = (name, AClass cl) - mk_thing (L _ decl, ~(ATyCon tc)) - = (tcdName decl, ATyCon tc) + rec_type_env :: TypeEnv + rec_type_env = mkTypeEnv rec_things + + get :: TyClDecl Name -> (Name, TyThing) + get (ClassDecl {tcdLName = L _ name}) = (name, AClass cl) + where + Just (AClass cl) = lookupTypeEnv rec_type_env name + get decl = (name, ATyCon tc) + where + name = tcdName decl + Just (ATyCon tc) = lookupTypeEnv rec_type_env name \end{code} %************************************************************************ %* * -\subsection{Type checking family instances} + Kind checking %* * %************************************************************************ -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). +Note [Kind checking for type and class decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Kind checking is done thus: -\begin{code} -tcFamInstDecl :: LTyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error -tcFamInstDecl (L loc decl) - = -- Prime error recovery, set source location - recoverM (return Nothing) $ - setSrcSpan loc $ - tcAddDeclCtxt decl $ - do { -- type families require -XTypeFamilies and can't be in an - -- hs-boot file - ; type_families <- doptM Opt_TypeFamilies - ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? - ; checkTc type_families $ badFamInstDecl (tcdLName decl) - ; checkTc (not is_boot) $ badBootFamInstDeclErr - - -- perform kind and type checking - ; tcFamInstDecl1 decl - } + 1. Make up a kind variable for each parameter of the *data* type, + and class, decls, and extend the kind environment (which is in + the TcLclEnv) -tcFamInstDecl1 :: TyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error - - -- "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 - ; 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 <- mapM tcHsKindedType k_typats - ; t_rhs <- tcHsKindedType k_rhs - - -- (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 (isAlgTyCon family) $ - addErr (wrongKindOfFamily family) - - ; -- (1) kind check the data declaration as usual - ; k_decl <- kcDataDecl decl k_tvs - ; 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 (tyConArity family) - - -- (2) type check indexed data type declaration - ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars - ; unbox_strict <- doptM Opt_UnboxStrictFields - - -- kind check the type indexes and the context - ; t_typats <- mapM tcHsKindedType k_typats - ; stupid_theta <- tcHsKindedContext k_ctxt - - -- (3) Check that - -- - left-hand side contains no type family applications - -- (vanilla synonyms are fine, though, and we checked for - -- foralls earlier) - ; mapM_ checkTyFamFreeness t_typats - - -- - we don't use GADT syntax for indexed types - ; checkTc h98_syntax (badGadtIdxTyDecl tc_name) - - -- - 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! - ; tycon <- fixM (\ tycon -> do - { data_cons <- mapM (addLocM (tcConDecl unbox_strict ex_ok tycon t_tvs)) - k_cons - ; tc_rhs <- - case new_or_data of - DataType -> return (mkDataTyConRhs data_cons) - NewType -> ASSERT( 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? - -- (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 - ; return $ Just (ATyCon tycon) - }} - where - h98_syntax = case cons of -- All constructors have same shape - L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False - other -> True - --- Kind checking of indexed types --- - - --- Kind check type patterns and kind annotate the embedded type variables. --- --- * 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 synonym instances. --- -kcIdxTyPats :: TyClDecl Name - -> ([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 { family <- tcLookupLocatedTyCon (tcdLName decl) - ; let { (kinds, resKind) = splitKindFunTys (tyConKind family) - ; hs_typats = fromJust $ tcdTyPats decl } - - -- we may not have more parameters than the kind indicates - ; checkTc (length kinds >= length hs_typats) $ - tooManyParmsErr (tcdLName decl) - - -- 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 family - } - where -\end{code} + 2. Dependency-analyse the type *synonyms* (which must be non-recursive), + and kind-check them in dependency order. Extend the kind envt. + 3. Kind check the data type and class decls -%************************************************************************ -%* * - Kind checking -%* * -%************************************************************************ +Synonyms are treated differently to data type and classes, +because a type synonym can be an unboxed type + type Foo = Int# +and a kind variable can't unify with UnboxedTypeKind +So we infer their kinds in dependency order We need to kind check all types in the mutually recursive group before we know the kind of the type variables. For example: @@ -434,83 +196,89 @@ 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 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 <- mapM getInitialKind initialKindDecls - ; tcExtendKindEnv alg_kinds $ do - - -- Now kind-check the type synonyms, in dependency order - -- We do these differently to data type and classes, - -- because a type synonym can be an unboxed type - -- type Foo = Int# - -- and a kind variable can't unify with UnboxedTypeKind - -- So we infer their kinds in dependency order - { (kc_syn_decls, syn_kinds) <- kcSynDecls (calcSynCycles syn_decls) - ; tcExtendKindEnv syn_kinds $ do - - -- Now kind-check the data type, class, and kind signatures, - -- returning kind-annotated decls; we don't kind-check - -- instances of indexed types yet, but leave this to - -- `tcInstDecls1' - { kc_alg_decls <- mapM (wrapLocM kcTyClDecl) - (filter (not . isFamInstDecl . unLoc) alg_decls) - - ; return (kc_syn_decls, kc_alg_decls) }}} +kcTyClDecls :: [[LTyClDecl Name]] -> TcM [LTyClDecl Name] +kcTyClDecls [] = return [] +kcTyClDecls (decls : decls_s) = do { (tcl_env, kc_decls1) <- kcTyClDecls1 decls + ; kc_decls2 <- setLclEnv tcl_env (kcTyClDecls decls_s) + ; return (kc_decls1 ++ kc_decls2) } + +kcTyClDecls1 :: [LTyClDecl Name] -> TcM (TcLclEnv, [LTyClDecl Name]) +kcTyClDecls1 decls + = do { -- Omit instances of type families; they are handled together + -- with the *heads* of class instances + ; let (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls + alg_at_decls = flattenATs alg_decls + + ; mod <- getModule + ; traceTc "tcTyAndCl" (ptext (sLit "module") <+> ppr mod $$ vcat (map ppr decls)) + + -- First check for cyclic classes + ; checkClassCycleErrs alg_decls + + -- Kind checking; see Note [Kind checking for type and class decls] + ; alg_kinds <- mapM getInitialKind alg_at_decls + ; tcExtendKindEnv alg_kinds $ do + + { (kc_syn_decls, tcl_env) <- kcSynDecls (calcSynCycles syn_decls) + ; setLclEnv tcl_env $ do + { kc_alg_decls <- mapM (wrapLocM kcTyClDecl) alg_decls + + -- Kind checking done for this group, so zonk the kind variables + -- See Note [Kind checking for type and class decls] + ; mapM_ (zonkTcKindToKind . snd) alg_kinds + + ; return (tcl_env, kc_syn_decls ++ kc_alg_decls) } } } + +flattenATs :: [LTyClDecl Name] -> [LTyClDecl Name] +flattenATs decls = concatMap flatten decls where - -- get all declarations relevant for determining the initial kind - -- environment - allDecls (decl@ClassDecl {tcdATs = ats}) = decl : [ at - | L _ at <- ats - , isFamilyDecl at] - allDecls decl | isFamInstDecl decl = [] - | otherwise = [decl] + flatten decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats + flatten decl = [decl] ------------------------------------------------------------------------- -getInitialKind :: TyClDecl Name -> TcM (Name, TcKind) +getInitialKind :: LTyClDecl Name -> TcM (Name, TcKind) -- Only for data type, class, and indexed type declarations -- Get as much info as possible from the data, class, or indexed type decl, -- so as to maximise usefulness of error messages -getInitialKind decl +getInitialKind (L _ decl) = do { arg_kinds <- mapM (mk_arg_kind . unLoc) (tyClDeclTyVars decl) ; res_kind <- mk_res_kind decl ; return (tcdName decl, mkArrowKinds arg_kinds res_kind) } where - mk_arg_kind (UserTyVar _) = newKindVar + mk_arg_kind (UserTyVar _ _) = newKindVar mk_arg_kind (KindedTyVar _ kind) = return kind 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 ---------------- kcSynDecls :: [SCC (LTyClDecl Name)] -> TcM ([LTyClDecl Name], -- Kind-annotated decls - [(Name,TcKind)]) -- Kind bindings + TcLclEnv) -- Kind bindings kcSynDecls [] - = return ([], []) + = do { tcl_env <- getLclEnv; return ([], tcl_env) } kcSynDecls (group : groups) - = do { (decl, nk) <- kcSynDecl group - ; (decls, nks) <- tcExtendKindEnv [nk] (kcSynDecls groups) - ; return (decl:decls, nk:nks) } + = do { (decl, nk) <- kcSynDecl group + ; (decls, tcl_env) <- tcExtendKindEnv [nk] (kcSynDecls groups) + ; return (decl:decls, tcl_env) } ---------------- 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)) + do { traceTc "kcd1" (ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl)) <+> brackets (ppr k_tvs)) - ; (k_rhs, rhs_kind) <- kcHsType (tcdSynRhs decl) - ; traceTc (text "kcd2" <+> ppr (unLoc (tcdLName decl))) - ; let tc_kind = foldr (mkArrowKind . kindedTyVarKind) rhs_kind k_tvs + ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl) + ; traceTc "kcd2" (ppr (unLoc (tcdLName decl))) + ; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }), (unLoc (tcdLName decl), tc_kind)) }) @@ -518,8 +286,6 @@ kcSynDecl (CyclicSCC decls) = do { recSynErr decls; failM } -- Fail here to avoid error cascade -- of out-of-scope tycons -kindedTyVarKind (L _ (KindedTyVar _ k)) = k - ------------------------------------------------------------------------ kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name) -- Not used for type synonyms (see kcSynDecl) @@ -534,8 +300,7 @@ kcTyClDecl decl@(TyFamily {}) kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) = kcTyClDeclBody decl $ \ tvs' -> - do { is_boot <- tcIsHsBoot - ; ctxt' <- kcHsContext ctxt + do { ctxt' <- kcHsContext ctxt ; ats' <- mapM (wrapLocM (kcFamilyDecl tvs')) ats ; sigs' <- mapM (wrapLocM kc_sig) sigs ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs', @@ -543,11 +308,15 @@ kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) where kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty ; return (TypeSig nm op_ty') } + kc_sig (GenericSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty + ; return (GenericSig nm op_ty') } kc_sig other_sig = return other_sig kcTyClDecl decl@(ForeignType {}) = return decl +kcTyClDecl (TySynonym {}) = panic "kcTyClDecl TySynonym" + kcTyClDeclBody :: TyClDecl Name -> ([LHsTyVarBndr Name] -> TcM a) -> TcM a @@ -559,13 +328,17 @@ 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 ) - [ L loc (KindedTyVar (hsTyVarName tv) k) - | (L loc tv, k) <- zip hs_tvs kinds] - ; tcExtendKindEnvTvs kinded_tvs (thing_inside kinded_tvs) } + zipWith add_kind hs_tvs kinds + ; tcExtendKindEnvTvs kinded_tvs thing_inside } + where + add_kind (L loc (UserTyVar n _)) k = L loc (UserTyVar n k) + add_kind (L loc (KindedTyVar n _)) k = L loc (KindedTyVar n k) -- Kind check a data declaration, assuming that we already extended the -- kind environment with the type variables of the left-hand side (these @@ -579,14 +352,17 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) ; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) } where -- doc comments are typechecked to Nothing here - 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' Nothing) + 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' <- mapM kc_larg_ty btys @@ -608,6 +384,7 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) -- Can't allow an unlifted type for newtypes, because we're effectively -- going to remove the constructor while coercing it to a lifted type. -- And newtypes can't be bang'd +kcDataDecl d _ = pprPanic "kcDataDecl" (ppr d) -- Kind check a family declaration or type family default declaration. -- @@ -621,12 +398,16 @@ kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind}) -- 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 + unifyClassParmKinds (L _ tv) + | (n,k) <- hsTyVarNameKind tv + , Just classParmKind <- lookup n classTyKinds + = unifyKind k classParmKind + | otherwise = return () + classTyKinds = [hsTyVarNameKind tv | L _ tv <- classTvs] + +kcFamilyDecl _ (TySynonym {}) -- type family defaults = panic "TcTyClsDecls.kcFamilyDecl: not implemented yet" +kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d) \end{code} @@ -637,146 +418,133 @@ kcFamilyDecl _ decl@(TySynonym {}) -- type family defaults %************************************************************************ \begin{code} -tcSynDecls :: [LTyClDecl Name] -> TcM [TyThing] -tcSynDecls [] = return [] -tcSynDecls (decl : decls) - = do { syn_tc <- addLocM tcSynDecl decl - ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls decls) - ; return (syn_tc : syn_tcs) } +tcTyClDecl :: (Name -> RecFlag) -> LTyClDecl Name -> TcM [TyThing] - -- "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 - ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') Nothing - ; return (ATyCon tycon) - } - --------------------- -tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] - -tcTyClDecl calc_isrec decl - = tcAddDeclCtxt decl (tcTyClDecl1 calc_isrec decl) +tcTyClDecl calc_isrec (L loc decl) + = setSrcSpan loc $ tcAddDeclCtxt decl $ + tcTyClDecl1 NoParentTyCon calc_isrec decl -- "type family" declarations -tcTyClDecl1 _calc_isrec +tcTyClDecl1 :: TyConParent -> (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] +tcTyClDecl1 parent _calc_isrec (TyFamily {tcdFlavour = TypeFamily, - tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = Just kind}) - -- NB: kind at latest - -- added during - -- kind checking + tcdLName = L _ tc_name, tcdTyVars = tvs, + tcdKind = Just kind}) -- NB: kind at latest added during kind checking = tcTyVarBndrs tvs $ \ tvs' -> do - { traceTc (text "type family: " <+> ppr tc_name) - ; idx_tys <- doptM Opt_TypeFamilies + { traceTc "type family:" (ppr tc_name) -- Check that we don't use families without -XTypeFamilies + ; idx_tys <- xoptM Opt_TypeFamilies ; checkTc idx_tys $ badFamInstDecl tc_name - ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) Nothing + ; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent Nothing ; return [ATyCon tycon] } -- "data family" declaration -tcTyClDecl1 _calc_isrec +tcTyClDecl1 parent _calc_isrec (TyFamily {tcdFlavour = DataFamily, tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind}) = tcTyVarBndrs tvs $ \ tvs' -> do - { traceTc (text "data family: " <+> ppr tc_name) + { traceTc "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_TypeFamilies -- Check that we don't use families without -XTypeFamilies + ; idx_tys <- xoptM Opt_TypeFamilies ; checkTc idx_tys $ badFamInstDecl tc_name ; tycon <- buildAlgTyCon tc_name final_tvs [] - mkOpenDataTyConRhs Recursive False True Nothing + DataFamilyTyCon Recursive True + parent Nothing ; return [ATyCon tycon] } + -- "type" +tcTyClDecl1 _parent _calc_isrec + (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) + = ASSERT( isNoParent _parent ) + tcTyVarBndrs tvs $ \ tvs' -> do + { traceTc "tcd1" (ppr tc_name) + ; rhs_ty' <- tcHsKindedType rhs_ty + ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') + (typeKind rhs_ty') NoParentTyCon Nothing + ; return [ATyCon tycon] } + -- "newtype" and "data" -- NB: not used for newtype/data instances (whether associated or not) -tcTyClDecl1 calc_isrec +tcTyClDecl1 _parent calc_isrec (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons}) - = tcTyVarBndrs tvs $ \ tvs' -> do + = ASSERT( isNoParent _parent ) + tcTyVarBndrs tvs $ \ tvs' -> do { extra_tvs <- tcDataKindSig mb_ksig ; let final_tvs = tvs' ++ extra_tvs ; stupid_theta <- tcHsKindedContext ctxt - ; want_generic <- doptM Opt_Generics - ; unbox_strict <- doptM Opt_UnboxStrictFields - ; empty_data_decls <- doptM Opt_EmptyDataDecls - ; kind_signatures <- doptM Opt_KindSignatures - ; existential_ok <- doptM Opt_ExistentialQuantification - ; gadt_ok <- doptM Opt_GADTs + ; kind_signatures <- xoptM Opt_KindSignatures + ; existential_ok <- xoptM Opt_ExistentialQuantification + ; gadt_ok <- xoptM Opt_GADTs ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? ; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context - -- Check that we don't use GADT syntax in H98 world - ; checkTc (gadt_ok || h98_syntax) (badGadtDecl tc_name) - -- Check that we don't use kind signatures without Glasgow extensions ; 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 -XEmptyDataDecls - ; checkTc (not (null cons) || empty_data_decls || is_boot) - (emptyConDeclsErr tc_name) - - -- Check that a newtype has exactly one constructor - ; checkTc (new_or_data == DataType || isSingleton cons) - (newtypeConError tc_name (length cons)) + ; dataDeclChecks tc_name new_or_data stupid_theta cons ; tycon <- fixM (\ tycon -> do - { data_cons <- mapM (addLocM (tcConDecl unbox_strict ex_ok tycon final_tvs)) - cons + { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs) + ; data_cons <- tcConDecls 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( not (null 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 Nothing + (not h98_syntax) NoParentTyCon Nothing }) ; 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 +tcTyClDecl1 _parent calc_isrec (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, tcdCtxt = ctxt, tcdMeths = meths, tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} ) - = tcTyVarBndrs tvs $ \ tvs' -> do + = ASSERT( isNoParent _parent ) + tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt ; fds' <- mapM (addLocM tc_fundep) fundeps - ; atss <- mapM (addLocM (tcTyClDecl1 (const Recursive))) ats - -- NB: 'ats' only contains "type family" and "data family" - -- declarations as well as type family defaults - ; let ats' = zipWith setTyThingPoss atss (map (tcdTyVars . unLoc) ats) - ; sig_stuff <- tcClassSigs class_name sigs meths - ; clas <- fixM (\ clas -> - let -- This little knot is just so we can get + ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths + ; clas <- fixM $ \ clas -> do + { let -- This little knot is just so we can get -- hold of the name of the class TyCon, which we -- need to look up its recursiveness tycon_name = tyConName (classTyCon clas) tc_isrec = calc_isrec tycon_name - in - buildClass class_name tvs' ctxt' fds' ats' - sig_stuff tc_isrec) - ; return (AClass clas : ats') + ; atss' <- mapM (addLocM $ tcTyClDecl1 (AssocFamilyTyCon clas) (const Recursive)) ats + -- NB: 'ats' only contains "type family" and "data family" + -- declarations as well as type family defaults + ; buildClass False {- Must include unfoldings for selectors -} + class_name tvs' ctxt' fds' (concat atss') + sig_stuff tc_isrec } + + ; let gen_dm_ids = [ AnId (mkExportedLocalId gen_dm_name gen_dm_ty) + | (sel_id, GenDefMeth gen_dm_name) <- classOpItems clas + , let gen_dm_tau = expectJust "tcTyClDecl1" $ + lookupNameEnv gen_dm_env (idName sel_id) + , let gen_dm_ty = mkSigmaTy tvs' + [mkClassPred clas (mkTyVarTys tvs')] + gen_dm_tau + ] + class_ats = map ATyCon (classATs clas) + + ; return (AClass clas : gen_dm_ids ++ class_ats ) -- NB: Order is important due to the call to `mkGlobalThings' when -- tying the the type and class declaration type checking knot. } @@ -785,48 +553,63 @@ tcTyClDecl1 calc_isrec ; tvs2' <- mapM tcLookupTyVar tvs2 ; ; return (tvs1', tvs2') } - -- For each AT argument compute the position of the corresponding class - -- parameter in the class head. This will later serve as a permutation - -- vector when checking the validity of instance declarations. - setTyThingPoss [ATyCon tycon] atTyVars = - let classTyVars = hsLTyVarNames tvs - poss = catMaybes - . map (`elemIndex` classTyVars) - . hsLTyVarNames - $ atTyVars - -- There will be no Nothing, as we already passed renaming - in - ATyCon (setTyConArgPoss tycon poss) - setTyThingPoss _ _ = panic "TcTyClsDecls.setTyThingPoss" - -tcTyClDecl1 calc_isrec +tcTyClDecl1 _ _ (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name}) = return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)] +tcTyClDecl1 _ _ d = pprPanic "tcTyClDecl1" (ppr d) + +dataDeclChecks :: Name -> NewOrData -> ThetaType -> [LConDecl Name] -> TcM () +dataDeclChecks tc_name new_or_data stupid_theta cons + = do { -- Check that we don't use GADT syntax in H98 world + gadtSyntax_ok <- xoptM Opt_GADTSyntax + ; let h98_syntax = consUseH98Syntax cons + ; checkTc (gadtSyntax_ok || h98_syntax) (badGadtDecl 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 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 + ; empty_data_decls <- xoptM Opt_EmptyDataDecls + ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? + ; checkTc (not (null cons) || empty_data_decls || is_boot) + (emptyConDeclsErr tc_name) } + ----------------------------------- -tcConDecl :: Bool -- True <=> -funbox-strict_fields - -> Bool -- True <=> -XExistentialQuantificaton or -XGADTs - -> TyCon -> [TyVar] +tcConDecls :: Bool -> TyCon -> ([TyVar], Type) + -> [LConDecl Name] -> TcM [DataCon] +tcConDecls ex_ok rep_tycon res_tmpl cons + = mapM (addLocM (tcConDecl ex_ok rep_tycon res_tmpl)) cons + +tcConDecl :: 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 tycon tc_tvs -- Data types - (ConDecl name _ tvs ctxt details res_ty _) - = tcTyVarBndrs tvs $ \ tvs' -> do +tcConDecl existential_ok rep_tycon res_tmpl -- Data types + con@(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 - ; checkTc (existential_ok || (null tvs && null (unLoc ctxt))) + ; checkTc (existential_ok || conRepresentibleWithH98Syntax con) (badExistential name) - ; (univ_tvs, ex_tvs, eq_preds, data_tc) <- tcResultType tycon tc_tvs tvs' res_ty + ; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty ; let - -- Tiresome: tidy the tyvar binders, since tc_tvs and tvs' may have the same OccNames tc_datacon is_infix field_lbls btys - = do { let bangs = map getBangStrictness btys - ; arg_tys <- mapM tcHsBangType btys + = do { (arg_tys, stricts) <- mapAndUnzipM tcConArg btys ; buildDataCon (unLoc name) is_infix - (argStrictness unbox_strict bangs arg_tys) - (map unLoc field_lbls) + stricts field_lbls univ_tvs ex_tvs eq_preds ctxt' arg_tys - data_tc } + 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. @@ -836,72 +619,103 @@ tcConDecl unbox_strict existential_ok tycon tc_tvs -- Data types InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2] RecCon fields -> tc_datacon False field_names btys where - field_names = map cd_fld_name 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 (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 - - ; let univ_tvs = choose_univs [] tidy_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: tc_tvs and dc_tvs are distinct, but + -- 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) - init_occ_env = initTidyOccEnv (map getOccName dc_tvs) - (_, tidy_tc_tvs) = mapAccumL tidy_one init_occ_env tc_tvs - tidy_one env tv = (env', setTyVarName tv (tidyNameOcc name occ')) + (_, 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) - ------------------- -argStrictness :: Bool -- True <=> -funbox-strict_fields - -> [HsBang] - -> [TcType] -> [StrictnessMark] -argStrictness unbox_strict bangs arg_tys - = ASSERT( length bangs == length arg_tys ) - zipWith (chooseBoxingStrategy unbox_strict) arg_tys bangs +consUseH98Syntax :: [LConDecl a] -> Bool +consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False +consUseH98Syntax _ = True + -- All constructors have same shape + +conRepresentibleWithH98Syntax :: ConDecl Name -> Bool +conRepresentibleWithH98Syntax + (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyH98 }) + = null tvs && null (unLoc ctxt) +conRepresentibleWithH98Syntax + (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyGADT (L _ t) }) + = null (unLoc ctxt) && f t (map (hsTyVarName . unLoc) tvs) + where -- Each type variable should be used exactly once in the + -- result type, and the result type must just be the type + -- constructor applied to type variables + f (HsAppTy (L _ t1) (L _ (HsTyVar v2))) vs + = (v2 `elem` vs) && f t1 (delete v2 vs) + f (HsTyVar _) [] = True + f _ _ = False + +------------------- +tcConArg :: LHsType Name -> TcM (TcType, HsBang) +tcConArg bty + = do { arg_ty <- tcHsBangType bty + ; strict_mark <- chooseBoxingStrategy arg_ty (getBangStrictness bty) + ; return (arg_ty, strict_mark) } -- We attempt to unbox/unpack a strict field when either: -- (i) The field is marked '!!', or @@ -909,27 +723,53 @@ argStrictness unbox_strict bangs arg_tys -- -- We have turned off unboxing of newtypes because coercions make unboxing -- and reboxing more complicated -chooseBoxingStrategy :: Bool -> TcType -> HsBang -> StrictnessMark -chooseBoxingStrategy unbox_strict_fields arg_ty bang +chooseBoxingStrategy :: TcType -> HsBang -> TcM HsBang +chooseBoxingStrategy 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 + HsNoBang -> return HsNoBang + HsStrict -> do { unbox_strict <- doptM Opt_UnboxStrictFields + ; if unbox_strict then return (can_unbox HsStrict arg_ty) + else return HsStrict } + HsUnpack -> do { omit_prags <- doptM Opt_OmitInterfacePragmas + -- Do not respect UNPACK pragmas if OmitInterfacePragmas is on + -- See Trac #5252: unpacking means we must not conceal the + -- representation of the argument type + ; if omit_prags then return HsStrict + else return (can_unbox HsUnpackFailed arg_ty) } + HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty) + -- Source code never has shtes 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 arg_tycon) && -- Note [Recusive unboxing] - isProductTyCon arg_tycon && - (if isNewTyCon arg_tycon then - can_unbox (newTyConInstRhs arg_tycon tycon_args) - else True) + can_unbox :: HsBang -> TcType -> HsBang + -- Returns HsUnpack if we can unpack arg_ty + -- fail_bang if we know what arg_ty is but we can't unpack it + -- HsStrict if it's abstract, so we don't know whether or not we can unbox it + can_unbox fail_bang arg_ty + = case splitTyConApp_maybe arg_ty of + Nothing -> fail_bang + + Just (arg_tycon, tycon_args) + | isAbstractTyCon arg_tycon -> HsStrict + -- See Note [Don't complain about UNPACK on abstract TyCons] + | not (isRecursiveTyCon arg_tycon) -- Note [Recusive unboxing] + , isProductTyCon arg_tycon + -- We can unbox if the type is a chain of newtypes + -- with a product tycon at the end + -> if isNewTyCon arg_tycon + then can_unbox fail_bang (newTyConInstRhs arg_tycon tycon_args) + else HsUnpack + + | otherwise -> fail_bang \end{code} +Note [Don't complain about UNPACK on abstract TyCons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We are going to complain about UnpackFailed, but if we say + data T = MkT {-# UNPACK #-} !Wobble +and Wobble is a newtype imported from a module that was compiled +without optimisation, we don't want to complain. Because it might +be fine when optimsation is on. I think this happens when Haddock +is working over (say) GHC souce files. + Note [Recursive unboxing] ~~~~~~~~~~~~~~~~~~~~~~~~~ Be careful not to try to unbox this! @@ -938,9 +778,10 @@ 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 %* * %************************************************************************ @@ -948,8 +789,8 @@ Validity checking is done once the mutually-recursive knot has been tied, so we can look at things freely. \begin{code} -checkCycleErrs :: [LTyClDecl Name] -> TcM () -checkCycleErrs tyclss +checkClassCycleErrs :: [LTyClDecl Name] -> TcM () +checkClassCycleErrs tyclss | null cls_cycles = return () | otherwise @@ -965,11 +806,15 @@ checkValidTyCl :: TyClDecl Name -> TcM () checkValidTyCl decl = tcAddDeclCtxt decl $ do { thing <- tcLookupLocatedGlobal (tcdLName decl) - ; traceTc (text "Validity of" <+> ppr thing) + ; traceTc "Validity of" (ppr thing) ; case thing of ATyCon tc -> checkValidTyCon tc - AClass cl -> checkValidClass cl - ; traceTc (text "Done validity of" <+> ppr thing) + AClass cl -> do { checkValidClass cl + ; mapM_ (addLocM checkValidTyCl) (tcdATs decl) } + AnId _ -> return () -- Generic default methods are checked + -- with their parent class + _ -> panic "checkValidTyCl" + ; traceTc "Done validity of" (ppr thing) } ------------------------- @@ -979,13 +824,20 @@ 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 + SynFamilyTyCon {} -> return () + SynonymTyCon ty -> checkValidType syn_ctxt ty | otherwise = do -- Check the context on the data decl checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) @@ -1020,7 +872,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 @@ -1039,7 +891,10 @@ checkValidTyCon tc (tvs2, _, _, res2) = dataConSig con2 ts2 = mkVarSet tvs2 fty2 = dataConFieldType con2 label + check_fields [] = panic "checkValidTyCon/check_fields []" +checkFieldCompat :: Name -> DataCon -> DataCon -> TyVarSet + -> Type -> Type -> Type -> Type -> TcM () checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2 = do { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2) ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) } @@ -1052,15 +907,28 @@ 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 "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) + ; mapM_ check_bang (dataConStrictMarks con `zip` [1..]) } where ctxt = ConArgCtxt (dataConName con) + check_bang (HsUnpackFailed, n) = addWarnTc (cant_unbox_msg n) + check_bang _ = return () + + cant_unbox_msg n = sep [ ptext (sLit "Ignoring unusable UNPACK pragma on the") + , speakNth n <+> ptext (sLit "argument of") <+> quotes (ppr con)] ------------------------------- checkNewDataCon :: DataCon -> TcM () @@ -1070,21 +938,21 @@ checkNewDataCon con -- 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) + ; checkTc (null ex_tvs && null theta) (newtypeExError con) -- No existentials - ; checkTc (not (any isMarkedStrict (dataConStrictMarks con))) + ; checkTc (not (any isBanged (dataConStrictMarks con))) (newtypeStrictError con) -- No strictness } where - (_univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _res_ty) = dataConFullSig con + (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con ------------------------------- checkValidClass :: Class -> TcM () checkValidClass cls - = do { constrained_class_methods <- doptM Opt_ConstrainedClassMethods - ; multi_param_type_classes <- doptM Opt_MultiParamTypeClasses - ; fundep_classes <- doptM Opt_FunctionalDependencies + = do { constrained_class_methods <- xoptM Opt_ConstrainedClassMethods + ; multi_param_type_classes <- xoptM Opt_MultiParamTypeClasses + ; fundep_classes <- xoptM Opt_FunctionalDependencies -- Check that the class is unary, unless GlaExs ; checkTc (notNull tyvars) (nullaryClassErr cls) @@ -1105,7 +973,7 @@ checkValidClass cls where (tyvars, fundeps, theta, _, _, op_stuff) = classExtraBigSig cls unary = isSingleton tyvars - no_generics = null [() | (_, GenDefMeth) <- op_stuff] + no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff] check_op constrained_class_methods (sel_id, dm) = addErrCtxt (classOpCtxt sel_id tau) $ do @@ -1113,7 +981,7 @@ checkValidClass cls -- The 'tail' removes the initial (C a) from the -- class itself, leaving just the method type - ; traceTc (text "class op type" <+> ppr op_ty <+> ppr tau) + ; traceTc "class op type" (ppr op_ty <+> ppr tau) ; checkValidType (FunSigCtxt op_name) tau -- Check that the type mentions at least one of @@ -1122,14 +990,14 @@ checkValidClass cls -- 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 = grow theta (mkVarSet tyvars) + ; 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 - -- the method is sufficiently simple - ; checkTc (dm /= GenDefMeth || validGenericMethodType tau) - (badGenericMethodType op_name op_ty) + ; case dm of + GenDefMeth dm_name -> do { dm_id <- tcLookupId dm_name + ; checkValidType (FunSigCtxt op_name) (idType dm_id) } + _ -> return () } where op_name = idName sel_id @@ -1144,58 +1012,270 @@ checkValidClass cls -- 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} +mkDefaultMethodIds :: [TyThing] -> [Id] +-- See Note [Default method Ids and Template Haskell] +mkDefaultMethodIds things + = [ mkExportedLocalId dm_name (idType sel_id) + | AClass cls <- things + , (sel_id, DefMeth dm_name) <- classOpItems cls ] +\end{code} + +Note [Default method Ids and Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (Trac #4169): + class Numeric a where + fromIntegerNum :: a + fromIntegerNum = ... + + ast :: Q [Dec] + ast = [d| instance Numeric Int |] + +When we typecheck 'ast' we have done the first pass over the class decl +(in tcTyClDecls), but we have not yet typechecked the default-method +declarations (becuase they can mention value declarations). So we +must bring the default method Ids into scope first (so they can be seen +when typechecking the [d| .. |] quote, and typecheck them later. + +\begin{code} +mkRecSelBinds :: [TyCon] -> 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 +mkRecSelBinds tycons + = ValBindsOut [(NonRecursive, b) | b <- binds] sigs + where + (sigs, binds) = unzip rec_sels + rec_sels = map mkRecSelBind [ (tc,fld) + | tc <- tycons + , 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 | not (any is_unused all_cons) = [] + | otherwise = [mkSimpleMatch [nlWildPat] + (nlHsApp (nlHsVar (getName rEC_SEL_ERROR_ID)) + (nlHsLit msg_lit))] + + -- Do not add a default case unless there are unmatched + -- constructors. We must take account of GADTs, else we + -- get overlap warning messages from the pattern-match checker + is_unused con = not (con `elem` cons_w_field + || dataConCannotMatch inst_tys con) + inst_tys = tyConAppArgs data_ty + + unit_rhs = mkLHsTupleExpr [] + 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 -XMultiParamTypeClasses to allow multi-parameter classes"))] + = vcat [ptext (sLit "Too many parameters for class") <+> quotes (ppr cls), + parens (ptext (sLit "Use -XMultiParamTypeClasses to allow multi-parameter classes"))] +classFunDepsErr :: Class -> SDoc classFunDepsErr cls - = vcat [ptext SLIT("Fundeps in class") <+> quotes (ppr cls), - parens (ptext SLIT("Use -XFunctionalDependencies to allow fundeps"))] + = vcat [ptext (sLit "Fundeps in class") <+> quotes (ppr cls), + parens (ptext (sLit "Use -XFunctionalDependencies to allow fundeps"))] +noClassTyVarErr :: Class -> Var -> SDoc noClassTyVarErr clas op - = sep [ptext SLIT("The class method") <+> quotes (ppr op), - ptext SLIT("mentions none of the type variables of the class") <+> + = sep [ptext (sLit "The class method") <+> quotes (ppr op), + ptext (sLit "mentions none of the type variables of the class") <+> ppr clas <+> hsep (map ppr (classTyVars clas))] +genericMultiParamErr :: Class -> SDoc genericMultiParamErr clas - = ptext SLIT("The multi-parameter class") <+> quotes (ppr clas) <+> - ptext SLIT("cannot have generic methods") - -badGenericMethodType op op_ty - = 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 "The multi-parameter class") <+> quotes (ppr clas) <+> + ptext (sLit "cannot have generic methods") +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 @@ -1206,82 +1286,66 @@ 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 -XGADTs to allow GADTs")) ] + = vcat [ ptext (sLit "Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name) + , nest 2 (parens $ ptext (sLit "Use -XGADTs to allow GADTs")) ] +badExistential :: Located Name -> SDoc badExistential con_name - = hang (ptext SLIT("Data constructor") <+> quotes (ppr con_name) <+> - ptext SLIT("has existential type variables, or a context")) - 2 (parens $ ptext SLIT("Use -XExistentialQuantification or -XGADTs to allow this")) + = hang (ptext (sLit "Data constructor") <+> quotes (ppr con_name) <+> + ptext (sLit "has existential type variables, a context, or a specialised result type")) + 2 (parens $ ptext (sLit "Use -XExistentialQuantification or -XGADTs to allow this")) +badStupidTheta :: Name -> SDoc badStupidTheta tc_name - = ptext SLIT("A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name) + = ptext (sLit "A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name) +newtypeConError :: Name -> Int -> SDoc newtypeConError tycon n - = sep [ptext SLIT("A newtype must have exactly one constructor,"), - nest 2 $ ptext SLIT("but") <+> quotes (ppr tycon) <+> ptext SLIT("has") <+> speakN n ] + = sep [ptext (sLit "A newtype must have exactly one constructor,"), + nest 2 $ ptext (sLit "but") <+> quotes (ppr tycon) <+> ptext (sLit "has") <+> speakN n ] +newtypeExError :: DataCon -> SDoc newtypeExError con - = sep [ptext SLIT("A newtype constructor cannot have an existential context,"), - nest 2 $ ptext SLIT("but") <+> quotes (ppr con) <+> ptext SLIT("does")] + = sep [ptext (sLit "A newtype constructor cannot have an existential context,"), + nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does")] +newtypeStrictError :: DataCon -> SDoc newtypeStrictError con - = sep [ptext SLIT("A newtype constructor cannot have a strictness annotation,"), - nest 2 $ ptext SLIT("but") <+> quotes (ppr con) <+> ptext SLIT("does")] + = sep [ptext (sLit "A newtype constructor cannot have a strictness annotation,"), + nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does")] +newtypePredError :: DataCon -> SDoc newtypePredError con - = sep [ptext SLIT("A newtype constructor must have a return type of form T a1 ... an"), - nest 2 $ ptext SLIT("but") <+> quotes (ppr con) <+> ptext SLIT("does not")] + = sep [ptext (sLit "A newtype constructor must have a return type of form T a1 ... an"), + nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does not")] +newtypeFieldErr :: DataCon -> Int -> SDoc newtypeFieldErr con_name n_flds - = sep [ptext SLIT("The constructor of a newtype must have exactly one field"), - nest 2 $ ptext SLIT("but") <+> quotes (ppr con_name) <+> ptext SLIT("has") <+> speakN n_flds] + = sep [ptext (sLit "The constructor of a newtype must have exactly one field"), + nest 2 $ ptext (sLit "but") <+> quotes (ppr con_name) <+> ptext (sLit "has") <+> speakN n_flds] +badSigTyDecl :: Name -> SDoc badSigTyDecl tc_name - = vcat [ ptext SLIT("Illegal kind signature") <+> + = vcat [ ptext (sLit "Illegal kind signature") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Use -XKindSignatures to allow kind signatures")) ] + , nest 2 (parens $ ptext (sLit "Use -XKindSignatures to allow kind signatures")) ] +badFamInstDecl :: Outputable a => a -> SDoc badFamInstDecl tc_name - = vcat [ ptext SLIT("Illegal family instance for") <+> - quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Use -XTypeFamilies to allow indexed type families")) ] - -badGadtIdxTyDecl tc_name - = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> + = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Family instances can not yet use GADT declarations")) ] - -tooManyParmsErr tc_name - = ptext SLIT("Family instance has too many 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") - -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) + , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ] +emptyConDeclsErr :: Name -> SDoc emptyConDeclsErr tycon - = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"), - nest 2 $ ptext SLIT("(-XEmptyDataDecls permits this)")] + = sep [quotes (ppr tycon) <+> ptext (sLit "has no constructors"), + nest 2 $ ptext (sLit "(-XEmptyDataDecls permits this)")] \end{code}