Commit 4ac2bb39 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Simon's hacking on monad-comp; incomplete

parent 5ccf6588
......@@ -301,11 +301,9 @@ addTickHsExpr (HsLet binds e) =
liftM2 HsLet
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsExprNeverOrAlways e)
addTickHsExpr (HsDo cxt stmts last_exp return_exp srcloc) = do
(stmts', last_exp') <- addTickLStmts' forQual stmts
(addTickLHsExpr last_exp)
return_exp' <- addTickSyntaxExpr hpcSrcSpan return_exp
return (HsDo cxt stmts' last_exp' return_exp' srcloc)
addTickHsExpr (HsDo cxt stmts srcloc)
= do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
; return (HsDo cxt stmts' srcloc) }
where
forQual = case cxt of
ListComp -> Just $ BinBox QualBinBox
......@@ -425,14 +423,16 @@ addTickLStmts isGuard stmts = do
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a
-> TM ([LStmt Id], a)
addTickLStmts' isGuard lstmts res
= bindLocals binders $ do
lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
a <- res
return (lstmts', a)
where
binders = collectLStmtsBinders lstmts
= bindLocals (collectLStmtsBinders lstmts) $
do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
; a <- res
; return (lstmts', a) }
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
addTickStmt _isGuard (LastStmt e ret) = do
liftM2 LastStmt
(addTickLHsExprAlways e)
(addTickSyntaxExpr hpcSrcSpan ret)
addTickStmt _isGuard (BindStmt pat e bind fail) = do
liftM4 BindStmt
(addTickLPat pat)
......@@ -577,10 +577,9 @@ addTickHsCmd (HsLet binds c) =
liftM2 HsLet
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsCmd c)
addTickHsCmd (HsDo cxt stmts last_exp return_exp srcloc) = do
(stmts', last_exp') <- addTickLCmdStmts' stmts (addTickLHsCmd last_exp)
return_exp' <- addTickSyntaxExpr hpcSrcSpan return_exp
return (HsDo cxt stmts' last_exp' return_exp' srcloc)
addTickHsCmd (HsDo cxt stmts srcloc)
= do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
; return (HsDo cxt stmts' srcloc) }
addTickHsCmd (HsArrApp e1 e2 ty1 arr_ty lr) =
liftM5 HsArrApp
......
......@@ -541,8 +541,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do
core_body,
exprFreeVars core_binds `intersectVarSet` local_vars)
dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts body _ _)
= dsCmdDo ids local_vars env_ids res_ty stmts body
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
......@@ -618,7 +618,6 @@ dsCmdDo :: DsCmdEnv -- arrow combinators
-- so don't pull on it too early
-> Type -- return type of the statement
-> [LStmt Id] -- statements to desugar
-> LHsExpr Id -- body
-> DsM (CoreExpr, -- desugared expression
IdSet) -- set of local vars that occur free
......@@ -626,15 +625,17 @@ dsCmdDo :: DsCmdEnv -- arrow combinators
-- --------------------------
-- A | xs |- do { c } :: [] t
dsCmdDo ids local_vars env_ids res_ty [] body
dsCmdDo _ _ _ _ [] = panic "dsCmdDo"
dsCmdDo ids local_vars env_ids res_ty [L _ (LastStmt body _)]
= dsLCmd ids local_vars env_ids [] res_ty body
dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body = do
dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) = do
let
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
(core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts
return (core_stmts, fv_stmts, varSetElems fv_stmts))
(core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt
return (do_compose ids
......
......@@ -325,29 +325,12 @@ dsExpr (HsLet binds body) = do
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
dsExpr (HsDo ListComp stmts body _ result_ty)
= -- Special case for list comprehensions
dsListComp stmts body elt_ty
where
[elt_ty] = tcTyConAppArgs result_ty
dsExpr (HsDo DoExpr stmts body _ result_ty)
= dsDo stmts body result_ty
dsExpr (HsDo GhciStmt stmts body _ result_ty)
= dsDo stmts body result_ty
dsExpr (HsDo MDoExpr stmts body _ result_ty)
= dsDo stmts body result_ty
dsExpr (HsDo MonadComp stmts body return_op result_ty)
= dsMonadComp stmts return_op body result_ty
dsExpr (HsDo PArrComp stmts body _ result_ty)
= -- Special case for array comprehensions
dsPArrComp (map unLoc stmts) body elt_ty
where
[elt_ty] = tcTyConAppArgs result_ty
dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty
dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts)
dsExpr (HsDo DoExpr stmts res_ty) = dsDo stmts res_ty
dsExpr (HsDo GhciStmt stmts res_ty) = dsDo stmts res_ty
dsExpr (HsDo MDoExpr stmts res_ty) = dsDo stmts res_ty
dsExpr (HsDo MonadComp stmts res_ty) = dsMonadComp stmts res_ty
dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
= do { pred <- dsLExpr guard_expr
......@@ -712,24 +695,24 @@ Haskell 98 report:
\begin{code}
dsDo :: [LStmt Id]
-> LHsExpr Id
-> Type -- Type of the whole expression
-> DsM CoreExpr
dsDo stmts body result_ty
dsDo stmts result_ty
= goL stmts
where
-- result_ty must be of the form (m b)
(m_ty, _b_ty) = tcSplitAppTy result_ty
goL [] = dsLExpr body
goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
goL [] = panic "dsDo"
goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
go _ (LastStmt body ret_op) stmts
= ASSERT( null stmts )
do { body' <- dsLExpr body
; ret_op' <- dsExpr ret_op
; return (App ret_op' body') }
go _ (ExprStmt rhs then_expr _ _) stmts
= do { rhs2 <- dsLExpr rhs
; case tcSplitAppTy_maybe (exprType rhs2) of
Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty
_ -> return ()
; warnDiscardedDoBindings rhs (exprType rhs2)
; then_expr2 <- dsExpr then_expr
; rest <- goL stmts
; return (mkApps then_expr2 [rhs2, rest]) }
......@@ -753,29 +736,25 @@ dsDo stmts body result_ty
go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
, recS_rec_ids = rec_ids, recS_ret_fn = return_op
, recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
, recS_rec_rets = rec_rets }) stmts
, recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts
= ASSERT( length rec_ids > 0 )
goL (new_bind_stmt : stmts)
where
-- returnE <- dsExpr return_id
-- mfixE <- dsExpr mfix_id
new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app
bind_op
new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats)
mfix_app bind_op
noSyntaxExpr -- Tuple cannot fail
tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
rec_tup_pats = map nlVarPat tup_ids
later_pats = rec_tup_pats
rets = map noLoc rec_rets
mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
(mkFunTy tup_ty body_ty))
mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
body = noLoc $ HsDo DoExpr rec_stmts return_app noSyntaxExpr body_ty
return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
body_ty = mkAppTy m_ty tup_ty
tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
(mkFunTy tup_ty body_ty))
mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty
ret_stmt = noLoc $ LastStmt return_op (mkLHsTupleExpr rets)
tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
-- In a do expression, pattern-match failure just calls
......@@ -793,103 +772,6 @@ mk_fail_msg pat = "Pattern match failure in do expression at " ++
showSDoc (ppr (getLoc pat))
\end{code}
Translation for RecStmt's:
-----------------------------
We turn (RecStmt [v1,..vn] stmts) into:
(v1,..,vn) <- mfix (\~(v1,..vn). do stmts
return (v1,..vn))
\begin{code}
{-
dsMDo :: HsStmtContext Name
-> [(Name,Id)]
-> [LStmt Id]
-> LHsExpr Id
-> Type -- Type of the whole expression
-> DsM CoreExpr
dsMDo ctxt tbl stmts body result_ty
= goL stmts
where
goL [] = dsLExpr body
goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
(m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
return_id = lookupEvidence tbl returnMName
bind_id = lookupEvidence tbl bindMName
then_id = lookupEvidence tbl thenMName
fail_id = lookupEvidence tbl failMName
go _ (LetStmt binds) stmts
= do { rest <- goL stmts
; dsLocalBinds binds rest }
go _ (ExprStmt rhs then_expr rhs_ty) stmts
= do { rhs2 <- dsLExpr rhs
; warnDiscardedDoBindings rhs m_ty rhs_ty
; then_expr2 <- dsExpr then_expr
; rest <- goL stmts
; return (mkApps then_expr2 [rhs2, rest]) }
go _ (BindStmt pat rhs bind_op _) stmts
= do { body <- goL stmts
; rhs' <- dsLExpr rhs
; bind_op' <- dsExpr bind_op
; var <- selectSimpleMatchVarL pat
; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
result_ty (cantFailMatchResult body)
; match_code <- handle_failure pat match fail_op
; return (mkApps bind_op [rhs', Lam var match_code]) }
go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
, recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
, recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) stmts
= ASSERT( length rec_ids > 0 )
ASSERT( length rec_ids == length rec_rets )
ASSERT( isEmptyTcEvBinds _ev_binds )
pprTrace "dsMDo" (ppr later_ids) $
goL (new_bind_stmt : stmts)
where
new_bind_stmt = L loc $ BindStmt (mk_tup_pat later_pats) mfix_app
bind_op noSyntaxExpr
-- Remove the later_ids that appear (without fancy coercions)
-- in rec_rets, because there's no need to knot-tie them separately
-- See Note [RecStmt] in HsExpr
later_ids' = filter (`notElem` mono_rec_ids) later_ids
mono_rec_ids = [ id | HsVar id <- rec_rets ]
mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
(mkFunTy tup_ty body_ty))
-- The rec_tup_pat must bind the rec_ids only; remember that the
-- trimmed_laters may share the same Names
-- Meanwhile, the later_pats must bind the later_vars
rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
later_pats = map nlVarPat later_ids' ++ map mk_later_pat rec_ids
rets = map nlHsVar later_ids' ++ map noLoc rec_rets
mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
body = noLoc $ HsDo ctxt rec_stmts return_app noSyntaxExpr body_ty
body_ty = mkAppTy m_ty tup_ty
tup_ty = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids)) -- Deals with singleton case
return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
mk_wild_pat :: Id -> LPat Id
mk_wild_pat v = noLoc $ WildPat $ idType v
mk_later_pat :: Id -> LPat Id
mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
| otherwise = nlVarPat v
mk_tup_pat :: [LPat Id] -> LPat Id
mk_tup_pat [p] = p
mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed
-}
\end{code}
%************************************************************************
%* *
......@@ -929,30 +811,34 @@ conversionNames
\begin{code}
-- Warn about certain types of values discarded in monadic bindings (#3263)
warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM ()
warnDiscardedDoBindings rhs container_ty returning_ty = do {
-- Warn about discarding non-() things in 'monadic' binding
; warn_unused <- doptDs Opt_WarnUnusedDoBind
; if warn_unused && not (returning_ty `tcEqType` unitTy)
then warnDs (unusedMonadBind rhs returning_ty)
else do {
-- Warn about discarding m a things in 'monadic' binding of the same type,
-- but only if we didn't already warn due to Opt_WarnUnusedDoBind
; warn_wrong <- doptDs Opt_WarnWrongDoBind
; case tcSplitAppTy_maybe returning_ty of
Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $
warnDs (wrongMonadBind rhs returning_ty)
_ -> return () } }
warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()
warnDiscardedDoBindings rhs rhs_ty
| Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
= do { -- Warn about discarding non-() things in 'monadic' binding
; warn_unused <- doptDs Opt_WarnUnusedDoBind
; if warn_unused && not (isUnitTy elt_ty)
then warnDs (unusedMonadBind rhs elt_ty)
else
-- Warn about discarding m a things in 'monadic' binding of the same type,
-- but only if we didn't already warn due to Opt_WarnUnusedDoBind
do { warn_wrong <- doptDs Opt_WarnWrongDoBind
; case tcSplitAppTy_maybe elt_ty of
Just (elt_m_ty, _) | warn_wrong, m_ty `tcEqType` elt_m_ty
-> warnDs (wrongMonadBind rhs elt_ty)
_ -> return () } }
| otherwise -- RHS does have type of form (m ty), which is wierd
= return () -- but at lesat this warning is irrelevant
unusedMonadBind :: LHsExpr Id -> Type -> SDoc
unusedMonadBind rhs returning_ty
= ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
unusedMonadBind rhs elt_ty
= ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
ptext (sLit "or by using the flag -fno-warn-unused-do-bind")
wrongMonadBind :: LHsExpr Id -> Type -> SDoc
wrongMonadBind rhs returning_ty
= ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
wrongMonadBind rhs elt_ty
= ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")
\end{code}
......@@ -49,12 +49,12 @@ There will be at least one ``qualifier'' in the input.
\begin{code}
dsListComp :: [LStmt Id]
-> LHsExpr Id
-> Type -- Type of list elements
-> Type -- Type of entire list
-> DsM CoreExpr
dsListComp lquals body elt_ty = do
dsListComp lquals res_ty = do
dflags <- getDOptsDs
let quals = map unLoc lquals
[elt_ty] = tcTyConAppArgs res_ty
if not (dopt Opt_EnableRewriteRules dflags) || dopt Opt_IgnoreInterfacePragmas dflags
-- Either rules are switched off, or we are ignoring what there are;
......@@ -62,8 +62,8 @@ dsListComp lquals body elt_ty = do
-- Wadler-style desugaring
|| isParallelComp quals
-- Foldr-style desugaring can't handle parallel list comprehensions
then deListComp quals body (mkNilExpr elt_ty)
else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals body)
then deListComp quals (mkNilExpr elt_ty)
else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals)
-- Foldr/build should be enabled, so desugar
-- into foldrs and builds
......@@ -83,12 +83,11 @@ dsListComp lquals body elt_ty = do
-- and the type of the elements that it outputs (tuples of binders)
dsInnerListComp :: ([LStmt Id], [Id]) -> DsM (CoreExpr, Type)
dsInnerListComp (stmts, bndrs) = do
expr <- dsListComp stmts (mkBigLHsVarTup bndrs) bndrs_tuple_type
return (expr, bndrs_tuple_type)
where
bndrs_types = map idType bndrs
bndrs_tuple_type = mkBigCoreTupTy bndrs_types
= do { expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTup bndrs)])
bndrs_tuple_type
; return (expr, bndrs_tuple_type) }
where
bndrs_tuple_type = mkBigCoreVarTupTy bndrs
-- This function factors out commonality between the desugaring strategies for TransformStmt.
-- Given such a statement it gives you back an expression representing how to compute the transformed
......@@ -228,9 +227,40 @@ with the Unboxed variety.
\begin{code}
deListComp :: [Stmt Id] -> LHsExpr Id -> CoreExpr -> DsM CoreExpr
deListComp :: [Stmt Id] -> CoreExpr -> DsM CoreExpr
deListComp [] _ = panic "deListComp"
deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) body list
deListComp (LastStmt body _ : quals) list
= -- Figure 7.4, SLPJ, p 135, rule C above
ASSERT( null quals )
do { core_body <- dsLExpr body
; return (mkConsExpr (exprType core_body) core_body list) }
-- Non-last: must be a guard
deListComp (ExprStmt guard _ _ _ : quals) list = do -- rule B above
core_guard <- dsLExpr guard
core_rest <- deListComp quals list
return (mkIfThenElse core_guard core_rest list)
-- [e | let B, qs] = let B in [e | qs]
deListComp (LetStmt binds : quals) list = do
core_rest <- deListComp quals list
dsLocalBinds binds core_rest
deListComp (stmt@(TransformStmt {}) : quals) list = do
(inner_list_expr, pat) <- dsTransformStmt stmt
deBindComp pat inner_list_expr quals list
deListComp (stmt@(GroupStmt {}) : quals) list = do
(inner_list_expr, pat) <- dsGroupStmt stmt
deBindComp pat inner_list_expr quals list
deListComp (BindStmt pat list1 _ _ : quals) core_list2 = do -- rule A' above
core_list1 <- dsLExpr list1
deBindComp pat core_list1 quals core_list2
deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list
= do
exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
let (exps, qual_tys) = unzip exps_and_qual_tys
......@@ -239,7 +269,7 @@ deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) body list
-- Deal with [e | pat <- zip l1 .. ln] in example above
deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
quals body list
quals list
where
bndrs_s = map snd stmtss_w_bndrs
......@@ -247,34 +277,6 @@ deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) body list
-- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
pat = mkBigLHsPatTup pats
pats = map mkBigLHsVarPatTup bndrs_s
-- Last: the one to return
deListComp [] body list = do -- Figure 7.4, SLPJ, p 135, rule C above
core_body <- dsLExpr body
return (mkConsExpr (exprType core_body) core_body list)
-- Non-last: must be a guard
deListComp (ExprStmt guard _ _ _ : quals) body list = do -- rule B above
core_guard <- dsLExpr guard
core_rest <- deListComp quals body list
return (mkIfThenElse core_guard core_rest list)
-- [e | let B, qs] = let B in [e | qs]
deListComp (LetStmt binds : quals) body list = do
core_rest <- deListComp quals body list
dsLocalBinds binds core_rest
deListComp (stmt@(TransformStmt {}) : quals) body list = do
(inner_list_expr, pat) <- dsTransformStmt stmt
deBindComp pat inner_list_expr quals body list
deListComp (stmt@(GroupStmt {}) : quals) body list = do
(inner_list_expr, pat) <- dsGroupStmt stmt
deBindComp pat inner_list_expr quals body list
deListComp (BindStmt pat list1 _ _ : quals) body core_list2 = do -- rule A' above
core_list1 <- dsLExpr list1
deBindComp pat core_list1 quals body core_list2
\end{code}
......@@ -282,10 +284,9 @@ deListComp (BindStmt pat list1 _ _ : quals) body core_list2 = do -- rule A' abov
deBindComp :: OutPat Id
-> CoreExpr
-> [Stmt Id]
-> LHsExpr Id
-> CoreExpr
-> DsM (Expr Id)
deBindComp pat core_list1 quals body core_list2 = do
deBindComp pat core_list1 quals core_list2 = do
let
u3_ty@u1_ty = exprType core_list1 -- two names, same thing
......@@ -302,7 +303,7 @@ deBindComp pat core_list1 quals body core_list2 = do
core_fail = App (Var h) (Var u3)
letrec_body = App (Var h) core_list1
rest_expr <- deListComp quals body core_fail
rest_expr <- deListComp quals core_fail
core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail
let
......@@ -337,48 +338,48 @@ TE[ e | p <- l , q ] c n = let
\begin{code}
dfListComp :: Id -> Id -- 'c' and 'n'
-> [Stmt Id] -- the rest of the qual's
-> LHsExpr Id
-> DsM CoreExpr
-- Last: the one to return
dfListComp c_id n_id [] body = do
core_body <- dsLExpr body
return (mkApps (Var c_id) [core_body, Var n_id])
dfListComp _ _ [] = panic "dfListComp"
dfListComp c_id n_id (LastStmt body _ : quals)
= ASSERT( null quals )
do { core_body <- dsLExpr body
; return (mkApps (Var c_id) [core_body, Var n_id]) }
-- Non-last: must be a guard
dfListComp c_id n_id (ExprStmt guard _ _ _ : quals) body = do
dfListComp c_id n_id (ExprStmt guard _ _ _ : quals) = do
core_guard <- dsLExpr guard
core_rest <- dfListComp c_id n_id quals body
core_rest <- dfListComp c_id n_id quals
return (mkIfThenElse core_guard core_rest (Var n_id))
dfListComp c_id n_id (LetStmt binds : quals) body = do
dfListComp c_id n_id (LetStmt binds : quals) = do
-- new in 1.3, local bindings
core_rest <- dfListComp c_id n_id quals body
core_rest <- dfListComp c_id n_id quals
dsLocalBinds binds core_rest
dfListComp c_id n_id (stmt@(TransformStmt {}) : quals) body = do
dfListComp c_id n_id (stmt@(TransformStmt {}) : quals) = do
(inner_list_expr, pat) <- dsTransformStmt stmt
-- Anyway, we bind the newly transformed list via the generic binding function
dfBindComp c_id n_id (pat, inner_list_expr) quals body
dfBindComp c_id n_id (pat, inner_list_expr) quals
dfListComp c_id n_id (stmt@(GroupStmt {}) : quals) body = do
dfListComp c_id n_id (stmt@(GroupStmt {}) : quals) = do
(inner_list_expr, pat) <- dsGroupStmt stmt
-- Anyway, we bind the newly grouped list via the generic binding function
dfBindComp c_id n_id (pat, inner_list_expr) quals body
dfBindComp c_id n_id (pat, inner_list_expr) quals
dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) body = do
dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) = do
-- evaluate the two lists
core_list1 <- dsLExpr list1
-- Do the rest of the work in the generic binding builder
dfBindComp c_id n_id (pat, core_list1) quals body
dfBindComp c_id n_id (pat, core_list1) quals
dfBindComp :: Id -> Id -- 'c' and 'n'
-> (LPat Id, CoreExpr)
-> [Stmt Id] -- the rest of the qual's
-> LHsExpr Id
-> DsM CoreExpr
dfBindComp c_id n_id (pat, core_list1) quals body = do
dfBindComp c_id n_id (pat, core_list1) quals = do
-- find the required type
let x_ty = hsLPatType pat
b_ty = idType n_id
......@@ -387,7 +388,7 @@ dfBindComp c_id n_id (pat, core_list1) quals body = do
[b, x] <- newSysLocalsDs [b_ty, x_ty]
-- build rest of the comprehesion
core_rest <- dfListComp c_id b quals body
core_rest <- dfListComp c_id b quals
-- build the pattern match
core_expr <- matchSimply (Var x) (StmtCtxt ListComp)
......@@ -482,9 +483,6 @@ mkUnzipBind elt_tys = do
unzip_fn_ty = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty
mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail
\end{code}
%************************************************************************
......@@ -500,11 +498,10 @@ mkUnzipBind elt_tys = do
-- [:e | qss:] = <<[:e | qss:]>> () [:():]
--
dsPArrComp :: [Stmt Id]
-> LHsExpr Id
-> Type -- Don't use; called with `undefined' below
-> DsM CoreExpr
dsPArrComp [ParStmt qss _ _ _] body _ = -- parallel comprehension
dePArrParComp qss body
-- Special case for parallel comprehension
dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals
-- Special case for simple generators:
--
......@@ -515,7 +512,7 @@ dsPArrComp [ParStmt qss _ _ _] body _ = -- parallel comprehension
-- <<[:e' | p <- e, qs:]>> =
-- <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)
--
dsPArrComp (BindStmt p e _ _ : qs) body _ = do
dsPArrComp (BindStmt p e _ _ : qs) = do
filterP <- dsLookupDPHId filterPName
ce <- dsLExpr e
let ety'ce = parrElemType ce
......@@ -525,38 +522,41 @@ dsPArrComp (BindStmt p e _ _ : qs) body _ = do
pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false
let gen | isIrrefutableHsPat p = ce
| otherwise = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
dePArrComp qs body p gen
dePArrComp qs p gen
dsPArrComp qs body _ = do -- no ParStmt in `qs'
dsPArrComp qs = do -- no ParStmt in `qs'
sglP <- dsLookupDPHId singletonPName
let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]
dePArrComp qs body (noLoc $ WildPat unitTy) unitArray
dePArrComp qs (noLoc $ WildPat unitTy) unitArray
-- the work horse
--
dePArrComp :: [Stmt Id]
-> LHsExpr Id
-> LPat Id -- the current generator pattern
-> CoreExpr -- the current generator expression
-> DsM CoreExpr
dePArrComp [] _ _ = panic "dePArrComp"
--
-- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
--
dePArrComp [] e' pa cea = do
mapP <- dsLookupDPHId mapPName
let ty = parrElemType cea
(clam, ty'e') <- deLambda ty pa e'
return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea]
dePArrComp (LastStmt e' _ : quals) pa cea
= ASSERT( null quals )
do { mapP <- dsLookupDPHId mapPName
; let ty = parrElemType cea
; (clam, ty'e') <- deLambda ty pa e'
; return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] }
--
-- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
--
dePArrComp (ExprStmt b _ _ _ : qs) body pa cea = do
dePArrComp (ExprStmt b _ _ _ : qs) pa cea = do
filterP <- dsLookupDPHId filterPName
let ty = parrElemType cea
(clam,_) <- deLambda ty pa b
dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea])
dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea])
--
-- <<[:e' | p <- e, qs:]>> pa ea =
......@@ -571,7 +571,7 @@ dePArrComp (ExprStmt b _ _ _ : qs) body pa cea = do
-- in
-- <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)
--
dePArrComp (BindStmt p e _ _ : qs) body pa cea = do
dePArrComp (BindStmt p e _ _ : qs) pa cea = do
filterP <- dsLookupDPHId filterPName
crossMapP <- dsLookupDPHId crossMapPName
ce <- dsLExpr e
......@@ -587,7 +587,7 @@ dePArrComp (BindStmt p e _ _ : qs) body pa cea = do
let ety'cef = ety'ce -- filter doesn't change the element type
pa' = mkLHsPatTup [pa, p]
dePArrComp qs body pa' (mkApps (Var crossMapP)
dePArrComp qs pa' (mkApps (Var crossMapP)
[Type ety'cea, Type ety'cef, cea, clam])
--
-- <<[:e' | let ds, qs:]>> pa ea =
......@@ -596,7 +596,7 @@ dePArrComp (BindStmt p e _ _ : qs) body pa cea = do
-- where
-- {x_1, ..., x_n} = DV (ds) -- Defined Variables
--
dePArrComp (LetStmt ds : qs) body pa cea = do
dePArrComp (LetStmt ds : qs) pa cea = do
mapP <- dsLookupDPHId mapPName
let xs = collectLocalBinders ds
ty'cea = parrElemType cea
......@@ -611,14 +611,14 @@ dePArrComp (LetStmt ds : qs) body pa cea = do
ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr
let pa' = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)]
proj = mkLams [v] ccase
dePArrComp qs body pa' (mkApps (Var mapP)
dePArrComp qs pa' (mkApps (Var mapP)
[Type ty'cea, Type errTy, proj, cea])
--
-- The parser guarantees that parallel comprehensions can only appear as
-- singeltons qualifier lists, which we already special case in the caller.
-- So, encountering one here is a bug.
--
dePArrComp (ParStmt _ _ _ _ : _) _ _ _ =
dePArrComp (ParStmt _ _ _ _ : _) _ _ =
panic "DsListComp.dePArrComp: malformed comprehension AST"
-- <<[:e' | qs | qss:]>> pa ea =
......@@ -627,17 +627,17 @@ dePArrComp (ParStmt _ _ _ _ : _) _ _ _ =
-- where
-- {x_1, ..., x_n} = DV (qs)
--
dePArrParComp :: [([LStmt Id], [Id])] -> LHsExpr Id -> DsM CoreExpr
dePArrParComp qss body = do
dePArrParComp :: [([LStmt Id], [Id])] -> [Stmt Id] -> DsM CoreExpr
dePArrParComp qss quals = do
(pQss, ceQss) <- deParStmt qss
dePArrComp [] body pQss ceQss
dePArrComp quals pQss ceQss
where
deParStmt [] =
-- empty parallel statement lists have no source representation
panic "DsListComp.dePArrComp: Empty parallel list comprehension"
deParStmt ((qs, xs):qss) = do -- first statement
let res_expr = mkLHsVarTuple xs
cqs <- dsPArrComp (map unLoc qs) res_expr undefined
cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
parStmts qss (mkLHsVarPatTup xs) cqs
---
parStmts [] pa cea = return (pa, cea)
......@@ -646,7 +646,7 @@ dePArrParComp qss body = do
let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs]
ty'cea = parrElemType cea
res_expr = mkLHsVarTuple xs
cqs <- dsPArrComp (map unLoc qs) res_expr undefined
cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
let ty'cqs = parrElemType cqs
cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
parStmts qss pa' cea'
......@@ -701,11 +701,9 @@ data DsMonadComp = DsMonadComp
-- Entry point for monad comprehension desugaring
--
dsMonadComp :: [LStmt Id] -- the statements
-> SyntaxExpr Id -- the "return" function
-> LHsExpr Id -- the body
-> Type -- the final type
-> DsM CoreExpr
dsMonadComp stmts return_op body res_ty
dsMonadComp stmts res_ty
= dsMcStmts stmts (DsMonadComp (Left return_op) body m_ty)
where
(m_ty, _) = tcSplitAppTy res_ty
......@@ -729,30 +727,33 @@ dsMcStmts ((L loc stmt) : lstmts) mc
= putSrcSpanDs loc (dsMcStmt stmt lstmts mc)
dsMcStmt :: Stmt Id
-> [LStmt Id]
-> DsMonadComp