tyConAppTyCon, tyConAppArgs,
splitTyConApp_maybe, splitTyConApp,
- mkUTy, splitUTy, splitUTy_maybe,
- isUTy, uaUTy, unUTy, liftUTy, mkUTyM,
- isUsageKind, isUsage, isUTyVar,
-
mkSynTy,
repType, splitRepFunTys, typePrimRep,
-- Free variables
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
- usageAnnOfType, typeKind, addFreeTyVars,
+ typeKind, addFreeTyVars,
-- Tidying up for printing
tidyType, tidyTypes,
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}
\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 ty1 = AppTy orig_ty1 orig_ty2
mkAppTys :: Type -> [Type] -> Type
-- 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)
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)
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}
\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
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)
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)
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}
-- 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)
| otherwise
= ASSERT(not (isSynTyCon tycon))
- UASSERT2( not (any isUTy tys), ppr tycon <+> fsep (map pprType tys) )
TyConApp tycon tys
mkTyConTy :: TyCon -> Type
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}
repType (ForAllTy _ ty) = repType ty
repType (NoteTy _ ty) = repType ty
repType (SourceTy p) = repType (sourceTypeRep p)
-repType (UsageTy _ ty) = repType ty
repType (TyConApp tc tys) | isNewTyCon tc && tys `lengthIs` tyConArity tc
= repType (newTypeRep tc tys)
repType ty = 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)
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)
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)
\end{code}
\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
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}
isSourceTy :: Type -> Bool
isSourceTy (NoteTy _ ty) = isSourceTy ty
-isSourceTy (UsageTy _ ty) = isSourceTy ty
isSourceTy (SourceTy sty) = True
isSourceTy _ = False
-- 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}
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
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}
%************************************************************************
go (ForAllTy tv ty) = ForAllTy tvp $! (tidyType envp ty)
where
(envp, tvp) = tidyTyVarBndr env tv
- go (UsageTy u ty) = (UsageTy $! (go u)) $! (go ty)
go_note (SynNote ty) = SynNote $! (go ty)
go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
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
isStrictType (ForAllTy tv ty) = isStrictType ty
isStrictType (NoteTy _ ty) = isStrictType ty
isStrictType (TyConApp tc _) = isUnLiftedTyCon tc
-isStrictType (UsageTy _ ty) = isStrictType ty
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.
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 [] = ()
| 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
projects / ghc-hetmet.git / blobdiff