import Match ( matchSimply )
import DsUtils ( mkErrorAppDs,
- mkCoreTupTy, mkCoreTup, selectMatchVar,
+ mkCoreTupTy, mkCoreTup, selectMatchVarL,
mkTupleCase, mkBigCoreTup, mkTupleType,
mkTupleExpr, mkTupleSelector,
dsReboundNames, lookupReboundName )
import DsMonad
-import HsSyn ( HsExpr(..),
- Stmt(..), HsMatchContext(..), HsStmtContext(..),
- Match(..), GRHSs(..), GRHS(..),
- HsCmdTop(..), HsArrAppType(..),
- ReboundNames,
- collectHsBinders,
- collectStmtBinders, collectStmtsBinders,
- matchContextErrString
- )
-import TcHsSyn ( TypecheckedHsCmd, TypecheckedHsCmdTop,
- TypecheckedHsExpr, TypecheckedPat,
- TypecheckedMatch, TypecheckedGRHS,
- TypecheckedStmt, hsPatType,
- TypecheckedMatchContext )
+import HsSyn
+import TcHsSyn ( hsPatType )
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
-- needs to see source types (newtypes etc), and sometimes not
-- So WATCH OUT; check each use of split*Ty functions.
-- Sigh. This is a pain.
-import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLet )
import TcType ( Type, tcSplitAppTy )
import Type ( mkTyConApp )
import CoreSyn
import CoreFVs ( exprFreeVars )
-import CoreUtils ( mkIfThenElse, bindNonRec )
+import CoreUtils ( mkIfThenElse, bindNonRec, exprType )
import Id ( Id, idType )
+import Name ( Name )
import PrelInfo ( pAT_ERROR_ID )
import DataCon ( dataConWrapId )
import TysWiredIn ( tupleCon )
import HsPat ( collectPatBinders, collectPatsBinders )
import VarSet ( IdSet, mkVarSet, varSetElems,
- intersectVarSet, minusVarSet,
+ intersectVarSet, minusVarSet, extendVarSetList,
unionVarSet, unionVarSets, elemVarSet )
-import SrcLoc ( SrcLoc )
+import SrcLoc ( Located(..), unLoc, noLoc, getLoc )
\end{code}
\begin{code}
do_map_arrow ids b_ty c_ty d_ty f c
= do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) c
-mkFailExpr :: TypecheckedMatchContext -> Type -> DsM CoreExpr
+mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr
mkFailExpr ctxt ty
= mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)
-> CoreExpr -- e
-> DsM CoreExpr
matchEnvStack env_ids stack_ids body
- = getUniqSupplyDs `thenDs` \ uniqs ->
+ = newUniqueSupply `thenDs` \ uniqs ->
newSysLocalDs (mkTupleType env_ids) `thenDs` \ tup_var ->
matchVarStack tup_var stack_ids
(coreCaseTuple uniqs tup_var env_ids body)
\end{code}
\begin{code}
-mkHsTupleExpr :: [TypecheckedHsExpr] -> TypecheckedHsExpr
+mkHsTupleExpr :: [HsExpr Id] -> HsExpr Id
mkHsTupleExpr [e] = e
-mkHsTupleExpr es = ExplicitTuple es Unboxed
+mkHsTupleExpr es = ExplicitTuple (map noLoc es) Boxed
-mkHsPairExpr :: TypecheckedHsExpr -> TypecheckedHsExpr -> TypecheckedHsExpr
+mkHsPairExpr :: HsExpr Id -> HsExpr Id -> HsExpr Id
mkHsPairExpr e1 e2 = mkHsTupleExpr [e1, e2]
-mkHsEnvStackExpr :: [Id] -> [Id] -> TypecheckedHsExpr
+mkHsEnvStackExpr :: [Id] -> [Id] -> HsExpr Id
mkHsEnvStackExpr env_ids stack_ids
= foldl mkHsPairExpr (mkHsTupleExpr (map HsVar env_ids)) (map HsVar stack_ids)
\end{code}
-- where (xs) is the tuple of variables bound by p
dsProcExpr
- :: TypecheckedPat
- -> TypecheckedHsCmdTop
- -> SrcLoc
+ :: LPat Id
+ -> LHsCmdTop Id
-> DsM CoreExpr
-dsProcExpr pat (HsCmdTop cmd [] cmd_ty ids) locn
- = putSrcLocDs locn $
- mkCmdEnv ids `thenDs` \ meth_ids ->
+dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids))
+ = mkCmdEnv ids `thenDs` \ meth_ids ->
let
locals = mkVarSet (collectPatBinders pat)
in
env_ty = mkTupleType env_ids
in
mkFailExpr ProcExpr env_ty `thenDs` \ fail_expr ->
- selectMatchVar pat `thenDs` \ var ->
+ selectMatchVarL pat `thenDs` \ var ->
matchSimply (Var var) ProcExpr pat (mkTupleExpr env_ids) fail_expr
`thenDs` \ match_code ->
let
core_cmd
in
returnDs (bindCmdEnv meth_ids proc_code)
-
\end{code}
Translation of command judgements of the form
A | xs |- c :: [ts] t
\begin{code}
+dsLCmd ids local_vars env_ids stack res_ty cmd
+ = dsCmd ids local_vars env_ids stack res_ty (unLoc cmd)
-dsCmd :: DsCmdEnv -- arrow combinators
+dsCmd :: DsCmdEnv -- arrow combinators
-> IdSet -- set of local vars available to this command
-> [Id] -- list of vars in the input to this command
-- This is typically fed back,
-- so don't pull on it too early
-> [Type] -- type of the stack
-> Type -- return type of the command
- -> TypecheckedHsCmd -- command to desugar
+ -> HsCmd Id -- command to desugar
-> DsM (CoreExpr, -- desugared expression
IdSet) -- set of local vars that occur free
-- A | xs |- f -< arg :: [] t' ---> arr (\ (xs) -> arg) >>> f
dsCmd ids local_vars env_ids [] res_ty
- (HsArrApp arrow arg arrow_ty HsFirstOrderApp _ _)
+ (HsArrApp arrow arg arrow_ty HsFirstOrderApp _)
= let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
(_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
env_ty = mkTupleType env_ids
in
- dsExpr arrow `thenDs` \ core_arrow ->
- dsExpr arg `thenDs` \ core_arg ->
+ 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
core_make_arg
-- A | xs |- f -<< arg :: [] t' ---> arr (\ (xs) -> (f,arg)) >>> app
dsCmd ids local_vars env_ids [] res_ty
- (HsArrApp arrow arg arrow_ty HsHigherOrderApp _ _)
+ (HsArrApp arrow arg arrow_ty HsHigherOrderApp _)
= let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
(_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
env_ty = mkTupleType env_ids
in
- dsExpr arrow `thenDs` \ core_arrow ->
- dsExpr arg `thenDs` \ core_arg ->
+ dsLExpr arrow `thenDs` \ core_arrow ->
+ dsLExpr arg `thenDs` \ core_arg ->
matchEnvStack env_ids [] (mkCorePairExpr core_arrow core_arg)
`thenDs` \ core_make_pair ->
returnDs (do_map_arrow ids env_ty (mkCorePairTy arrow_ty arg_ty) res_ty
(exprFreeVars core_arrow `unionVarSet` exprFreeVars core_arg)
`intersectVarSet` local_vars)
+-- A | ys |- c :: [t:ts] t'
+-- A, xs |- e :: t
+-- ------------------------
+-- A | xs |- c e :: [ts] t'
+--
+-- ---> arr (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) >>> c
+
+dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg)
+ = dsLExpr arg `thenDs` \ core_arg ->
+ let
+ arg_ty = exprType core_arg
+ stack' = arg_ty:stack
+ in
+ dsfixCmd ids local_vars stack' res_ty cmd
+ `thenDs` \ (core_cmd, free_vars, env_ids') ->
+ mappM newSysLocalDs stack `thenDs` \ stack_ids ->
+ newSysLocalDs arg_ty `thenDs` \ arg_id ->
+ -- push the argument expression onto the stack
+ let
+ core_body = bindNonRec arg_id core_arg
+ (buildEnvStack env_ids' (arg_id:stack_ids))
+ in
+ -- match the environment and stack against the input
+ matchEnvStack env_ids stack_ids core_body
+ `thenDs` \ core_map ->
+ returnDs (do_map_arrow ids
+ (envStackType env_ids stack)
+ (envStackType env_ids' stack')
+ res_ty
+ core_map
+ core_cmd,
+ (exprFreeVars core_arg `intersectVarSet` local_vars)
+ `unionVarSet` free_vars)
+
-- A | ys |- c :: [ts] t'
-- -----------------------------------------------
-- A | xs |- \ p1 ... pk -> c :: [t1:...:tk:ts] t'
-- ---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c
dsCmd ids local_vars env_ids stack res_ty
- (HsLam (Match pats _ (GRHSs [GRHS [ResultStmt body _] _loc] _ _cmd_ty)))
+ (HsLam (L _ (Match pats _ (GRHSs [L _ (GRHS [L _ (ResultStmt body)])] _ _cmd_ty))))
= let
pat_vars = mkVarSet (collectPatsBinders pats)
local_vars' = local_vars `unionVarSet` pat_vars
in
dsfixCmd ids local_vars' stack' res_ty body
`thenDs` \ (core_body, free_vars, env_ids') ->
- mapDs newSysLocalDs stack `thenDs` \ stack_ids ->
+ mappM newSysLocalDs stack `thenDs` \ stack_ids ->
-- the expression is built from the inside out, so the actions
-- are presented in reverse order
free_vars `minusVarSet` pat_vars)
dsCmd ids local_vars env_ids stack res_ty (HsPar cmd)
- = dsCmd ids local_vars env_ids stack res_ty cmd
-
-dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches src_loc)
- = dsExpr exp `thenDs` \ core_exp ->
- mapDs newSysLocalDs stack `thenDs` \ stack_ids ->
-
- -- Extract and desugar the leaf commands in the case, building tuple
- -- expressions that will (after tagging) replace these leaves
-
- let
- leaves = concatMap leavesMatch matches
- make_branch (leaf, bound_vars)
- = dsfixCmd ids (local_vars `unionVarSet` bound_vars) stack res_ty leaf
- `thenDs` \ (core_leaf, fvs, leaf_ids) ->
- returnDs (fvs `minusVarSet` bound_vars,
- [mkHsEnvStackExpr leaf_ids stack_ids],
- envStackType leaf_ids stack,
- core_leaf)
- in
- mapDs make_branch leaves `thenDs` \ branches ->
- dsLookupTyCon eitherTyConName `thenDs` \ either_con ->
- dsLookupDataCon leftDataConName `thenDs` \ left_con ->
- dsLookupDataCon rightDataConName `thenDs` \ right_con ->
- let
- left_id = HsVar (dataConWrapId left_con)
- right_id = HsVar (dataConWrapId right_con)
- left_expr ty1 ty2 e = HsApp (TyApp left_id [ty1, ty2]) e
- right_expr ty1 ty2 e = HsApp (TyApp right_id [ty1, ty2]) e
-
- -- Prefix each tuple with a distinct series of Left's and Right's,
- -- in a balanced way, keeping track of the types.
-
- merge_branches (fvs1, builds1, in_ty1, core_exp1)
- (fvs2, builds2, in_ty2, core_exp2)
- = (fvs1 `unionVarSet` fvs2,
- map (left_expr in_ty1 in_ty2) builds1 ++
- map (right_expr in_ty1 in_ty2) builds2,
- mkTyConApp either_con [in_ty1, in_ty2],
- do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)
- (fvs, leaves', sum_ty, core_choices) = foldb merge_branches branches
-
- -- Replace the commands in the case with these tagged tuples,
- -- yielding a TypecheckedHsExpr we can feed to dsExpr.
-
- (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
- in_ty = envStackType env_ids stack
- in
- dsExpr (HsCase exp matches' src_loc) `thenDs` \ core_matches ->
- returnDs(do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices,
- exprFreeVars core_exp `unionVarSet` fvs)
+ = dsLCmd ids local_vars env_ids stack res_ty cmd
-- A, xs |- e :: Bool
-- A | xs1 |- c1 :: [ts] t
-- if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>>
-- c1 ||| c2
-dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd _loc)
- = dsExpr cond `thenDs` \ core_cond ->
+dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd)
+ = dsLExpr cond `thenDs` \ core_cond ->
dsfixCmd ids local_vars stack res_ty then_cmd
`thenDs` \ (core_then, fvs_then, then_ids) ->
dsfixCmd ids local_vars stack res_ty else_cmd
`thenDs` \ (core_else, fvs_else, else_ids) ->
- mapDs newSysLocalDs stack `thenDs` \ stack_ids ->
+ mappM newSysLocalDs stack `thenDs` \ stack_ids ->
dsLookupTyCon eitherTyConName `thenDs` \ either_con ->
dsLookupDataCon leftDataConName `thenDs` \ left_con ->
dsLookupDataCon rightDataConName `thenDs` \ right_con ->
then_ty = envStackType then_ids stack
else_ty = envStackType else_ids stack
sum_ty = mkTyConApp either_con [then_ty, else_ty]
+ fvs_cond = exprFreeVars core_cond `intersectVarSet` local_vars
in
matchEnvStack env_ids stack_ids
(mkIfThenElse core_cond
returnDs(do_map_arrow ids in_ty sum_ty res_ty
core_if
(do_choice ids then_ty else_ty res_ty core_then core_else),
- exprFreeVars core_cond `unionVarSet` fvs_then `unionVarSet` fvs_else)
+ fvs_cond `unionVarSet` fvs_then `unionVarSet` fvs_else)
+\end{code}
+
+Case commands are treated in much the same way as if commands
+(see above) except that there are more alternatives. For example
+
+ case e of { p1 -> c1; p2 -> c2; p3 -> c3 }
+
+is translated to
+
+ arr (\ ((xs)*ts) -> case e of
+ p1 -> (Left (Left (xs1)*ts))
+ p2 -> Left ((Right (xs2)*ts))
+ p3 -> Right ((xs3)*ts)) >>>
+ (c1 ||| c2) ||| c3
+
+The idea is to extract the commands from the case, build a balanced tree
+of choices, and replace the commands with expressions that build tagged
+tuples, obtaining a case expression that can be desugared normally.
+To build all this, we use quadruples decribing segments of the list of
+case bodies, containing the following fields:
+1. an IdSet containing the environment variables free in the case bodies
+2. a list of expressions of the form (Left|Right)* ((xs)*ts), to be put
+ into the case replacing the commands
+3. a sum type that is the common type of these expressions, and also the
+ input type of the arrow
+4. a CoreExpr for an arrow built by combining the translated command
+ bodies with |||.
+
+\begin{code}
+dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches)
+ = dsLExpr exp `thenDs` \ core_exp ->
+ mappM newSysLocalDs stack `thenDs` \ stack_ids ->
+
+ -- Extract and desugar the leaf commands in the case, building tuple
+ -- expressions that will (after tagging) replace these leaves
+
+ let
+ leaves = concatMap leavesMatch matches
+ make_branch (leaf, bound_vars)
+ = dsfixCmd ids (local_vars `unionVarSet` bound_vars) stack res_ty leaf
+ `thenDs` \ (core_leaf, fvs, leaf_ids) ->
+ returnDs (fvs `minusVarSet` bound_vars,
+ [noLoc $ mkHsEnvStackExpr leaf_ids stack_ids],
+ envStackType leaf_ids stack,
+ core_leaf)
+ in
+ mappM make_branch leaves `thenDs` \ branches ->
+ dsLookupTyCon eitherTyConName `thenDs` \ either_con ->
+ dsLookupDataCon leftDataConName `thenDs` \ left_con ->
+ dsLookupDataCon rightDataConName `thenDs` \ right_con ->
+ let
+ left_id = nlHsVar (dataConWrapId left_con)
+ right_id = nlHsVar (dataConWrapId right_con)
+ left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ TyApp left_id [ty1, ty2]) e
+ right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ TyApp right_id [ty1, ty2]) e
+
+ -- Prefix each tuple with a distinct series of Left's and Right's,
+ -- in a balanced way, keeping track of the types.
+
+ merge_branches (fvs1, builds1, in_ty1, core_exp1)
+ (fvs2, builds2, in_ty2, core_exp2)
+ = (fvs1 `unionVarSet` fvs2,
+ map (left_expr in_ty1 in_ty2) builds1 ++
+ map (right_expr in_ty1 in_ty2) builds2,
+ mkTyConApp either_con [in_ty1, in_ty2],
+ do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)
+ (fvs_alts, leaves', sum_ty, core_choices)
+ = foldb merge_branches branches
+
+ -- Replace the commands in the case with these tagged tuples,
+ -- yielding a HsExpr Id we can feed to dsExpr.
+
+ (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
+ in_ty = envStackType env_ids stack
+ fvs_exp = exprFreeVars core_exp `intersectVarSet` local_vars
+ in
+ dsExpr (HsCase exp matches') `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,
+ fvs_exp `unionVarSet` fvs_alts)
-- A | ys |- c :: [ts] t
-- ----------------------------------
dsCmd ids local_vars env_ids stack res_ty (HsLet binds body)
= let
- defined_vars = mkVarSet (collectHsBinders binds)
+ defined_vars = mkVarSet (map unLoc (collectGroupBinders binds))
local_vars' = local_vars `unionVarSet` defined_vars
in
dsfixCmd ids local_vars' stack res_ty body
`thenDs` \ (core_body, free_vars, env_ids') ->
- mapDs newSysLocalDs stack `thenDs` \ stack_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)
`thenDs` \ core_binds ->
core_body,
exprFreeVars core_binds `intersectVarSet` local_vars)
-dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _ _ _loc)
+dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _ _)
= dsCmdDo ids local_vars env_ids res_ty stmts
-- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t
-- A | xs |- ci :: [tsi] ti
-- -----------------------------------
--- A | xs |- (|e|) c1 ... cn :: [ts] t ---> e [t_xs] c1 ... cn
+-- A | xs |- (|e c1 ... cn|) :: [ts] t ---> e [t_xs] c1 ... cn
-dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args _)
+dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args)
= let
env_ty = mkTupleType env_ids
in
- dsExpr op `thenDs` \ core_op ->
+ dsLExpr op `thenDs` \ core_op ->
mapAndUnzipDs (dsTrimCmdArg local_vars env_ids) args
`thenDs` \ (core_args, fv_sets) ->
returnDs (mkApps (App core_op (Type env_ty)) core_args,
dsTrimCmdArg
:: IdSet -- set of local vars available to this command
-> [Id] -- list of vars in the input to this command
- -> TypecheckedHsCmdTop -- command argument to desugar
+ -> LHsCmdTop Id -- command argument to desugar
-> DsM (CoreExpr, -- desugared expression
IdSet) -- set of local vars that occur free
-dsTrimCmdArg local_vars env_ids (HsCmdTop cmd stack cmd_ty ids)
+dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack cmd_ty ids))
= mkCmdEnv ids `thenDs` \ meth_ids ->
dsfixCmd meth_ids local_vars stack cmd_ty cmd
`thenDs` \ (core_cmd, free_vars, env_ids') ->
- mapDs newSysLocalDs stack `thenDs` \ stack_ids ->
+ mappM newSysLocalDs stack `thenDs` \ stack_ids ->
matchEnvStack env_ids stack_ids (buildEnvStack env_ids' stack_ids)
`thenDs` \ trim_code ->
let
-> IdSet -- set of local vars available to this command
-> [Type] -- type of the stack
-> Type -- return type of the command
- -> TypecheckedHsCmd -- command to desugar
+ -> LHsCmd Id -- command to desugar
-> DsM (CoreExpr, -- desugared expression
IdSet, -- set of local vars that occur free
[Id]) -- set as a list, fed back
dsfixCmd ids local_vars stack cmd_ty cmd
= fixDs (\ ~(_,_,env_ids') ->
- dsCmd ids local_vars env_ids' stack cmd_ty cmd
+ dsLCmd ids local_vars env_ids' stack cmd_ty cmd
`thenDs` \ (core_cmd, free_vars) ->
returnDs (core_cmd, free_vars, varSetElems free_vars))
-- This is typically fed back,
-- so don't pull on it too early
-> Type -- return type of the statement
- -> [TypecheckedStmt] -- statements to desugar
+ -> [LStmt Id] -- statements to desugar
-> 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 [ResultStmt cmd _locn]
- = dsCmd ids local_vars env_ids [] res_ty cmd
+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 (stmt:stmts)
= let
- bound_vars = mkVarSet (collectStmtBinders stmt)
+ bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
local_vars' = local_vars `unionVarSet` bound_vars
in
fixDs (\ ~(_,_,env_ids') ->
`thenDs` \ (core_stmts, fv_stmts) ->
returnDs (core_stmts, fv_stmts, varSetElems fv_stmts))
`thenDs` \ (core_stmts, fv_stmts, env_ids') ->
- dsCmdStmt ids local_vars env_ids env_ids' stmt
+ dsCmdLStmt ids local_vars env_ids env_ids' stmt
`thenDs` \ (core_stmt, fv_stmt) ->
returnDs (do_compose ids
(mkTupleType env_ids)
as an arrow from one tuple type to another. A statement sequence is
translated to a composition of such arrows.
\begin{code}
+dsCmdLStmt ids local_vars env_ids out_ids cmd
+ = dsCmdStmt ids local_vars env_ids out_ids (unLoc cmd)
dsCmdStmt
:: DsCmdEnv -- arrow combinators
-- This is typically fed back,
-- so don't pull on it too early
-> [Id] -- list of vars in the output of this statement
- -> TypecheckedStmt -- statement to desugar
+ -> Stmt Id -- statement to desugar
-> DsM (CoreExpr, -- desugared expression
IdSet) -- set of local vars that occur free
-- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>>
-- arr snd >>> ss
-dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd c_ty _loc)
+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 _loc)
+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)
- selectMatchVar pat `thenDs` \ pat_id ->
+ selectMatchVarL pat `thenDs` \ pat_id ->
newSysLocalDs env_ty2 `thenDs` \ env_id ->
- getUniqSupplyDs `thenDs` \ uniqs ->
+ newUniqueSupply `thenDs` \ uniqs ->
let
after_c_ty = mkCorePairTy pat_ty env_ty2
out_ty = mkTupleType out_ids
-- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)
- getUniqSupplyDs `thenDs` \ uniqs ->
+ newUniqueSupply `thenDs` \ uniqs ->
newSysLocalDs env2_ty `thenDs` \ env2_id ->
let
later_ty = mkTupleType later_ids
-- mk_pair_fn = \ (out_ids) -> ((later_ids),(rhss))
- mapDs dsExpr rhss `thenDs` \ core_rhss ->
+ mappM dsLExpr rhss `thenDs` \ core_rhss ->
let
later_tuple = mkTupleExpr later_ids
later_ty = mkTupleType later_ids
:: DsCmdEnv -- arrow combinators
-> IdSet -- set of local vars available to this statement
-> [Id] -- output vars of these statements
- -> [TypecheckedStmt] -- statements to desugar
+ -> [LStmt Id] -- statements to desugar
-> DsM (CoreExpr, -- desugared expression
IdSet, -- set of local vars that occur free
[Id]) -- input vars
-> IdSet -- set of local vars available to this statement
-> [Id] -- list of vars in the input to these statements
-> [Id] -- output vars of these statements
- -> [TypecheckedStmt] -- statements to desugar
+ -> [LStmt Id] -- statements to desugar
-> DsM (CoreExpr, -- desugared expression
IdSet) -- set of local vars that occur free
dsCmdStmts ids local_vars env_ids out_ids [stmt]
- = dsCmdStmt ids local_vars env_ids out_ids stmt
+ = dsCmdLStmt ids local_vars env_ids out_ids stmt
dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts)
= let
- bound_vars = mkVarSet (collectStmtBinders stmt)
+ bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
local_vars' = local_vars `unionVarSet` bound_vars
in
dsfixCmdStmts ids local_vars' out_ids stmts
`thenDs` \ (core_stmts, fv_stmts, env_ids') ->
- dsCmdStmt ids local_vars env_ids env_ids' stmt
+ dsCmdLStmt ids local_vars env_ids env_ids' stmt
`thenDs` \ (core_stmt, fv_stmt) ->
returnDs (do_compose ids
(mkTupleType env_ids)
Match a list of expressions against a list of patterns, left-to-right.
\begin{code}
-matchSimplys :: [CoreExpr] -- Scrutinees
- -> TypecheckedMatchContext -- Match kind
- -> [TypecheckedPat] -- Patterns they should match
- -> CoreExpr -- Return this if they all match
- -> CoreExpr -- Return this if they don't
+matchSimplys :: [CoreExpr] -- Scrutinees
+ -> HsMatchContext Name -- Match kind
+ -> [LPat Id] -- Patterns they should match
+ -> CoreExpr -- Return this if they all match
+ -> CoreExpr -- Return this if they don't
-> DsM CoreExpr
matchSimplys [] _ctxt [] result_expr _fail_expr = returnDs result_expr
matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr
matchSimply exp ctxt pat match_code fail_expr
\end{code}
-\begin{code}
+List of leaf expressions, with set of variables bound in each
--- list of leaf expressions, with set of variables bound in each
-leavesMatch :: TypecheckedMatch -> [(TypecheckedHsExpr, IdSet)]
-leavesMatch (Match pats _ (GRHSs grhss binds _ty))
+\begin{code}
+leavesMatch :: LMatch Id -> [(LHsExpr Id, IdSet)]
+leavesMatch (L _ (Match pats _ (GRHSs grhss binds _ty)))
= let
- defined_vars = mkVarSet (collectPatsBinders pats) `unionVarSet`
- mkVarSet (collectHsBinders binds)
+ defined_vars = mkVarSet (collectPatsBinders pats)
+ `unionVarSet`
+ mkVarSet (map unLoc (collectGroupBinders binds))
in
- [(expr, mkVarSet (collectStmtsBinders stmts) `unionVarSet` defined_vars) |
- GRHS stmts _locn <- grhss,
- let ResultStmt expr _ = last stmts]
+ [(expr,
+ mkVarSet (map unLoc (collectStmtsBinders stmts))
+ `unionVarSet` defined_vars)
+ | L _ (GRHS stmts) <- grhss,
+ let L _ (ResultStmt expr) = last stmts]
+\end{code}
--- Replace the leaf commands in a match
+Replace the leaf commands in a match
+\begin{code}
replaceLeavesMatch
:: Type -- new result type
- -> [TypecheckedHsExpr] -- replacement leaf expressions of that type
- -> TypecheckedMatch -- the matches of a case command
- -> ([TypecheckedHsExpr],-- remaining leaf expressions
- TypecheckedMatch) -- updated match
-replaceLeavesMatch res_ty leaves (Match pat mt (GRHSs grhss binds _ty))
+ -> [LHsExpr Id] -- replacement leaf expressions of that type
+ -> 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)))
= let
(leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
in
- (leaves', Match pat mt (GRHSs grhss' binds res_ty))
+ (leaves', L loc (Match pat mt (GRHSs grhss' binds res_ty)))
replaceLeavesGRHS
- :: [TypecheckedHsExpr] -- replacement leaf expressions of that type
- -> TypecheckedGRHS -- rhss of a case command
- -> ([TypecheckedHsExpr],-- remaining leaf expressions
- TypecheckedGRHS) -- updated GRHS
-replaceLeavesGRHS (leaf:leaves) (GRHS stmts srcloc)
- = (leaves, GRHS (init stmts ++ [ResultStmt leaf srcloc]) srcloc)
-
+ :: [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)])))
\end{code}
Balanced fold of a non-empty list.
projects / ghc-hetmet.git / blobdiff