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) = ...@@ -301,11 +301,9 @@ addTickHsExpr (HsLet binds e) =
liftM2 HsLet liftM2 HsLet
(addTickHsLocalBinds binds) -- to think about: !patterns. (addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsExprNeverOrAlways e) (addTickLHsExprNeverOrAlways e)
addTickHsExpr (HsDo cxt stmts last_exp return_exp srcloc) = do addTickHsExpr (HsDo cxt stmts srcloc)
(stmts', last_exp') <- addTickLStmts' forQual stmts = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
(addTickLHsExpr last_exp) ; return (HsDo cxt stmts' srcloc) }
return_exp' <- addTickSyntaxExpr hpcSrcSpan return_exp
return (HsDo cxt stmts' last_exp' return_exp' srcloc)
where where
forQual = case cxt of forQual = case cxt of
ListComp -> Just $ BinBox QualBinBox ListComp -> Just $ BinBox QualBinBox
...@@ -425,14 +423,16 @@ addTickLStmts isGuard stmts = do ...@@ -425,14 +423,16 @@ addTickLStmts isGuard stmts = do
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a
-> TM ([LStmt Id], a) -> TM ([LStmt Id], a)
addTickLStmts' isGuard lstmts res addTickLStmts' isGuard lstmts res
= bindLocals binders $ do = bindLocals (collectLStmtsBinders lstmts) $
lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
a <- res ; a <- res
return (lstmts', a) ; return (lstmts', a) }
where
binders = collectLStmtsBinders lstmts
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id) 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 addTickStmt _isGuard (BindStmt pat e bind fail) = do
liftM4 BindStmt liftM4 BindStmt
(addTickLPat pat) (addTickLPat pat)
...@@ -577,10 +577,9 @@ addTickHsCmd (HsLet binds c) = ...@@ -577,10 +577,9 @@ addTickHsCmd (HsLet binds c) =
liftM2 HsLet liftM2 HsLet
(addTickHsLocalBinds binds) -- to think about: !patterns. (addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsCmd c) (addTickLHsCmd c)
addTickHsCmd (HsDo cxt stmts last_exp return_exp srcloc) = do addTickHsCmd (HsDo cxt stmts srcloc)
(stmts', last_exp') <- addTickLCmdStmts' stmts (addTickLHsCmd last_exp) = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
return_exp' <- addTickSyntaxExpr hpcSrcSpan return_exp ; return (HsDo cxt stmts' srcloc) }
return (HsDo cxt stmts' last_exp' return_exp' srcloc)
addTickHsCmd (HsArrApp e1 e2 ty1 arr_ty lr) = addTickHsCmd (HsArrApp e1 e2 ty1 arr_ty lr) =
liftM5 HsArrApp liftM5 HsArrApp
......
...@@ -541,8 +541,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do ...@@ -541,8 +541,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do
core_body, core_body,
exprFreeVars core_binds `intersectVarSet` local_vars) exprFreeVars core_binds `intersectVarSet` local_vars)
dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts body _ _) dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _)
= dsCmdDo ids local_vars env_ids res_ty stmts body = 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 |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t
-- A | xs |- ci :: [tsi] ti -- A | xs |- ci :: [tsi] ti
...@@ -618,7 +618,6 @@ dsCmdDo :: DsCmdEnv -- arrow combinators ...@@ -618,7 +618,6 @@ dsCmdDo :: DsCmdEnv -- arrow combinators
-- so don't pull on it too early -- so don't pull on it too early
-> Type -- return type of the statement -> Type -- return type of the statement
-> [LStmt Id] -- statements to desugar -> [LStmt Id] -- statements to desugar
-> LHsExpr Id -- body
-> DsM (CoreExpr, -- desugared expression -> DsM (CoreExpr, -- desugared expression
IdSet) -- set of local vars that occur free IdSet) -- set of local vars that occur free
...@@ -626,15 +625,17 @@ dsCmdDo :: DsCmdEnv -- arrow combinators ...@@ -626,15 +625,17 @@ dsCmdDo :: DsCmdEnv -- arrow combinators
-- -------------------------- -- --------------------------
-- A | xs |- do { c } :: [] t -- 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 = 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 let
bound_vars = mkVarSet (collectLStmtBinders stmt) bound_vars = mkVarSet (collectLStmtBinders stmt)
local_vars' = local_vars `unionVarSet` bound_vars local_vars' = local_vars `unionVarSet` bound_vars
(core_stmts, _, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do (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)) return (core_stmts, fv_stmts, varSetElems fv_stmts))
(core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt
return (do_compose ids return (do_compose ids
......
This diff is collapsed.
This diff is collapsed.
...@@ -23,6 +23,7 @@ import Name ...@@ -23,6 +23,7 @@ import Name
import BasicTypes import BasicTypes
import DataCon import DataCon
import SrcLoc import SrcLoc
import Util( dropTail )
import Outputable import Outputable
import FastString import FastString
...@@ -146,10 +147,6 @@ data HsExpr id ...@@ -146,10 +147,6 @@ data HsExpr id
-- because in this context we never use -- because in this context we never use
-- the PatGuard or ParStmt variant -- the PatGuard or ParStmt variant
[LStmt id] -- "do":one or more stmts [LStmt id] -- "do":one or more stmts
(LHsExpr id) -- The body; the last expression in the
-- 'do' of [ body | ... ] in a list comp
(SyntaxExpr id) -- The 'return' function, see Note
-- [Monad Comprehensions]
PostTcType -- Type of the whole expression PostTcType -- Type of the whole expression
| ExplicitList -- syntactic list | ExplicitList -- syntactic list
...@@ -441,7 +438,7 @@ ppr_expr (HsLet binds expr) ...@@ -441,7 +438,7 @@ ppr_expr (HsLet binds expr)
= sep [hang (ptext (sLit "let")) 2 (pprBinds binds), = sep [hang (ptext (sLit "let")) 2 (pprBinds binds),
hang (ptext (sLit "in")) 2 (ppr expr)] hang (ptext (sLit "in")) 2 (ppr expr)]
ppr_expr (HsDo do_or_list_comp stmts body _ _) = pprDo do_or_list_comp stmts body ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts
ppr_expr (ExplicitList _ exprs) ppr_expr (ExplicitList _ exprs)
= brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
...@@ -577,7 +574,7 @@ pprParendExpr expr ...@@ -577,7 +574,7 @@ pprParendExpr expr
HsPar {} -> pp_as_was HsPar {} -> pp_as_was
HsBracket {} -> pp_as_was HsBracket {} -> pp_as_was
HsBracketOut _ [] -> pp_as_was HsBracketOut _ [] -> pp_as_was
HsDo sc _ _ _ _ HsDo sc _ _
| isListCompExpr sc -> pp_as_was | isListCompExpr sc -> pp_as_was
_ -> parens pp_as_was _ -> parens pp_as_was
...@@ -835,7 +832,12 @@ type Stmt id = StmtLR id id ...@@ -835,7 +832,12 @@ type Stmt id = StmtLR id id
-- The SyntaxExprs in here are used *only* for do-notation and monad -- The SyntaxExprs in here are used *only* for do-notation and monad
-- comprehensions, which have rebindable syntax. Otherwise they are unused. -- comprehensions, which have rebindable syntax. Otherwise they are unused.
data StmtLR idL idR data StmtLR idL idR
= BindStmt (LPat idL) = LastStmt -- Always the last Stmt in ListComp, MonadComp, PArrComp, DoExpr, MDoExpr
-- Not used for GhciStmt, PatGuard, which scope over other stuff
(LHsExpr idR)
(SyntaxExpr idR) -- The return operator, used only for MonadComp
-- See Note [Monad Comprehensions]
| BindStmt (LPat idL)
(LHsExpr idR) (LHsExpr idR)
(SyntaxExpr idR) -- The (>>=) operator (SyntaxExpr idR) -- The (>>=) operator
(SyntaxExpr idR) -- The fail operator (SyntaxExpr idR) -- The fail operator
...@@ -852,9 +854,10 @@ data StmtLR idL idR ...@@ -852,9 +854,10 @@ data StmtLR idL idR
-- ParStmts only occur in a list/monad comprehension -- ParStmts only occur in a list/monad comprehension
| ParStmt [([LStmt idL], [idR])] | ParStmt [([LStmt idL], [idR])]
(SyntaxExpr idR) -- polymorphic `mzip` for monad comprehensions (SyntaxExpr idR) -- Polymorphic `mzip` for monad comprehensions
(SyntaxExpr idR) -- The `>>=` operator (SyntaxExpr idR) -- The `>>=` operator
(SyntaxExpr idR) -- polymorphic `return` operator (SyntaxExpr idR) -- Polymorphic `return` operator
-- with type (forall a. a -> m a)
-- See notes [Monad Comprehensions] -- See notes [Monad Comprehensions]
-- After renaming, the ids are the binders bound by the stmts and used -- After renaming, the ids are the binders bound by the stmts and used
...@@ -926,6 +929,10 @@ data StmtLR idL idR ...@@ -926,6 +929,10 @@ data StmtLR idL idR
-- because the Id may be *polymorphic*, but -- because the Id may be *polymorphic*, but
-- the returned thing has to be *monomorphic*, -- the returned thing has to be *monomorphic*,
-- so they may be type applications -- so they may be type applications
, recS_ret_ty :: PostTcType -- The type of of do { stmts; return (a,b,c) }
-- With rebindable syntax the type might not
-- be quite as simple as (m (tya, tyb, tyc)).
} }
deriving (Data, Typeable) deriving (Data, Typeable)
\end{code} \end{code}
...@@ -1022,10 +1029,10 @@ where v1..vn are the later_ids ...@@ -1022,10 +1029,10 @@ where v1..vn are the later_ids
Note [Monad Comprehensions] Note [Monad Comprehensions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~
Monad comprehensions require seperate functions like 'return' and '>>=' for Monad comprehensions require separate functions like 'return' and
desugaring. These functions are stored in the 'HsDo' expression and the '>>=' for desugaring. These functions are stored in the statements
statements used in monad comprehensions. For example, the 'return' of the used in monad comprehensions. For example, the 'return' of the 'LastStmt'
'HsDo' expression is used to lift the body of the monad comprehension: expression is used to lift the body of the monad comprehension:
[ body | stmts ] [ body | stmts ]
=> =>
...@@ -1065,6 +1072,7 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (StmtLR idL idR) ...@@ -1065,6 +1072,7 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (StmtLR idL idR)
ppr stmt = pprStmt stmt ppr stmt = pprStmt stmt
pprStmt :: (OutputableBndr idL, OutputableBndr idR) => (StmtLR idL idR) -> SDoc pprStmt :: (OutputableBndr idL, OutputableBndr idR) => (StmtLR idL idR) -> SDoc
pprStmt (LastStmt expr _) = ppr expr
pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, ptext (sLit "<-"), ppr expr] pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, ptext (sLit "<-"), ppr expr]
pprStmt (LetStmt binds) = hsep [ptext (sLit "let"), pprBinds binds] pprStmt (LetStmt binds) = hsep [ptext (sLit "let"), pprBinds binds]
pprStmt (ExprStmt expr _ _ _) = ppr expr pprStmt (ExprStmt expr _ _ _) = ppr expr
...@@ -1103,28 +1111,32 @@ pprBy :: OutputableBndr id => Maybe (LHsExpr id) -> SDoc ...@@ -1103,28 +1111,32 @@ pprBy :: OutputableBndr id => Maybe (LHsExpr id) -> SDoc
pprBy Nothing = empty pprBy Nothing = empty
pprBy (Just e) = ptext (sLit "by") <+> ppr e pprBy (Just e) = ptext (sLit "by") <+> ppr e
pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> SDoc
pprDo DoExpr stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body pprDo DoExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts
pprDo GhciStmt stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body pprDo GhciStmt stmts = ptext (sLit "do") <+> ppr_do_stmts stmts
pprDo MDoExpr stmts body = ptext (sLit "mdo") <+> ppr_do_stmts stmts body pprDo MDoExpr stmts = ptext (sLit "mdo") <+> ppr_do_stmts stmts
pprDo ListComp stmts body = brackets $ pprComp stmts body pprDo ListComp stmts = brackets $ pprComp stmts
pprDo PArrComp stmts body = pa_brackets $ pprComp stmts body pprDo PArrComp stmts = pa_brackets $ pprComp stmts
pprDo MonadComp stmts body = brackets $ pprComp stmts body pprDo MonadComp stmts = brackets $ pprComp stmts
pprDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt
ppr_do_stmts :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc ppr_do_stmts :: OutputableBndr id => [LStmt id] -> SDoc
-- Print a bunch of do stmts, with explicit braces and semicolons, -- Print a bunch of do stmts, with explicit braces and semicolons,
-- so that we are not vulnerable to layout bugs -- so that we are not vulnerable to layout bugs
ppr_do_stmts stmts body ppr_do_stmts stmts
= lbrace <+> pprDeeperList vcat ([ppr s <> semi | s <- stmts] ++ [ppr body]) = lbrace <+> pprDeeperList vcat ([ppr s <> semi | s <- stmts])
<+> rbrace <+> rbrace
ppr_lc_stmts :: OutputableBndr id => [LStmt id] -> [SDoc] ppr_lc_stmts :: OutputableBndr id => [LStmt id] -> [SDoc]
ppr_lc_stmts stmts = [ppr s <> comma | s <- stmts] ppr_lc_stmts stmts = [ppr s <> comma | s <- stmts]
pprComp :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc pprComp :: OutputableBndr id => [LStmt id] -> SDoc
pprComp quals body -- Prints: body | qual1, ..., qualn pprComp quals -- Prints: body | qual1, ..., qualn
= hang (ppr body <+> char '|') 2 (interpp'SP quals) | not (null quals)
, L _ (LastStmt body _) <- last quals
= hang (ppr body <+> char '|') 2 (interpp'SP (dropTail 1 quals))
| otherwise
= pprPanic "pprComp" (interpp'SP quals)
\end{code} \end{code}
%************************************************************************ %************************************************************************
...@@ -1242,11 +1254,13 @@ data HsMatchContext id -- Context of a Match ...@@ -1242,11 +1254,13 @@ data HsMatchContext id -- Context of a Match
data HsStmtContext id data HsStmtContext id
= ListComp = ListComp
| DoExpr
| GhciStmt -- A command-line Stmt in GHCi pat <- rhs
| MDoExpr -- Recursive do-expression
| MonadComp | MonadComp
| PArrComp -- Parallel array comprehension | PArrComp -- Parallel array comprehension
| DoExpr -- do { ... }
| MDoExpr -- mdo { ... } ie recursive do-expression
| GhciStmt -- A command-line Stmt in GHCi pat <- rhs
| PatGuard (HsMatchContext id) -- Pattern guard for specified thing | PatGuard (HsMatchContext id) -- Pattern guard for specified thing
| ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt | ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt
| TransformStmtCtxt (HsStmtContext id) -- A branch of a transform stmt | TransformStmtCtxt (HsStmtContext id) -- A branch of a transform stmt
......
...@@ -21,7 +21,7 @@ module HsUtils( ...@@ -21,7 +21,7 @@ module HsUtils(
mkMatchGroup, mkMatch, mkHsLam, mkHsIf, mkMatchGroup, mkMatch, mkHsLam, mkHsIf,
mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI, mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI,
coiToHsWrapper, mkHsLams, mkHsDictLet, coiToHsWrapper, mkHsLams, mkHsDictLet,
mkHsOpApp, mkHsDo, mkHsWrapPat, mkHsWrapPatCoI, mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCoI, mkDoStmts,
nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
...@@ -42,7 +42,7 @@ module HsUtils( ...@@ -42,7 +42,7 @@ module HsUtils(
nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp, nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp,
-- Stmts -- Stmts
mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, mkLastStmt,
mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt, mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt,
emptyRecStmt, mkRecStmt, emptyRecStmt, mkRecStmt,
...@@ -190,7 +190,9 @@ mkSimpleHsAlt pat expr ...@@ -190,7 +190,9 @@ mkSimpleHsAlt pat expr
mkHsIntegral :: Integer -> PostTcType -> HsOverLit id mkHsIntegral :: Integer -> PostTcType -> HsOverLit id
mkHsFractional :: Rational -> PostTcType -> HsOverLit id mkHsFractional :: Rational -> PostTcType -> HsOverLit id
mkHsIsString :: FastString -> PostTcType -> HsOverLit id mkHsIsString :: FastString -> PostTcType -> HsOverLit id
mkHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id mkHsDo :: HsStmtContext Name -> [LStmt id] -> HsExpr id
mkHsComp :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id
mkDoStmts :: [LStmt id] -> [LStmt id]
mkNPat :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id mkNPat :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id
mkNPlusKPat :: Located id -> HsOverLit id -> Pat id mkNPlusKPat :: Located id -> HsOverLit id -> Pat id
...@@ -198,6 +200,7 @@ mkNPlusKPat :: Located id -> HsOverLit id -> Pat id ...@@ -198,6 +200,7 @@ mkNPlusKPat :: Located id -> HsOverLit id -> Pat id
mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> 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 mkExprStmt :: LHsExpr idR -> StmtLR idL idR
mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR
...@@ -212,7 +215,15 @@ mkHsIsString s = OverLit (HsIsString s) noRebindableInfo noSyntaxExpr ...@@ -212,7 +215,15 @@ mkHsIsString s = OverLit (HsIsString s) noRebindableInfo noSyntaxExpr
noRebindableInfo :: Bool noRebindableInfo :: Bool
noRebindableInfo = error "noRebindableInfo" -- Just another placeholder; noRebindableInfo = error "noRebindableInfo" -- Just another placeholder;
mkHsDo ctxt stmts body = HsDo ctxt stmts body noSyntaxExpr placeHolderType -- mkDoStmts turns a trailing ExprStmt into a LastStmt
mkDoStmts [L loc (ExprStmt e _ _ _)] = [L loc (mkLastStmt e)]
mkDoStmts (s:ss) = s : mkDoStmts ss
mkDoStmts [] = []
mkHsDo ctxt stmts = HsDo ctxt stmts placeHolderType
mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
where
last_stmt = L (getLoc expr) $ mkLastStmt expr
mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id
mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
...@@ -231,13 +242,14 @@ mkGroupUsingStmt stmts usingExpr = GroupStmt stmts [] Nothing (Le ...@@ -231,13 +242,14 @@ mkGroupUsingStmt stmts usingExpr = GroupStmt stmts [] Nothing (Le
mkGroupByStmt stmts byExpr = GroupStmt stmts [] (Just byExpr) (Right noSyntaxExpr) noSyntaxExpr noSyntaxExpr noSyntaxExpr mkGroupByStmt stmts byExpr = GroupStmt stmts [] (Just byExpr) (Right noSyntaxExpr) noSyntaxExpr noSyntaxExpr noSyntaxExpr
mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt stmts [] (Just byExpr) (Left usingExpr) noSyntaxExpr noSyntaxExpr noSyntaxExpr mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt stmts [] (Just byExpr) (Left usingExpr) noSyntaxExpr noSyntaxExpr noSyntaxExpr
mkLastStmt expr = LastStmt expr noSyntaxExpr
mkExprStmt expr = ExprStmt expr noSyntaxExpr noSyntaxExpr placeHolderType mkExprStmt expr = ExprStmt expr noSyntaxExpr noSyntaxExpr placeHolderType
mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = [] emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = []
, recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr
, recS_bind_fn = noSyntaxExpr , recS_bind_fn = noSyntaxExpr
, recS_rec_rets = [] } , recS_rec_rets = [], recS_ret_ty = placeHolderType }
mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
...@@ -327,8 +339,8 @@ nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) ...@@ -327,8 +339,8 @@ nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
nlWildPat :: LPat id nlWildPat :: LPat id
nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking
nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id
nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body) nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
...@@ -496,7 +508,8 @@ collectStmtBinders :: StmtLR idL idR -> [idL] ...@@ -496,7 +508,8 @@ collectStmtBinders :: StmtLR idL idR -> [idL]
-- Id Binders for a Stmt... [but what about pattern-sig type vars]? -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
collectStmtBinders (LetStmt binds) = collectLocalBinders binds collectStmtBinders (LetStmt binds) = collectLocalBinders binds
collectStmtBinders (ExprStmt _ _ _ _) = [] collectStmtBinders (ExprStmt {}) = []
collectStmtBinders (LastStmt {}) = []
collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders
$ concatMap fst xs $ concatMap fst xs
collectStmtBinders (TransformStmt stmts _ _ _ _ _) = collectLStmtsBinders stmts collectStmtBinders (TransformStmt stmts _ _ _ _ _) = collectLStmtsBinders stmts
...@@ -642,7 +655,8 @@ lStmtsImplicits = hs_lstmts ...@@ -642,7 +655,8 @@ lStmtsImplicits = hs_lstmts
hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat
hs_stmt (LetStmt binds) = hs_local_binds binds hs_stmt (LetStmt binds) = hs_local_binds binds
hs_stmt (ExprStmt _ _ _ _) = emptyNameSet hs_stmt (ExprStmt {}) = emptyNameSet
hs_stmt (LastStmt {}) = emptyNameSet
hs_stmt (ParStmt xs _ _ _) = hs_lstmts $ concatMap fst xs hs_stmt (ParStmt xs _ _ _) = hs_lstmts $ concatMap fst xs
hs_stmt (TransformStmt stmts _ _ _ _ _) = hs_lstmts stmts hs_stmt (TransformStmt stmts _ _ _ _ _) = hs_lstmts stmts
......
...@@ -1283,14 +1283,9 @@ exp10 :: { LHsExpr RdrName } ...@@ -1283,14 +1283,9 @@ exp10 :: { LHsExpr RdrName }
| 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) } | 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
| '-' fexp { LL $ NegApp $2 noSyntaxExpr } | '-' fexp { LL $ NegApp $2 noSyntaxExpr }
| 'do' stmtlist {% let loc = comb2 $1 $2 in | 'do' stmtlist { L (comb2 $1 $2) (mkHsDo DoExpr (unLoc $2)) }
checkDo loc (unLoc $2) >>= \ (stmts,body) -> | 'mdo' stmtlist { L (comb2 $1 $2) (mkHsDo MDoExpr (unLoc $2)) }
return (L loc (mkHsDo DoExpr stmts body)) }
| 'mdo' stmtlist {% let loc = comb2 $1 $2 in
checkDo loc (unLoc $2) >>= \ (stmts,body) ->
return (L loc (mkHsDo MDoExpr
[L loc (mkRecStmt stmts)]
body)) }
| scc_annot exp { LL $ if opt_SccProfilingOn | scc_annot exp { LL $ if opt_SccProfilingOn
then HsSCC (unLoc $1) $2 then HsSCC (unLoc $1) $2
else HsPar $2 } else HsPar $2 }
...@@ -1465,8 +1460,10 @@ list :: { LHsExpr RdrName } ...@@ -1465,8 +1460,10 @@ list :: { LHsExpr RdrName }
| texp ',' exp '..' { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) } | texp ',' exp '..' { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) }
| texp '..' exp { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) } | texp '..' exp { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) }
| texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) } | texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) }
| texp '|' flattenedpquals {% checkMonadComp >>= \ ctxt -> | texp '|' flattenedpquals
return (sL (comb2 $1 $>) $ mkHsDo ctxt (unLoc $3) $1) } {% checkMonadComp >>= \ ctxt ->
return (sL (comb2 $1 $>) $
mkHsComp ctxt (unLoc $3) $1) }
lexps :: { Located [LHsExpr RdrName] } lexps :: { Located [LHsExpr RdrName] }
: lexps ',' texp { LL (((:) $! $3) $! unLoc $1) } : lexps ',' texp { LL (((:) $! $3) $! unLoc $1) }
...@@ -1538,7 +1535,7 @@ parr :: { LHsExpr RdrName } ...@@ -1538,7 +1535,7 @@ parr :: { LHsExpr RdrName }
(reverse (unLoc $1)) } (reverse (unLoc $1)) }
| texp '..' exp { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) } | texp '..' exp { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) }
| texp ',' exp '..' exp { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) } | texp ',' exp '..' exp { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) }
| texp '|' flattenedpquals { LL $ mkHsDo PArrComp (unLoc $3) $1 } | texp '|' flattenedpquals { LL $ mkHsComp PArrComp (unLoc $3) $1 }
-- We are reusing `lexps' and `flattenedpquals' from the list case. -- We are reusing `lexps' and `flattenedpquals' from the list case.
...@@ -1605,7 +1602,7 @@ apats :: { [LPat RdrName] } ...@@ -1605,7 +1602,7 @@ apats :: { [LPat RdrName] }
-- Statement sequences -- Statement sequences
stmtlist :: { Located [LStmt RdrName] } stmtlist :: { Located [LStmt RdrName] }
: '{' stmts '}' { LL (unLoc $2) } : '{' stmts '}' { LL (mkDoStmts (unLoc $2)) }
| vocurly stmts close { $2 } | vocurly stmts close { $2 }
-- do { ;; s ; s ; ; s ;; } -- do { ;; s ; s ; ; s ;; }
......
...@@ -40,8 +40,6 @@ module RdrHsSyn ( ...@@ -40,8 +40,6 @@ module RdrHsSyn (
checkPattern, -- HsExp -> P HsPat checkPattern, -- HsExp -> P HsPat
bang_RDR, bang_RDR,
checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat] checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
checkDo, -- [Stmt] -> P [Stmt]
checkMDo, -- [Stmt] -> P [Stmt]
checkMonadComp, -- P (HsStmtContext RdrName) checkMonadComp, -- P (HsStmtContext RdrName)
checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
...@@ -613,34 +611,6 @@ checkPred (L spn ty) ...@@ -613,34 +611,6 @@ checkPred (L spn ty)
check loc _ _ = parseErrorSDoc loc check loc _ _ = parseErrorSDoc loc
(text "malformed class assertion:" <+> ppr ty) (text "malformed class assertion:" <+> ppr ty)
---------------------------------------------------------------------------
-- Checking statements in a do-expression
-- We parse do { e1 ; e2 ; }
-- as [ExprStmt e1, ExprStmt e2]
-- checkDo (a) checks that the last thing is an ExprStmt
-- (b) returns it separately
-- same comments apply for mdo as well
checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
checkDo = checkDoMDo "a " "'do'"
checkMDo = checkDoMDo "an " "'mdo'"
checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
checkDoMDo _ nm loc [] = parseErrorSDoc loc (text ("Empty " ++ nm ++ " construct"))
checkDoMDo pre nm _ ss = do
check ss
where
check [] = panic "RdrHsSyn:checkDoMDo"
check [L _ (ExprStmt e _ _ _)] = return ([], e)
check [L l e] = parseErrorSDoc l
(text ("The last statement in " ++ pre ++ nm ++
" construct must be an expression:")
$$ ppr e)
check (s:ss) = do
(ss',e') <- check ss
return ((s:ss'),e')
-- ------------------------------------------------------------------------- -- -------------------------------------------------------------------------
-- Checking Patterns. -- Checking Patterns.
......
...@@ -160,6 +160,7 @@ basicKnownKeyNames ...@@ -160,6 +160,7 @@ basicKnownKeyNames
-- Monad stuff -- Monad stuff
thenIOName, bindIOName, returnIOName, failIOName, thenIOName, bindIOName, returnIOName, failIOName,
failMName, bindMName, thenMName, returnMName, failMName, bindMName, thenMName, returnMName,
fmapName,
-- MonadRec stuff -- MonadRec stuff
mfixName, mfixName,
...@@ -612,6 +613,7 @@ eqName = methName gHC_CLASSES (fsLit "==") eqClassOpKey ...@@ -612,6 +613,7 @@ eqName = methName gHC_CLASSES (fsLit "==") eqClassOpKey
ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey
geName = methName gHC_CLASSES (fsLit ">=") geClassOpKey geName = methName gHC_CLASSES (fsLit ">=") geClassOpKey
functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey
fmapName = methName gHC_BASE (fsLit "fmap") fmapClassOpKey
-- Class Monad -- Class Monad
monadClassName, thenMName, bindMName, returnMName, failMName :: Name monadClassName, thenMName, bindMName, returnMName, failMName :: Name
...@@ -1312,6 +1314,7 @@ negateClassOpKey = mkPreludeMiscIdUnique 111 ...@@ -1312,6 +1314,7 @@ negateClassOpKey = mkPreludeMiscIdUnique 111
failMClassOpKey = mkPreludeMiscIdUnique 112 failMClassOpKey = mkPreludeMiscIdUnique 112
bindMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=) bindMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=)
thenMClassOpKey = mkPreludeMiscIdUnique 114 -- (>>) thenMClassOpKey = mkPreludeMiscIdUnique 114 -- (>>)
fmapClassOpKey = mkPreludeMiscIdUnique 115
returnMClassOpKey = mkPreludeMiscIdUnique 117 returnMClassOpKey = mkPreludeMiscIdUnique 117
-- Recursive do notation -- Recursive do notation
......
This diff is collapsed.
...@@ -415,8 +415,8 @@ tcExpr (HsIf (Just fun) pred b1 b2) res_ty -- Note [Rebindable syntax for if] ...@@ -415,8 +415,8 @@ tcExpr (HsIf (Just fun) pred b1 b2) res_ty -- Note [Rebindable syntax for if]
-- and it maintains uniformity with other rebindable syntax -- and it maintains uniformity with other rebindable syntax
; return (HsIf (Just fun') pred' b1' b2') } ; return (HsIf (Just fun') pred' b1' b2') }
tcExpr (HsDo do_or_lc stmts body return_op _) res_ty tcExpr (HsDo do_or_lc stmts _) res_ty
= tcDoStmts do_or_lc stmts body return_op res_ty = tcDoStmts do_or_lc stmts res_ty
tcExpr (HsProc pat cmd) res_ty tcExpr (HsProc pat cmd) res_ty
= do { (pat', cmd', coi) <- tcProc pat cmd res_ty = do { (pat', cmd', coi) <- tcProc pat cmd res_ty
......
...@@ -779,7 +779,7 @@ gen_Ix_binds loc tycon ...@@ -779,7 +779,7 @@ gen_Ix_binds loc tycon
single_con_range single_con_range
= mk_easy_FunBind loc range_RDR = mk_easy_FunBind loc range_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $ [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
nlHsDo ListComp stmts con_expr noLoc (mkHsComp ListComp stmts con_expr)
where where
stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
...@@ -893,7 +893,7 @@ gen_Read_binds get_fixity loc tycon ...@@ -893,7 +893,7 @@ gen_Read_binds get_fixity loc tycon
read_nullary_cons read_nullary_cons
= case nullary_cons of = case nullary_cons of
[] -> [] [] -> []
[con] -> [nlHsDo DoExpr (match_con con) (result_expr con [])] [con] -> [nlHsDo DoExpr (match_con con ++ [mkExprStmt (result_expr con [])])]
_ -> [nlHsApp (nlHsVar choose_RDR) _ -> [nlHsApp (nlHsVar choose_RDR)
(nlList (map mk_pair nullary_cons))] (nlList (map mk_pair nullary_cons))]
-- NB For operators the parens around (:=:) are matched by the -- NB For operators the parens around (:=:) are matched by the
...@@ -965,11 +965,12 @@ gen_Read_binds get_fixity loc tycon ...@@ -965,11 +965,12 @@ gen_Read_binds get_fixity loc tycon
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- Helpers -- Helpers
------------------------------------------------------------------------ ------------------------------------------------------------------------
mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b }) mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b })
bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP , nlHsDo DoExpr (ss ++ [mkExprStmt b])]
con_app con as = nlHsVarApps (getRdrName con) as -- con as bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) con_app con as = nlHsVarApps (getRdrName con) as -- con as
result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c' punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
......
...@@ -578,12 +578,10 @@ zonkExpr env (HsLet binds expr) ...@@ -578,12 +578,10 @@ zonkExpr env (HsLet binds expr)
zonkLExpr new_env expr `thenM` \ new_expr -> zonkLExpr new_env expr `thenM` \ new_expr ->
returnM (HsLet new_binds new_expr) returnM (HsLet new_binds new_expr)
zonkExpr env (HsDo do_or_lc stmts body return_op ty) zonkExpr env (HsDo do_or_lc stmts ty)
= zonkStmts env stmts `thenM` \ (new_env, new_stmts) -> = zonkStmts env stmts `thenM` \ (_, new_stmts) ->
zonkLExpr new_env body `thenM` \ new_body ->
zonkExpr new_env return_op `thenM` \ new_return ->
zonkTcTypeToType env ty `thenM` \ new_ty -> zonkTcTypeToType env ty `thenM` \ new_ty ->
returnM (HsDo do_or_lc new_stmts new_body new_return new_ty) returnM (HsDo do_or_lc new_stmts new_ty)
zonkExpr env (ExplicitList ty exprs) zonkExpr env (ExplicitList ty exprs)
= zonkTcTypeToType env ty `thenM` \ new_ty -> = zonkTcTypeToType env ty `thenM` \ new_ty ->
...@@ -745,9 +743,10 @@ zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op return_op) ...@@ -745,9 +743,10 @@ zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op return_op)
zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
, recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id
, recS_rec_rets = rets }) , recS_rec_rets = rets, redS_ret_ty = ret_ty })
= do { new_rvs <- zonkIdBndrs env rvs = do { new_rvs <- zonkIdBndrs env rvs
; new_lvs <- zonkIdBndrs env lvs ; new_lvs <- zonkIdBndrs env lvs
; new_ret_ty <- zonkTcTypeToType env ret_ty
; new_ret_id <- zonkExpr env ret_id ; new_ret_id <- zonkExpr env ret_id
; new_mfix_id <- zonkExpr env mfix_id ; new_mfix_id <- zonkExpr env mfix_id
; new_bind_id <- zonkExpr env bind_id ; new_bind_id <- zonkExpr env bind_id
...@@ -760,7 +759,7 @@ zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_id ...@@ -760,7 +759,7 @@ zonkStmt env (Re