X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=34022db5ebf7b16bb9a984eceb396a6090fb347c;hp=e83d77f5fcf1bb9b1527f49000fc75f291644780;hb=940524aec90652b5ef81789c9a453c57c0e42cc9;hpb=53569e145c8ff8af89303742f261302fdcd98f04 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index e83d77f..34022db 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -1,75 +1,51 @@ % +% (c) The University of Glasgow 2006 % (c) The AQUA Project, Glasgow University, 1996-1998 % -\section[TcTyClsDecls]{Typecheck type and class declarations} + +TcTyClsDecls: Typecheck type and class declarations \begin{code} module TcTyClsDecls ( - tcTyAndClassDecls, tcIdxTyInstDecl + tcTyAndClassDecls, tcFamInstDecl ) where #include "HsVersions.h" -import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..), - ConDecl(..), Sig(..), NewOrData(..), ResType(..), - tyClDeclTyVars, isSynDecl, isClassDecl, isIdxTyDecl, - isKindSigDecl, hsConArgs, LTyClDecl, tcdName, - hsTyVarName, LHsTyVarBndr, LHsType, HsType(..), - mkHsAppTy - ) -import HsTypes ( HsBang(..), getBangStrictness, hsLTyVarNames ) -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 TcRnMonad -import TcEnv ( TyThing(..), - tcLookupLocated, tcLookupLocatedGlobal, - tcExtendGlobalEnv, tcExtendKindEnv, tcExtendKindEnvTvs, - tcExtendRecEnv, tcLookupTyVar, InstInfo ) -import TcTyDecls ( calcRecFlags, calcClassCycles, calcSynCycles ) -import TcClassDcl ( tcClassSigs, tcAddDeclCtxt ) -import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType, - kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext, - kcHsSigType, tcHsBangType, tcLHsConResTy, - tcDataKindSig, kcCheckHsType ) -import TcMType ( newKindVar, checkValidTheta, checkValidType, - -- checkFreeness, - UserTypeCtxt(..), SourceTyCtxt(..) ) -import TcType ( TcKind, TcType, Type, tyVarsOfType, mkPhiTy, - mkArrowKind, liftedTypeKind, mkTyVarTys, - tcSplitSigmaTy, tcEqTypes, tcGetTyVar_maybe ) -import Type ( PredType(..), splitTyConApp_maybe, mkTyVarTy, - newTyConInstRhs, isLiftedTypeKind, Kind - -- pprParendType, pprThetaArrow - ) -import Generics ( validGenericMethodType, canDoGenerics ) -import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars ) -import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon, OpenDataTyCon, - OpenNewTyCon ), - SynTyConRhs( OpenSynTyCon, SynonymTyCon ), - tyConDataCons, mkForeignTyCon, isProductTyCon, - isRecursiveTyCon, isOpenTyCon, - tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName, - isNewTyCon, tyConKind, setTyConArgPoss ) -import DataCon ( DataCon, dataConUserType, dataConName, - dataConFieldLabels, dataConTyCon, dataConAllTyVars, - dataConFieldType, dataConResTys ) -import Var ( TyVar, idType, idName ) -import VarSet ( elemVarSet, mkVarSet ) -import Name ( Name, getSrcLoc ) +import TcEnv +import TcTyDecls +import TcClassDcl +import TcHsType +import TcMType +import TcType +import FunDeps +import Type +import Generics +import Class +import TyCon +import DataCon +import Var +import VarSet +import Name +import OccName import Outputable -import Maybe ( isJust, fromJust, isNothing, catMaybes ) -import Maybes ( expectJust ) -import Unify ( tcMatchTys, tcMatchTyX ) -import Util ( zipLazy, isSingleton, notNull, sortLe ) -import List ( partition, elemIndex ) -import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan ) -import ListSetOps ( equivClasses, minusList ) -import List ( delete ) -import Digraph ( SCC(..) ) -import DynFlags ( DynFlag( Opt_GlasgowExts, Opt_Generics, - Opt_UnboxStrictFields ) ) +import Maybes +import Monad +import Unify +import Util +import SrcLoc +import ListSetOps +import Digraph +import DynFlags + +import Data.List ( partition, elemIndex ) +import Control.Monad ( mplus ) \end{code} @@ -159,7 +135,7 @@ tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name] tcTyAndClassDecls boot_details allDecls = do { -- Omit instances of indexed types; they are handled together -- with the *heads* of class instances - ; let decls = filter (not . isIdxTyDecl . unLoc) allDecls + ; let decls = filter (not . isFamInstDecl . unLoc) allDecls -- First check for cyclic type synonysm or classes -- See notes with checkCycleErrs @@ -192,6 +168,7 @@ tcTyAndClassDecls boot_details allDecls ; 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 @@ -212,12 +189,20 @@ tcTyAndClassDecls boot_details allDecls -- 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)) ; 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] @@ -238,40 +223,43 @@ mkGlobalThings decls things %************************************************************************ %* * -\subsection{Type checking instances of indexed types} +\subsection{Type checking family instances} %* * %************************************************************************ -Instances of indexed types are somewhat of a hybrid. They are processed -together with class instance heads, but can contain data constructors and hence -they share a lot of kinding and type checking code with ordinary algebraic -data types (and GADTs). +Family instances are somewhat of a hybrid. They are processed together with +class instance heads, but can contain data constructors and hence they share a +lot of kinding and type checking code with ordinary algebraic data types (and +GADTs). \begin{code} -tcIdxTyInstDecl :: LTyClDecl Name - -> TcM (Maybe InstInfo, Maybe TyThing) -- Nothing if error -tcIdxTyInstDecl (L loc decl) +tcFamInstDecl :: LTyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error +tcFamInstDecl (L loc decl) = -- Prime error recovery, set source location - recoverM (returnM (Nothing, Nothing)) $ + recoverM (returnM Nothing) $ setSrcSpan loc $ tcAddDeclCtxt decl $ - do { -- indexed data types require -fglasgow-exts and can't be in an + do { -- type families require -findexed-types and can't be in an -- hs-boot file - ; gla_exts <- doptM Opt_GlasgowExts + ; gla_exts <- doptM Opt_IndexedTypes ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? - ; checkTc gla_exts $ badIdxTyDecl (tcdLName decl) - ; checkTc (not is_boot) $ badBootTyIdxDeclErr + ; checkTc gla_exts $ badFamInstDecl (tcdLName decl) + ; checkTc (not is_boot) $ badBootFamInstDeclErr -- perform kind and type checking - ; tcIdxTyInstDecl1 decl + ; tcFamInstDecl1 decl } -tcIdxTyInstDecl1 :: TyClDecl Name - -> TcM (Maybe InstInfo, Maybe TyThing) -- Nothing if error +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) -tcIdxTyInstDecl1 (decl@TySynonym {}) - = kcIdxTyPats decl $ \k_tvs k_typats resKind _ -> - do { -- (1) kind check the right hand side of the type equation + ; -- (1) kind check the right hand side of the type equation ; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind -- (2) type check type equation @@ -279,15 +267,24 @@ tcIdxTyInstDecl1 (decl@TySynonym {}) ; t_typats <- mappM tcHsKindedType k_typats ; t_rhs <- tcHsKindedType k_rhs - -- construct type rewrite rule - -- !!!of the form: forall t_tvs. (tcdLName decl) t_typats = t_rhs - ; return (Nothing, Nothing) -- !!!TODO: need InstInfo for eq axioms + -- (3) 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) }} - -tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, - tcdCons = cons}) + + -- "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 { -- (1) kind check the data declaration as usual + do { -- check that the family declaration is for the right kind + unless (new_or_data == NewType && isNewTyCon family || + new_or_data == DataType && isDataTyCon 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 @@ -309,17 +306,17 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, ; t_typats <- mappM tcHsKindedType k_typats ; stupid_theta <- tcHsKindedContext k_ctxt + -- (3) construct representation tycon + ; rep_tc_name <- newFamInstTyConName tc_name loc ; tycon <- fixM (\ tycon -> do - { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data - tycon t_tvs)) + { data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon t_tvs)) k_cons ; tc_rhs <- case new_or_data of DataType -> return (mkDataTyConRhs data_cons) - NewType -> - ASSERT( isSingleton data_cons ) - mkNewTyConRhs tc_name tycon (head data_cons) - ; buildAlgTyCon tc_name t_tvs stupid_theta tc_rhs Recursive + NewType -> ASSERT( isSingleton data_cons ) + mkNewTyConRhs 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 @@ -329,7 +326,7 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, }) -- construct result - ; return (Nothing, Just (ATyCon tycon)) + ; return $ Just (ATyCon tycon) }} where h98_syntax = case cons of -- All constructors have same shape @@ -351,10 +348,8 @@ kcIdxTyPats :: TyClDecl Name -> TcM a kcIdxTyPats decl thing_inside = kcHsTyVars (tcdTyVars decl) $ \tvs -> - do { tc_ty_thing <- tcLookupLocated (tcdLName decl) - ; let { family = case tc_ty_thing of - AGlobal (ATyCon family) -> family - ; (kinds, resKind) = splitKindFunTys (tyConKind family) + 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 @@ -363,7 +358,7 @@ kcIdxTyPats decl thing_inside -- type functions can have a higher-kinded result ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind - ; typats <- zipWithM kcCheckHsType hs_typats kinds + ; typats <- TcRnMonad.zipWithM kcCheckHsType hs_typats kinds ; thing_inside tvs typats resultKind family } where @@ -403,11 +398,11 @@ Indexed Types This treatment of type synonyms only applies to Haskell 98-style synonyms. General type functions can be recursive, and hence, appear in `alg_decls'. -The kind of an indexed type is solely determinded by its kind signature; +The kind of a type family is solely determinded by its kind signature; hence, only kind signatures participate in the construction of the initial kind environment (as constructed by `getInitialKind'). In fact, we ignore -instances of indexed types altogether in the following. However, we need to -include the kind signatures of associated types into the construction of the +instances of families altogether in the following. However, we need to +include the kinds of associated families into the construction of the initial kind environment. (This is handled by `allDecls'). \begin{code} @@ -432,7 +427,7 @@ kcTyClDecls syn_decls alg_decls -- instances of indexed types yet, but leave this to -- `tcInstDecls1' { kc_alg_decls <- mappM (wrapLocM kcTyClDecl) - (filter (not . isIdxTyDecl . unLoc) alg_decls) + (filter (not . isFamInstDecl . unLoc) alg_decls) ; return (kc_syn_decls, kc_alg_decls) }}} where @@ -440,9 +435,9 @@ kcTyClDecls syn_decls alg_decls -- environment allDecls (decl@ClassDecl {tcdATs = ats}) = decl : [ at | L _ at <- ats - , isKindSigDecl at] - allDecls decl | isIdxTyDecl decl = [] - | otherwise = [decl] + , isFamilyDecl at] + allDecls decl | isFamInstDecl decl = [] + | otherwise = [decl] ------------------------------------------------------------------------ getInitialKind :: TyClDecl Name -> TcM (Name, TcKind) @@ -457,10 +452,9 @@ getInitialKind decl mk_arg_kind (UserTyVar _) = newKindVar mk_arg_kind (KindedTyVar _ kind) = return kind - mk_res_kind (TyFunction { tcdKind = kind }) = return kind - mk_res_kind (TyData { tcdKindSig = Just kind }) = return kind - -- On GADT-style and data signature declarations we allow a kind - -- signature + mk_res_kind (TyFamily { tcdKind = Just kind }) = return kind + mk_res_kind (TyData { tcdKindSig = Just kind }) = return kind + -- On GADT-style declarations we allow a kind signature -- data T :: *->* where { ... } mk_res_kind other = return liftedTypeKind @@ -502,13 +496,15 @@ kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name) -- Not used for type synonyms (see kcSynDecl) kcTyClDecl decl@(TyData {}) - = ASSERT( not . isJust $ tcdTyPats decl ) -- must not be instance of idx ty + = ASSERT( not . isFamInstDecl $ decl ) -- must not be a family instance kcTyClDeclBody decl $ kcDataDecl decl -kcTyClDecl decl@(TyFunction {}) +kcTyClDecl decl@(TyFamily {tcdKind = kind}) = kcTyClDeclBody decl $ \ tvs' -> - return (decl {tcdTyVars = tvs'}) + return (decl {tcdTyVars = tvs', + tcdKind = kind `mplus` Just liftedTypeKind}) + -- default result kind is '*' kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) = kcTyClDeclBody decl $ \ tvs' -> @@ -556,14 +552,15 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) ; 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 + -- 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') + 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') } @@ -572,7 +569,7 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) kc_con_details (RecCon fields) = do { fields' <- mappM kc_field fields; return (RecCon fields') } - kc_field (fld, bty) = do { bty' <- kc_larg_ty bty ; return (fld, bty') } + kc_field (HsRecField fld bty d) = do { bty' <- kc_larg_ty bty ; return (HsRecField fld bty' d) } kc_larg_ty bty = case new_or_data of DataType -> kcHsSigType bty @@ -597,12 +594,15 @@ tcSynDecls (decl : decls) ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls decls) ; return (syn_tc : syn_tcs) } + -- "type" tcSynDecl (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) = tcTyVarBndrs tvs $ \ tvs' -> do { traceTc (text "tcd1" <+> ppr tc_name) ; rhs_ty' <- tcHsKindedType rhs_ty - ; return (ATyCon (buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty'))) } + ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') Nothing + ; return (ATyCon tycon) + } -------------------- tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] @@ -610,42 +610,47 @@ tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] tcTyClDecl calc_isrec decl = tcAddDeclCtxt decl (tcTyClDecl1 calc_isrec decl) - -- kind signature for a type function + -- "type family" declarations tcTyClDecl1 _calc_isrec - (TyFunction {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = kind}) + (TyFamily {tcdFlavour = TypeFamily, + tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = Just kind}) + -- NB: kind at latest + -- added during + -- kind checking = tcTyVarBndrs tvs $ \ tvs' -> do { traceTc (text "type family: " <+> ppr tc_name) - ; gla_exts <- doptM Opt_GlasgowExts + ; idx_tys <- doptM Opt_IndexedTypes - -- Check that we don't use kind signatures without Glasgow extensions - ; checkTc gla_exts $ badSigTyDecl tc_name + -- Check that we don't use families without -findexed-types + ; checkTc idx_tys $ badFamInstDecl tc_name - ; return [ATyCon $ buildSynTyCon tc_name tvs' (OpenSynTyCon kind)] + ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) Nothing + ; return [ATyCon tycon] } - -- kind signature for an indexed data type + -- "newtype family" or "data family" declaration tcTyClDecl1 _calc_isrec - (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, - tcdLName = L _ tc_name, tcdKindSig = Just ksig, tcdCons = []}) + (TyFamily {tcdFlavour = DataFamily new_or_data, + tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind}) = tcTyVarBndrs tvs $ \ tvs' -> do { traceTc (text "data/newtype family: " <+> ppr tc_name) - ; extra_tvs <- tcDataKindSig (Just ksig) + ; extra_tvs <- tcDataKindSig mb_kind ; let final_tvs = tvs' ++ extra_tvs -- we may not need these - ; checkTc (null . unLoc $ ctxt) $ badKindSigCtxt tc_name - ; gla_exts <- doptM Opt_GlasgowExts + ; idx_tys <- doptM Opt_IndexedTypes - -- Check that we don't use kind signatures without Glasgow extensions - ; checkTc gla_exts $ badSigTyDecl tc_name + -- Check that we don't use families without -findexed-types + ; checkTc idx_tys $ badFamInstDecl tc_name ; tycon <- buildAlgTyCon tc_name final_tvs [] (case new_or_data of - DataType -> OpenDataTyCon - NewType -> OpenNewTyCon) + DataType -> mkOpenDataTyConRhs + NewType -> mkOpenNewTyConRhs) Recursive False True Nothing ; return [ATyCon tycon] } + -- "newtype" and "data" tcTyClDecl1 calc_isrec (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons}) @@ -677,8 +682,7 @@ tcTyClDecl1 calc_isrec (newtypeConError tc_name (length cons)) ; tycon <- fixM (\ tycon -> do - { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data - tycon final_tvs)) + { data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon final_tvs)) cons ; tc_rhs <- if null cons && is_boot -- In a hs-boot file, empty cons means @@ -727,6 +731,9 @@ tcTyClDecl1 calc_isrec ; tvs2' <- mappM 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 @@ -736,8 +743,7 @@ tcTyClDecl1 calc_isrec -- There will be no Nothing, as we already passed renaming in ATyCon (setTyConArgPoss tycon poss) - setTyThingPoss _ _ = panic "setTyThingPoss" - + setTyThingPoss _ _ = panic "TcTyClsDecls.setTyThingPoss" tcTyClDecl1 calc_isrec (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name}) @@ -745,45 +751,22 @@ tcTyClDecl1 calc_isrec ----------------------------------- tcConDecl :: Bool -- True <=> -funbox-strict_fields - -> NewOrData -> TyCon -> [TyVar] -> ConDecl Name -> TcM DataCon -tcConDecl unbox_strict NewType tycon tc_tvs -- Newtypes - (ConDecl name _ ex_tvs ex_ctxt details ResTyH98) - = do { let tc_datacon field_lbls arg_ty - = do { arg_ty' <- tcHsKindedType arg_ty -- No bang on newtype - ; buildDataCon (unLoc name) False {- Prefix -} - [NotMarkedStrict] - (map unLoc field_lbls) - tc_tvs [] -- No existentials - [] [] -- No equalities, predicates - [arg_ty'] - tycon } - - -- Check that a newtype has no existential stuff - ; checkTc (null ex_tvs && null (unLoc ex_ctxt)) (newtypeExError name) - - ; case details of - PrefixCon [arg_ty] -> tc_datacon [] arg_ty - RecCon [(field_lbl, arg_ty)] -> tc_datacon [field_lbl] arg_ty - other -> - failWithTc (newtypeFieldErr name (length (hsConArgs details))) - -- Check that the constructor has exactly one field - } - -tcConDecl unbox_strict DataType tycon tc_tvs -- Data types - (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 ; (univ_tvs, ex_tvs, eq_preds, data_tc) <- tcResultType tycon tc_tvs 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 <- mappM tcHsBangType btys ; buildDataCon (unLoc name) is_infix - (argStrictness unbox_strict tycon bangs arg_tys) + (argStrictness unbox_strict bangs arg_tys) (map unLoc field_lbls) univ_tvs ex_tvs eq_preds ctxt' arg_tys data_tc } @@ -796,7 +779,7 @@ tcConDecl unbox_strict DataType tycon tc_tvs -- Data types InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2] RecCon fields -> tc_datacon False field_names btys where - (field_names, btys) = unzip fields + (field_names, btys) = unzip [ (n, t) | HsRecField n t _ <- fields ] } @@ -805,7 +788,7 @@ tcResultType :: TyCon -> [TyVar] -- where MkT :: forall a b c. ... -> ResType Name -> TcM ([TyVar], -- Universal - [TyVar], -- Existential + [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 @@ -825,8 +808,8 @@ tcResultType _ tc_tvs dc_tvs (ResTyGADT res_ty) -- ([a,z,c], [x,y], [a:=:(x,y), c:=:z], T) = do { (dc_tycon, res_tys) <- tcLHsConResTy res_ty - -- NB: tc_tvs and dc_tvs are distinct - ; let univ_tvs = choose_univs [] tc_tvs res_tys + + ; 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, @@ -843,13 +826,25 @@ tcResultType _ tc_tvs dc_tvs (ResTyGADT res_ty) | 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 @@ -857,8 +852,8 @@ argStrictness unbox_strict tycon bangs arg_tys -- -- We have turned off unboxing of newtypes because coercions make unboxing -- and reboxing more complicated -chooseBoxingStrategy :: Bool -> TyCon -> TcType -> HsBang -> StrictnessMark -chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang +chooseBoxingStrategy :: Bool -> TcType -> HsBang -> StrictnessMark +chooseBoxingStrategy unbox_strict_fields arg_ty bang = case bang of HsNoBang -> NotMarkedStrict HsStrict | unbox_strict_fields @@ -871,13 +866,21 @@ chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang can_unbox arg_ty = case splitTyConApp_maybe arg_ty of Nothing -> False Just (arg_tycon, tycon_args) -> - not (isRecursiveTyCon tycon) && + not (isRecursiveTyCon arg_tycon) && -- Note [Recusive unboxing] isProductTyCon arg_tycon && (if isNewTyCon arg_tycon then can_unbox (newTyConInstRhs arg_tycon tycon_args) else True) \end{code} +Note [Recursive unboxing] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Be careful not to try to unbox this! + data T = MkT !T Int +But it's the *argument* type that matters. This is fine: + data S = MkS S !Int +because Int is non-recursive. + %************************************************************************ %* * \subsection{Dependency analysis} @@ -924,8 +927,8 @@ checkValidTyCon :: TyCon -> TcM () checkValidTyCon tc | isSynTyCon tc = case synTyConRhs tc of - OpenSynTyCon _ -> return () - SynonymTyCon ty -> checkValidType syn_ctxt ty + OpenSynTyCon _ _ -> return () + SynonymTyCon ty -> checkValidType syn_ctxt ty | otherwise = -- Check the context on the data decl checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) `thenM_` @@ -968,23 +971,23 @@ checkValidTyCon tc -- NB: this check assumes that all the constructors of a given -- data type use the same type variables where - tvs1 = mkVarSet (dataConAllTyVars con1) - res1 = dataConResTys con1 + (tvs1, _, _, res1) = dataConSig con1 + ts1 = mkVarSet tvs1 fty1 = dataConFieldType con1 label checkOne (_, con2) -- Do it bothways to ensure they are structurally identical - = do { checkFieldCompat label con1 con2 tvs1 res1 res2 fty1 fty2 - ; checkFieldCompat label con2 con1 tvs2 res2 res1 fty2 fty1 } + = do { checkFieldCompat label con1 con2 ts1 res1 res2 fty1 fty2 + ; checkFieldCompat label con2 con1 ts2 res2 res1 fty2 fty1 } where - tvs2 = mkVarSet (dataConAllTyVars con2) - res2 = dataConResTys con2 + (tvs2, _, _, res2) = dataConSig con2 + ts2 = mkVarSet tvs2 fty2 = dataConFieldType con2 label checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2 = do { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2) ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) } where - mb_subst1 = tcMatchTys tvs1 res1 res2 + mb_subst1 = tcMatchTy tvs1 res1 res2 mb_subst2 = tcMatchTyX tvs1 (expectJust "checkFieldCompat" mb_subst1) fty1 fty2 ------------------------------- @@ -993,11 +996,27 @@ checkValidDataCon tc con = setSrcSpan (srcLocSpan (getSrcLoc con)) $ addErrCtxt (dataConCtxt con) $ do { checkTc (dataConTyCon con == tc) (badDataConTyCon con) - ; checkValidType ctxt (dataConUserType con) } + ; checkValidType ctxt (dataConUserType con) + ; ifM (isNewTyCon tc) (checkNewDataCon con) + } where ctxt = ConArgCtxt (dataConName con) ------------------------------- +checkNewDataCon :: DataCon -> TcM () +-- Checks for the data constructor of a newtype +checkNewDataCon con + = do { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys)) + -- One argument + ; checkTc (null eq_spec) (newtypePredError con) + -- Return type is (T a b c) + ; checkTc (null ex_tvs && null theta) (newtypeExError con) + -- No existentials + } + where + (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con + +------------------------------- checkValidClass :: Class -> TcM () checkValidClass cls = do { -- CHECK ARITY 1 FOR HASKELL 1.4 @@ -1032,8 +1051,13 @@ checkValidClass cls ; 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 @@ -1132,6 +1156,10 @@ newtypeExError con = sep [ptext SLIT("A newtype constructor cannot have an existential context,"), 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] @@ -1139,32 +1167,37 @@ newtypeFieldErr con_name n_flds badSigTyDecl tc_name = vcat [ ptext SLIT("Illegal kind signature") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow indexed types")) ] + , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow kind signatures")) ] -badKindSigCtxt tc_name - = vcat [ ptext SLIT("Illegal context in kind signature") <+> +badFamInstDecl tc_name + = vcat [ ptext SLIT("Illegal family instance for") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Currently, kind signatures cannot have a context")) ] - -badIdxTyDecl tc_name - = vcat [ ptext SLIT("Illegal indexed type instance for") <+> - quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow indexed types")) ] + , nest 2 (parens $ ptext SLIT("Use -findexed-types 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("Indexed types cannot use GADT declarations")) ] + , nest 2 (parens $ ptext SLIT("Family instances can not yet use GADT declarations")) ] tooManyParmsErr tc_name - = ptext SLIT("Indexed type instance has too many parameters:") <+> + = ptext SLIT("Family instance has too many parameters:") <+> quotes (ppr tc_name) tooFewParmsErr tc_name - = ptext SLIT("Indexed type instance has too few parameters:") <+> + = ptext SLIT("Family instance has too few parameters:") <+> quotes (ppr tc_name) -badBootTyIdxDeclErr = ptext SLIT("Illegal indexed type instance in hs-boot file") +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") + | isDataTyCon family = ptext SLIT("data type") + | isNewTyCon family = ptext SLIT("newtype") + | otherwise = pprPanic "wrongKindOfFamily" (ppr family) emptyConDeclsErr tycon = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),