X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=de5893b071b8732204cea4674333e39e39bef1a0;hp=8ca5b01e81aef9ed5992379a1b568c2af3ff8024;hb=08a681f1f95b465867c362faf8eb1b40f7bd19dd;hpb=202ac08f3e2afde0620e889cc81a95b2fd0ad9e1 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 8ca5b01..de5893b 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -12,11 +12,11 @@ module TcTyClsDecls ( import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..), ConDecl(..), Sig(..), NewOrData(..), ResType(..), - tyClDeclTyVars, isSynDecl, isClassDecl, isIdxTyDecl, + tyClDeclTyVars, isSynDecl, isIdxTyDecl, isKindSigDecl, hsConArgs, LTyClDecl, tcdName, hsTyVarName, LHsTyVarBndr, LHsType ) -import HsTypes ( HsBang(..), getBangStrictness ) +import HsTypes ( HsBang(..), getBangStrictness, hsLTyVarNames ) import BasicTypes ( RecFlag(..), StrictnessMark(..) ) import HscTypes ( implicitTyThings, ModDetails ) import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon, @@ -24,8 +24,9 @@ import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon, import TcRnMonad import TcEnv ( TyThing(..), tcLookupLocated, tcLookupLocatedGlobal, - tcExtendGlobalEnv, tcExtendKindEnv, tcExtendKindEnvTvs, - tcExtendRecEnv, tcLookupTyVar, InstInfo ) + tcExtendGlobalEnv, tcExtendKindEnv, + tcExtendKindEnvTvs, newFamInstTyConName, + tcExtendRecEnv, tcLookupTyVar, tcLookupLocatedTyCon ) import TcTyDecls ( calcRecFlags, calcClassCycles, calcSynCycles ) import TcClassDcl ( tcClassSigs, tcAddDeclCtxt ) import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType, @@ -36,36 +37,43 @@ 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 + mkArrowKind, liftedTypeKind, + tcSplitSigmaTy, tcGetTyVar_maybe ) +import Type ( splitTyConApp_maybe, + newTyConInstRhs, isLiftedTypeKind, Kind, + splitKindFunTys, mkArrowKinds -- pprParendType, pprThetaArrow ) import Generics ( validGenericMethodType, canDoGenerics ) import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars ) -import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon ), - tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon, +import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon, OpenDataTyCon, + OpenNewTyCon ), + SynTyConRhs( OpenSynTyCon, SynonymTyCon ), + tyConDataCons, mkForeignTyCon, isProductTyCon, + isRecursiveTyCon, tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName, - isNewTyCon ) + isNewTyCon, isDataTyCon, tyConKind, + setTyConArgPoss ) import DataCon ( DataCon, dataConUserType, dataConName, dataConFieldLabels, dataConTyCon, dataConAllTyVars, dataConFieldType, dataConResTys ) -import Var ( TyVar, idType, idName ) +import Var ( TyVar, idType, idName, tyVarName, setTyVarName ) import VarSet ( elemVarSet, mkVarSet ) -import Name ( Name, getSrcLoc ) +import Name ( Name, getSrcLoc, tidyNameOcc, getOccName ) +import OccName ( initTidyOccEnv, tidyOccName ) import Outputable -import Maybe ( isJust, fromJust, isNothing ) +import Maybe ( isJust, fromJust, isNothing, catMaybes ) import Maybes ( expectJust ) +import Monad ( unless ) import Unify ( tcMatchTys, tcMatchTyX ) -import Util ( zipLazy, isSingleton, notNull, sortLe ) -import List ( partition ) -import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan ) +import Util ( zipLazy, isSingleton, notNull, sortLe, mapAccumL ) +import List ( partition, elemIndex ) +import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan, + srcSpanStart ) import ListSetOps ( equivClasses, minusList ) -import List ( delete ) import Digraph ( SCC(..) ) import DynFlags ( DynFlag( Opt_GlasgowExts, Opt_Generics, - Opt_UnboxStrictFields ) ) + Opt_UnboxStrictFields, Opt_IndexedTypes ) ) \end{code} @@ -163,22 +171,30 @@ tcTyAndClassDecls boot_details allDecls ; 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_rec = calcRecFlags boot_details rec_alg_tyclss + ; let { -- Calculate rec-flag + ; calc_rec = calcRecFlags boot_details rec_alg_tyclss ; tc_decl = addLocM (tcTyClDecl calc_rec) } -- Type-check the type synonyms, and extend the envt ; syn_tycons <- tcSynDecls kc_syn_decls @@ -186,7 +202,7 @@ tcTyAndClassDecls boot_details allDecls -- 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 @@ -200,10 +216,22 @@ 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)) + ; 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 @@ -232,15 +260,15 @@ they share a lot of kinding and type checking code with ordinary algebraic data types (and GADTs). \begin{code} -tcIdxTyInstDecl :: LTyClDecl Name -> TcM (Maybe InstInfo) -- Nothing if error +tcIdxTyInstDecl :: LTyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error tcIdxTyInstDecl (L loc decl) = -- Prime error recovery, set source location - recoverM (returnM Nothing) $ - setSrcSpan loc $ - tcAddDeclCtxt decl $ - do { -- indexed data types require -fglasgow-exts and can't be in an + recoverM (returnM Nothing) $ + setSrcSpan loc $ + tcAddDeclCtxt decl $ + do { -- indexed data types 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 @@ -249,60 +277,68 @@ tcIdxTyInstDecl (L loc decl) ; tcIdxTyInstDecl1 decl } -tcIdxTyInstDecl1 :: TyClDecl Name -> TcM (Maybe InstInfo) -- Nothing if error +tcIdxTyInstDecl1 :: TyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error tcIdxTyInstDecl1 (decl@TySynonym {}) - = kcIdxTyPats decl $ \k_tvs k_typats resKind -> - do { -- kind check the right hand side of the type equation + = 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 - -- type check type equation - ; tcTyVarBndrs k_tvs $ \t_tvs -> do { + -- (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 - -- construct type rewrite rule -- !!!of the form: forall t_tvs. (tcdLName decl) t_typats = t_rhs - ; return Nothing -- !!!TODO: need InstInfo for indexed types + ; return Nothing -- !!!TODO: need TyThing for indexed synonym }} -tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L _ tc_name, +tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, tcdCons = cons}) - = kcIdxTyPats decl $ \k_tvs k_typats resKind -> - do { -- kind check the data declaration as usual + = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> + do { -- check that the family declaration is for the right kind + unless (new_or_data == NewType && isNewTyCon family || + new_or_data == DataType && isDataTyCon family) $ + addErr (wrongKindOfFamily family) + + ; -- (1) kind check the data declaration as usual ; k_decl <- kcDataDecl decl k_tvs - ; k_typats <- mappM tcHsKindedType k_typats - ; let k_ctxt = tcdCtxt decl - k_cons = tcdCons decl + ; let k_ctxt = tcdCtxt k_decl + k_cons = tcdCons k_decl -- result kind must be '*' (otherwise, we have too few patterns) ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr tc_name - -- type check indexed data type declaration - ; tcTyVarBndrs k_tvs $ \t_tvs -> do { + -- (2) type check indexed data type declaration + ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars ; unbox_strict <- doptM Opt_UnboxStrictFields -- Check that we don't use GADT syntax for indexed types ; checkTc h98_syntax (badGadtIdxTyDecl tc_name) -- Check that a newtype has exactly one constructor - ; checkTc (new_or_data == DataType || isSingleton cons) $ - newtypeConError tc_name (length cons) + ; checkTc (new_or_data == DataType || isSingleton k_cons) $ + newtypeConError tc_name (length k_cons) + ; t_typats <- mappM tcHsKindedType k_typats ; stupid_theta <- tcHsKindedContext k_ctxt + + ; rep_tc_name <- newFamInstTyConName tc_name (srcSpanStart loc) ; tycon <- fixM (\ tycon -> do { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data - tycon t_tvs)) + 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) - --vvvvvvv !!! need a new derived tc_name here - ; buildAlgTyCon tc_name t_tvs stupid_theta tc_rhs Recursive - False h98_syntax + 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 -- further instance might not introduce a new recursive @@ -311,8 +347,7 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L _ tc_name, }) -- construct result - -- !!!twofold: (1) (ATyCon tycon) and (2) an equality axiom - ; return Nothing -- !!!TODO: need InstInfo for indexed types + ; return $ Just (ATyCon tycon) }} where h98_syntax = case cons of -- All constructors have same shape @@ -329,15 +364,14 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L _ tc_name, -- check is only required for type functions. -- kcIdxTyPats :: TyClDecl Name - -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TcM a) + -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a) -- ^^kinded tvs ^^kinded ty pats ^^res kind -> TcM a kcIdxTyPats decl thing_inside = kcHsTyVars (tcdTyVars decl) $ \tvs -> - do { tc_ty_thing <- tcLookupLocated (tcdLName decl) - ; let tc_kind = case tc_ty_thing of { AThing k -> k } - (kinds, resKind) = splitKindFunTys tc_kind - hs_typats = fromJust $ tcdTyPats decl + do { 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) $ @@ -346,8 +380,9 @@ kcIdxTyPats decl thing_inside -- type functions can have a higher-kinded result ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind ; typats <- zipWithM kcCheckHsType hs_typats kinds - ; thing_inside tvs typats resultKind + ; thing_inside tvs typats resultKind family } + where \end{code} @@ -583,26 +618,48 @@ tcSynDecl = tcTyVarBndrs tvs $ \ tvs' -> do { traceTc (text "tcd1" <+> ppr tc_name) ; rhs_ty' <- tcHsKindedType rhs_ty - ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty')) } + ; return (ATyCon (buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty'))) } -------------------- -tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM TyThing +tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] tcTyClDecl calc_isrec decl = tcAddDeclCtxt decl (tcTyClDecl1 calc_isrec decl) - -- kind signature for a type functions + -- kind signature for a type function tcTyClDecl1 _calc_isrec (TyFunction {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = kind}) - = tcKindSigDecl tc_name tvs kind + = tcTyVarBndrs tvs $ \ tvs' -> do + { traceTc (text "type family: " <+> ppr tc_name) + ; gla_exts <- doptM Opt_IndexedTypes + + -- Check that we don't use kind signatures without Glasgow extensions + ; checkTc gla_exts $ badSigTyDecl tc_name + + ; return [ATyCon $ buildSynTyCon tc_name tvs' (OpenSynTyCon kind)] + } -- kind signature for an indexed data type tcTyClDecl1 _calc_isrec - (TyData {tcdCtxt = ctxt, tcdTyVars = tvs, - tcdLName = L _ tc_name, tcdKindSig = Just kind, tcdCons = []}) - = do - { checkTc (null . unLoc $ ctxt) $ badKindSigCtxt tc_name - ; tcKindSigDecl tc_name tvs kind + (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, + tcdLName = L _ tc_name, tcdKindSig = Just ksig, tcdCons = []}) + = tcTyVarBndrs tvs $ \ tvs' -> do + { traceTc (text "data/newtype family: " <+> ppr tc_name) + ; extra_tvs <- tcDataKindSig (Just ksig) + ; let final_tvs = tvs' ++ extra_tvs -- we may not need these + + ; checkTc (null . unLoc $ ctxt) $ badKindSigCtxt tc_name + ; gla_exts <- doptM Opt_IndexedTypes + + -- Check that we don't use kind signatures without Glasgow extensions + ; checkTc gla_exts $ badSigTyDecl tc_name + + ; tycon <- buildAlgTyCon tc_name final_tvs [] + (case new_or_data of + DataType -> OpenDataTyCon + NewType -> OpenNewTyCon) + Recursive False True Nothing + ; return [ATyCon tycon] } tcTyClDecl1 calc_isrec @@ -648,9 +705,9 @@ tcTyClDecl1 calc_isrec ASSERT( isSingleton data_cons ) mkNewTyConRhs tc_name tycon (head data_cons) ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec - (want_generic && canDoGenerics data_cons) h98_syntax + (want_generic && canDoGenerics data_cons) h98_syntax Nothing }) - ; return (ATyCon tycon) + ; return [ATyCon tycon] } where is_rec = calc_isrec tc_name @@ -665,8 +722,8 @@ tcTyClDecl1 calc_isrec = tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt ; fds' <- mappM (addLocM tc_fundep) fundeps - ; ats' <- mappM (addLocM (tcTyClDecl1 (const Recursive))) ats - -- ^^^^ !!!TODO: what to do with this? Need to generate FC tyfun decls. + ; 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 @@ -675,45 +732,41 @@ tcTyClDecl1 calc_isrec tycon_name = tyConName (classTyCon clas) tc_isrec = calc_isrec tycon_name in - buildClass class_name tvs' ctxt' fds' + buildClass class_name tvs' ctxt' fds' ats' sig_stuff tc_isrec) - ; return (AClass clas) } + ; return (AClass clas : ats') + -- NB: Order is important due to the call to `mkGlobalThings' when + -- tying the the type and class declaration type checking knot. + } where tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ; ; tvs2' <- mappM tcLookupTyVar tvs2 ; ; 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 (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name}) - = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)) - ------------------------------------ -tcKindSigDecl :: Name -> [LHsTyVarBndr Name] -> Kind -> TcM TyThing -tcKindSigDecl tc_name tvs kind - = tcTyVarBndrs tvs $ \ tvs' -> do - { gla_exts <- doptM Opt_GlasgowExts - - -- Check that we don't use kind signatures without Glasgow extensions - ; checkTc gla_exts $ badSigTyDecl tc_name - - -- !!!TODO - -- We need to extend TyCon.TyCon with a new variant representing indexed - -- type constructors (ie, IdxTyCon). We will use them for both indexed - -- data types as well as type functions. In the case of indexed *data* - -- types, they are *abstract*; ie, won't be rewritten. OR do we just want - -- to make another variant of AlgTyCon (after all synonyms are also - -- AlgTyCons...) - -- We need an additional argument to this functions, which determines - -- whether the type constructor is abstract. - ; tycon <- error "TcTyClsDecls.tcKindSigDecl: IdxTyCon not implemented yet." - ; return (ATyCon tycon) - } + = returnM [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)] ----------------------------------- tcConDecl :: Bool -- True <=> -funbox-strict_fields - -> NewOrData -> TyCon -> [TyVar] - -> ConDecl Name -> TcM DataCon + -> NewOrData + -> TyCon -> [TyVar] + -> ConDecl Name + -> TcM DataCon tcConDecl unbox_strict NewType tycon tc_tvs -- Newtypes (ConDecl name _ ex_tvs ex_ctxt details ResTyH98) @@ -731,9 +784,10 @@ tcConDecl unbox_strict NewType tycon tc_tvs -- Newtypes ; checkTc (null ex_tvs && null (unLoc ex_ctxt)) (newtypeExError name) ; case details of - PrefixCon [arg_ty] -> tc_datacon [] arg_ty + 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))) + other -> + failWithTc (newtypeFieldErr name (length (hsConArgs details))) -- Check that the constructor has exactly one field } @@ -743,17 +797,18 @@ tcConDecl unbox_strict DataType tycon tc_tvs -- Data types { 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 } - -- 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. + -- 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 @@ -769,7 +824,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 @@ -789,8 +844,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, @@ -807,13 +862,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 @@ -821,8 +888,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 @@ -835,13 +902,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} @@ -887,7 +962,9 @@ checkValidTyCl decl checkValidTyCon :: TyCon -> TcM () 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_` @@ -901,7 +978,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) @@ -1127,7 +1203,16 @@ tooFewParmsErr tc_name = ptext SLIT("Indexed type instance has too few parameters:") <+> quotes (ppr tc_name) -badBootTyIdxDeclErr = ptext SLIT("Illegal indexed type instance in hs-boot file") +badBootTyIdxDeclErr = + ptext SLIT("Illegal indexed type instance in hs-boot file") + +wrongKindOfFamily family = + ptext SLIT("Wrong category of type 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") emptyConDeclsErr tycon = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),