-- A worry: what if an Id's unfolding is just itself:
-- then we could get an infinite loop...
-exprIsHNF (Lit l) = True
-exprIsHNF (Type ty) = True -- Types are honorary Values;
- -- we don't mind copying them
-exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e
-exprIsHNF (Note _ e) = exprIsHNF e
-exprIsHNF (Cast e co) = exprIsHNF e
+exprIsHNF (Lit l) = True
+exprIsHNF (Type ty) = True -- Types are honorary Values;
+ -- we don't mind copying them
+exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e
+exprIsHNF (Note _ e) = exprIsHNF e
+exprIsHNF (Cast e co) = exprIsHNF e
exprIsHNF (App e (Type _)) = exprIsHNF e
exprIsHNF (App e a) = app_is_value e [a]
-exprIsHNF other = False
+exprIsHNF other = False
-- There is at least one value argument
app_is_value (Var fun) args
-- The left-hand one must be a T, because exprIsConApp returned True
-- but the right-hand one might not be. (Though it usually will.)
- let (from_ty, to_ty) = coercionKind co
- (from_tc, _from_tc_arg_tys) = splitTyConApp from_ty
+ let (from_ty, to_ty) = coercionKind co
+ (from_tc, from_tc_arg_tys) = splitTyConApp from_ty
-- The inner one must be a TyConApp
in
- ASSERT( from_tc == dataConTyCon dc )
-
case splitTyConApp_maybe to_ty of {
Nothing -> Nothing ;
- Just (to_tc, _to_tc_arg_tys) | from_tc /= to_tc -> Nothing
- | otherwise ->
+ Just (to_tc, to_tc_arg_tys)
+ | from_tc /= to_tc -> Nothing
+ -- These two Nothing cases are possible; we might see
+ -- (C x y) `cast` (g :: T a ~ S [a]),
+ -- where S is a type function. In fact, exprIsConApp
+ -- will probably not be called in such circumstances,
+ -- but there't nothing wrong with it
+
+ | otherwise ->
let
tc_arity = tyConArity from_tc
in
ASSERT( length univ_args == tc_arity )
+ ASSERT( from_tc == dataConTyCon dc )
+ ASSERT( and (zipWith coreEqType [t | Type t <- univ_args] from_tc_arg_tys) )
ASSERT( all isTypeArg (univ_args ++ ex_args) )
ASSERT2( equalLength val_args arg_tys, ppr dc $$ ppr dc_tyvars $$ ppr dc_ex_tyvars $$ ppr arg_tys $$ ppr dc_args $$ ppr univ_args $$ ppr ex_args $$ ppr val_args $$ ppr arg_tys )
- Just (dc, univ_args ++ ex_args ++ new_co_args ++ new_val_args)
+ Just (dc, map Type to_tc_arg_tys ++ ex_args ++ new_co_args ++ new_val_args)
}}
exprIsConApp_maybe (Note _ expr)
exprIsBig (Var v) = False
exprIsBig (Type t) = False
exprIsBig (App f a) = exprIsBig f || exprIsBig a
+exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big!
exprIsBig other = True
\end{code}