import Match ( matchSimply )
import DsUtils ( mkErrorAppDs,
- mkCoreTupTy, mkCoreTup, selectMatchVarL,
+ mkCoreTupTy, mkCoreTup, selectSimpleMatchVarL,
mkTupleCase, mkBigCoreTup, mkTupleType,
mkTupleExpr, mkTupleSelector,
dsReboundNames, lookupReboundName )
import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLet )
-import TcType ( Type, tcSplitAppTy )
-import Type ( mkTyConApp )
+import TcType ( Type, tcSplitAppTy, mkFunTy )
+import Type ( mkTyConApp, funArgTy )
import CoreSyn
import CoreFVs ( exprFreeVars )
import CoreUtils ( mkIfThenElse, bindNonRec, exprType )
import Util ( mapAccumL )
import Outputable
-import HsPat ( collectPatBinders, collectPatsBinders )
+import HsUtils ( collectPatBinders, collectPatsBinders )
import VarSet ( IdSet, mkVarSet, varSetElems,
intersectVarSet, minusVarSet, extendVarSetList,
unionVarSet, unionVarSets, elemVarSet )
coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
coreCasePair scrut_var var1 var2 body
- = Case (Var scrut_var) scrut_var
+-- gaw 2004
+ = Case (Var scrut_var) scrut_var (exprType body)
[(DataAlt (tupleCon Boxed 2), [var1, var2], body)]
\end{code}
env_ty = mkTupleType env_ids
in
mkFailExpr ProcExpr env_ty `thenDs` \ fail_expr ->
- selectMatchVarL pat `thenDs` \ var ->
+ selectSimpleMatchVarL pat `thenDs` \ var ->
matchSimply (Var var) ProcExpr pat (mkTupleExpr env_ids) fail_expr
`thenDs` \ match_code ->
let
-> DsM (CoreExpr, -- desugared expression
IdSet) -- set of local vars that occur free
--- A |- f :: a t t'
+-- A |- f :: a (t*ts) t'
-- A, xs |- arg :: t
--- ---------------------------
--- A | xs |- f -< arg :: [] t' ---> arr (\ (xs) -> arg) >>> f
+-- -----------------------------
+-- A | xs |- f -< arg :: [ts] t'
+--
+-- ---> arr (\ ((xs)*ts) -> (arg*ts)) >>> f
-dsCmd ids local_vars env_ids [] res_ty
+dsCmd ids local_vars env_ids stack res_ty
(HsArrApp arrow arg arrow_ty HsFirstOrderApp _)
= let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
in
dsLExpr arrow `thenDs` \ core_arrow ->
dsLExpr arg `thenDs` \ core_arg ->
- matchEnvStack env_ids [] core_arg `thenDs` \ core_make_arg ->
- returnDs (do_map_arrow ids env_ty arg_ty res_ty
+ mappM newSysLocalDs stack `thenDs` \ stack_ids ->
+ matchEnvStack env_ids stack_ids
+ (foldl mkCorePairExpr core_arg (map Var stack_ids))
+ `thenDs` \ core_make_arg ->
+ returnDs (do_map_arrow ids
+ (envStackType env_ids stack)
+ arg_ty
+ res_ty
core_make_arg
core_arrow,
exprFreeVars core_arg `intersectVarSet` local_vars)
--- A, xs |- f :: a t t'
+-- A, xs |- f :: a (t*ts) t'
-- A, xs |- arg :: t
--- ---------------------------
--- A | xs |- f -<< arg :: [] t' ---> arr (\ (xs) -> (f,arg)) >>> app
+-- ------------------------------
+-- A | xs |- f -<< arg :: [ts] t'
+--
+-- ---> arr (\ ((xs)*ts) -> (f,(arg*ts))) >>> app
-dsCmd ids local_vars env_ids [] res_ty
+dsCmd ids local_vars env_ids stack res_ty
(HsArrApp arrow arg arrow_ty HsHigherOrderApp _)
= let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
in
dsLExpr arrow `thenDs` \ core_arrow ->
dsLExpr arg `thenDs` \ core_arg ->
- matchEnvStack env_ids [] (mkCorePairExpr core_arrow core_arg)
+ mappM newSysLocalDs stack `thenDs` \ stack_ids ->
+ matchEnvStack env_ids stack_ids
+ (mkCorePairExpr core_arrow
+ (foldl mkCorePairExpr core_arg (map Var stack_ids)))
`thenDs` \ core_make_pair ->
- returnDs (do_map_arrow ids env_ty (mkCorePairTy arrow_ty arg_ty) res_ty
+ returnDs (do_map_arrow ids
+ (envStackType env_ids stack)
+ (mkCorePairTy arrow_ty arg_ty)
+ res_ty
core_make_pair
(do_app ids arg_ty res_ty),
(exprFreeVars core_arrow `unionVarSet` exprFreeVars core_arg)
-- ---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c
dsCmd ids local_vars env_ids stack res_ty
- (HsLam (L _ (Match pats _ (GRHSs [L _ (GRHS [L _ (ResultStmt body)])] _ _cmd_ty))))
+ (HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [L _ (ResultStmt body)])] _ ))] _))
= let
pat_vars = mkVarSet (collectPatsBinders pats)
local_vars' = local_vars `unionVarSet` pat_vars
bodies with |||.
\begin{code}
-dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches)
+dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ty))
= dsLExpr exp `thenDs` \ core_exp ->
mappM newSysLocalDs stack `thenDs` \ stack_ids ->
(_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
in_ty = envStackType env_ids stack
fvs_exp = exprFreeVars core_exp `intersectVarSet` local_vars
+
+ pat_ty = funArgTy match_ty
+ match_ty' = mkFunTy pat_ty sum_ty
+ -- Note that we replace the HsCase result type by sum_ty,
+ -- which is the type of matches'
in
- dsExpr (HsCase exp matches') `thenDs` \ core_body ->
+ dsExpr (HsCase exp (MatchGroup matches' match_ty')) `thenDs` \ core_body ->
matchEnvStack env_ids stack_ids core_body
`thenDs` \ core_matches ->
returnDs(do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices,
-- projection function
-- \ (p, (xs2)) -> (zs)
- selectMatchVarL pat `thenDs` \ pat_id ->
newSysLocalDs env_ty2 `thenDs` \ env_id ->
newUniqueSupply `thenDs` \ uniqs ->
let
body_expr = coreCaseTuple uniqs env_id env_ids2 (mkTupleExpr out_ids)
in
mkFailExpr (StmtCtxt DoExpr) out_ty `thenDs` \ fail_expr ->
+ selectSimpleMatchVarL pat `thenDs` \ pat_id ->
matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr
`thenDs` \ match_code ->
newSysLocalDs after_c_ty `thenDs` \ pair_id ->
\begin{code}
leavesMatch :: LMatch Id -> [(LHsExpr Id, IdSet)]
-leavesMatch (L _ (Match pats _ (GRHSs grhss binds _ty)))
+leavesMatch (L _ (Match pats _ (GRHSs grhss binds)))
= let
defined_vars = mkVarSet (collectPatsBinders pats)
`unionVarSet`
-> LMatch Id -- the matches of a case command
-> ([LHsExpr Id],-- remaining leaf expressions
LMatch Id) -- updated match
-replaceLeavesMatch res_ty leaves (L loc (Match pat mt (GRHSs grhss binds _ty)))
+replaceLeavesMatch res_ty leaves (L loc (Match pat mt (GRHSs grhss binds)))
= let
(leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
in
- (leaves', L loc (Match pat mt (GRHSs grhss' binds res_ty)))
+ (leaves', L loc (Match pat mt (GRHSs grhss' binds)))
replaceLeavesGRHS
:: [LHsExpr Id] -- replacement leaf expressions of that type
projects / ghc-hetmet.git / blobdiff