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
(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)
-- 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!
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 $
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
| 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}
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")
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
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}
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
\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) }
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"
-- 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) }
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),
{ (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
{ 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
; 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) }
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
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]
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
ListComp -> check_comp
MonadComp -> check_comp
PArrComp -> check_comp
+ ArrowExpr -> check_do
DoExpr -> check_do
MDoExpr -> check_do
_ -> check_other
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
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 ()
\begin{code}
module TcArrows ( tcProc ) where
-import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp )
+import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId )
import HsSyn
import TcMatches
import TcPat
import TcUnify
import TcRnMonad
+import TcEnv
import Coercion
+import Id( mkLocalId )
import Inst
import Name
import TysWiredIn
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
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
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') }
-------------------------------------------
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) }
-----------------------------------------------------------------
%************************************************************************
%* *
+ 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
%* *
%************************************************************************
TcMatches: Typecheck some @Matches@
\begin{code}
+{-# OPTIONS_GHC -w #-} -- debugging
module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
- TcMatchCtxt(..),
+ TcMatchCtxt(..), TcStmtChecker,
tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,
- tcDoStmt, tcMDoStmt, tcGuardStmt
+ tcDoStmt, tcGuardStmt
) where
import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho, tcCheckId,
import Id
import TyCon
import TysPrim
-import Coercion ( mkSymCoI )
+import Coercion ( isIdentityCoI, mkSymCoI )
import Outputable
import Util
import SrcLoc
-> TcM (HsExpr TcId) -- Returns a HsDo
tcDoStmts ListComp stmts res_ty
= do { (coi, elt_ty) <- matchExpectedListTy res_ty
+ ; let list_ty = mkListTy elt_ty
; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty
- ; return $ mkHsWrapCoI coi
- (HsDo ListComp stmts' (mkListTy elt_ty)) }
+ ; return $ mkHsWrapCoI coi (HsDo ListComp stmts' list_ty) }
tcDoStmts PArrComp stmts res_ty
= do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
+ ; let parr_ty = mkPArrTy elt_ty
; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty
- ; return $ mkHsWrapCoI coi
- (HsDo PArrComp stmts' (mkPArrTy elt_ty)) }
+ ; return $ mkHsWrapCoI coi (HsDo PArrComp stmts' parr_ty) }
tcDoStmts DoExpr stmts res_ty
= do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty
thing_inside
; return (L loc stmt' : stmts', thing) }
---------------------------------
--- Pattern guards
+---------------------------------------------------
+-- Pattern guards
+---------------------------------------------------
+
tcGuardStmt :: TcStmtChecker
tcGuardStmt _ (ExprStmt guard _ _ _) res_ty thing_inside
= do { guard' <- tcMonoExpr guard boolTy
= pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
---------------------------------
--- List comprehensions and PArrays
+---------------------------------------------------
+-- List comprehensions and PArrays
+-- (no rebindable syntax)
+---------------------------------------------------
+
+-- Dealt with separately, rather than by tcMcStmt, because
+-- a) PArr isn't (yet) an instance of Monad, so the generality seems overkill
+-- b) We have special desugaring rules for list comprehensions,
+-- which avoid creating intermediate lists. They in turn
+-- assume that the bind/return operations are the regular
+-- polymorphic ones, and in particular don't have any
+-- coercion matching stuff in them. It's hard to avoid the
+-- potential for non-trivial coercions in tcMcStmt
tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
-> TcStmtChecker
; thing <- thing_inside elt_ty
; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) }
--- A parallel set of comprehensions
--- [ (g x, h x) | ... ; let g v = ...
--- | ... ; let h v = ... ]
---
--- It's possible that g,h are overloaded, so we need to feed the LIE from the
--- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods).
--- Similarly if we had an existential pattern match:
---
--- data T = forall a. Show a => C a
---
--- [ (show x, show y) | ... ; C x <- ...
--- | ... ; C y <- ... ]
---
--- Then we need the LIE from (show x, show y) to be simplified against
--- the bindings for x and y.
---
--- It's difficult to do this in parallel, so we rely on the renamer to
--- ensure that g,h and x,y don't duplicate, and simply grow the environment.
--- So the binders of the first parallel group will be in scope in the second
--- group. But that's fine; there's no shadowing to worry about.
-
+-- ParStmt: See notes with tcMcStmt
tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside
= do { (pairs', thing) <- loop bndr_stmts_s
; return (ParStmt pairs' noSyntaxExpr noSyntaxExpr noSyntaxExpr, thing) }
-- The inner 'stmts' lack a LastStmt, so the element type
-- passed in to tcStmtsAndThen is never looked at
; (stmts', (bndr_ids, by'))
- <- tcStmtsAndThen (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do
+ <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do
{ by' <- case by of
Nothing -> return Nothing
Just e -> do { e_ty <- tcInferRho e; return (Just e_ty) }
by_arrow :: Type -> Type -- Wraps 'ty' to '(a->t) -> ty' if the By is present
by_arrow = case by' of
Nothing -> \ty -> ty
- Just (_,e_ty) -> \ty -> e_ty `mkFunTy` ty
+ Just (_,e_ty) -> \ty -> (alphaTy `mkFunTy` e_ty) `mkFunTy` ty
tup_ty = mkBigCoreVarTupTy bndr_ids
poly_arg_ty = m_app alphaTy
tcLcStmt _ _ stmt _ _
= pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
-
---------------------------------
--- Monad comprehensions
+
+---------------------------------------------------
+-- Monad comprehensions
+-- (supports rebindable syntax)
+---------------------------------------------------
tcMcStmt :: TcStmtChecker
; m1_ty <- newFlexiTyVarTy star_star_kind
; m2_ty <- newFlexiTyVarTy star_star_kind
; tup_ty <- newFlexiTyVarTy liftedTypeKind
- ; by_e_ty <- newFlexiTyVarTy liftedTypeKind -- The type of the 'by' expression (if any)
-
- --------------- Typecheck the 'using' function -------------
- -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c))
+ ; by_e_ty <- newFlexiTyVarTy liftedTypeKind -- The type of the 'by' expression (if any)
-- n_app :: Type -> Type -- Wraps a 'ty' into '(n ty)' for GroupForm
; n_app <- case form of
ThenForm -> return (\ty -> ty)
_ -> do { n_ty <- newFlexiTyVarTy star_star_kind
; return (n_ty `mkAppTy`) }
- ; let by_arrow :: Type -> Type -- Wraps 'ty' to '(a->t) -> ty' if the By is present
+ ; let by_arrow :: Type -> Type
+ -- (by_arrow res) produces ((alpha->e_ty) -> res) ('by' present)
+ -- or res ('by' absent)
by_arrow = case by of
- Nothing -> \ty -> ty
- Just {} -> \ty -> by_e_ty `mkFunTy` ty
+ Nothing -> \res -> res
+ Just {} -> \res -> (alphaTy `mkFunTy` by_e_ty) `mkFunTy` res
poly_arg_ty = m1_ty `mkAppTy` alphaTy
using_arg_ty = m1_ty `mkAppTy` tup_ty
using_poly_ty = mkForAllTy alphaTyVar $ by_arrow $
poly_arg_ty `mkFunTy` poly_res_ty
- ; using' <- tcPolyExpr using using_poly_ty
- ; let final_using = fmap (HsWrap (WpTyApp tup_ty)) using'
-
- --------------- Typecheck the 'bind' function -------------
- -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty
- ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
- ; let n_tup_ty = n_app tup_ty -- n (a,b,c)
- ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
- using_res_ty `mkFunTy` (n_tup_ty `mkFunTy` new_res_ty)
- `mkFunTy` res_ty
-
- --------------- Typecheck the 'fmap' function -------------
- ; fmap_op' <- case form of
- ThenForm -> return noSyntaxExpr
- _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $
- mkForAllTy alphaTyVar $ mkForAllTy betaTyVar $
- (alphaTy `mkFunTy` betaTy)
- `mkFunTy` (n_app alphaTy)
- `mkFunTy` (n_app betaTy)
-
-- 'stmts' returns a result of type (m1_ty tuple_ty),
-- typically something like [(Int,Bool,Int)]
-- We don't know what tuple_ty is yet, so we use a variable
; let (bndr_names, n_bndr_names) = unzip bindersMap
; (stmts', (bndr_ids, by', return_op')) <-
- tcStmtsAndThen (TransformStmtCtxt ctxt) tcMcStmt stmts using_arg_ty $ \res_ty' -> do
+ tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts using_arg_ty $ \res_ty' -> do
{ by' <- case by of
Nothing -> return Nothing
Just e -> do { e' <- tcMonoExpr e by_e_ty; return (Just e') }
; return (bndr_ids, by', return_op') }
+ --------------- Typecheck the 'bind' function -------------
+ -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty
+ ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
+ ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
+ using_res_ty `mkFunTy` (n_app tup_ty `mkFunTy` new_res_ty)
+ `mkFunTy` res_ty
+
+ --------------- Typecheck the 'fmap' function -------------
+ ; fmap_op' <- case form of
+ ThenForm -> return noSyntaxExpr
+ _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $
+ mkForAllTy alphaTyVar $ mkForAllTy betaTyVar $
+ (alphaTy `mkFunTy` betaTy)
+ `mkFunTy` (n_app alphaTy)
+ `mkFunTy` (n_app betaTy)
+
+ --------------- Typecheck the 'using' function -------------
+ -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c))
+
+ ; using' <- tcPolyExpr using using_poly_ty
+ ; let final_using = fmap (HsWrap (WpTyApp tup_ty)) using'
+
+ --------------- Bulding the bindersMap ----------------
; let mk_n_bndr :: Name -> TcId -> TcId
mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id))
-- Type check the thing in the environment with
-- these new binders and return the result
- ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside res_ty)
+ ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside new_res_ty)
; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
, trS_by = by', trS_using = final_using
, trS_ret = return_op', trS_bind = bind_op'
, trS_fmap = fmap_op', trS_form = form }, thing) }
--- Typecheck `ParStmt`. See `tcLcStmt` for more informations about typechecking
--- of `ParStmt`s.
+-- A parallel set of comprehensions
+-- [ (g x, h x) | ... ; let g v = ...
+-- | ... ; let h v = ... ]
+--
+-- It's possible that g,h are overloaded, so we need to feed the LIE from the
+-- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods).
+-- Similarly if we had an existential pattern match:
+--
+-- data T = forall a. Show a => C a
+--
+-- [ (show x, show y) | ... ; C x <- ...
+-- | ... ; C y <- ... ]
+--
+-- Then we need the LIE from (show x, show y) to be simplified against
+-- the bindings for x and y.
+--
+-- It's difficult to do this in parallel, so we rely on the renamer to
+-- ensure that g,h and x,y don't duplicate, and simply grow the environment.
+-- So the binders of the first parallel group will be in scope in the second
+-- group. But that's fine; there's no shadowing to worry about.
--
-- Note: The `mzip` function will get typechecked via:
--
-- -> m (st1, (st2, st3))
--
tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_inside
- = do { (_,(m_ty,_)) <- matchExpectedAppTy res_ty
- -- ToDo: what if the coercion isn't the identity?
+ = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind
+ ; m_ty <- newFlexiTyVarTy star_star_kind
- ; (pairs', thing) <- loop m_ty bndr_stmts_s
+ ; let mzip_ty = mkForAllTys [alphaTyVar, betaTyVar] $
+ (m_ty `mkAppTy` alphaTy)
+ `mkFunTy`
+ (m_ty `mkAppTy` betaTy)
+ `mkFunTy`
+ (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
+ ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty
- ; let mzip_ty = mkForAllTys [alphaTyVar, betaTyVar] $
- (m_ty `mkAppTy` alphaTy)
- `mkFunTy`
- (m_ty `mkAppTy` betaTy)
- `mkFunTy`
- (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
- ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty
+ ; return_op' <- fmap unLoc . tcPolyExpr (noLoc return_op) $
+ mkForAllTy alphaTyVar $
+ alphaTy `mkFunTy` (m_ty `mkAppTy` alphaTy)
- -- Typecheck bind:
- ; let tys = map (mkBigCoreVarTupTy . snd) pairs'
- tuple_ty = mk_tuple_ty tys
+ ; (pairs', thing) <- loop m_ty bndr_stmts_s
- ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
- (m_ty `mkAppTy` tuple_ty)
- `mkFunTy`
- (tuple_ty `mkFunTy` res_ty)
- `mkFunTy`
- res_ty
+ -- Typecheck bind:
+ ; let tys = map (mkBigCoreVarTupTy . snd) pairs'
+ tuple_ty = mk_tuple_ty tys
- ; return_op' <- fmap unLoc . tcPolyExpr (noLoc return_op) $
- mkForAllTy alphaTyVar $
- alphaTy `mkFunTy` (m_ty `mkAppTy` alphaTy)
+ ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
+ (m_ty `mkAppTy` tuple_ty)
+ `mkFunTy` (tuple_ty `mkFunTy` res_ty)
+ `mkFunTy` res_ty
- ; return (ParStmt pairs' mzip_op' bind_op' return_op', thing) }
+ ; return (ParStmt pairs' mzip_op' bind_op' return_op', thing) }
- where mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
+ where
+ mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
-- loop :: Type -- m_ty
-- -> [([LStmt Name], [Name])]
-- -> TcM ([([LStmt TcId], [TcId])], thing)
- loop _ [] = do { thing <- thing_inside res_ty
- ; return ([], thing) } -- matching in the branches
-
- loop m_ty ((stmts, names) : pairs)
- = do { -- type dummy since we don't know all binder types yet
- ty_dummy <- newFlexiTyVarTy liftedTypeKind
- ; (stmts', (ids, pairs', thing))
- <- tcStmtsAndThen ctxt tcMcStmt stmts ty_dummy $ \res_ty' ->
- do { ids <- tcLookupLocalIds names
- ; _ <- unifyType res_ty' (m_ty `mkAppTy` mkBigCoreVarTupTy ids)
- ; (pairs', thing) <- loop m_ty pairs
- ; return (ids, pairs', thing) }
- ; return ( (stmts', ids) : pairs', thing ) }
+ loop _ [] = do { thing <- thing_inside res_ty
+ ; return ([], thing) } -- matching in the branches
+
+ loop m_ty ((stmts, names) : pairs)
+ = do { -- type dummy since we don't know all binder types yet
+ ty_dummy <- newFlexiTyVarTy liftedTypeKind
+ ; (stmts', (ids, pairs', thing))
+ <- tcStmtsAndThen ctxt tcMcStmt stmts ty_dummy $ \res_ty' ->
+ do { ids <- tcLookupLocalIds names
+ ; let m_tup_ty = m_ty `mkAppTy` mkBigCoreVarTupTy ids
+
+ ; check_same m_tup_ty res_ty'
+ ; check_same m_tup_ty ty_dummy
+
+ ; (pairs', thing) <- loop m_ty pairs
+ ; return (ids, pairs', thing) }
+ ; return ( (stmts', ids) : pairs', thing ) }
+
+ -- Check that the types match up.
+ -- This is a grevious hack. They always *will* match
+ -- If (>>=) and (>>) are polymorpic in the return type,
+ -- but we don't have any good way to incorporate the coercion
+ -- so for now we just check that it's the identity
+ check_same actual expected
+ = do { coi <- unifyType actual expected
+ ; unless (isIdentityCoI coi) $
+ failWithMisMatch [UnifyOrigin { uo_expected = expected
+ , uo_actual = actual }] }
tcMcStmt _ stmt _ _
= pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
---------------------------------
--- Do-notation
--- The main excitement here is dealing with rebindable syntax
+
+---------------------------------------------------
+-- Do-notation
+-- (supports rebindable syntax)
+---------------------------------------------------
tcDoStmt :: TcStmtChecker
(mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty)
; thing <- thing_inside new_res_ty
--- ; lie_binds <- bindLocalMethods lie tup_ids
; let rec_ids = takeList rec_names tup_ids
; later_ids <- tcLookupLocalIds later_names
Otherwise the error shows up when cheking the rebindable syntax, and
the expected/inferred stuff is back to front (see Trac #3613).
-\begin{code}
---------------------------------
--- Mdo-notation
--- The distinctive features here are
--- (a) RecStmts, and
--- (b) no rebindable syntax
-
-tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
- -> TcStmtChecker
--- Used only by TcArrows... should be gotten rid of
-tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside
- = do { (rhs', pat_ty) <- tc_rhs rhs
- ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
- thing_inside res_ty
- ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
-
-tcMDoStmt tc_rhs _ (ExprStmt rhs _ _ _) res_ty thing_inside
- = do { (rhs', elt_ty) <- tc_rhs rhs
- ; thing <- thing_inside res_ty
- ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) }
-
-tcMDoStmt tc_rhs 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 (tcMDoStmt tc_rhs) 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)
- }}
-
-tcMDoStmt _ _ stmt _ _
- = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
-\end{code}
-
%************************************************************************
%* *
import BasicTypes hiding (SuccessFlag(..))
import DynFlags
import SrcLoc
-import ErrUtils
import Util
import Outputable
import FastString
-> 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
-- coi : T tys ~ pat_ty
\end{code}
-Noate [
Note [Matching constructor patterns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose (coi, tys) = matchExpectedConType data_tc pat_ty
-}
\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 ()
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 })
matchExpectedListTy, matchExpectedPArrTy,
matchExpectedTyConApp, matchExpectedAppTy,
matchExpectedFunTys, matchExpectedFunKind,
- wrapFunResCoercion
+ wrapFunResCoercion, failWithMisMatch
) where
#include "HsVersions.h"
<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>
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 <- e, Q ] = e >>= \p -> D[ e | Q ]
+D[ e | e, Q ] = guard e >> \p -> 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 ] >>= \(Qv,Rv) -> D[ e | S ]
+
+-- Transform comprehensions
+D[ e | Q then f, R ] = f D[ Qv | Q ] >>= \Qv -> D[ e | R ]
+
+D[ e | Q then f by b, R ] = f b D[ Qv | Q ] >>= \Qv -> D[ e | R ]
+
+D[ e | Q then group using f, R ] = f D[ Qv | Q ] >>= \ys ->
+ case (fmap selQv1 ys, ..., fmap selQvn ys) of
+ Qv -> D[ e | R ]
+
+D[ e | Q then group by b using f, R ] = f b D[ Qv | Q ] >>= \ys ->
+ case (fmap selQv1 ys, ..., fmap selQvn ys) of
+ Qv -> D[ e | R ]
+
+where Qv is the tuple of variables bound by Q (and used subsequently)
+ selQvi is a selector mapping Qv to the ith component of Qv
+Operator Standard binding Expected type
+--------------------------------------------------------------------
+return GHC.Base t1 -> m t2
+(>>=) GHC.Base m1 t1 -> (t2 -> m2 t3) -> m3 t3
+(>>) GHC.Base m1 t1 -> m2 t2 -> m3 t3
+guard Control.Monad t1 -> m t2
+fmap GHC.Base forall a b. (a->b) -> n a -> n b
+mgroupWith Control.Monad.Group forall a. (a -> t) -> m1 a -> m2 (n a)
+mzip Control.Monad.Zip forall a b. m a -> m b -> m (a,b)
+</programlisting>
+The comprehension should typecheck when its desugaring would typecheck.
+</para>
+<para>
+Monad comprehensions support rebindable syntax (<xref linkend="rebindable-syntax"/>).
+Without rebindable
+syntax, the operators from the "standard binding" module are used; with
+rebindable syntax, the operators are looked up in the current lexical scope.
+For example, parallel comprehensions will be typechecked and desugared
+using whatever "<literal>mzip</literal>" is in scope.
+</para>
+<para>
+The rebindable operators must have the "Expected type" given in the
+table above. These types are surprisingly general. For example, you can
+use a bind operator with the type
+<programlisting>
+(>>=) :: T x y a -> (a -> T y z b) -> T x z b
+</programlisting>
+In the case of transform comprehensions, notice that the groups are
+parameterised over some arbitrary type <literal>n</literal> (provided it
+has an <literal>fmap</literal>, as well as
+the comprehension being over an arbitrary monad.
+</para>
</sect2>
<!-- ===================== REBINDABLE SYNTAX =================== -->