hashExpr,
-- Equality
- cheapEqExpr, eqExpr, applyTypeToArgs
+ cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg
) where
#include "HsVersions.h"
import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy,
applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
splitForAllTy_maybe, isForAllTy, splitNewType_maybe,
- splitTyConApp_maybe, eqType, funResultTy, applyTy
+ splitTyConApp_maybe, eqType, funResultTy, applyTy,
+ funResultTy, applyTy
)
import TyCon ( tyConArity )
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
\end{code}
\begin{code}
--- The first argument is just for debugging
+applyTypeToArg :: Type -> CoreExpr -> Type
+applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
+applyTypeToArg fun_ty other_arg = funResultTy fun_ty
+
applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
+-- A more efficient version of applyTypeToArg
+-- when we have several args
+-- The first argument is just for debugging
applyTypeToArgs e op_ty [] = op_ty
applyTypeToArgs e op_ty (Type ty : args)
= -- Accumulate type arguments so we can instantiate all at once
- applyTypeToArgs e (applyTys op_ty tys) rest_args
+ go [ty] args
where
- (tys, rest_args) = go [ty] args
- go tys (Type ty : args) = go (ty:tys) args
- go tys rest_args = (reverse tys, rest_args)
+ go rev_tys (Type ty : args) = go (ty:rev_tys) args
+ go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
+ where
+ op_ty' = applyTys op_ty (reverse rev_tys)
applyTypeToArgs e op_ty (other_arg : args)
= case (splitFunTy_maybe op_ty) of
exprIsConApp_maybe, mkPiType, findAlt,
exprType, coreAltsType, exprIsValue,
exprOkForSpeculation, exprArity, findDefault,
- mkCoerce, mkSCC, mkInlineMe, mkAltExpr
+ mkCoerce, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg
)
import Rules ( lookupRule )
import BasicTypes ( isMarkedStrict )
-- ==>
-- let a = ...arg...
-- in [...hole...] a
- mkDupableCont env (funResultTy ty) cont `thenSmpl` \ (floats, cont') ->
+ simplExpr (setInScope se env) arg `thenSmpl` \ arg' ->
+
+ mkDupableCont env (applyTypeToArg ty arg') cont `thenSmpl` \ (floats, cont') ->
+ -- It's possible (albeit unusual) that arg is a type
+ -- argument, if the alternatives have a for-all type;
+ -- hence the applyTypeToArg
addFloats env floats $ \ env ->
- simplExpr (setInScope se env) arg `thenSmpl` \ arg' ->
if exprIsDupable arg' then
returnSmpl (emptyFloats env, ApplyTo OkToDup arg' (zapSubstEnv se) cont')
else