Commit e01036f8 authored by Simon Peyton Jones's avatar Simon Peyton Jones

More hacking on monad-comp

Lots of refactoring. In particular I have now combined
TansformStmt and GroupStmt into a single constructor TransStmt.
This gives lots of useful code sharing.
parent f6d254cc
Pipeline #23 failed with stages
in 31 seconds
This diff is collapsed.
......@@ -455,26 +455,18 @@ addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr returnExpr) = do
(addTickSyntaxExpr hpcSrcSpan bindExpr)
(addTickSyntaxExpr hpcSrcSpan returnExpr)
addTickStmt isGuard (TransformStmt stmts ids usingExpr maybeByExpr returnExpr bindExpr) = do
t_s <- (addTickLStmts isGuard stmts)
t_u <- (addTickLHsExprAlways usingExpr)
t_m <- (addTickMaybeByLHsExpr maybeByExpr)
t_r <- (addTickSyntaxExpr hpcSrcSpan returnExpr)
t_b <- (addTickSyntaxExpr hpcSrcSpan bindExpr)
return $ TransformStmt t_s ids t_u t_m t_r t_b
addTickStmt isGuard stmt@(GroupStmt { grpS_stmts = stmts
, grpS_by = by, grpS_using = using
, grpS_ret = returnExpr, grpS_bind = bindExpr
, grpS_fmap = liftMExpr }) = do
addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
, trS_by = by, trS_using = using
, trS_ret = returnExpr, trS_bind = bindExpr
, trS_fmap = liftMExpr }) = do
t_s <- addTickLStmts isGuard stmts
t_y <- fmapMaybeM addTickLHsExprAlways by
t_u <- addTickLHsExprAlways using
t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr
return $ stmt { grpS_stmts = t_s, grpS_by = t_y, grpS_using = t_u
, grpS_ret = t_f, grpS_bind = t_b, grpS_fmap = t_m }
return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u
, trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }
addTickStmt isGuard stmt@(RecStmt {})
= do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
......@@ -495,12 +487,6 @@ addTickStmtAndBinders isGuard (stmts, ids) =
(addTickLStmts isGuard stmts)
(return ids)
addTickMaybeByLHsExpr :: Maybe (LHsExpr Id) -> TM (Maybe (LHsExpr Id))
addTickMaybeByLHsExpr maybeByExpr =
case maybeByExpr of
Nothing -> return Nothing
Just byExpr -> addTickLHsExprAlways byExpr >>= (return . Just)
addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
addTickHsLocalBinds (HsValBinds binds) =
liftM HsValBinds
......
This diff is collapsed.
......@@ -864,48 +864,24 @@ data StmtLR idL idR
-- with type (forall a. a -> m a)
-- See notes [Monad Comprehensions]
-- After renaming, the ids are the binders
-- bound by the stmts and used after them
-- bound by the stmts and used after themp
-- "qs, then f by e" ==> TransformStmt qs binders f (Just e) (return) (>>=)
-- "qs, then f" ==> TransformStmt qs binders f Nothing (return) (>>=)
| TransformStmt
[LStmt idL] -- Stmts are the ones to the left of the 'then'
[idR] -- After renaming, the Ids are the binders occurring
-- within this transform statement that are used after it
(LHsExpr idR) -- "then f"
(Maybe (LHsExpr idR)) -- "by e" (optional)
(SyntaxExpr idR) -- The 'return' function for inner monad
-- comprehensions
(SyntaxExpr idR) -- The '(>>=)' operator.
-- See Note [Monad Comprehensions]
| GroupStmt {
grpS_stmts :: [LStmt idL], -- Stmts to the *left* of the 'group'
| TransStmt {
trS_form :: TransForm,
trS_stmts :: [LStmt idL], -- Stmts to the *left* of the 'group'
-- which generates the tuples to be grouped
grpS_bndrs :: [(idR, idR)], -- See Note [GroupStmt binder map]
trS_bndrs :: [(idR, idR)], -- See Note [TransStmt binder map]
grpS_by :: Maybe (LHsExpr idR), -- "by e" (optional)
grpS_using :: LHsExpr idR,
grpS_explicit :: Bool, -- True <=> explicit "using f"
-- False <=> implicit; grpS_using is filled in with
-- 'groupWith' (list comprehensions) or
-- 'groupM' (monad comprehensions)
-- Invariant: if grpS_explicit = False, then grp_by = Just e
-- That is, we can have group by e
-- group using f
-- group by e using f
grpS_ret :: SyntaxExpr idR, -- The 'return' function for inner monad
-- comprehensions
grpS_bind :: SyntaxExpr idR, -- The '(>>=)' operator
grpS_fmap :: SyntaxExpr idR -- The polymorphic 'fmap' function for desugaring
trS_using :: LHsExpr idR,
trS_by :: Maybe (LHsExpr idR), -- "by e" (optional)
-- Invariant: if trS_form = GroupBy, then grp_by = Just e
trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for
-- the inner monad comprehensions
trS_bind :: SyntaxExpr idR, -- The '(>>=)' operator
trS_fmap :: SyntaxExpr idR -- The polymorphic 'fmap' function for desugaring
-- Only for 'group' forms
} -- See Note [Monad Comprehensions]
-- Recursive statement (see Note [How RecStmt works] below)
......@@ -943,6 +919,15 @@ data StmtLR idL idR
-- be quite as simple as (m (tya, tyb, tyc)).
}
deriving (Data, Typeable)
data TransForm -- The 'f' below is the 'using' function, 'e' is the by function
= ThenForm -- then f or then f by e
| GroupFormU -- group using f or group using f by e
| GroupFormB -- group by e
-- In the GroupByFormB, trS_using is filled in with
-- 'groupWith' (list comprehensions) or
-- 'groupM' (monad comprehensions)
deriving (Data, Typeable)
\end{code}
Note [The type of bind in Stmts]
......@@ -956,9 +941,9 @@ exotic type, such as
So we must be careful not to make assumptions about the type.
In particular, the monad may not be uniform throughout.
Note [GroupStmt binder map]
Note [TransStmt binder map]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
The [(idR,idR)] in a GroupStmt behaves as follows:
The [(idR,idR)] in a TransStmt behaves as follows:
* Before renaming: []
......@@ -1098,11 +1083,8 @@ pprStmt (ExprStmt expr _ _ _) = ppr expr
pprStmt (ParStmt stmtss _ _ _) = hsep (map doStmts stmtss)
where doStmts stmts = ptext (sLit "| ") <> ppr stmts
pprStmt (TransformStmt stmts bndrs using by _ _)
= sep (ppr_lc_stmts stmts ++ [pprTransformStmt bndrs using by])
pprStmt (GroupStmt { grpS_stmts = stmts, grpS_by = by, grpS_using = using, grpS_explicit = explicit })
= sep (ppr_lc_stmts stmts ++ [pprGroupStmt by using explicit])
pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form = form })
= sep (ppr_lc_stmts stmts ++ [pprTransStmt by using form])
pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids
, recS_later_ids = later_ids })
......@@ -1117,14 +1099,15 @@ pprTransformStmt bndrs using by
, nest 2 (ppr using)
, nest 2 (pprBy by)]
pprGroupStmt :: OutputableBndr id => Maybe (LHsExpr id)
-> LHsExpr id -> Bool
pprTransStmt :: OutputableBndr id => Maybe (LHsExpr id)
-> LHsExpr id -> TransForm
-> SDoc
pprGroupStmt by using explicit
= sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 pp_using ]
where
pp_using | explicit = ptext (sLit "using") <+> ppr using
| otherwise = empty
pprTransStmt by using ThenForm
= sep [ ptext (sLit "then"), nest 2 (ppr using), nest 2 (pprBy by)]
pprTransStmt by _ GroupFormB
= sep [ ptext (sLit "then group"), nest 2 (pprBy by) ]
pprTransStmt by using GroupFormU
= sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)]
pprBy :: OutputableBndr id => Maybe (LHsExpr id) -> SDoc
pprBy Nothing = empty
......@@ -1412,8 +1395,7 @@ pprStmtInCtxt ctxt stmt
2 (ppr_stmt stmt)
where
-- For Group and Transform Stmts, don't print the nested stmts!
ppr_stmt (GroupStmt { grpS_by = by, grpS_using = using
, grpS_explicit = explicit }) = pprGroupStmt by using explicit
ppr_stmt (TransformStmt _ bndrs using by _ _) = pprTransformStmt bndrs using by
ppr_stmt stmt = pprStmt stmt
ppr_stmt (TransStmt { trS_by = by, trS_using = using
, trS_form = form }) = pprTransStmt by using form
ppr_stmt stmt = pprStmt stmt
\end{code}
......@@ -43,7 +43,7 @@ module HsUtils(
-- Stmts
mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, mkLastStmt,
emptyGroupStmt, mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt,
emptyTransStmt, mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt,
emptyRecStmt, mkRecStmt,
-- Template Haskell
......@@ -196,9 +196,6 @@ mkHsComp :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id
mkNPat :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id
mkNPlusKPat :: Located id -> HsOverLit id -> Pat id
mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
mkLastStmt :: LHsExpr idR -> StmtLR idL idR
mkExprStmt :: LHsExpr idR -> StmtLR idL idR
mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR
......@@ -225,22 +222,23 @@ mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
mkNPat lit neg = NPat lit neg noSyntaxExpr
mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
mkTransformStmt stmts usingExpr = TransformStmt stmts [] usingExpr Nothing noSyntaxExpr noSyntaxExpr
mkTransformByStmt stmts usingExpr byExpr = TransformStmt stmts [] usingExpr (Just byExpr) noSyntaxExpr noSyntaxExpr
mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
mkGroupUsingStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
mkGroupByStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
emptyGroupStmt :: StmtLR idL idR
emptyGroupStmt = GroupStmt { grpS_stmts = [], grpS_bndrs = [], grpS_explicit = False
, grpS_by = Nothing, grpS_using = noLoc noSyntaxExpr
, grpS_ret = noSyntaxExpr, grpS_bind = noSyntaxExpr
, grpS_fmap = noSyntaxExpr }
mkGroupUsingStmt ss u = emptyGroupStmt { grpS_stmts = ss, grpS_explicit = True, grpS_using = u }
mkGroupByStmt ss b = emptyGroupStmt { grpS_stmts = ss, grpS_by = Just b }
mkGroupByUsingStmt ss b u = emptyGroupStmt { grpS_stmts = ss, grpS_by = Just b
, grpS_explicit = True, grpS_using = u }
emptyTransStmt :: StmtLR idL idR
emptyTransStmt = TransStmt { trS_form = undefined, trS_stmts = [], trS_bndrs = []
, trS_by = Nothing, trS_using = noLoc noSyntaxExpr
, trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
, trS_fmap = noSyntaxExpr }
mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u }
mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
mkGroupByStmt ss b = emptyTransStmt { trS_form = GroupFormB, trS_stmts = ss, trS_by = Just b }
mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupFormU, trS_stmts = ss, trS_using = u }
mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupFormU, trS_stmts = ss
, trS_by = Just b, trS_using = u }
mkLastStmt expr = LastStmt expr noSyntaxExpr
mkExprStmt expr = ExprStmt expr noSyntaxExpr noSyntaxExpr placeHolderType
......@@ -512,9 +510,8 @@ collectStmtBinders (ExprStmt {}) = []
collectStmtBinders (LastStmt {}) = []
collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders
$ concatMap fst xs
collectStmtBinders (TransformStmt stmts _ _ _ _ _) = collectLStmtsBinders stmts
collectStmtBinders (GroupStmt { grpS_stmts = stmts }) = collectLStmtsBinders stmts
collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
----------------- Patterns --------------------------
......@@ -659,9 +656,8 @@ lStmtsImplicits = hs_lstmts
hs_stmt (LastStmt {}) = emptyNameSet
hs_stmt (ParStmt xs _ _ _) = hs_lstmts $ concatMap fst xs
hs_stmt (TransformStmt stmts _ _ _ _ _) = hs_lstmts stmts
hs_stmt (GroupStmt { grpS_stmts = stmts }) = hs_lstmts stmts
hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss
hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss
hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds
hs_local_binds (HsIPBinds _) = emptyNameSet
......
......@@ -538,9 +538,8 @@ methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
methodNamesStmt (LetStmt _) = emptyFVs
methodNamesStmt (ParStmt _ _ _ _) = emptyFVs
methodNamesStmt (TransformStmt {}) = emptyFVs
methodNamesStmt (GroupStmt {}) = emptyFVs
-- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
methodNamesStmt (TransStmt {}) = emptyFVs
-- ParStmt and TransStmt can't occur in commands, but it's not convenient to error
-- here so we just do what's convenient
\end{code}
......@@ -766,41 +765,15 @@ rnStmt ctxt (L loc (ParStmt segs _ _ _)) thing_inside
; return ( ([L loc (ParStmt segs' mzip_op bind_op return_op)], thing)
, fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
rnStmt ctxt (L loc (TransformStmt stmts _ using by _ _)) thing_inside
= do { (using', fvs1) <- rnLExpr using
; ((stmts', (by', used_bndrs, thing)), fvs2)
<- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
do { (by', fvs_by) <- case by of
Nothing -> return (Nothing, emptyFVs)
Just e -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) }
; (thing, fvs_thing) <- thing_inside bndrs
; let fvs = fvs_by `plusFV` fvs_thing
used_bndrs = filter (`elemNameSet` fvs) bndrs
-- The paper (Fig 5) has a bug here; we must treat any free varaible of
-- the "thing inside", **or of the by-expression**, as used
; return ((by', used_bndrs, thing), fvs) }
-- Lookup `(>>=)` and `fail` for monad comprehensions
; ((return_op, fvs3), (bind_op, fvs4)) <-
if isMonadCompExpr ctxt
then (,) <$> lookupSyntaxName returnMName
<*> lookupSyntaxName bindMName
else return ( (noSyntaxExpr, emptyFVs)
, (noSyntaxExpr, emptyFVs) )
; return (([L loc (TransformStmt stmts' used_bndrs using' by' return_op bind_op)], thing),
fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
rnStmt ctxt (L loc (GroupStmt { grpS_stmts = stmts, grpS_by = by, grpS_explicit = explicit
, grpS_using = using })) thing_inside
rnStmt ctxt (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
, trS_using = using })) thing_inside
= do { -- Rename the 'using' expression in the context before the transform is begun
let implicit_name | isMonadCompExpr ctxt = groupMName
| otherwise = groupWithName
; (using', fvs1) <- if explicit
then rnLExpr using
else do { (e,fvs) <- lookupSyntaxName implicit_name
; return (noLoc e, fvs) }
; (using', fvs1) <- case form of
GroupFormB -> do { (e,fvs) <- lookupSyntaxName implicit_name
; return (noLoc e, fvs) }
_ -> rnLExpr using
-- Rename the stmts and the 'by' expression
-- Keep track of the variables mentioned in the 'by' expression
......@@ -810,28 +783,27 @@ rnStmt ctxt (L loc (GroupStmt { grpS_stmts = stmts, grpS_by = by, grpS_explicit
; (thing, fvs_thing) <- thing_inside bndrs
; let fvs = fvs_by `plusFV` fvs_thing
used_bndrs = filter (`elemNameSet` fvs) bndrs
-- The paper (Fig 5) has a bug here; we must treat any free varaible of
-- the "thing inside", **or of the by-expression**, as used
; return ((by', used_bndrs, thing), fvs) }
-- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
; ((return_op, fvs3), (bind_op, fvs4), (fmap_op, fvs5)) <-
if isMonadCompExpr ctxt
then (,,) <$> lookupSyntaxName returnMName
<*> lookupSyntaxName bindMName
<*> lookupSyntaxName fmapName
else return ( (noSyntaxExpr, emptyFVs)
, (noSyntaxExpr, emptyFVs)
, (noSyntaxExpr, emptyFVs) )
; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4
`plusFV` fvs5
; (return_op, fvs3) <- lookupSyntaxName returnMName
; (bind_op, fvs4) <- lookupSyntaxName bindMName
; (fmap_op, fvs5) <- case form of
ThenForm -> return (noSyntaxExpr, emptyFVs)
_ -> lookupSyntaxName fmapName
; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
`plusFV` fvs4 `plusFV` fvs5
bndr_map = used_bndrs `zip` used_bndrs
-- See Note [GroupStmt binder map] in HsExpr
-- See Note [TransStmt binder map] in HsExpr
; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
; return (([L loc (GroupStmt { grpS_stmts = stmts', grpS_bndrs = bndr_map
, grpS_by = by', grpS_using = using', grpS_explicit = explicit
, grpS_ret = return_op, grpS_bind = bind_op
, grpS_fmap = fmap_op })], thing), all_fvs) }
; return (([L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map
, trS_by = by', trS_using = using', trS_form = form
, trS_ret = return_op, trS_bind = bind_op
, trS_fmap = fmap_op })], thing), all_fvs) }
type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts
......@@ -978,10 +950,7 @@ rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec in
rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _ _ _ _)) -- Syntactically illegal in mdo
= pprPanic "rn_rec_stmt" (ppr stmt)
rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt {})) -- Syntactically illegal in mdo
= pprPanic "rn_rec_stmt" (ppr stmt)
rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt {})) -- Syntactically illegal in mdo
rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo
= pprPanic "rn_rec_stmt" (ppr stmt)
rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
......@@ -1046,11 +1015,8 @@ rn_rec_stmt _ stmt@(L _ (RecStmt {})) _
rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo
= pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _ -- Syntactically illegal in mdo
= pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _ -- Syntactically illegal in mdo
= pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
rn_rec_stmt _ stmt@(L _ (TransStmt {})) _ -- Syntactically illegal in mdo
= pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
= panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
......@@ -1254,8 +1220,7 @@ checkStmt ctxt (L _ stmt)
, ptext (sLit "in") <+> pprAStmtContext ctxt ]
pprStmtCat :: Stmt a -> SDoc
pprStmtCat (TransformStmt {}) = ptext (sLit "transform")
pprStmtCat (GroupStmt {}) = ptext (sLit "group")
pprStmtCat (TransStmt {}) = ptext (sLit "transform")
pprStmtCat (LastStmt {}) = ptext (sLit "return expression")
pprStmtCat (ExprStmt {}) = ptext (sLit "exprssion")
pprStmtCat (BindStmt {}) = ptext (sLit "binding")
......@@ -1313,10 +1278,7 @@ okCompStmt dflags _ stmt
ParStmt {}
| Opt_ParallelListComp `xopt` dflags -> isOK
| otherwise -> Just (ptext (sLit "Use -XParallelListComp"))
TransformStmt {}
| Opt_TransformListComp `xopt` dflags -> isOK
| otherwise -> Just (ptext (sLit "Use -XTransformListComp"))
GroupStmt {}
TransStmt {}
| Opt_TransformListComp `xopt` dflags -> isOK
| otherwise -> Just (ptext (sLit "Use -XTransformListComp"))
LastStmt {} -> notOK
......
......@@ -773,29 +773,20 @@ zonkStmt env (LastStmt expr ret_op)
zonkExpr env ret_op `thenM` \ new_ret ->
returnM (env, LastStmt new_expr new_ret)
zonkStmt env (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_op)
= do { (env', stmts') <- zonkStmts env stmts
; let binders' = zonkIdOccs env' binders
; usingExpr' <- zonkLExpr env' usingExpr
; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr
; return_op' <- zonkExpr env' return_op
; bind_op' <- zonkExpr env' bind_op
; return (env', TransformStmt stmts' binders' usingExpr' maybeByExpr' return_op' bind_op') }
zonkStmt env (GroupStmt { grpS_stmts = stmts, grpS_bndrs = binderMap
, grpS_by = by, grpS_explicit = explicit, grpS_using = using
, grpS_ret = return_op, grpS_bind = bind_op, grpS_fmap = liftM_op })
zonkStmt env (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
, trS_by = by, trS_form = form, trS_using = using
, trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op })
= do { (env', stmts') <- zonkStmts env stmts
; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
; by' <- fmapMaybeM (zonkLExpr env') by
; using' <- zonkLExpr env using
; by' <- fmapMaybeM (zonkLExpr env') by
; using' <- zonkLExpr env using
; return_op' <- zonkExpr env' return_op
; bind_op' <- zonkExpr env' bind_op
; liftM_op' <- zonkExpr env' liftM_op
; bind_op' <- zonkExpr env' bind_op
; liftM_op' <- zonkExpr env' liftM_op
; let env'' = extendZonkEnv env' (map snd binderMap')
; return (env'', GroupStmt { grpS_stmts = stmts', grpS_bndrs = binderMap'
, grpS_by = by', grpS_explicit = explicit, grpS_using = using'
, grpS_ret = return_op', grpS_bind = bind_op', grpS_fmap = liftM_op' }) }
; return (env'', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
, trS_by = by', trS_form = form, trS_using = using'
, trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) }
where
zonkBinderMapEntry env (oldBinder, newBinder) = do
let oldBinder' = zonkIdOcc env oldBinder
......@@ -813,11 +804,6 @@ zonkStmt env (BindStmt pat expr bind_op fail_op)
; new_fail <- zonkExpr env fail_op
; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
zonkMaybeLExpr :: ZonkEnv -> Maybe (LHsExpr TcId) -> TcM (Maybe (LHsExpr Id))
zonkMaybeLExpr _ Nothing = return Nothing
zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just)
-------------------------------------------------------------------------
zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
zonkRecFields env (HsRecFields flds dd)
......
This diff is collapsed.
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment