X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FType.lhs;h=93a421a08a2544136ebfee3a7afe668725f05679;hb=9003a18c4efa4548ae80709aef9963f7b544ded3;hp=be39f10f39103f9beca30227cd2bfe8261ff892a;hpb=2767767f7b4acf89f56d18231f143b60429631f6;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index be39f10..93a421a 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -6,8 +6,8 @@ \begin{code} module Type ( -- re-exports from TypeRep: - Type, PredType, TauType, ThetaType, - Kind, TyVarSubst, + Type, PredType, ThetaType, + Kind, TyVarSubst, superKind, superBoxity, -- KX and BX respectively liftedBoxity, unliftedBoxity, -- :: BX @@ -15,7 +15,7 @@ module Type ( typeCon, -- :: BX -> KX liftedTypeKind, unliftedTypeKind, openTypeKind, -- :: KX mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX - isTypeKind, + isTypeKind, isAnyTypeKind, funTyCon, usageKindCon, -- :: KX @@ -31,41 +31,38 @@ module Type ( mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe, mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, - funResultTy, funArgTy, zipFunTys, + funResultTy, funArgTy, zipFunTys, isFunTy, - mkTyConApp, mkTyConTy, + mkGenTyConApp, mkTyConApp, mkTyConTy, tyConAppTyCon, tyConAppArgs, splitTyConApp_maybe, splitTyConApp, - mkUTy, splitUTy, splitUTy_maybe, - isUTy, uaUTy, unUTy, liftUTy, mkUTyM, - isUsageKind, isUsage, isUTyVar, - mkSynTy, - repType, splitRepFunTys, typePrimRep, + repType, typePrimRep, mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, - applyTy, applyTys, isForAllTy, + applyTy, applyTys, isForAllTy, dropForAlls, -- Source types - SourceType(..), sourceTypeRep, + SourceType(..), sourceTypeRep, mkPredTy, mkPredTys, -- Newtypes splitNewType_maybe, -- Lifting and boxity - isUnLiftedType, isUnboxedTupleType, isAlgType, + isUnLiftedType, isUnboxedTupleType, isAlgType, isStrictType, isPrimitiveType, -- Free variables tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, - usageAnnOfType, typeKind, addFreeTyVars, + typeKind, addFreeTyVars, -- Tidying up for printing - tidyType, tidyTypes, - tidyOpenType, tidyOpenTypes, - tidyTyVar, tidyTyVars, tidyFreeTyVars, - tidyTopType, tidyPred, + tidyType, tidyTypes, + tidyOpenType, tidyOpenTypes, + tidyTyVarBndr, tidyFreeTyVars, + tidyOpenTyVar, tidyOpenTyVars, + tidyTopType, tidyPred, -- Comparison eqType, eqKind, eqUsage, @@ -88,13 +85,13 @@ import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages import {-# SOURCE #-} Subst ( substTyWith ) -- friends: -import Var ( Var, TyVar, tyVarKind, tyVarName, setTyVarName ) +import Var ( TyVar, tyVarKind, tyVarName, setTyVarName ) import VarEnv import VarSet -import Name ( NamedThing(..), mkLocalName, tidyOccName ) +import Name ( NamedThing(..), mkInternalName, tidyOccName ) import Class ( classTyCon ) -import TyCon ( TyCon, isRecursiveTyCon, +import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon, isUnboxedTupleTyCon, isUnLiftedTyCon, isFunTyCon, isNewTyCon, newTyConRep, isAlgTyCon, isSynTyCon, tyConArity, @@ -103,13 +100,14 @@ import TyCon ( TyCon, isRecursiveTyCon, ) -- others -import Maybes ( maybeToBool ) +import CmdLineOpts ( opt_DictsStrict ) import SrcLoc ( noSrcLoc ) import PrimRep ( PrimRep(..) ) import Unique ( Uniquable(..) ) -import Util ( mapAccumL, seqList ) +import Util ( mapAccumL, seqList, lengthIs ) import Outputable import UniqSet ( sizeUniqSet ) -- Should come via VarSet +import Maybe ( isJust ) \end{code} @@ -121,20 +119,28 @@ import UniqSet ( sizeUniqSet ) -- Should come via VarSet \begin{code} hasMoreBoxityInfo :: Kind -> Kind -> Bool +-- (k1 `hasMoreBoxityInfo` k2) checks that k1 <: k2 hasMoreBoxityInfo k1 k2 - | k2 `eqKind` openTypeKind = True - | otherwise = k1 `eqType` k2 + | k2 `eqKind` openTypeKind = isAnyTypeKind k1 + | otherwise = k1 `eqKind` k2 + where + +isAnyTypeKind :: Kind -> Bool +-- True of kind * and *# and ? +isAnyTypeKind (TyConApp tc _) = tc == typeCon || tc == openKindCon +isAnyTypeKind (NoteTy _ k) = isAnyTypeKind k +isAnyTypeKind other = False + +isTypeKind :: Kind -> Bool +-- True of kind * and *# +isTypeKind (TyConApp tc _) = tc == typeCon +isTypeKind (NoteTy _ k) = isTypeKind k +isTypeKind other = False defaultKind :: Kind -> Kind -- Used when generalising: default kind '?' to '*' defaultKind kind | kind `eqKind` openTypeKind = liftedTypeKind | otherwise = kind - -isTypeKind :: Kind -> Bool --- True of kind * and *# -isTypeKind k = case splitTyConApp_maybe k of - Just (tc,[k]) -> tc == typeCon - other -> False \end{code} @@ -159,21 +165,18 @@ getTyVar :: String -> Type -> TyVar getTyVar msg (TyVarTy tv) = tv getTyVar msg (SourceTy p) = getTyVar msg (sourceTypeRep p) getTyVar msg (NoteTy _ t) = getTyVar msg t -getTyVar msg ty@(UsageTy _ _) = pprPanic "getTyVar: UTy:" (text msg $$ pprType ty) getTyVar msg other = panic ("getTyVar: " ++ msg) getTyVar_maybe :: Type -> Maybe TyVar getTyVar_maybe (TyVarTy tv) = Just tv getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t getTyVar_maybe (SourceTy p) = getTyVar_maybe (sourceTypeRep p) -getTyVar_maybe ty@(UsageTy _ _) = pprPanic "getTyVar_maybe: UTy:" (pprType ty) getTyVar_maybe other = Nothing isTyVarTy :: Type -> Bool isTyVarTy (TyVarTy tv) = True isTyVarTy (NoteTy _ ty) = isTyVarTy ty isTyVarTy (SourceTy p) = isTyVarTy (sourceTypeRep p) -isTyVarTy ty@(UsageTy _ _) = pprPanic "isTyVarTy: UTy:" (pprType ty) isTyVarTy other = False \end{code} @@ -188,14 +191,19 @@ invariant: use it. \begin{code} mkAppTy orig_ty1 orig_ty2 = ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind * - UASSERT2( not (isUTy orig_ty2), pprType orig_ty1 <+> pprType orig_ty2 ) - -- argument must be unannotated mk_app orig_ty1 where mk_app (NoteTy _ ty1) = mk_app ty1 - mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2]) - mk_app ty@(UsageTy _ _) = pprPanic "mkAppTy: UTy:" (pprType ty) + mk_app (TyConApp tc tys) = mkGenTyConApp tc (tys ++ [orig_ty2]) mk_app ty1 = AppTy orig_ty1 orig_ty2 + -- We call mkGenTyConApp because the TyConApp could be an + -- under-saturated type synonym. GHC allows that; e.g. + -- type Foo k = k a -> k a + -- type Id x = x + -- foo :: Foo Id -> Foo Id + -- + -- Here Id is partially applied in the type sig for Foo, + -- but once the type synonyms are expanded all is well mkAppTys :: Type -> [Type] -> Type mkAppTys orig_ty1 [] = orig_ty1 @@ -206,17 +214,14 @@ mkAppTys orig_ty1 [] = orig_ty1 -- the Rational part. mkAppTys orig_ty1 orig_tys2 = ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind * - UASSERT2( not (any isUTy orig_tys2), pprType orig_ty1 <+> fsep (map pprType orig_tys2) ) - -- arguments must be unannotated mk_app orig_ty1 where mk_app (NoteTy _ ty1) = mk_app ty1 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2) - mk_app ty@(UsageTy _ _) = pprPanic "mkAppTys: UTy:" (pprType ty) mk_app ty1 = foldl AppTy orig_ty1 orig_tys2 splitAppTy_maybe :: Type -> Maybe (Type, Type) -splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [unUTy ty1], unUTy ty2) +splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty splitAppTy_maybe (SourceTy p) = splitAppTy_maybe (sourceTypeRep p) @@ -226,7 +231,6 @@ splitAppTy_maybe (TyConApp tc tys) = split tys [] split [ty2] acc = Just (TyConApp tc (reverse acc), ty2) split (ty:tys) acc = split tys (ty:acc) -splitAppTy_maybe ty@(UsageTy _ _) = pprPanic "splitAppTy_maybe: UTy:" (pprType ty) splitAppTy_maybe other = Nothing splitAppTy :: Type -> (Type, Type) @@ -241,9 +245,8 @@ splitAppTys ty = split ty ty [] split orig_ty (NoteTy _ ty) args = split orig_ty ty args split orig_ty (SourceTy p) args = split orig_ty (sourceTypeRep p) args split orig_ty (FunTy ty1 ty2) args = ASSERT( null args ) - (TyConApp funTyCon [], [unUTy ty1,unUTy ty2]) + (TyConApp funTyCon [], [ty1,ty2]) split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args) - split orig_ty (UsageTy _ _) args = pprPanic "splitAppTys: UTy:" (pprType orig_ty) split orig_ty ty args = (orig_ty, args) \end{code} @@ -254,24 +257,23 @@ splitAppTys ty = split ty ty [] \begin{code} mkFunTy :: Type -> Type -> Type -mkFunTy arg res = UASSERT2( isUTy arg && isUTy res, pprType arg <+> pprType res ) - FunTy arg res +mkFunTy arg res = FunTy arg res mkFunTys :: [Type] -> Type -> Type -mkFunTys tys ty = UASSERT2( all isUTy (ty:tys), fsep (map pprType (tys++[ty])) ) - foldr FunTy ty tys +mkFunTys tys ty = foldr FunTy ty tys + +isFunTy :: Type -> Bool +isFunTy ty = isJust (splitFunTy_maybe ty) splitFunTy :: Type -> (Type, Type) splitFunTy (FunTy arg res) = (arg, res) splitFunTy (NoteTy _ ty) = splitFunTy ty -splitFunTy (SourceTy p) = splitFunTy (sourceTypeRep p) -splitFunTy ty@(UsageTy _ _) = pprPanic "splitFunTy: UTy:" (pprType ty) +splitFunTy (SourceTy p) = splitFunTy (sourceTypeRep p) splitFunTy_maybe :: Type -> Maybe (Type, Type) splitFunTy_maybe (FunTy arg res) = Just (arg, res) splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty -splitFunTy_maybe (SourceTy p) = splitFunTy_maybe (sourceTypeRep p) -splitFunTy_maybe ty@(UsageTy _ _) = pprPanic "splitFunTy_maybe: UTy:" (pprType ty) +splitFunTy_maybe (SourceTy p) = splitFunTy_maybe (sourceTypeRep p) splitFunTy_maybe other = Nothing splitFunTys :: Type -> ([Type], Type) @@ -279,8 +281,7 @@ splitFunTys ty = split [] ty ty where split args orig_ty (FunTy arg res) = split (arg:args) res res split args orig_ty (NoteTy _ ty) = split args orig_ty ty - split args orig_ty (SourceTy p) = split args orig_ty (sourceTypeRep p) - split args orig_ty (UsageTy _ _) = pprPanic "splitFunTys: UTy:" (pprType orig_ty) + split args orig_ty (SourceTy p) = split args orig_ty (sourceTypeRep p) split args orig_ty ty = (reverse args, orig_ty) zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type) @@ -289,22 +290,19 @@ zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty split acc [] nty ty = (reverse acc, nty) split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res split acc xs nty (NoteTy _ ty) = split acc xs nty ty - split acc xs nty (SourceTy p) = split acc xs nty (sourceTypeRep p) - split acc xs nty (UsageTy _ _) = pprPanic "zipFunTys: UTy:" (ppr orig_xs <+> pprType orig_ty) + split acc xs nty (SourceTy p) = split acc xs nty (sourceTypeRep p) split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty) funResultTy :: Type -> Type funResultTy (FunTy arg res) = res funResultTy (NoteTy _ ty) = funResultTy ty -funResultTy (SourceTy p) = funResultTy (sourceTypeRep p) -funResultTy (UsageTy _ ty) = funResultTy ty +funResultTy (SourceTy p) = funResultTy (sourceTypeRep p) funResultTy ty = pprPanic "funResultTy" (pprType ty) funArgTy :: Type -> Type funArgTy (FunTy arg res) = arg funArgTy (NoteTy _ ty) = funArgTy ty -funArgTy (SourceTy p) = funArgTy (sourceTypeRep p) -funArgTy (UsageTy _ ty) = funArgTy ty +funArgTy (SourceTy p) = funArgTy (sourceTypeRep p) funArgTy ty = pprPanic "funArgTy" (pprType ty) \end{code} @@ -316,20 +314,24 @@ funArgTy ty = pprPanic "funArgTy" (pprType ty) as apppropriate. \begin{code} +mkGenTyConApp :: TyCon -> [Type] -> Type +mkGenTyConApp tc tys + | isSynTyCon tc = mkSynTy tc tys + | otherwise = mkTyConApp tc tys + mkTyConApp :: TyCon -> [Type] -> Type -- Assumes TyCon is not a SynTyCon; use mkSynTy instead for those mkTyConApp tycon tys | isFunTyCon tycon, [ty1,ty2] <- tys - = FunTy (mkUTyM ty1) (mkUTyM ty2) + = FunTy ty1 ty2 | isNewTyCon tycon, -- A saturated newtype application; not (isRecursiveTyCon tycon), -- Not recursive (we don't use SourceTypes for them) - length tys == tyConArity tycon -- use the SourceType form + tys `lengthIs` tyConArity tycon -- use the SourceType form = SourceTy (NType tycon tys) | otherwise = ASSERT(not (isSynTyCon tycon)) - UASSERT2( not (any isUTy tys), ppr tycon <+> fsep (map pprType tys) ) TyConApp tycon tys mkTyConTy :: TyCon -> Type @@ -353,10 +355,9 @@ splitTyConApp ty = case splitTyConApp_maybe ty of splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [unUTy arg,unUTy res]) +splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty splitTyConApp_maybe (SourceTy p) = splitTyConApp_maybe (sourceTypeRep p) -splitTyConApp_maybe (UsageTy _ ty) = splitTyConApp_maybe ty splitTyConApp_maybe other = Nothing \end{code} @@ -366,13 +367,29 @@ splitTyConApp_maybe other = Nothing ~~~~~ \begin{code} -mkSynTy syn_tycon tys - = ASSERT( isSynTyCon syn_tycon ) - ASSERT( length tyvars == length tys ) - NoteTy (SynNote (TyConApp syn_tycon tys)) - (substTyWith tyvars tys body) +mkSynTy tycon tys + | n_args == arity -- Exactly saturated + = mk_syn tys + | n_args > arity -- Over-saturated + = case splitAt arity tys of { (as,bs) -> mkAppTys (mk_syn as) bs } + -- Its important to use mkAppTys, rather than (foldl AppTy), + -- because (mk_syn as) might well return a partially-applied + -- type constructor; indeed, usually will! + | otherwise -- Un-saturated + = TyConApp tycon tys + -- For the un-saturated case we build TyConApp directly + -- (mkTyConApp ASSERTs that the tc isn't a SynTyCon). + -- Here we are relying on checkValidType to find + -- the error. What we can't do is use mkSynTy with + -- too few arg tys, because that is utterly bogus. + where - (tyvars, body) = getSynTyConDefn syn_tycon + mk_syn tys = NoteTy (SynNote (TyConApp tycon tys)) + (substTyWith tyvars tys body) + + (tyvars, body) = ASSERT( isSynTyCon tycon ) getSynTyConDefn tycon + arity = tyConArity tycon + n_args = length tys \end{code} Notes on type synonyms @@ -392,28 +409,27 @@ interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs. Representation types ~~~~~~~~~~~~~~~~~~~~ - repType looks through (a) for-alls, and (b) synonyms (c) predicates (d) usage annotations + (e) [recursive] newtypes It's useful in the back end. +Remember, non-recursive newtypes get expanded as part of the SourceTy case, +but recursive ones are represented by TyConApps and have to be expanded +by steam. + \begin{code} repType :: Type -> Type -repType (ForAllTy _ ty) = repType ty -repType (NoteTy _ ty) = repType ty -repType (SourceTy p) = repType (sourceTypeRep p) -repType (UsageTy _ ty) = repType ty -repType ty = ty - -splitRepFunTys :: Type -> ([Type], Type) --- Like splitFunTys, but looks through newtypes and for-alls -splitRepFunTys ty = split [] (repType ty) - where - split args (FunTy arg res) = split (arg:args) (repType res) - split args ty = (reverse args, ty) +repType (ForAllTy _ ty) = repType ty +repType (NoteTy _ ty) = repType ty +repType (SourceTy p) = repType (sourceTypeRep p) +repType (TyConApp tc tys) | isNewTyCon tc && tys `lengthIs` tyConArity tc + = repType (newTypeRep tc tys) +repType ty = ty + typePrimRep :: Type -> PrimRep typePrimRep ty = case repType ty of @@ -435,18 +451,11 @@ mkForAllTy tyvar ty = mkForAllTys [tyvar] ty mkForAllTys :: [TyVar] -> Type -> Type -mkForAllTys tyvars ty - = case splitUTy_maybe ty of - Just (u,ty1) -> UASSERT2( not (mkVarSet tyvars `intersectsVarSet` tyVarsOfType u), - ptext SLIT("mkForAllTys: usage scope") - <+> ppr tyvars <+> pprType ty ) - mkUTy u (foldr ForAllTy ty1 tyvars) -- we lift usage annotations over foralls - Nothing -> foldr ForAllTy ty tyvars +mkForAllTys tyvars ty = foldr ForAllTy ty tyvars isForAllTy :: Type -> Bool isForAllTy (NoteTy _ ty) = isForAllTy ty isForAllTy (ForAllTy _ _) = True -isForAllTy (UsageTy _ ty) = isForAllTy ty isForAllTy other_ty = False splitForAllTy_maybe :: Type -> Maybe (TyVar, Type) @@ -455,7 +464,6 @@ splitForAllTy_maybe ty = splitFAT_m ty splitFAT_m (NoteTy _ ty) = splitFAT_m ty splitFAT_m (SourceTy p) = splitFAT_m (sourceTypeRep p) splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty) - splitFAT_m (UsageTy _ ty) = splitFAT_m ty splitFAT_m _ = Nothing splitForAllTys :: Type -> ([TyVar], Type) @@ -464,8 +472,10 @@ splitForAllTys ty = split ty ty [] split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs) split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs split orig_ty (SourceTy p) tvs = split orig_ty (sourceTypeRep p) tvs - split orig_ty (UsageTy _ ty) tvs = split orig_ty ty tvs split orig_ty t tvs = (reverse tvs, orig_ty) + +dropForAlls :: Type -> Type +dropForAlls ty = snd (splitForAllTys ty) \end{code} -- (mkPiType now in CoreUtils) @@ -474,22 +484,14 @@ Applying a for-all to its arguments. Lift usage annotation as required. \begin{code} applyTy :: Type -> Type -> Type -applyTy (SourceTy p) arg = applyTy (sourceTypeRep p) arg -applyTy (NoteTy _ fun) arg = applyTy fun arg -applyTy (ForAllTy tv ty) arg = UASSERT2( not (isUTy arg), - ptext SLIT("applyTy") - <+> pprType ty <+> pprType arg ) - substTyWith [tv] [arg] ty -applyTy (UsageTy u ty) arg = UsageTy u (applyTy ty arg) -applyTy other arg = panic "applyTy" +applyTy (SourceTy p) arg = applyTy (sourceTypeRep p) arg +applyTy (NoteTy _ fun) arg = applyTy fun arg +applyTy (ForAllTy tv ty) arg = substTyWith [tv] [arg] ty +applyTy other arg = panic "applyTy" applyTys :: Type -> [Type] -> Type applyTys fun_ty arg_tys - = UASSERT2( not (any isUTy arg_tys), ptext SLIT("applyTys") <+> pprType fun_ty ) - (case mu of - Just u -> UsageTy u - Nothing -> id) $ - substTyWith tvs arg_tys ty + = substTyWith tvs arg_tys ty where (mu, tvs, ty) = split fun_ty arg_tys @@ -498,93 +500,10 @@ applyTys fun_ty arg_tys split (SourceTy p) args = split (sourceTypeRep p) args split (ForAllTy tv fun_ty) (arg:args) = case split fun_ty args of (mu, tvs, ty) -> (mu, tv:tvs, ty) - split (UsageTy u ty) args = case split ty args of - (Nothing, tvs, ty) -> (Just u, tvs, ty) - (Just _ , _ , _ ) -> pprPanic "applyTys:" - (pprType fun_ty) split other_ty args = panic "applyTys" \end{code} ---------------------------------------------------------------------- - UsageTy - ~~~~~~~ - -Constructing and taking apart usage types. - -\begin{code} -mkUTy :: Type -> Type -> Type -mkUTy u ty - = ASSERT2( typeKind u `eqKind` usageTypeKind, - ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty ) - UASSERT2( not (isUTy ty), ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty ) - -- if u == usMany then ty else : ToDo? KSW 2000-10 -#ifdef DO_USAGES - UsageTy u ty -#else - ty -#endif - -splitUTy :: Type -> (Type {- :: $ -}, Type) -splitUTy orig_ty - = case splitUTy_maybe orig_ty of - Just (u,ty) -> (u,ty) -#ifdef DO_USAGES - Nothing -> pprPanic "splitUTy:" (pprType orig_ty) -#else - Nothing -> (usMany,orig_ty) -- default annotation ToDo KSW 2000-10 -#endif - -splitUTy_maybe :: Type -> Maybe (Type {- :: $ -}, Type) -splitUTy_maybe (UsageTy u ty) = Just (u,ty) -splitUTy_maybe (NoteTy _ ty) = splitUTy_maybe ty -splitUTy_maybe other_ty = Nothing - -isUTy :: Type -> Bool - -- has usage annotation -isUTy = maybeToBool . splitUTy_maybe - -uaUTy :: Type -> Type - -- extract annotation -uaUTy = fst . splitUTy - -unUTy :: Type -> Type - -- extract unannotated type -unUTy = snd . splitUTy -\end{code} - -\begin{code} -liftUTy :: (Type -> Type) -> Type -> Type - -- lift outer usage annot over operation on unannotated types -liftUTy f ty - = let - (u,ty') = splitUTy ty - in - mkUTy u (f ty') -\end{code} - -\begin{code} -mkUTyM :: Type -> Type - -- put TOP (no info) annotation on unannotated type -mkUTyM ty = mkUTy usMany ty -\end{code} - -\begin{code} -isUsageKind :: Kind -> Bool -isUsageKind k - = ASSERT( typeKind k `eqKind` superKind ) - k `eqKind` usageTypeKind - -isUsage :: Type -> Bool -isUsage ty - = isUsageKind (typeKind ty) - -isUTyVar :: Var -> Bool -isUTyVar v - = isUsageKind (tyVarKind v) -\end{code} - - %************************************************************************ %* * \subsection{Source types} @@ -599,10 +518,16 @@ Source types are always lifted. The key function is sourceTypeRep which gives the representation of a source type: \begin{code} +mkPredTy :: PredType -> Type +mkPredTy pred = SourceTy pred + +mkPredTys :: ThetaType -> [Type] +mkPredTys preds = map SourceTy preds + sourceTypeRep :: SourceType -> Type -- Convert a predicate to its "representation type"; -- the type of evidence for that predicate, which is actually passed at runtime -sourceTypeRep (IParam n ty) = ty +sourceTypeRep (IParam _ ty) = ty sourceTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys -- Note the mkTyConApp; the classTyCon might be a newtype! sourceTypeRep (NType tc tys) = newTypeRep tc tys @@ -610,7 +535,6 @@ sourceTypeRep (NType tc tys) = newTypeRep tc tys isSourceTy :: Type -> Bool isSourceTy (NoteTy _ ty) = isSourceTy ty -isSourceTy (UsageTy _ ty) = isSourceTy ty isSourceTy (SourceTy sty) = True isSourceTy _ = False @@ -622,7 +546,7 @@ splitNewType_maybe :: Type -> Maybe Type splitNewType_maybe ty = case splitTyConApp_maybe ty of - Just (tc,tys) | isNewTyCon tc -> ASSERT( length tys == tyConArity tc ) + Just (tc,tys) | isNewTyCon tc -> ASSERT( tys `lengthIs` tyConArity tc ) -- The assert should hold because repType should -- only be applied to *types* (of kind *) Just (newTypeRep tc tys) @@ -667,7 +591,6 @@ typeKind (FunTy arg res) = fix_up (typeKind res) -- a strange kind like (*->*). typeKind (ForAllTy tv ty) = typeKind ty -typeKind (UsageTy _ ty) = typeKind ty -- we don't have separate kinds for ann/unann \end{code} @@ -675,7 +598,6 @@ typeKind (UsageTy _ ty) = typeKind ty -- we don't have separate kinds f Free variables of a type ~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} - tyVarsOfType :: Type -> TyVarSet tyVarsOfType (TyVarTy tv) = unitVarSet tv tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys @@ -685,7 +607,6 @@ tyVarsOfType (SourceTy sty) = tyVarsOfSourceType sty tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar -tyVarsOfType (UsageTy u ty) = tyVarsOfType u `unionVarSet` tyVarsOfType ty tyVarsOfTypes :: [Type] -> TyVarSet tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys @@ -694,9 +615,9 @@ tyVarsOfPred :: PredType -> TyVarSet tyVarsOfPred = tyVarsOfSourceType -- Just a subtype tyVarsOfSourceType :: SourceType -> TyVarSet -tyVarsOfSourceType (IParam n ty) = tyVarsOfType ty -tyVarsOfSourceType (ClassP clas tys) = tyVarsOfTypes tys -tyVarsOfSourceType (NType tc tys) = tyVarsOfTypes tys +tyVarsOfSourceType (IParam _ ty) = tyVarsOfType ty +tyVarsOfSourceType (ClassP _ tys) = tyVarsOfTypes tys +tyVarsOfSourceType (NType _ tys) = tyVarsOfTypes tys tyVarsOfTheta :: ThetaType -> TyVarSet tyVarsOfTheta = foldr (unionVarSet . tyVarsOfSourceType) emptyVarSet @@ -707,28 +628,6 @@ addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty \end{code} -Usage annotations of a type -~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Get a list of usage annotations of a type, *in left-to-right pre-order*. - -\begin{code} -usageAnnOfType :: Type -> [Type] -usageAnnOfType ty - = goS ty - where - goT (TyVarTy _) = [] - goT (AppTy ty1 ty2) = goT ty1 ++ goT ty2 - goT (TyConApp tc tys) = concatMap goT tys - goT (FunTy sty1 sty2) = goS sty1 ++ goS sty2 - goT (ForAllTy mv ty) = goT ty - goT (SourceTy p) = goT (sourceTypeRep p) - goT ty@(UsageTy _ _) = pprPanic "usageAnnOfType: unexpected usage:" (pprType ty) - goT (NoteTy note ty) = goT ty - - goS sty = case splitUTy sty of - (u,tty) -> u : goT tty -\end{code} %************************************************************************ @@ -743,36 +642,34 @@ an interface file. It doesn't change the uniques at all, just the print names. \begin{code} -tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar) -tidyTyVar env@(tidy_env, subst) tyvar - = case lookupVarEnv subst tyvar of - - Just tyvar' -> -- Already substituted - (env, tyvar') - - Nothing -> -- Make a new nice name for it - - case tidyOccName tidy_env (getOccName name) of - (tidy', occ') -> -- New occname reqd - ((tidy', subst'), tyvar') - where - subst' = extendVarEnv subst tyvar tyvar' - tyvar' = setTyVarName tyvar name' - name' = mkLocalName (getUnique name) occ' noSrcLoc - -- Note: make a *user* tyvar, so it printes nicely - -- Could extract src loc, but no need. +tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar) +tidyTyVarBndr (tidy_env, subst) tyvar + = case tidyOccName tidy_env (getOccName name) of + (tidy', occ') -> -- New occname reqd + ((tidy', subst'), tyvar') + where + subst' = extendVarEnv subst tyvar tyvar' + tyvar' = setTyVarName tyvar name' + name' = mkInternalName (getUnique name) occ' noSrcLoc + -- Note: make a *user* tyvar, so it printes nicely + -- Could extract src loc, but no need. where name = tyVarName tyvar -tidyTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar]) -tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars - tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv -- Add the free tyvars to the env in tidy form, -- so that we can tidy the type they are free in -tidyFreeTyVars env tyvars = foldl add env (varSetElems tyvars) - where - add env tv = fst (tidyTyVar env tv) +tidyFreeTyVars env tyvars = fst (tidyOpenTyVars env (varSetElems tyvars)) + +tidyOpenTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar]) +tidyOpenTyVars env tyvars = mapAccumL tidyOpenTyVar env tyvars + +tidyOpenTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar) +-- Treat a new tyvar as a binder, and give it a fresh tidy name +tidyOpenTyVar env@(tidy_env, subst) tyvar + = case lookupVarEnv subst tyvar of + Just tyvar' -> (env, tyvar') -- Already substituted + Nothing -> tidyTyVarBndr env tyvar -- Treat it as a binder tidyType :: TidyEnv -> Type -> Type tidyType env@(tidy_env, subst) ty @@ -783,16 +680,15 @@ tidyType env@(tidy_env, subst) ty Just tv' -> TyVarTy tv' go (TyConApp tycon tys) = let args = map go tys in args `seqList` TyConApp tycon args - go (NoteTy note ty) = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty) + go (NoteTy note ty) = (NoteTy $! (go_note note)) $! (go ty) go (SourceTy sty) = SourceTy (tidySourceType env sty) - go (AppTy fun arg) = (AppTy SAPPLY (go fun)) SAPPLY (go arg) - go (FunTy fun arg) = (FunTy SAPPLY (go fun)) SAPPLY (go arg) - go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty) + go (AppTy fun arg) = (AppTy $! (go fun)) $! (go arg) + go (FunTy fun arg) = (FunTy $! (go fun)) $! (go arg) + go (ForAllTy tv ty) = ForAllTy tvp $! (tidyType envp ty) where - (envp, tvp) = tidyTyVar env tv - go (UsageTy u ty) = (UsageTy SAPPLY (go u)) SAPPLY (go ty) + (envp, tvp) = tidyTyVarBndr env tv - go_note (SynNote ty) = SynNote SAPPLY (go ty) + go_note (SynNote ty) = SynNote $! (go ty) go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars tidyTypes env tys = map (tidyType env) tys @@ -843,7 +739,6 @@ isUnLiftedType :: Type -> Bool isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc -isUnLiftedType (UsageTy _ ty) = isUnLiftedType ty isUnLiftedType (SourceTy _) = False -- All source types are lifted isUnLiftedType other = False @@ -855,11 +750,41 @@ isUnboxedTupleType ty = case splitTyConApp_maybe ty of -- Should only be applied to *types*; hence the assert isAlgType :: Type -> Bool isAlgType ty = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc ) + Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) isAlgTyCon tc other -> False \end{code} +@isStrictType@ computes whether an argument (or let RHS) should +be computed strictly or lazily, based only on its type. +Works just like isUnLiftedType, except that it has a special case +for dictionaries. Since it takes account of ClassP, you might think +this function should be in TcType, but isStrictType is used by DataCon, +which is below TcType in the hierarchy, so it's convenient to put it here. + +\begin{code} +isStrictType (ForAllTy tv ty) = isStrictType ty +isStrictType (NoteTy _ ty) = isStrictType ty +isStrictType (TyConApp tc _) = isUnLiftedTyCon tc +isStrictType (SourceTy (ClassP clas _)) = opt_DictsStrict && not (isNewTyCon (classTyCon clas)) + -- We may be strict in dictionary types, but only if it + -- has more than one component. + -- [Being strict in a single-component dictionary risks + -- poking the dictionary component, which is wrong.] +isStrictType other = False +\end{code} + +\begin{code} +isPrimitiveType :: Type -> Bool +-- Returns types that are opaque to Haskell. +-- Most of these are unlifted, but now that we interact with .NET, we +-- may have primtive (foreign-imported) types that are lifted +isPrimitiveType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) + isPrimTyCon tc + other -> False +\end{code} + %************************************************************************ %* * @@ -876,7 +801,6 @@ seqType (NoteTy note t2) = seqNote note `seq` seqType t2 seqType (SourceTy p) = seqPred p seqType (TyConApp tc tys) = tc `seq` seqTypes tys seqType (ForAllTy tv ty) = tv `seq` seqType ty -seqType (UsageTy u ty) = seqType u `seq` seqType ty seqTypes :: [Type] -> () seqTypes [] = () @@ -902,6 +826,16 @@ seqPred (IParam n ty) = n `seq` seqType ty Comparison; don't use instances so that we know where it happens. Look through newtypes but not usage types. +Note that eqType can respond 'False' for partial applications of newtypes. +Consider + newtype Parser m a = MkParser (Foogle m a) + +Does + Monad (Parser m) `eqType` Monad (Foogle m) + +Well, yes, but eqType won't see that they are the same. +I don't think this is harmful, but it's soemthing to watch out for. + \begin{code} eqType t1 t2 = eq_ty emptyVarEnv t1 t2 eqKind = eqType -- No worries about looking @@ -920,11 +854,10 @@ eq_ty env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of Just tv1a -> tv1a == tv2 Nothing -> tv1 == tv2 eq_ty env (ForAllTy tv1 t1) (ForAllTy tv2 t2) - | tv1 == tv2 = eq_ty env t1 t2 + | tv1 == tv2 = eq_ty (delVarEnv env tv1) t1 t2 | otherwise = eq_ty (extendVarEnv env tv1 tv2) t1 t2 eq_ty env (AppTy s1 t1) (AppTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2) eq_ty env (FunTy s1 t1) (FunTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2) -eq_ty env (UsageTy _ t1) (UsageTy _ t2) = eq_ty env t1 t2 eq_ty env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 == tc2) && (eq_tys env tys1 tys2) eq_ty env t1 t2 = False