-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
- where
- (mu, tvs, ty) = split fun_ty arg_tys
-
- split fun_ty [] = (Nothing, [], fun_ty)
- split (NoteTy _ fun_ty) args = split fun_ty args
- 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)
+-- This function is interesting because
+-- a) the function may have more for-alls than there are args
+-- b) less obviously, it may have fewer for-alls
+-- For case (b) think of
+-- applyTys (forall a.a) [forall b.b, Int]
+-- This really can happen, via dressing up polymorphic types with newtype
+-- clothing. Here's an example:
+-- newtype R = R (forall a. a->a)
+-- foo = case undefined :: R of
+-- R f -> f ()
+
+applyTys orig_fun_ty [] = orig_fun_ty
+applyTys orig_fun_ty arg_tys
+ | n_tvs == n_args -- The vastly common case
+ = substTyWith tvs arg_tys rho_ty
+ | n_tvs > n_args -- Too many for-alls
+ = substTyWith (take n_args tvs) arg_tys
+ (mkForAllTys (drop n_args tvs) rho_ty)
+ | otherwise -- Too many type args
+ = ASSERT2( n_tvs > 0, ppr orig_fun_ty ) -- Zero case gives infnite loop!
+ applyTys (substTyWith tvs (take n_tvs arg_tys) rho_ty)
+ (drop n_tvs arg_tys)
+ where
+ (tvs, rho_ty) = splitForAllTys orig_fun_ty
+ n_tvs = length tvs
+ n_args = length arg_tys