X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=3df2eef785d5772eed389788276698d2637357f2;hp=a41ccbe5e3f1658b5dcb90589de9814ff5703b4e;hb=17b297d97d327620ed6bfab942f8992b2446f1bf;hpb=839a0880ea32b3ef2f0715957bfeec6e4bb3367b diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index a41ccbe..3df2eef 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -1,68 +1,59 @@ % +% (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} +{-# OPTIONS_GHC -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/WorkingConventions#Warnings +-- for details + module TcTyClsDecls ( - tcTyAndClassDecls + tcTyAndClassDecls, tcFamInstDecl ) where #include "HsVersions.h" -import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..), - ConDecl(..), Sig(..), NewOrData(..), ResType(..), - tyClDeclTyVars, isSynDecl, isClassDecl, hsConArgs, - LTyClDecl, tcdName, hsTyVarName, LHsTyVarBndr - ) -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 BasicTypes +import HscTypes +import BuildTyCl +import TcUnify import TcRnMonad -import TcEnv ( TyThing(..), - tcLookupLocated, tcLookupLocatedGlobal, - tcExtendGlobalEnv, tcExtendKindEnv, tcExtendKindEnvTvs, - tcExtendRecEnv, tcLookupTyVar ) -import TcTyDecls ( calcTyConArgVrcs, calcRecFlags, calcClassCycles, calcSynCycles ) -import TcClassDcl ( tcClassSigs, tcAddDeclCtxt ) -import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType, - kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext, - kcHsSigType, tcHsBangType, tcLHsConResTy, tcDataKindSig ) -import TcMType ( newKindVar, checkValidTheta, checkValidType, - -- checkFreeness, - UserTypeCtxt(..), SourceTyCtxt(..) ) -import TcType ( TcKind, TcType, tyVarsOfType, mkPhiTy, - mkArrowKind, liftedTypeKind, mkTyVarTys, - tcSplitSigmaTy, tcEqTypes, tcGetTyVar_maybe ) -import Type ( splitTyConApp_maybe, - -- pprParendType, pprThetaArrow - ) -import Kind ( mkArrowKinds, splitKindFunTys ) -import Generics ( validGenericMethodType, canDoGenerics ) -import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars ) -import TyCon ( TyCon, ArgVrcs, AlgTyConRhs( AbstractTyCon ), - tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon, - tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName ) -import DataCon ( DataCon, dataConWrapId, dataConName, - dataConFieldLabels, dataConTyCon, - dataConTyVars, 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 FunDeps +import Type +import Generics +import Class +import TyCon +import DataCon +import Var +import VarSet +import Name +import OccName import Outputable -import Maybe ( isJust ) -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 ) -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 Data.List +import Control.Monad ( mplus ) \end{code} @@ -111,46 +102,88 @@ Step 7: checkValidTyCl 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. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s. +@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 boot_details decls - = do { -- First check for cyclic type synonysm or classes +tcTyAndClassDecls boot_details allDecls + = do { -- Omit instances of type families; they are handled together + -- with the *heads* of class instances + ; let decls = filter (not . isFamInstDecl . unLoc) allDecls + + -- First check for cyclic type synonysm or classes -- See notes with checkCycleErrs - checkCycleErrs decls + ; 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 + 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_vrcs = calcTyConArgVrcs (rec_syn_tycons ++ rec_alg_tyclss) + ; let { -- Calculate rec-flag ; calc_rec = calcRecFlags boot_details rec_alg_tyclss - ; tc_decl = addLocM (tcTyClDecl calc_vrcs calc_rec) } + ; tc_decl = addLocM (tcTyClDecl calc_rec) } + -- Type-check the type synonyms, and extend the envt - ; syn_tycons <- tcSynDecls calc_vrcs kc_syn_decls + ; 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) + ; return (syn_tycons, concat alg_tyclss) }}}) -- Finished with knot-tying now -- Extend the environment with the finished things @@ -164,10 +197,22 @@ tcTyAndClassDecls boot_details decls -- Add the implicit things; -- 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)) + ; traceTc ((text "Adding" <+> ppr alg_tyclss) + $$ (text "and" <+> ppr implicit_things)) ; tcExtendGlobalEnv implicit_things getGblEnv }} + 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 @@ -186,6 +231,166 @@ mkGlobalThings decls things %************************************************************************ %* * +\subsection{Type checking family instances} +%* * +%************************************************************************ + +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} +tcFamInstDecl :: LTyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error +tcFamInstDecl (L loc decl) + = -- Prime error recovery, set source location + recoverM (returnM Nothing) $ + setSrcSpan loc $ + tcAddDeclCtxt decl $ + do { -- type families require -ftype-families 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 + } + +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 <- mappM 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 <- mappM tcHsKindedType k_typats + ; stupid_theta <- tcHsKindedContext k_ctxt + + -- (3) Check that + -- - left-hand side contains no type family applications + -- (vanilla synonyms are fine, though, and we checked for + -- foralls earlier) + ; mappM_ checkTyFamFreeness t_typats + + -- - we don't use GADT syntax for indexed types + ; checkTc h98_syntax (badGadtIdxTyDecl tc_name) + + -- - 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 + ; tycon <- fixM (\ tycon -> do + { data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon t_tvs)) + k_cons + ; tc_rhs <- + case new_or_data of + DataType -> return (mkDataTyConRhs data_cons) + NewType -> ASSERT( 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 <- TcRnMonad.zipWithM kcCheckHsType hs_typats kinds + ; thing_inside tvs typats resultKind family + } + where +\end{code} + + +%************************************************************************ +%* * Kind checking %* * %************************************************************************ @@ -212,11 +417,24 @@ 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. +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 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 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 and class, mapping them to a type variable - alg_kinds <- mappM getInitialKind 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 ; tcExtendKindEnv alg_kinds $ do -- Now kind-check the type synonyms, in dependency order @@ -228,18 +446,29 @@ kcTyClDecls syn_decls alg_decls { (kc_syn_decls, syn_kinds) <- kcSynDecls (calcSynCycles syn_decls) ; tcExtendKindEnv syn_kinds $ do - -- Now kind-check the data type and class declarations, - -- returning kind-annotated decls - { kc_alg_decls <- mappM (wrapLocM kcTyClDecl) alg_decls + -- 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 <- mappM (wrapLocM kcTyClDecl) + (filter (not . isFamInstDecl . unLoc) alg_decls) ; return (kc_syn_decls, kc_alg_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] ------------------------------------------------------------------------ -getInitialKind :: LTyClDecl Name -> TcM (Name, TcKind) --- Only for data type and class declarations --- Get as much info as possible from the data or class decl, +getInitialKind :: TyClDecl 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 (L _ decl) +getInitialKind 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) } @@ -247,7 +476,8 @@ getInitialKind (L _ decl) mk_arg_kind (UserTyVar _) = newKindVar mk_arg_kind (KindedTyVar _ kind) = return kind - mk_res_kind (TyData { tcdKindSig = Just 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 @@ -289,44 +519,22 @@ kindedTyVarKind (L _ (KindedTyVar _ k)) = k kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name) -- Not used for type synonyms (see kcSynDecl) -kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) - = kcTyClDeclBody decl $ \ tvs' -> - do { ctxt' <- kcHsContext ctxt - ; cons' <- mappM (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') - - kc_con_details (PrefixCon btys) - = do { btys' <- mappM kc_larg_ty btys ; return (PrefixCon btys') } - kc_con_details (InfixCon bty1 bty2) - = do { bty1' <- kc_larg_ty bty1; bty2' <- kc_larg_ty bty2; return (InfixCon bty1' bty2') } - kc_con_details (RecCon fields) - = do { fields' <- mappM kc_field fields; return (RecCon fields') } +kcTyClDecl decl@(TyData {}) + = ASSERT( not . isFamInstDecl $ decl ) -- must not be a family instance + kcTyClDeclBody decl $ + kcDataDecl decl - kc_field (fld, bty) = do { bty' <- kc_larg_ty bty ; return (fld, bty') } - - kc_larg_ty bty = case new_or_data of - DataType -> kcHsSigType bty - NewType -> kcHsLiftedSigType bty - -- 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 +kcTyClDecl decl@(TyFamily {}) + = kcFamilyDecl [] decl -- the empty list signals a toplevel decl --- !!!TODO -=chak -kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs}) +kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) = kcTyClDeclBody decl $ \ tvs' -> do { is_boot <- tcIsHsBoot ; ctxt' <- kcHsContext ctxt + ; ats' <- mappM (wrapLocM (kcFamilyDecl tvs')) ats ; sigs' <- mappM (wrapLocM kc_sig) sigs - ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs'}) } + ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs', + tcdATs = ats'}) } where kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty ; return (TypeSig nm op_ty') } @@ -342,7 +550,7 @@ kcTyClDeclBody :: TyClDecl Name -- Unpack it, and attribute those kinds to the type variables -- Extend the env with bindings for the tyvars, taken from -- the kind of the tycon/class. Give it to the thing inside, and - -- check the result kind matches +-- check the result kind matches kcTyClDeclBody decl thing_inside = tcAddDeclCtxt decl $ do { tc_ty_thing <- tcLookupLocated (tcdLName decl) @@ -353,6 +561,67 @@ kcTyClDeclBody decl thing_inside [ L loc (KindedTyVar (hsTyVarName tv) k) | (L loc tv, k) <- zip hs_tvs kinds] ; tcExtendKindEnvTvs kinded_tvs (thing_inside kinded_tvs) } + +-- Kind check a data declaration, assuming that we already extended the +-- kind environment with the type variables of the left-hand side (these +-- kinded type variables are also passed as the second parameter). +-- +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 + ; 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_details (PrefixCon btys) + = do { btys' <- mappM kc_larg_ty btys + ; return (PrefixCon btys') } + kc_con_details (InfixCon bty1 bty2) + = do { bty1' <- kc_larg_ty bty1 + ; bty2' <- kc_larg_ty bty2 + ; return (InfixCon bty1' bty2') } + kc_con_details (RecCon fields) + = do { fields' <- mappM kc_field fields + ; return (RecCon fields') } + + 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 + NewType -> kcHsLiftedSigType bty + -- Can't allow an unlifted type for newtypes, because we're effectively + -- going to remove the constructor while coercing it to a lifted type. + -- And newtypes can't be bang'd + +-- Kind check a family declaration or type family default declaration. +-- +kcFamilyDecl :: [LHsTyVarBndr Name] -- tyvars of enclosing class decl if any + -> TyClDecl Name -> TcM (TyClDecl Name) +kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind}) + = kcTyClDeclBody decl $ \tvs' -> + do { mapM_ unifyClassParmKinds tvs' + ; return (decl {tcdTyVars = tvs', + tcdKind = kind `mplus` Just liftedTypeKind}) + -- default result kind is '*' + } + where + unifyClassParmKinds (L _ (KindedTyVar n k)) + | Just classParmKind <- lookup n classTyKinds = unifyKind k classParmKind + | otherwise = return () + classTyKinds = [(n, k) | L _ (KindedTyVar n k) <- classTvs] +kcFamilyDecl _ decl@(TySynonym {}) -- type family defaults + = panic "TcTyClsDecls.kcFamilyDecl: not implemented yet" \end{code} @@ -363,28 +632,68 @@ kcTyClDeclBody decl thing_inside %************************************************************************ \begin{code} -tcSynDecls :: (Name -> ArgVrcs) -> [LTyClDecl Name] -> TcM [TyThing] -tcSynDecls calc_vrcs [] = return [] -tcSynDecls calc_vrcs (decl : decls) - = do { syn_tc <- addLocM (tcSynDecl calc_vrcs) decl - ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls calc_vrcs decls) +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) } -tcSynDecl calc_vrcs + -- "type" +tcSynDecl (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) = tcTyVarBndrs tvs $ \ tvs' -> do { traceTc (text "tcd1" <+> ppr tc_name) ; rhs_ty' <- tcHsKindedType rhs_ty - ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty' (calc_vrcs tc_name))) } + ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') Nothing + ; return (ATyCon tycon) + } -------------------- -tcTyClDecl :: (Name -> ArgVrcs) -> (Name -> RecFlag) - -> TyClDecl Name -> TcM TyThing +tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] + +tcTyClDecl calc_isrec decl + = tcAddDeclCtxt decl (tcTyClDecl1 calc_isrec decl) + + -- "type family" declarations +tcTyClDecl1 _calc_isrec + (TyFamily {tcdFlavour = TypeFamily, + 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 + + -- Check that we don't use families without -ftype-families + ; checkTc idx_tys $ badFamInstDecl tc_name + + ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) Nothing + ; return [ATyCon tycon] + } + + -- "newtype family" or "data family" declaration +tcTyClDecl1 _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) + ; extra_tvs <- tcDataKindSig mb_kind + ; let final_tvs = tvs' ++ extra_tvs -- we may not need these -tcTyClDecl calc_vrcs calc_isrec decl - = tcAddDeclCtxt decl (tcTyClDecl1 calc_vrcs calc_isrec decl) + ; idx_tys <- doptM Opt_TypeFamilies + + -- Check that we don't use families without -ftype-families + ; checkTc idx_tys $ badFamInstDecl tc_name + + ; tycon <- buildAlgTyCon tc_name final_tvs [] + mkOpenDataTyConRhs Recursive False True Nothing + ; return [ATyCon tycon] + } -tcTyClDecl1 calc_vrcs calc_isrec + -- "newtype" and "data" +tcTyClDecl1 calc_isrec (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons}) = tcTyVarBndrs tvs $ \ tvs' -> do @@ -393,15 +702,23 @@ tcTyClDecl1 calc_vrcs calc_isrec ; stupid_theta <- tcHsKindedContext ctxt ; want_generic <- doptM Opt_Generics ; unbox_strict <- doptM Opt_UnboxStrictFields - ; gla_exts <- doptM Opt_GlasgowExts + ; empty_data_decls <- doptM Opt_EmptyDataDecls + ; kind_signatures <- doptM Opt_KindSignatures + ; gadt_ok <- doptM Opt_GADTs ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? -- Check that we don't use GADT syntax in H98 world - ; checkTc (gla_exts || h98_syntax) (badGadtDecl tc_name) + ; checkTc (gadt_ok || h98_syntax) (badGadtDecl tc_name) + + -- Check that we don't use kind signatures without Glasgow extensions + ; checkTc (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 interface file, or -fglasgow-exts - ; checkTc (not (null cons) || gla_exts || is_boot) + -- or else we're reading an hs-boot file, or -XEmptyDataDecls + ; checkTc (not (null cons) || empty_data_decls || is_boot) (emptyConDeclsErr tc_name) -- Check that a newtype has exactly one constructor @@ -409,162 +726,205 @@ tcTyClDecl1 calc_vrcs calc_isrec (newtypeConError tc_name (length cons)) ; tycon <- fixM (\ tycon -> do - { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data - tycon final_tvs)) + { data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon final_tvs)) cons - ; let tc_rhs - | null cons && is_boot -- In a hs-boot file, empty cons means - = AbstractTyCon -- "don't know"; hence Abstract - | otherwise - = case new_or_data of - DataType -> mkDataTyConRhs data_cons - NewType -> ASSERT( isSingleton data_cons ) - mkNewTyConRhs tycon (head data_cons) - ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs arg_vrcs is_rec - (want_generic && canDoGenerics data_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) + ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec + (want_generic && canDoGenerics data_cons) h98_syntax Nothing }) - ; return (ATyCon tycon) + ; return [ATyCon tycon] } where - arg_vrcs = calc_vrcs tc_name is_rec = calc_isrec tc_name h98_syntax = case cons of -- All constructors have same shape L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False other -> True -tcTyClDecl1 calc_vrcs calc_isrec +tcTyClDecl1 calc_isrec (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, tcdCtxt = ctxt, tcdMeths = meths, tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} ) = tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt ; fds' <- mappM (addLocM tc_fundep) fundeps - -- !!!TODO: process `ats`; what do we want to store in the `Class'? -=chak + ; atss <- mappM (addLocM (tcTyClDecl1 (const Recursive))) ats + ; 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 -- hold of the name of the class TyCon, which we - -- need to look up its recursiveness and variance + -- need to look up its recursiveness tycon_name = tyConName (classTyCon clas) tc_isrec = calc_isrec tycon_name - tc_vrcs = calc_vrcs tycon_name in - buildClass class_name tvs' ctxt' fds' - sig_stuff tc_isrec tc_vrcs) - ; return (AClass clas) } + buildClass class_name tvs' ctxt' fds' ats' + sig_stuff tc_isrec) + ; return (AClass clas : ats') + -- NB: Order is important due to the call to `mkGlobalThings' when + -- tying the the type and class declaration type checking knot. + } where tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ; ; tvs2' <- mappM tcLookupTyVar tvs2 ; ; return (tvs1', tvs2') } - -tcTyClDecl1 calc_vrcs calc_isrec + -- 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 (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name}) - = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0 [])) + = returnM [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)] ----------------------------------- 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 -} - True {- Vanilla -} [NotMarkedStrict] - (map unLoc field_lbls) - tc_tvs [] [arg_ty'] - tycon (mkTyVarTys tc_tvs) } - - -- 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 - } + -> TyCon -> [TyVar] + -> ConDecl Name + -> TcM DataCon -tcConDecl unbox_strict DataType tycon tc_tvs -- Data types - (ConDecl name _ tvs ctxt details res_ty) +tcConDecl unbox_strict tycon tc_tvs -- Data types + (ConDecl name _ tvs ctxt details res_ty _) = tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt - ; (data_tc, res_ty_args) <- tcResultType tycon tc_tvs res_ty + ; (univ_tvs, ex_tvs, eq_preds, data_tc) <- tcResultType tycon tc_tvs tvs' res_ty ; let - con_tvs = case res_ty of - ResTyH98 -> tc_tvs ++ tvs' - ResTyGADT _ -> tryVanilla tvs' res_ty_args - - -- Vanilla iff result type matches the quantified vars exactly, - -- and there is no existential context - -- Must check the context too because of implicit params; e.g. - -- data T = (?x::Int) => MkT Int - is_vanilla = res_ty_args `tcEqTypes` mkTyVarTys con_tvs - && null (unLoc ctxt) - + -- 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 <- mappM tcHsBangType btys - ; buildDataCon (unLoc name) is_infix is_vanilla - (argStrictness unbox_strict tycon bangs arg_tys) + ; buildDataCon (unLoc name) is_infix + (argStrictness unbox_strict bangs arg_tys) (map unLoc field_lbls) - con_tvs ctxt' arg_tys - data_tc res_ty_args } - -- 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. + 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. ; 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 cd_fld_name fields + btys = map cd_fld_type fields } -tcResultType :: TyCon -> [TyVar] -> ResType Name -> TcM (TyCon, [TcType]) -tcResultType tycon tvs ResTyH98 = return (tycon, mkTyVarTys tvs) -tcResultType _ _ (ResTyGADT res_ty) = tcLHsConResTy res_ty - -tryVanilla :: [TyVar] -> [TcType] -> [TyVar] --- (tryVanilla tvs tys) returns a permutation of tvs. --- It tries to re-order the tvs so that it exactly --- matches the [Type], if that is possible -tryVanilla tvs (ty:tys) | Just tv <- tcGetTyVar_maybe ty -- The type is a tyvar - , tv `elem` tvs -- That tyvar is in the list - = tv : tryVanilla (delete tv tvs) tys -tryVanilla tvs tys = tvs -- Fall through case - - -------------------- +tcResultType :: TyCon + -> [TyVar] -- data T a b c = ... + -> [TyVar] -- where MkT :: forall a b c. ... + -> ResType Name + -> TcM ([TyVar], -- Universal + [TyVar], -- Existential (distinct OccNames from univs) + [(TyVar,Type)], -- Equality predicates + TyCon) -- TyCon given in the ResTy + -- 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) + -- 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 + -- 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 + 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) } + 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 + -- 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')) + where + name = tyVarName tv + (env', occ') = tidyOccName env (getOccName name) + + ------------------- argStrictness :: Bool -- True <=> -funbox-strict_fields - -> TyCon -> [HsBang] + -> [HsBang] -> [TcType] -> [StrictnessMark] -argStrictness unbox_strict tycon bangs arg_tys +argStrictness unbox_strict bangs arg_tys = ASSERT( length bangs == length arg_tys ) - zipWith (chooseBoxingStrategy unbox_strict tycon) arg_tys bangs + zipWith (chooseBoxingStrategy unbox_strict) arg_tys bangs -- We attempt to unbox/unpack a strict field when either: -- (i) The field is marked '!!', or -- (ii) The field is marked '!', and the -funbox-strict-fields flag is on. - -chooseBoxingStrategy :: Bool -> TyCon -> TcType -> HsBang -> StrictnessMark -chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang +-- +-- 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 = case bang of HsNoBang -> NotMarkedStrict - HsStrict | unbox_strict_fields && can_unbox -> MarkedUnboxed - HsUnbox | can_unbox -> MarkedUnboxed + HsStrict | unbox_strict_fields + && can_unbox arg_ty -> MarkedUnboxed + HsUnbox | can_unbox arg_ty -> MarkedUnboxed other -> MarkedStrict where - can_unbox = case splitTyConApp_maybe arg_ty of - Nothing -> False - Just (arg_tycon, _) -> not (isRecursiveTyCon tycon) && - isProductTyCon arg_tycon + -- 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) \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} @@ -608,9 +968,11 @@ checkValidTyCl decl -- of the constructor. checkValidTyCon :: TyCon -> TcM () -checkValidTyCon tc +checkValidTyCon tc | isSynTyCon tc - = checkValidType syn_ctxt syn_rhs + = case synTyConRhs tc of + OpenSynTyCon _ _ -> return () + SynonymTyCon ty -> checkValidType syn_ctxt ty | otherwise = -- Check the context on the data decl checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) `thenM_` @@ -624,7 +986,6 @@ checkValidTyCon tc where syn_ctxt = TySynCtxt name name = tyConName tc - syn_rhs = synTyConRhs tc data_cons = tyConDataCons tc groups = equivClasses cmp_fld (concatMap get_fields data_cons) @@ -632,14 +993,20 @@ checkValidTyCon tc get_fields con = dataConFieldLabels con `zip` repeat con -- dataConFieldLabels may return the empty list, which is fine - -- Note: The complicated checkOne logic below is there to accomodate - -- for different return types. Add res_ty to the mix, - -- comparing them in two steps, all for good error messages. - -- Plan: Use Unify.tcMatchTys to compare the first candidate's - -- result type against other candidates' types (check bothways). - -- If they magically agrees, take the substitution and - -- apply them to the latter ones, and see if they match perfectly. - -- check_fields fields@((first_field_label, field_ty) : other_fields) + -- See Note [GADT record selectors] in MkId.lhs + -- We must check (a) that the named field has the same + -- type in each constructor + -- (b) that those constructors have the same result type + -- + -- However, the constructors may have differently named type variable + -- and (worse) we don't know how the correspond to each other. E.g. + -- C1 :: forall a b. { f :: a, g :: b } -> T a b + -- C2 :: forall d c. { f :: c, g :: c } -> T c d + -- + -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's + -- 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) -- These fields all have the same name, but are from -- different constructors in the data type @@ -648,23 +1015,23 @@ checkValidTyCon tc -- NB: this check assumes that all the constructors of a given -- data type use the same type variables where - tvs1 = mkVarSet (dataConTyVars 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 (dataConTyVars con2) - res2 = dataConResTys con2 + (tvs2, _, _, res2) = dataConSig con2 + ts2 = mkVarSet tvs2 fty2 = dataConFieldType con2 label checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2 = do { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2) ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) } where - mb_subst1 = tcMatchTys tvs1 res1 res2 + mb_subst1 = tcMatchTy tvs1 res1 res2 mb_subst2 = tcMatchTyX tvs1 (expectJust "checkFieldCompat" mb_subst1) fty1 fty2 ------------------------------- @@ -673,60 +1040,74 @@ checkValidDataCon tc con = setSrcSpan (srcLocSpan (getSrcLoc con)) $ addErrCtxt (dataConCtxt con) $ do { checkTc (dataConTyCon con == tc) (badDataConTyCon con) - ; checkValidType ctxt (idType (dataConWrapId con)) } - - -- This checks the argument types and - -- ambiguity of the existential context (if any) - -- - -- Note [Sept 04] Now that tvs is all the tvs, this - -- test doesn't actually check anything --- ; checkFreeness tvs ex_theta } + ; checkValidType ctxt (dataConUserType con) + ; ifM (isNewTyCon tc) (checkNewDataCon con) + } where ctxt = ConArgCtxt (dataConName con) --- (tvs, ex_theta, _, _, _) = dataConSig con +------------------------------- +checkNewDataCon :: DataCon -> TcM () +-- Checks for the data constructor of a newtype +checkNewDataCon con + = do { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys)) + -- One argument + ; checkTc (null eq_spec) (newtypePredError con) + -- Return type is (T a b c) + ; checkTc (null ex_tvs && null eq_theta && null dict_theta) (newtypeExError con) + -- No existentials + ; checkTc (not (any isMarkedStrict (dataConStrictMarks con))) + (newtypeStrictError con) + -- No strictness + } + where + (_univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _res_ty) = dataConFullSig con ------------------------------- checkValidClass :: Class -> TcM () checkValidClass cls - = do { -- CHECK ARITY 1 FOR HASKELL 1.4 - gla_exts <- doptM Opt_GlasgowExts + = do { constrained_class_methods <- doptM Opt_ConstrainedClassMethods + ; multi_param_type_classes <- doptM Opt_MultiParamTypeClasses + ; fundep_classes <- doptM Opt_FunctionalDependencies -- Check that the class is unary, unless GlaExs ; checkTc (notNull tyvars) (nullaryClassErr cls) - ; checkTc (gla_exts || unary) (classArityErr cls) + ; checkTc (multi_param_type_classes || unary) (classArityErr cls) + ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls) -- Check the super-classes ; checkValidTheta (ClassSCCtxt (className cls)) theta -- Check the class operations - ; mappM_ (check_op gla_exts) op_stuff + ; mappM_ (check_op constrained_class_methods) op_stuff -- Check that if the class has generic methods, then the -- class has only one parameter. We can't do generic -- multi-parameter type classes! ; checkTc (unary || no_generics) (genericMultiParamErr cls) - - -- Check that the class has no associated types, unless GlaExs - ; checkTc (gla_exts || no_ats) (badATDecl cls) } where - (tyvars, theta, _, op_stuff) = classBigSig cls + (tyvars, fundeps, theta, _, _, op_stuff) = classExtraBigSig cls unary = isSingleton tyvars no_generics = null [() | (_, GenDefMeth) <- op_stuff] - no_ats = True -- !!!TODO: determine whether the class has ATs -=chak - 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 = grow theta (mkVarSet tyvars) + ; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars) (noClassTyVarErr cls sel_id) -- Check that for a generic method, the type of @@ -739,11 +1120,11 @@ checkValidClass cls op_ty = idType sel_id (_,theta1,tau1) = tcSplitSigmaTy op_ty (_,theta2,tau2) = tcSplitSigmaTy tau1 - (theta,tau) | gla_exts = (theta1 ++ theta2, tau2) - | otherwise = (theta1, mkPhiTy (tail theta1) tau1) + (theta,tau) | constrained_class_methods = (theta1 ++ theta2, tau2) + | otherwise = (theta1, mkPhiTy (tail theta1) tau1) -- Ugh! The function might have a type like -- op :: forall a. C a => forall b. (Eq b, Eq a) => tau2 - -- With -fglasgow-exts, we want to allow this, even though the inner + -- With -XConstrainedClassMethods, we want to allow this, even though the inner -- forall has an (Eq a) constraint. Whereas in general, each constraint -- in the context of a for-all must mention at least one quantified -- type variable. What a mess! @@ -768,7 +1149,11 @@ nullaryClassErr cls classArityErr cls = vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls), - parens (ptext SLIT("Use -fglasgow-exts to allow multi-parameter classes"))] + parens (ptext SLIT("Use -XMultiParamTypeClasses to allow multi-parameter classes"))] + +classFunDepsErr cls + = vcat [ptext SLIT("Fundeps in class") <+> quotes (ppr cls), + parens (ptext SLIT("Use -XFunctionalDependencies to allow fundeps"))] noClassTyVarErr clas op = sep [ptext SLIT("The class method") <+> quotes (ppr op), @@ -812,7 +1197,10 @@ badDataConTyCon data_con badGadtDecl tc_name = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow GADTs")) ] + , nest 2 (parens $ ptext SLIT("Use -XGADTs to allow GADTs")) ] + +badStupidTheta tc_name + = ptext SLIT("A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name) newtypeConError tycon n = sep [ptext SLIT("A newtype must have exactly one constructor,"), @@ -822,15 +1210,57 @@ newtypeExError con = sep [ptext SLIT("A newtype constructor cannot have an existential context,"), nest 2 $ ptext SLIT("but") <+> quotes (ppr con) <+> ptext SLIT("does")] +newtypeStrictError con + = sep [ptext SLIT("A newtype constructor cannot have a strictness annotation,"), + nest 2 $ ptext SLIT("but") <+> quotes (ppr con) <+> ptext SLIT("does")] + +newtypePredError con + = sep [ptext SLIT("A newtype constructor must have a return type of form T a1 ... an"), + nest 2 $ ptext SLIT("but") <+> quotes (ppr con) <+> ptext SLIT("does not")] + newtypeFieldErr con_name n_flds = sep [ptext SLIT("The constructor of a newtype must have exactly one field"), nest 2 $ ptext SLIT("but") <+> quotes (ppr con_name) <+> ptext SLIT("has") <+> speakN n_flds] -badATDecl cl_name - = vcat [ ptext SLIT("Illegal associated type declaration in") <+> quotes (ppr cl_name) - , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow ATs")) ] +badSigTyDecl tc_name + = vcat [ ptext SLIT("Illegal kind signature") <+> + quotes (ppr tc_name) + , nest 2 (parens $ ptext SLIT("Use -XKindSignatures to allow kind signatures")) ] + +badFamInstDecl tc_name + = vcat [ ptext SLIT("Illegal family instance for") <+> + quotes (ppr tc_name) + , nest 2 (parens $ ptext SLIT("Use -XTypeFamilies to allow indexed type families")) ] + +badGadtIdxTyDecl tc_name + = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> + quotes (ppr tc_name) + , nest 2 (parens $ ptext SLIT("Family instances can not yet use GADT declarations")) ] + +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) emptyConDeclsErr tycon = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"), - nest 2 $ ptext SLIT("(-fglasgow-exts permits this)")] + nest 2 $ ptext SLIT("(-XEmptyDataDecls permits this)")] \end{code}