Skip to content

GitLab

GHC
GHC
Commit 3bb700d5 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files
Options

Final batch of monad-comprehension stuff 

* Do-notation in arrows is marked with HsStmtContext = ArrowExpr
* tcMDoStmt (which was only used for arrows) is moved
  to TcArrows, and renamed tcArrDoStmt
* Improved documentation in the user manual
* Lots of other minor changes
parent 4b73bcc1
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 416 additions and 282 deletions
compiler/deSugar/Coverage.lhs
View file @ 3bb700d5
......@@ -431,7 +431,7 @@ addTickLStmts' isGuard lstmts res
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
addTickStmt _isGuard (LastStmt e ret) = do
liftM2 LastStmt
(addTickLHsExprAlways e)
(addTickLHsExpr e)
(addTickSyntaxExpr hpcSrcSpan ret)
addTickStmt _isGuard (BindStmt pat e bind fail) = do
liftM4 BindStmt
......@@ -633,6 +633,10 @@ addTickCmdStmt (BindStmt pat c bind fail) = do
(addTickLHsCmd c)
(return bind)
(return fail)
addTickCmdStmt (LastStmt c ret) = do
liftM2 LastStmt
(addTickLHsCmd c)
(addTickSyntaxExpr hpcSrcSpan ret)
addTickCmdStmt (ExprStmt c bind' guard' ty) = do
liftM4 ExprStmt
(addTickLHsCmd c)
......
compiler/deSugar/DsListComp.lhs
View file @ 3bb700d5
......@@ -120,7 +120,7 @@ dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderM
-- Generate the expressions to build the grouped list
let -- First we apply the grouping function to the inner list
inner_list_expr = mkApps usingExpr' (Type from_tup_ty : usingArgs)
inner_list_expr = mkApps usingExpr' usingArgs
-- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists
-- We make sure we instantiate the type variable "a" to be a list of "from" tuples and
-- the "b" to be a tuple of "to" lists!
......@@ -861,11 +861,11 @@ mkMcUnzipM ThenForm _ ys _
mkMcUnzipM _ fmap_op ys elt_tys
= do { fmap_op' <- dsExpr fmap_op
; xs <- mapM newSysLocalDs elt_tys
; tup_xs <- newSysLocalDs (mkBigCoreTupTy elt_tys)
; let arg_ty = idType ys
mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b
[ Type arg_ty, Type (elt_tys !! i)
; let tup_ty = mkBigCoreTupTy elt_tys
; tup_xs <- newSysLocalDs tup_ty
; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b
[ Type tup_ty, Type (elt_tys !! i)
, mk_sel i, Var ys]
mk_sel n = Lam tup_xs $
......
compiler/hsSyn/HsExpr.lhs
View file @ 3bb700d5
......@@ -1116,6 +1116,7 @@ pprBy (Just e) = ptext (sLit "by") <+> ppr e
pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> SDoc
pprDo DoExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts
pprDo GhciStmt stmts = ptext (sLit "do") <+> ppr_do_stmts stmts
pprDo ArrowExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts
pprDo MDoExpr stmts = ptext (sLit "mdo") <+> ppr_do_stmts stmts
pprDo ListComp stmts = brackets $ pprComp stmts
pprDo PArrComp stmts = pa_brackets $ pprComp stmts
......@@ -1261,32 +1262,28 @@ data HsStmtContext id
| DoExpr -- do { ... }
| MDoExpr -- mdo { ... } ie recursive do-expression
| ArrowExpr -- do-notation in an arrow-command context
| GhciStmt -- A command-line Stmt in GHCi pat <- rhs
| PatGuard (HsMatchContext id) -- Pattern guard for specified thing
| ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt
| TransformStmtCtxt (HsStmtContext id) -- A branch of a transform stmt
| TransStmtCtxt (HsStmtContext id) -- A branch of a transform stmt
deriving (Data, Typeable)
\end{code}
\begin{code}
isDoExpr :: HsStmtContext id -> Bool
isDoExpr DoExpr = True
isDoExpr MDoExpr = True
isDoExpr GhciStmt = True
isDoExpr _ = False
isListCompExpr :: HsStmtContext id -> Bool
-- Uses syntax [ e | quals ]
isListCompExpr ListComp = True
isListCompExpr PArrComp = True
isListCompExpr MonadComp = True
isListCompExpr _ = False
isMonadCompExpr :: HsStmtContext id -> Bool
isMonadCompExpr MonadComp = True
isMonadCompExpr (ParStmtCtxt ctxt) = isMonadCompExpr ctxt
isMonadCompExpr (TransformStmtCtxt ctxt) = isMonadCompExpr ctxt
isMonadCompExpr _ = False
isMonadCompExpr MonadComp = True
isMonadCompExpr (ParStmtCtxt ctxt) = isMonadCompExpr ctxt
isMonadCompExpr (TransStmtCtxt ctxt) = isMonadCompExpr ctxt
isMonadCompExpr _ = False
\end{code}
\begin{code}
......@@ -1340,6 +1337,7 @@ pprAStmtContext ctxt = article <+> pprStmtContext ctxt
pprStmtContext GhciStmt = ptext (sLit "interactive GHCi command")
pprStmtContext DoExpr = ptext (sLit "'do' block")
pprStmtContext MDoExpr = ptext (sLit "'mdo' block")
pprStmtContext ArrowExpr = ptext (sLit "'do' block in an arrow command")
pprStmtContext ListComp = ptext (sLit "list comprehension")
pprStmtContext MonadComp = ptext (sLit "monad comprehension")
pprStmtContext PArrComp = ptext (sLit "array comprehension")
......@@ -1353,7 +1351,7 @@ pprStmtContext (PatGuard ctxt) = ptext (sLit "pattern guard for") $$ pprMatchCon
pprStmtContext (ParStmtCtxt c)
| opt_PprStyle_Debug = sep [ptext (sLit "parallel branch of"), pprAStmtContext c]
| otherwise = pprStmtContext c
pprStmtContext (TransformStmtCtxt c)
pprStmtContext (TransStmtCtxt c)
| opt_PprStyle_Debug = sep [ptext (sLit "transformed branch of"), pprAStmtContext c]
| otherwise = pprStmtContext c
......@@ -1367,15 +1365,16 @@ matchContextErrString RecUpd = ptext (sLit "record update")
matchContextErrString LambdaExpr = ptext (sLit "lambda")
matchContextErrString ProcExpr = ptext (sLit "proc")
matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime
matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (TransformStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard")
matchContextErrString (StmtCtxt GhciStmt) = ptext (sLit "interactive GHCi command")
matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' expression")
matchContextErrString (StmtCtxt MDoExpr) = ptext (sLit "'mdo' expression")
matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension")
matchContextErrString (StmtCtxt MonadComp) = ptext (sLit "monad comprehension")
matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehension")
matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard")
matchContextErrString (StmtCtxt GhciStmt) = ptext (sLit "interactive GHCi command")
matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' block")
matchContextErrString (StmtCtxt ArrowExpr) = ptext (sLit "'do' block")
matchContextErrString (StmtCtxt MDoExpr) = ptext (sLit "'mdo' block")
matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension")
matchContextErrString (StmtCtxt MonadComp) = ptext (sLit "monad comprehension")
matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehension")
\end{code}
\begin{code}
......
compiler/rename/RnExpr.lhs
View file @ 3bb700d5
......@@ -440,8 +440,9 @@ convertOpFormsCmd (HsIf f exp c1 c2)
convertOpFormsCmd (HsLet binds cmd)
= HsLet binds (convertOpFormsLCmd cmd)
convertOpFormsCmd (HsDo ctxt stmts ty)
= HsDo ctxt (map (fmap convertOpFormsStmt) stmts) ty
convertOpFormsCmd (HsDo DoExpr stmts ty)
= HsDo ArrowExpr (map (fmap convertOpFormsStmt) stmts) ty
-- Mark the HsDo as begin the body of an arrow command
-- Anything else is unchanged. This includes HsArrForm (already done),
-- things with no sub-commands, and illegal commands (which will be
......@@ -582,14 +583,16 @@ rnArithSeq (FromThenTo expr1 expr2 expr3)
\begin{code}
rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
rnBracket (VarBr n) = do { name <- lookupOccRn n
; this_mod <- getModule
; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the
do { _ <- loadInterfaceForName msg name -- home interface is loaded, and this is the
; return () } -- only way that is going to happen
; return (VarBr name, unitFV name) }
where
msg = ptext (sLit "Need interface for Template Haskell quoted Name")
rnBracket (VarBr n)
= do { name <- lookupOccRn n
; this_mod <- getModule
; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking assumes
do { _ <- loadInterfaceForName msg name -- the home interface is loaded, and
; return () } -- this is the only way that is going
-- to happen
; return (VarBr name, unitFV name) }
where
msg = ptext (sLit "Need interface for Template Haskell quoted Name")
rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
; return (ExpBr e', fvs) }
......@@ -619,7 +622,8 @@ rnBracket (DecBrL decls)
rnSrcDecls group
-- Discard the tcg_env; it contains only extra info about fixity
; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env))))
; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$
ppr (duUses (tcg_dus tcg_env))))
; return (DecBrG group', duUses (tcg_dus tcg_env)) }
rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
......@@ -676,19 +680,20 @@ rnStmt :: HsStmtContext Name
-- Variables bound by the Stmt, and mentioned in thing_inside,
-- do not appear in the result FreeVars
rnStmt _ (L loc (LastStmt expr _)) thing_inside
rnStmt ctxt (L loc (LastStmt expr _)) thing_inside
= do { (expr', fv_expr) <- rnLExpr expr
; (ret_op, fvs1) <- lookupSyntaxName returnMName
; (thing, fvs3) <- thing_inside []
; (ret_op, fvs1) <- lookupStmtName ctxt returnMName
; (thing, fvs3) <- thing_inside []
; return (([L loc (LastStmt expr' ret_op)], thing),
fv_expr `plusFV` fvs1 `plusFV` fvs3) }
rnStmt ctxt (L loc (ExprStmt expr _ _ _)) thing_inside
= do { (expr', fv_expr) <- rnLExpr expr
; (then_op, fvs1) <- lookupSyntaxName thenMName
; (guard_op, fvs2) <- if isMonadCompExpr ctxt
then lookupSyntaxName guardMName
else return (noSyntaxExpr, emptyFVs)
; (then_op, fvs1) <- lookupStmtName ctxt thenMName
; (guard_op, fvs2) <- if isListCompExpr ctxt
then lookupStmtName ctxt guardMName
else return (noSyntaxExpr, emptyFVs)
-- Only list/parr/monad comprehensions use 'guard'
; (thing, fvs3) <- thing_inside []
; return (([L loc (ExprStmt expr' then_op guard_op placeHolderType)], thing),
fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
......@@ -696,8 +701,8 @@ rnStmt ctxt (L loc (ExprStmt expr _ _ _)) thing_inside
rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
= do { (expr', fv_expr) <- rnLExpr expr
-- The binders do not scope over the expression
; (bind_op, fvs1) <- lookupSyntaxName bindMName
; (fail_op, fvs2) <- lookupSyntaxName failMName
; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
; (fail_op, fvs2) <- lookupStmtName ctxt failMName
; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
{ (thing, fvs3) <- thing_inside (collectPatBinders pat')
; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing),
......@@ -710,7 +715,7 @@ rnStmt _ (L loc (LetStmt binds)) thing_inside
{ (thing, fvs) <- thing_inside (collectLocalBinders binds')
; return (([L loc (LetStmt binds')], thing), fvs) } }
rnStmt _ (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
= do {
-- Step1: Bring all the binders of the mdo into scope
-- (Remember that this also removes the binders from the
......@@ -726,9 +731,9 @@ rnStmt _ (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
{ let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds))
emptyNameSet segs
; (thing, fvs_later) <- thing_inside bndrs
; (return_op, fvs1) <- lookupSyntaxName returnMName
; (mfix_op, fvs2) <- lookupSyntaxName mfixName
; (bind_op, fvs3) <- lookupSyntaxName bindMName
; (return_op, fvs1) <- lookupStmtName ctxt returnMName
; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName
; (bind_op, fvs3) <- lookupStmtName ctxt bindMName
; let
-- Step 2: Fill in the fwd refs.
-- The segments are all singletons, but their fwd-ref
......@@ -754,13 +759,9 @@ rnStmt _ (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
rnStmt ctxt (L loc (ParStmt segs _ _ _)) thing_inside
= do { ((mzip_op, fvs1), (bind_op, fvs2), (return_op, fvs3)) <- if isMonadCompExpr ctxt
then (,,) <$> lookupSyntaxName mzipName
<*> lookupSyntaxName bindMName
<*> lookupSyntaxName returnMName
else return ( (noSyntaxExpr, emptyFVs)
, (noSyntaxExpr, emptyFVs)
, (noSyntaxExpr, emptyFVs) )
= do { (mzip_op, fvs1) <- lookupStmtName ctxt mzipName
; (bind_op, fvs2) <- lookupStmtName ctxt bindMName
; (return_op, fvs3) <- lookupStmtName ctxt returnMName
; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
; return ( ([L loc (ParStmt segs' mzip_op bind_op return_op)], thing)
, fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
......@@ -768,31 +769,29 @@ rnStmt ctxt (L loc (ParStmt segs _ _ _)) 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) <- case form of
GroupFormB -> do { (e,fvs) <- lookupSyntaxName implicit_name
; return (noLoc e, fvs) }
(using', fvs1) <- case form of
GroupFormB -> do { (e,fvs) <- lookupStmtName ctxt groupMName
; return (noLoc e, fvs) }
_ -> rnLExpr using
-- Rename the stmts and the 'by' expression
-- Keep track of the variables mentioned in the 'by' expression
; ((stmts', (by', used_bndrs, thing)), fvs2)
<- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
<- rnStmts (TransStmtCtxt ctxt) stmts $ \ bndrs ->
do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
; (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
-- 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) <- lookupSyntaxName returnMName
; (bind_op, fvs4) <- lookupSyntaxName bindMName
; (return_op, fvs3) <- lookupStmtName ctxt returnMName
; (bind_op, fvs4) <- lookupStmtName ctxt bindMName
; (fmap_op, fvs5) <- case form of
ThenForm -> return (noSyntaxExpr, emptyFVs)
_ -> lookupSyntaxName fmapName
_ -> lookupStmtName ctxt fmapName
; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
`plusFV` fvs4 `plusFV` fvs5
......@@ -839,6 +838,12 @@ rnParallelStmts ctxt segs thing_inside
cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
<+> quotes (ppr (head vs)))
lookupStmtName :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars)
-- Like lookupSyntaxName, but ListComp/PArrComp are never rebindable
lookupStmtName ListComp n = return (HsVar n, emptyFVs)
lookupStmtName PArrComp n = return (HsVar n, emptyFVs)
lookupStmtName _ n = lookupSyntaxName n
\end{code}
Note [Renaming parallel Stmts]
......@@ -1172,9 +1177,9 @@ okEmpty (PatGuard {}) = True
okEmpty _ = False
emptyErr :: HsStmtContext Name -> SDoc
emptyErr (ParStmtCtxt {}) = ptext (sLit "Empty statement group in parallel comprehension")
emptyErr (TransformStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'")
emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt
emptyErr (ParStmtCtxt {}) = ptext (sLit "Empty statement group in parallel comprehension")
emptyErr (TransStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'")
emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt
----------------------
checkLastStmt :: HsStmtContext Name
......@@ -1185,6 +1190,7 @@ checkLastStmt ctxt lstmt@(L loc stmt)
ListComp -> check_comp
MonadComp -> check_comp
PArrComp -> check_comp
ArrowExpr -> check_do
DoExpr -> check_do
MDoExpr -> check_do
_ -> check_other
......@@ -1233,42 +1239,52 @@ isOK, notOK :: Maybe SDoc
isOK = Nothing
notOK = Just empty
okStmt, okDoStmt, okCompStmt :: DynFlags -> HsStmtContext Name
-> Stmt RdrName -> Maybe SDoc
okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt
:: DynFlags -> HsStmtContext Name
-> Stmt RdrName -> Maybe SDoc
-- Return Nothing if OK, (Just extra) if not ok
-- The "extra" is an SDoc that is appended to an generic error message
okStmt _ (PatGuard {}) stmt
okStmt dflags ctxt stmt
= case ctxt of
PatGuard {} -> okPatGuardStmt stmt
ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt
DoExpr -> okDoStmt dflags ctxt stmt
MDoExpr -> okDoStmt dflags ctxt stmt
ArrowExpr -> okDoStmt dflags ctxt stmt
GhciStmt -> okDoStmt dflags ctxt stmt
ListComp -> okCompStmt dflags ctxt stmt
MonadComp -> okCompStmt dflags ctxt stmt
PArrComp -> okPArrStmt dflags ctxt stmt
TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
-------------
okPatGuardStmt :: Stmt RdrName -> Maybe SDoc
okPatGuardStmt stmt
= case stmt of
ExprStmt {} -> isOK
BindStmt {} -> isOK
LetStmt {} -> isOK
_ -> notOK
okStmt dflags (ParStmtCtxt ctxt) stmt
-------------
okParStmt dflags ctxt stmt
= case stmt of
LetStmt (HsIPBinds {}) -> notOK
_ -> okStmt dflags ctxt stmt
okStmt dflags (TransformStmtCtxt ctxt) stmt
= okStmt dflags ctxt stmt
okStmt dflags ctxt stmt
| isDoExpr ctxt = okDoStmt dflags ctxt stmt
| isListCompExpr ctxt = okCompStmt dflags ctxt stmt
| otherwise = pprPanic "okStmt" (pprStmtContext ctxt)
----------------
okDoStmt dflags _ stmt
okDoStmt dflags ctxt stmt
= case stmt of
RecStmt {}
RecStmt {}
| Opt_DoRec `xopt` dflags -> isOK
| otherwise -> Just (ptext (sLit "Use -XDoRec"))
| ArrowExpr <- ctxt -> isOK -- Arrows allows 'rec'
| otherwise -> Just (ptext (sLit "Use -XDoRec"))
BindStmt {} -> isOK
LetStmt {} -> isOK
ExprStmt {} -> isOK
_ -> notOK
----------------
okCompStmt dflags _ stmt
= case stmt of
......@@ -1281,8 +1297,21 @@ okCompStmt dflags _ stmt
TransStmt {}
| Opt_TransformListComp `xopt` dflags -> isOK
| otherwise -> Just (ptext (sLit "Use -XTransformListComp"))
LastStmt {} -> notOK
RecStmt {} -> notOK
LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt)
----------------
okPArrStmt dflags _ stmt
= case stmt of
BindStmt {} -> isOK
LetStmt {} -> isOK
ExprStmt {} -> isOK
ParStmt {}
| Opt_ParallelListComp `xopt` dflags -> isOK
| otherwise -> Just (ptext (sLit "Use -XParallelListComp"))
TransStmt {} -> notOK
RecStmt {} -> notOK
LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt)
---------
checkTupleSection :: [HsTupArg RdrName] -> RnM ()
......
compiler/typecheck/TcArrows.lhs
View file @ 3bb700d5
......@@ -7,7 +7,7 @@ Typecheck arrow notation
\begin{code}
module TcArrows ( tcProc ) where
import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp )
import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId )
import HsSyn
import TcMatches
......@@ -17,7 +17,9 @@ import TcBinds
import TcPat
import TcUnify
import TcRnMonad
import TcEnv
import Coercion
import Id( mkLocalId )
import Inst
import Name
import TysWiredIn
......@@ -83,20 +85,12 @@ tcCmdTop :: CmdEnv
tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_stk res_ty
= setSrcSpan loc $
do { cmd' <- tcGuardedCmd env cmd cmd_stk res_ty
do { cmd' <- tcCmd env cmd (cmd_stk, res_ty)
; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names
; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') }
----------------------------------------
tcGuardedCmd :: CmdEnv -> LHsExpr Name -> CmdStack
-> TcTauType -> TcM (LHsExpr TcId)
-- A wrapper that deals with the refinement (if any)
tcGuardedCmd env expr stk res_ty
= do { body <- tcCmd env expr (stk, res_ty)
; return body
}
tcCmd :: CmdEnv -> LHsExpr Name -> (CmdStack, TcTauType) -> TcM (LHsExpr TcId)
-- The main recursive function
tcCmd env (L loc expr) res_ty
......@@ -123,7 +117,7 @@ tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty)
where
match_ctxt = MC { mc_what = CaseAlt,
mc_body = mc_body }
mc_body body res_ty' = tcGuardedCmd env body stk res_ty'
mc_body body res_ty' = tcCmd env body (stk, res_ty')
tc_cmd env (HsIf mb_fun pred b1 b2) (stack_ty,res_ty)
= do { pred_ty <- newFlexiTyVarTy openTypeKind
......@@ -207,7 +201,7 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig
tc_grhs res_ty (GRHS guards body)
= do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $
tcGuardedCmd env body stk'
\ res_ty -> tcCmd env body (stk', res_ty)
; return (GRHS guards' rhs') }
-------------------------------------------
......@@ -215,12 +209,9 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig
tc_cmd env cmd@(HsDo do_or_lc stmts _) (cmd_stk, res_ty)
= do { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd)
; stmts' <- tcStmts do_or_lc (tcMDoStmt tc_rhs) stmts res_ty
; stmts' <- tcStmts do_or_lc (tcArrDoStmt env) stmts res_ty
; return (HsDo do_or_lc stmts' res_ty) }
where
tc_rhs rhs = do { ty <- newFlexiTyVarTy liftedTypeKind
; rhs' <- tcCmd env rhs ([], ty)
; return (rhs', ty) }
-----------------------------------------------------------------
......@@ -304,6 +295,69 @@ tc_cmd _ cmd _
\end{code}
%************************************************************************
%* *
Stmts
%* *
%************************************************************************
\begin{code}
--------------------------------
-- Mdo-notation
-- The distinctive features here are
-- (a) RecStmts, and
-- (b) no rebindable syntax
tcArrDoStmt :: CmdEnv -> TcStmtChecker
tcArrDoStmt env _ (LastStmt rhs _) res_ty thing_inside
= do { rhs' <- tcCmd env rhs ([], res_ty)
; thing <- thing_inside (panic "tcArrDoStmt")
; return (LastStmt rhs' noSyntaxExpr, thing) }
tcArrDoStmt env _ (ExprStmt rhs _ _ _) res_ty thing_inside
= do { (rhs', elt_ty) <- tc_arr_rhs env rhs
; thing <- thing_inside res_ty
; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) }
tcArrDoStmt env ctxt (BindStmt pat rhs _ _) res_ty thing_inside
= do { (rhs', pat_ty) <- tc_arr_rhs env rhs
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
thing_inside res_ty
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames
, recS_rec_ids = recNames }) res_ty thing_inside
= do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
; let rec_ids = zipWith mkLocalId recNames rec_tys
; tcExtendIdEnv rec_ids $ do
{ (stmts', (later_ids, rec_rets))
<- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' ->
-- ToDo: res_ty not really right
do { rec_rets <- zipWithM tcCheckId recNames rec_tys
; later_ids <- tcLookupLocalIds laterNames
; return (later_ids, rec_rets) }
; thing <- tcExtendIdEnv later_ids (thing_inside res_ty)
-- NB: The rec_ids for the recursive things
-- already scope over this part. This binding may shadow
-- some of them with polymorphic things with the same Name
-- (see note [RecStmt] in HsExpr)
; return (emptyRecStmt { recS_stmts = stmts', recS_later_ids = later_ids
, recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
, recS_ret_ty = res_ty }, thing)
}}
tcArrDoStmt _ _ stmt _ _
= pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt)
tc_arr_rhs :: CmdEnv -> LHsExpr Name -> TcM (LHsExpr TcId, TcType)
tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind
; rhs' <- tcCmd env rhs ([], ty)
; return (rhs', ty) }
\end{code}
%************************************************************************
%* *
Helpers
......
compiler/typecheck/TcMatches.lhs
View file @ 3bb700d5
This diff is collapsed.
compiler/typecheck/TcPat.lhs
View file @ 3bb700d5
......@@ -36,7 +36,6 @@ import PrelNames
import BasicTypes hiding (SuccessFlag(..))
import DynFlags
import SrcLoc
import ErrUtils
import Util
import Outputable
import FastString
......@@ -348,9 +347,9 @@ tc_lpat :: LPat Name
-> TcM a
-> TcM (LPat TcId, a)
tc_lpat (L span pat) pat_ty penv thing_inside
= setSrcSpan span $
maybeAddErrCtxt (patCtxt pat) $
do { (pat', res) <- tc_pat penv pat pat_ty thing_inside
= setSrcSpan span $
do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty)
thing_inside
; return (L span pat', res) }
tc_lpats :: PatEnv
......@@ -774,7 +773,6 @@ matchExpectedConTy data_tc pat_ty
-- coi : T tys ~ pat_ty
\end{code}
Noate [
Note [Matching constructor patterns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose (coi, tys) = matchExpectedConType data_tc pat_ty
......@@ -1006,12 +1004,18 @@ sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env
-}
\begin{code}
patCtxt :: Pat Name -> Maybe Message -- Not all patterns are worth pushing a context
patCtxt (VarPat _) = Nothing
patCtxt (ParPat _) = Nothing
patCtxt (AsPat _ _) = Nothing
patCtxt pat = Just (hang (ptext (sLit "In the pattern:"))
2 (ppr pat))
maybeWrapPatCtxt :: Pat Name -> (TcM a -> TcM b) -> TcM a -> TcM b
-- Not all patterns are worth pushing a context
maybeWrapPatCtxt pat tcm thing_inside
| not (worth_wrapping pat) = tcm thing_inside
| otherwise = addErrCtxt msg $ tcm $ popErrCtxt thing_inside
-- Remember to pop before doing thing_inside
where
worth_wrapping (VarPat {}) = False
worth_wrapping (ParPat {}) = False
worth_wrapping (AsPat {}) = False
worth_wrapping _ = True
msg = hang (ptext (sLit "In the pattern:")) 2 (ppr pat)
-----------------------------------------------
checkExistentials :: [TyVar] -> PatEnv -> TcM ()
......
compiler/typecheck/TcRnMonad.lhs
View file @ 3bb700d5
......@@ -781,11 +781,6 @@ updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
env { tcl_ctxt = upd ctxt })
-- Conditionally add an error context
maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a
maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside
maybeAddErrCtxt Nothing thing_inside = thing_inside
popErrCtxt :: TcM a -> TcM a
popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
......
compiler/typecheck/TcUnify.lhs
View file @ 3bb700d5
......@@ -20,7 +20,7 @@ module TcUnify (
matchExpectedListTy, matchExpectedPArrTy,
matchExpectedTyConApp, matchExpectedAppTy,
matchExpectedFunTys, matchExpectedFunKind,
wrapFunResCoercion
wrapFunResCoercion, failWithMisMatch
) where
#include "HsVersions.h"
......
docs/users_guide/glasgow_exts.xml
View file @ 3bb700d5
......@@ -1208,8 +1208,11 @@ output = [ x
<indexterm><primary>monad comprehensions</primary></indexterm>
<para>
Monad comprehesions generalise the list comprehension notation to work
for any monad.
Monad comprehesions generalise the list comprehension notation,
including parallel comprehensions
(<xref linkend="parallel-list-comprehensions"/>) and
transform comprenensions (<xref linkend="generalised-list-comprehensions"/>)
to work for any monad.
</para>
<para>Monad comprehensions support:</para>
......@@ -1360,7 +1363,70 @@ do (x,y) &lt;- mzip (do x &lt;- [1..10]
lists, which make <literal>MonadComprehensions</literal> backward
compatible to built-in, transform and parallel list comprehensions.
</para>
<para> More formally, the desugaring is as follows. We write <literal>D[ e | Q]</literal>
to mean the desugaring of the monad comprehension <literal>[ e | Q]</literal>:
<programlisting>
Expressions: e
Declarations: d
Lists of qualifiers: Q,R,S
-- Basic forms
D[ e | ] = return e
D[ e | p &lt;- e, Q ] = e &gt;&gt;= \p -&gt; D[ e | Q ]
D[ e | e, Q ] = guard e &gt;&gt; \p -&gt; D[ e | Q ]
D[ e | let d, Q ] = let d in D[ e | Q ]
-- Parallel comprehensions (iterate for multiple parallel branches)
D[ e | (Q | R), S ] = mzip D[ Qv | Q ] D[ Rv | R ] &gt;&gt;= \(Qv,Rv) -&gt; D[ e | S ]