import Match ( matchSimply )
import DsUtils ( mkErrorAppDs,
- mkCoreTupTy, mkCoreTup, selectMatchVarL,
+ mkCoreTupTy, mkCoreTup, selectSimpleMatchVarL,
mkTupleCase, mkBigCoreTup, mkTupleType,
mkTupleExpr, mkTupleSelector,
- dsReboundNames, lookupReboundName )
+ dsSyntaxTable, lookupEvidence )
import DsMonad
import HsSyn
-- So WATCH OUT; check each use of split*Ty functions.
-- Sigh. This is a pain.
-import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLet )
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds )
-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,
+ intersectVarSet, minusVarSet, extendVarSetList,
unionVarSet, unionVarSets, elemVarSet )
-import SrcLoc ( Located(..), unLoc, noLoc, getLoc )
+import SrcLoc ( Located(..), unLoc, noLoc )
\end{code}
\begin{code}
arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
}
-mkCmdEnv :: ReboundNames Id -> DsM DsCmdEnv
+mkCmdEnv :: SyntaxTable Id -> DsM DsCmdEnv
mkCmdEnv ids
- = dsReboundNames ids `thenDs` \ (meth_binds, ds_meths) ->
+ = dsSyntaxTable ids `thenDs` \ (meth_binds, ds_meths) ->
return $ DsCmdEnv {
meth_binds = meth_binds,
- arr_id = lookupReboundName ds_meths arrAName,
- compose_id = lookupReboundName ds_meths composeAName,
- first_id = lookupReboundName ds_meths firstAName,
- app_id = lookupReboundName ds_meths appAName,
- choice_id = lookupReboundName ds_meths choiceAName,
- loop_id = lookupReboundName ds_meths loopAName
+ arr_id = Var (lookupEvidence ds_meths arrAName),
+ compose_id = Var (lookupEvidence ds_meths composeAName),
+ first_id = Var (lookupEvidence ds_meths firstAName),
+ app_id = Var (lookupEvidence ds_meths appAName),
+ choice_id = Var (lookupEvidence ds_meths choiceAName),
+ loop_id = Var (lookupEvidence ds_meths loopAName)
}
bindCmdEnv :: DsCmdEnv -> CoreExpr -> CoreExpr
coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
coreCasePair scrut_var var1 var2 body
- = Case (Var scrut_var) scrut_var
+ = 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 [] 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,
dsCmd ids local_vars env_ids stack res_ty (HsLet binds body)
= let
- defined_vars = mkVarSet (map unLoc (collectGroupBinders binds))
+ defined_vars = mkVarSet (map unLoc (collectLocalBinders binds))
local_vars' = local_vars `unionVarSet` defined_vars
in
dsfixCmd ids local_vars' stack res_ty body
`thenDs` \ (core_body, free_vars, env_ids') ->
mappM newSysLocalDs stack `thenDs` \ stack_ids ->
-- build a new environment, plus the stack, using the let bindings
- dsLet binds (buildEnvStack env_ids' stack_ids)
+ dsLocalBinds binds (buildEnvStack env_ids' stack_ids)
`thenDs` \ core_binds ->
-- match the old environment and stack against the input
matchEnvStack env_ids stack_ids core_binds
core_body,
exprFreeVars core_binds `intersectVarSet` local_vars)
-dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _ _)
- = dsCmdDo ids local_vars env_ids res_ty stmts
+dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts body _)
+ = dsCmdDo ids local_vars env_ids res_ty stmts body
-- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t
-- A | xs |- ci :: [tsi] ti
-- This is typically fed back,
-- so don't pull on it too early
-> Type -- return type of the statement
- -> [LStmt Id] -- statements to desugar
+ -> [LStmt Id] -- statements to desugar
+ -> LHsExpr Id -- body
-> DsM (CoreExpr, -- desugared expression
IdSet) -- set of local vars that occur free
-- --------------------------
-- A | xs |- do { c } :: [] t
-dsCmdDo ids local_vars env_ids res_ty [L _ (ResultStmt cmd)]
- = dsLCmd ids local_vars env_ids [] res_ty cmd
+dsCmdDo ids local_vars env_ids res_ty [] body
+ = dsLCmd ids local_vars env_ids [] res_ty body
-dsCmdDo ids local_vars env_ids res_ty (stmt:stmts)
+dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body
= let
bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
local_vars' = local_vars `unionVarSet` bound_vars
in
fixDs (\ ~(_,_,env_ids') ->
- dsCmdDo ids local_vars' env_ids' res_ty stmts
+ dsCmdDo ids local_vars' env_ids' res_ty stmts body
`thenDs` \ (core_stmts, fv_stmts) ->
returnDs (core_stmts, fv_stmts, varSetElems fv_stmts))
`thenDs` \ (core_stmts, fv_stmts, env_ids') ->
-- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>>
-- arr snd >>> ss
-dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd c_ty)
+dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ c_ty)
= dsfixCmd ids local_vars [] c_ty cmd
`thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
matchEnvStack env_ids []
do_compose ids before_c_ty after_c_ty out_ty
(do_first ids in_ty1 c_ty out_ty core_cmd) $
do_arr ids after_c_ty out_ty snd_fn,
- fv_cmd `unionVarSet` mkVarSet out_ids)
+ extendVarSetList fv_cmd out_ids)
where
-- A | xs1 |- c :: [] t
-- It would be simpler and more consistent to do this using second,
-- but that's likely to be defined in terms of first.
-dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd)
+dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _)
= dsfixCmd ids local_vars [] (hsPatType pat) cmd
`thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
let
-- 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 ->
dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds)
-- build a new environment using the let bindings
- = dsLet binds (mkTupleExpr out_ids) `thenDs` \ core_binds ->
+ = dsLocalBinds binds (mkTupleExpr out_ids) `thenDs` \ core_binds ->
-- match the old environment against the input
matchEnvStack env_ids [] core_binds `thenDs` \ core_map ->
returnDs (do_arr ids
-- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
-- arr (\((xs1),(xs2)) -> (xs')) >>> ss'
-dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss)
- = let
+dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss binds)
+ = let -- ToDo: ****** binds not desugared; ROSS PLEASE FIX ********
env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids
env2_ids = varSetElems env2_id_set
env2_ty = mkTupleType env2_ids
-- mk_pair_fn = \ (out_ids) -> ((later_ids),(rhss))
- mappM dsLExpr rhss `thenDs` \ core_rhss ->
+ mappM dsExpr rhss `thenDs` \ core_rhss ->
let
later_tuple = mkTupleExpr later_ids
later_ty = mkTupleType later_ids
\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`
- mkVarSet (map unLoc (collectGroupBinders binds))
+ mkVarSet (map unLoc (collectLocalBinders binds))
in
[(expr,
- mkVarSet (map unLoc (collectStmtsBinders stmts))
+ mkVarSet (map unLoc (collectLStmtsBinders stmts))
`unionVarSet` defined_vars)
- | L _ (GRHS stmts) <- grhss,
- let L _ (ResultStmt expr) = last stmts]
+ | L _ (GRHS stmts expr) <- grhss]
\end{code}
Replace the leaf commands in a match
-> 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
-> LGRHS Id -- rhss of a case command
-> ([LHsExpr Id],-- remaining leaf expressions
LGRHS Id) -- updated GRHS
-replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts))
- = (leaves, L loc (GRHS (init stmts ++ [L (getLoc leaf) (ResultStmt leaf)])))
+replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts rhs))
+ = (leaves, L loc (GRHS stmts leaf))
\end{code}
Balanced fold of a non-empty list.