import DsUtils
import DsMonad
-import HsSyn hiding (collectPatBinders, collectLocatedPatBinders, collectl,
- collectPatsBinders, collectLocatedPatsBinders)
+import HsSyn hiding (collectPatBinders, collectPatsBinders )
import TcHsSyn
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
import CoreSyn
import CoreFVs
import CoreUtils
+import MkCore
import Name
import Var
+import Id
import PrelInfo
import DataCon
import TysWiredIn
\begin{code}
mkCorePairTy :: Type -> Type -> Type
-mkCorePairTy t1 t2 = mkCoreTupTy [t1, t2]
+mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2]
mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr
mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]
\end{code}
\begin{code}
-mkHsTupleExpr :: [HsExpr Id] -> HsExpr Id
-mkHsTupleExpr [e] = e
-mkHsTupleExpr es = ExplicitTuple (map noLoc es) Boxed
-
-mkHsPairExpr :: HsExpr Id -> HsExpr Id -> HsExpr Id
-mkHsPairExpr e1 e2 = mkHsTupleExpr [e1, e2]
-
-mkHsEnvStackExpr :: [Id] -> [Id] -> HsExpr Id
+mkHsEnvStackExpr :: [Id] -> [Id] -> LHsExpr Id
mkHsEnvStackExpr env_ids stack_ids
- = foldl mkHsPairExpr (mkHsTupleExpr (map HsVar env_ids)) (map HsVar stack_ids)
+ = foldl (\a b -> mkLHsTupleExpr [a,b])
+ (mkLHsVarTuple env_ids)
+ (map nlHsVar stack_ids)
\end{code}
Translation of arrow abstraction
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
+To build all this, we use triples describing 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
+ * 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
+ * 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
+ * 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 (MatchGroup matches match_ty)) = do
- core_exp <- dsLExpr exp
stack_ids <- mapM newSysLocalDs stack
-- Extract and desugar the leaf commands in the case, building tuple
let
leaves = concatMap leavesMatch matches
make_branch (leaf, bound_vars) = do
- (core_leaf, fvs, leaf_ids) <-
+ (core_leaf, _fvs, leaf_ids) <-
dsfixCmd ids (local_vars `unionVarSet` bound_vars) stack res_ty leaf
- return (fvs `minusVarSet` bound_vars,
- [noLoc $ mkHsEnvStackExpr leaf_ids stack_ids],
+ return ([mkHsEnvStackExpr leaf_ids stack_ids],
envStackType leaf_ids stack,
core_leaf)
-- 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 ++
+ merge_branches (builds1, in_ty1, core_exp1)
+ (builds2, in_ty2, core_exp2)
+ = (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
+ (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
pat_ty = funArgTy match_ty
match_ty' = mkFunTy pat_ty sum_ty
core_body <- dsExpr (HsCase exp (MatchGroup matches' match_ty'))
core_matches <- matchEnvStack env_ids stack_ids core_body
return (do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices,
- fvs_exp `unionVarSet` fvs_alts)
+ exprFreeVars core_body `intersectVarSet` local_vars)
-- A | ys |- c :: [ts] t
-- ----------------------------------
dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do
let
- defined_vars = mkVarSet (map unLoc (collectLocalBinders binds))
+ defined_vars = mkVarSet (collectLocalBinders binds)
local_vars' = local_vars `unionVarSet` defined_vars
(core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack res_ty body
dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body = do
let
- bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
+ bound_vars = mkVarSet (collectLStmtBinders stmt)
local_vars' = local_vars `unionVarSet` bound_vars
(core_stmts, _, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do
(core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts body
-- 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 _binds) = do
+dsCmdStmt ids local_vars env_ids out_ids
+ (RecStmt { recS_stmts = stmts, recS_later_ids = later_ids, recS_rec_ids = rec_ids
+ , recS_rec_rets = rhss, recS_dicts = _binds }) = do
let -- ToDo: ****** binds not desugared; ROSS PLEASE FIX ********
env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids
env2_ids = varSetElems env2_id_set
dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) = do
let
- bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
+ bound_vars = mkVarSet (collectLStmtBinders stmt)
local_vars' = local_vars `unionVarSet` bound_vars
(core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts
(core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt
= let
defined_vars = mkVarSet (collectPatsBinders pats)
`unionVarSet`
- mkVarSet (map unLoc (collectLocalBinders binds))
+ mkVarSet (collectLocalBinders binds)
in
[(expr,
- mkVarSet (map unLoc (collectLStmtsBinders stmts))
+ mkVarSet (collectLStmtsBinders stmts)
`unionVarSet` defined_vars)
| L _ (GRHS stmts expr) <- grhss]
\end{code}
fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs
\end{code}
+Note [Dictionary binders in ConPatOut] See also same Note in HsUtils
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The following functions to collect value variables from patterns are
copied from HsUtils, with one change: we also collect the dictionary
bindings (pat_binds) from ConPatOut. We need them for cases like
\begin{code}
collectPatBinders :: OutputableBndr a => LPat a -> [a]
-collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
-
-collectLocatedPatBinders :: OutputableBndr a => LPat a -> [Located a]
-collectLocatedPatBinders pat = collectl pat []
+collectPatBinders pat = collectl pat []
collectPatsBinders :: OutputableBndr a => [LPat a] -> [a]
-collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
-
-collectLocatedPatsBinders :: OutputableBndr a => [LPat a] -> [Located a]
-collectLocatedPatsBinders pats = foldr collectl [] pats
+collectPatsBinders pats = foldr collectl [] pats
---------------------
-collectl :: OutputableBndr a => LPat a -> [Located a] -> [Located a]
-collectl (L l pat) bndrs
+collectl :: OutputableBndr a => LPat a -> [a] -> [a]
+-- See Note [Dictionary binders in ConPatOut]
+collectl (L _ pat) bndrs
= go pat
where
- go (VarPat var) = L l var : bndrs
- go (VarPatOut var bs) = L l var : collectHsBindLocatedBinders bs
+ go (VarPat var) = var : bndrs
+ go (VarPatOut var bs) = var : collectHsBindsBinders bs
++ bndrs
go (WildPat _) = bndrs
go (LazyPat pat) = collectl pat bndrs
go (BangPat pat) = collectl pat bndrs
- go (AsPat a pat) = a : collectl pat bndrs
+ go (AsPat (L _ a) pat) = a : collectl pat bndrs
go (ParPat pat) = collectl pat bndrs
go (ListPat pats _) = foldr collectl bndrs pats
go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps)
go (ConPatOut {pat_args=ps, pat_binds=ds}) =
- collectHsBindLocatedBinders ds
+ collectHsBindsBinders ds
++ foldr collectl bndrs (hsConPatArgs ps)
go (LitPat _) = bndrs
go (NPat _ _ _) = bndrs
- go (NPlusKPat n _ _ _) = n : bndrs
+ go (NPlusKPat (L _ n) _ _ _) = n : bndrs
go (SigPatIn pat _) = collectl pat bndrs
go (SigPatOut pat _) = collectl pat bndrs
go (TypePat _) = bndrs
go (CoPat _ pat _) = collectl (noLoc pat) bndrs
- go p = pprPanic "collectl/go" (ppr p)
+ go (ViewPat _ pat _) = collectl pat bndrs
+ go p@(QuasiQuotePat {}) = pprPanic "collectl/go" (ppr p)
\end{code}