liftM2 HsLet
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsExprNeverOrAlways e)
-addTickHsExpr (HsDo cxt stmts last_exp return_exp srcloc) = do
- (stmts', last_exp') <- addTickLStmts' forQual stmts
- (addTickLHsExpr last_exp)
- return_exp' <- addTickSyntaxExpr hpcSrcSpan return_exp
- return (HsDo cxt stmts' last_exp' return_exp' srcloc)
+addTickHsExpr (HsDo cxt stmts srcloc)
+ = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
+ ; return (HsDo cxt stmts' srcloc) }
where
forQual = case cxt of
ListComp -> Just $ BinBox QualBinBox
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a
-> TM ([LStmt Id], a)
addTickLStmts' isGuard lstmts res
- = bindLocals binders $ do
- lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
- a <- res
- return (lstmts', a)
- where
- binders = collectLStmtsBinders lstmts
+ = bindLocals (collectLStmtsBinders lstmts) $
+ do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
+ ; a <- res
+ ; return (lstmts', a) }
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
+addTickStmt _isGuard (LastStmt e ret) = do
+ liftM2 LastStmt
+ (addTickLHsExprAlways e)
+ (addTickSyntaxExpr hpcSrcSpan ret)
addTickStmt _isGuard (BindStmt pat e bind fail) = do
liftM4 BindStmt
(addTickLPat pat)
liftM2 HsLet
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsCmd c)
-addTickHsCmd (HsDo cxt stmts last_exp return_exp srcloc) = do
- (stmts', last_exp') <- addTickLCmdStmts' stmts (addTickLHsCmd last_exp)
- return_exp' <- addTickSyntaxExpr hpcSrcSpan return_exp
- return (HsDo cxt stmts' last_exp' return_exp' srcloc)
+addTickHsCmd (HsDo cxt stmts srcloc)
+ = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
+ ; return (HsDo cxt stmts' srcloc) }
addTickHsCmd (HsArrApp e1 e2 ty1 arr_ty lr) =
liftM5 HsArrApp
core_body,
exprFreeVars core_binds `intersectVarSet` local_vars)
-dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts body _ _)
- = dsCmdDo ids local_vars env_ids res_ty stmts body
+dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _)
+ = dsCmdDo ids local_vars env_ids res_ty stmts
-- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t
-- A | xs |- ci :: [tsi] ti
-- so don't pull on it too early
-> Type -- return type of the statement
-> [LStmt Id] -- statements to desugar
- -> LHsExpr Id -- body
-> DsM (CoreExpr, -- desugared expression
IdSet) -- set of local vars that occur free
-- --------------------------
-- A | xs |- do { c } :: [] t
-dsCmdDo ids local_vars env_ids res_ty [] body
+dsCmdDo _ _ _ _ [] = panic "dsCmdDo"
+
+dsCmdDo ids local_vars env_ids res_ty [L _ (LastStmt body _)]
= dsLCmd ids local_vars env_ids [] res_ty body
-dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body = do
+dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) = do
let
bound_vars = mkVarSet (collectLStmtBinders stmt)
local_vars' = local_vars `unionVarSet` bound_vars
(core_stmts, _, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do
- (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts body
+ (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts
return (core_stmts, fv_stmts, varSetElems fv_stmts))
(core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt
return (do_compose ids
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
-dsExpr (HsDo ListComp stmts body _ result_ty)
- = -- Special case for list comprehensions
- dsListComp stmts body elt_ty
- where
- [elt_ty] = tcTyConAppArgs result_ty
-
-dsExpr (HsDo DoExpr stmts body _ result_ty)
- = dsDo stmts body result_ty
-
-dsExpr (HsDo GhciStmt stmts body _ result_ty)
- = dsDo stmts body result_ty
-
-dsExpr (HsDo MDoExpr stmts body _ result_ty)
- = dsDo stmts body result_ty
-
-dsExpr (HsDo MonadComp stmts body return_op result_ty)
- = dsMonadComp stmts return_op body result_ty
-
-dsExpr (HsDo PArrComp stmts body _ result_ty)
- = -- Special case for array comprehensions
- dsPArrComp (map unLoc stmts) body elt_ty
- where
- [elt_ty] = tcTyConAppArgs result_ty
+dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty
+dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts)
+dsExpr (HsDo DoExpr stmts res_ty) = dsDo stmts res_ty
+dsExpr (HsDo GhciStmt stmts res_ty) = dsDo stmts res_ty
+dsExpr (HsDo MDoExpr stmts res_ty) = dsDo stmts res_ty
+dsExpr (HsDo MonadComp stmts res_ty) = dsMonadComp stmts res_ty
dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
= do { pred <- dsLExpr guard_expr
\begin{code}
dsDo :: [LStmt Id]
- -> LHsExpr Id
-> Type -- Type of the whole expression
-> DsM CoreExpr
-dsDo stmts body result_ty
+dsDo stmts result_ty
= goL stmts
where
- -- result_ty must be of the form (m b)
- (m_ty, _b_ty) = tcSplitAppTy result_ty
-
- goL [] = dsLExpr body
- goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
+ goL [] = panic "dsDo"
+ goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
+ go _ (LastStmt body ret_op) stmts
+ = ASSERT( null stmts )
+ do { body' <- dsLExpr body
+ ; ret_op' <- dsExpr ret_op
+ ; return (App ret_op' body') }
+
go _ (ExprStmt rhs then_expr _ _) stmts
= do { rhs2 <- dsLExpr rhs
- ; case tcSplitAppTy_maybe (exprType rhs2) of
- Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty
- _ -> return ()
+ ; warnDiscardedDoBindings rhs (exprType rhs2)
; then_expr2 <- dsExpr then_expr
; rest <- goL stmts
; return (mkApps then_expr2 [rhs2, rest]) }
go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
, recS_rec_ids = rec_ids, recS_ret_fn = return_op
, recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
- , recS_rec_rets = rec_rets }) stmts
+ , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts
= ASSERT( length rec_ids > 0 )
goL (new_bind_stmt : stmts)
where
- -- returnE <- dsExpr return_id
- -- mfixE <- dsExpr mfix_id
- new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app
- bind_op
+ new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats)
+ mfix_app bind_op
noSyntaxExpr -- Tuple cannot fail
tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
rec_tup_pats = map nlVarPat tup_ids
later_pats = rec_tup_pats
rets = map noLoc rec_rets
-
- mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
- mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
- (mkFunTy tup_ty body_ty))
- mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
- body = noLoc $ HsDo DoExpr rec_stmts return_app noSyntaxExpr body_ty
- return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
- body_ty = mkAppTy m_ty tup_ty
- tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
+ mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
+ mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
+ (mkFunTy tup_ty body_ty))
+ mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
+ body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty
+ ret_stmt = noLoc $ LastStmt return_op (mkLHsTupleExpr rets)
+ tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
-- In a do expression, pattern-match failure just calls
showSDoc (ppr (getLoc pat))
\end{code}
-Translation for RecStmt's:
------------------------------
-We turn (RecStmt [v1,..vn] stmts) into:
-
- (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
- return (v1,..vn))
-
-\begin{code}
-{-
-dsMDo :: HsStmtContext Name
- -> [(Name,Id)]
- -> [LStmt Id]
- -> LHsExpr Id
- -> Type -- Type of the whole expression
- -> DsM CoreExpr
-
-dsMDo ctxt tbl stmts body result_ty
- = goL stmts
- where
- goL [] = dsLExpr body
- goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
-
- (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
- return_id = lookupEvidence tbl returnMName
- bind_id = lookupEvidence tbl bindMName
- then_id = lookupEvidence tbl thenMName
- fail_id = lookupEvidence tbl failMName
-
- go _ (LetStmt binds) stmts
- = do { rest <- goL stmts
- ; dsLocalBinds binds rest }
-
- go _ (ExprStmt rhs then_expr rhs_ty) stmts
- = do { rhs2 <- dsLExpr rhs
- ; warnDiscardedDoBindings rhs m_ty rhs_ty
- ; then_expr2 <- dsExpr then_expr
- ; rest <- goL stmts
- ; return (mkApps then_expr2 [rhs2, rest]) }
-
- go _ (BindStmt pat rhs bind_op _) stmts
- = do { body <- goL stmts
- ; rhs' <- dsLExpr rhs
- ; bind_op' <- dsExpr bind_op
- ; var <- selectSimpleMatchVarL pat
- ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
- result_ty (cantFailMatchResult body)
- ; match_code <- handle_failure pat match fail_op
- ; return (mkApps bind_op [rhs', Lam var match_code]) }
-
- go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
- , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
- , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) stmts
- = ASSERT( length rec_ids > 0 )
- ASSERT( length rec_ids == length rec_rets )
- ASSERT( isEmptyTcEvBinds _ev_binds )
- pprTrace "dsMDo" (ppr later_ids) $
- goL (new_bind_stmt : stmts)
- where
- new_bind_stmt = L loc $ BindStmt (mk_tup_pat later_pats) mfix_app
- bind_op noSyntaxExpr
-
- -- Remove the later_ids that appear (without fancy coercions)
- -- in rec_rets, because there's no need to knot-tie them separately
- -- See Note [RecStmt] in HsExpr
- later_ids' = filter (`notElem` mono_rec_ids) later_ids
- mono_rec_ids = [ id | HsVar id <- rec_rets ]
-
- mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
- mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
- (mkFunTy tup_ty body_ty))
-
- -- The rec_tup_pat must bind the rec_ids only; remember that the
- -- trimmed_laters may share the same Names
- -- Meanwhile, the later_pats must bind the later_vars
- rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
- later_pats = map nlVarPat later_ids' ++ map mk_later_pat rec_ids
- rets = map nlHsVar later_ids' ++ map noLoc rec_rets
-
- mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
- body = noLoc $ HsDo ctxt rec_stmts return_app noSyntaxExpr body_ty
- body_ty = mkAppTy m_ty tup_ty
- tup_ty = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids)) -- Deals with singleton case
-
- return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
-
- mk_wild_pat :: Id -> LPat Id
- mk_wild_pat v = noLoc $ WildPat $ idType v
-
- mk_later_pat :: Id -> LPat Id
- mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
- | otherwise = nlVarPat v
-
- mk_tup_pat :: [LPat Id] -> LPat Id
- mk_tup_pat [p] = p
- mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed
--}
-\end{code}
%************************************************************************
%* *
\begin{code}
-- Warn about certain types of values discarded in monadic bindings (#3263)
-warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM ()
-warnDiscardedDoBindings rhs container_ty returning_ty = do {
- -- Warn about discarding non-() things in 'monadic' binding
- ; warn_unused <- doptDs Opt_WarnUnusedDoBind
- ; if warn_unused && not (returning_ty `tcEqType` unitTy)
- then warnDs (unusedMonadBind rhs returning_ty)
- else do {
- -- Warn about discarding m a things in 'monadic' binding of the same type,
- -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
- ; warn_wrong <- doptDs Opt_WarnWrongDoBind
- ; case tcSplitAppTy_maybe returning_ty of
- Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $
- warnDs (wrongMonadBind rhs returning_ty)
- _ -> return () } }
+warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()
+warnDiscardedDoBindings rhs rhs_ty
+ | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
+ = do { -- Warn about discarding non-() things in 'monadic' binding
+ ; warn_unused <- doptDs Opt_WarnUnusedDoBind
+ ; if warn_unused && not (isUnitTy elt_ty)
+ then warnDs (unusedMonadBind rhs elt_ty)
+ else
+ -- Warn about discarding m a things in 'monadic' binding of the same type,
+ -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
+ do { warn_wrong <- doptDs Opt_WarnWrongDoBind
+ ; case tcSplitAppTy_maybe elt_ty of
+ Just (elt_m_ty, _) | warn_wrong, m_ty `tcEqType` elt_m_ty
+ -> warnDs (wrongMonadBind rhs elt_ty)
+ _ -> return () } }
+
+ | otherwise -- RHS does have type of form (m ty), which is wierd
+ = return () -- but at lesat this warning is irrelevant
unusedMonadBind :: LHsExpr Id -> Type -> SDoc
-unusedMonadBind rhs returning_ty
- = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
+unusedMonadBind rhs elt_ty
+ = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
ptext (sLit "or by using the flag -fno-warn-unused-do-bind")
wrongMonadBind :: LHsExpr Id -> Type -> SDoc
-wrongMonadBind rhs returning_ty
- = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
+wrongMonadBind rhs elt_ty
+ = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")
\end{code}
\begin{code}
dsListComp :: [LStmt Id]
- -> LHsExpr Id
- -> Type -- Type of list elements
+ -> Type -- Type of entire list
-> DsM CoreExpr
-dsListComp lquals body elt_ty = do
+dsListComp lquals res_ty = do
dflags <- getDOptsDs
let quals = map unLoc lquals
+ [elt_ty] = tcTyConAppArgs res_ty
if not (dopt Opt_EnableRewriteRules dflags) || dopt Opt_IgnoreInterfacePragmas dflags
-- Either rules are switched off, or we are ignoring what there are;
-- Wadler-style desugaring
|| isParallelComp quals
-- Foldr-style desugaring can't handle parallel list comprehensions
- then deListComp quals body (mkNilExpr elt_ty)
- else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals body)
+ then deListComp quals (mkNilExpr elt_ty)
+ else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals)
-- Foldr/build should be enabled, so desugar
-- into foldrs and builds
-- and the type of the elements that it outputs (tuples of binders)
dsInnerListComp :: ([LStmt Id], [Id]) -> DsM (CoreExpr, Type)
dsInnerListComp (stmts, bndrs) = do
- expr <- dsListComp stmts (mkBigLHsVarTup bndrs) bndrs_tuple_type
- return (expr, bndrs_tuple_type)
- where
- bndrs_types = map idType bndrs
- bndrs_tuple_type = mkBigCoreTupTy bndrs_types
-
+ = do { expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTup bndrs)])
+ bndrs_tuple_type
+ ; return (expr, bndrs_tuple_type) }
+ where
+ bndrs_tuple_type = mkBigCoreVarTupTy bndrs
-- This function factors out commonality between the desugaring strategies for TransformStmt.
-- Given such a statement it gives you back an expression representing how to compute the transformed
\begin{code}
-deListComp :: [Stmt Id] -> LHsExpr Id -> CoreExpr -> DsM CoreExpr
+deListComp :: [Stmt Id] -> CoreExpr -> DsM CoreExpr
+
+deListComp [] _ = panic "deListComp"
-deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) body list
+deListComp (LastStmt body _ : quals) list
+ = -- Figure 7.4, SLPJ, p 135, rule C above
+ ASSERT( null quals )
+ do { core_body <- dsLExpr body
+ ; return (mkConsExpr (exprType core_body) core_body list) }
+
+ -- Non-last: must be a guard
+deListComp (ExprStmt guard _ _ _ : quals) list = do -- rule B above
+ core_guard <- dsLExpr guard
+ core_rest <- deListComp quals list
+ return (mkIfThenElse core_guard core_rest list)
+
+-- [e | let B, qs] = let B in [e | qs]
+deListComp (LetStmt binds : quals) list = do
+ core_rest <- deListComp quals list
+ dsLocalBinds binds core_rest
+
+deListComp (stmt@(TransformStmt {}) : quals) list = do
+ (inner_list_expr, pat) <- dsTransformStmt stmt
+ deBindComp pat inner_list_expr quals list
+
+deListComp (stmt@(GroupStmt {}) : quals) list = do
+ (inner_list_expr, pat) <- dsGroupStmt stmt
+ deBindComp pat inner_list_expr quals list
+
+deListComp (BindStmt pat list1 _ _ : quals) core_list2 = do -- rule A' above
+ core_list1 <- dsLExpr list1
+ deBindComp pat core_list1 quals core_list2
+
+deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list
= do
exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
let (exps, qual_tys) = unzip exps_and_qual_tys
-- Deal with [e | pat <- zip l1 .. ln] in example above
deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
- quals body list
+ quals list
where
bndrs_s = map snd stmtss_w_bndrs
-- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
pat = mkBigLHsPatTup pats
pats = map mkBigLHsVarPatTup bndrs_s
-
- -- Last: the one to return
-deListComp [] body list = do -- Figure 7.4, SLPJ, p 135, rule C above
- core_body <- dsLExpr body
- return (mkConsExpr (exprType core_body) core_body list)
-
- -- Non-last: must be a guard
-deListComp (ExprStmt guard _ _ _ : quals) body list = do -- rule B above
- core_guard <- dsLExpr guard
- core_rest <- deListComp quals body list
- return (mkIfThenElse core_guard core_rest list)
-
--- [e | let B, qs] = let B in [e | qs]
-deListComp (LetStmt binds : quals) body list = do
- core_rest <- deListComp quals body list
- dsLocalBinds binds core_rest
-
-deListComp (stmt@(TransformStmt {}) : quals) body list = do
- (inner_list_expr, pat) <- dsTransformStmt stmt
- deBindComp pat inner_list_expr quals body list
-
-deListComp (stmt@(GroupStmt {}) : quals) body list = do
- (inner_list_expr, pat) <- dsGroupStmt stmt
- deBindComp pat inner_list_expr quals body list
-
-deListComp (BindStmt pat list1 _ _ : quals) body core_list2 = do -- rule A' above
- core_list1 <- dsLExpr list1
- deBindComp pat core_list1 quals body core_list2
\end{code}
deBindComp :: OutPat Id
-> CoreExpr
-> [Stmt Id]
- -> LHsExpr Id
-> CoreExpr
-> DsM (Expr Id)
-deBindComp pat core_list1 quals body core_list2 = do
+deBindComp pat core_list1 quals core_list2 = do
let
u3_ty@u1_ty = exprType core_list1 -- two names, same thing
core_fail = App (Var h) (Var u3)
letrec_body = App (Var h) core_list1
- rest_expr <- deListComp quals body core_fail
+ rest_expr <- deListComp quals core_fail
core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail
let
\begin{code}
dfListComp :: Id -> Id -- 'c' and 'n'
-> [Stmt Id] -- the rest of the qual's
- -> LHsExpr Id
-> DsM CoreExpr
- -- Last: the one to return
-dfListComp c_id n_id [] body = do
- core_body <- dsLExpr body
- return (mkApps (Var c_id) [core_body, Var n_id])
+dfListComp _ _ [] = panic "dfListComp"
+
+dfListComp c_id n_id (LastStmt body _ : quals)
+ = ASSERT( null quals )
+ do { core_body <- dsLExpr body
+ ; return (mkApps (Var c_id) [core_body, Var n_id]) }
-- Non-last: must be a guard
-dfListComp c_id n_id (ExprStmt guard _ _ _ : quals) body = do
+dfListComp c_id n_id (ExprStmt guard _ _ _ : quals) = do
core_guard <- dsLExpr guard
- core_rest <- dfListComp c_id n_id quals body
+ core_rest <- dfListComp c_id n_id quals
return (mkIfThenElse core_guard core_rest (Var n_id))
-dfListComp c_id n_id (LetStmt binds : quals) body = do
+dfListComp c_id n_id (LetStmt binds : quals) = do
-- new in 1.3, local bindings
- core_rest <- dfListComp c_id n_id quals body
+ core_rest <- dfListComp c_id n_id quals
dsLocalBinds binds core_rest
-dfListComp c_id n_id (stmt@(TransformStmt {}) : quals) body = do
+dfListComp c_id n_id (stmt@(TransformStmt {}) : quals) = do
(inner_list_expr, pat) <- dsTransformStmt stmt
-- Anyway, we bind the newly transformed list via the generic binding function
- dfBindComp c_id n_id (pat, inner_list_expr) quals body
+ dfBindComp c_id n_id (pat, inner_list_expr) quals
-dfListComp c_id n_id (stmt@(GroupStmt {}) : quals) body = do
+dfListComp c_id n_id (stmt@(GroupStmt {}) : quals) = do
(inner_list_expr, pat) <- dsGroupStmt stmt
-- Anyway, we bind the newly grouped list via the generic binding function
- dfBindComp c_id n_id (pat, inner_list_expr) quals body
+ dfBindComp c_id n_id (pat, inner_list_expr) quals
-dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) body = do
+dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) = do
-- evaluate the two lists
core_list1 <- dsLExpr list1
-- Do the rest of the work in the generic binding builder
- dfBindComp c_id n_id (pat, core_list1) quals body
+ dfBindComp c_id n_id (pat, core_list1) quals
dfBindComp :: Id -> Id -- 'c' and 'n'
-> (LPat Id, CoreExpr)
-> [Stmt Id] -- the rest of the qual's
- -> LHsExpr Id
-> DsM CoreExpr
-dfBindComp c_id n_id (pat, core_list1) quals body = do
+dfBindComp c_id n_id (pat, core_list1) quals = do
-- find the required type
let x_ty = hsLPatType pat
b_ty = idType n_id
[b, x] <- newSysLocalsDs [b_ty, x_ty]
-- build rest of the comprehesion
- core_rest <- dfListComp c_id b quals body
+ core_rest <- dfListComp c_id b quals
-- build the pattern match
core_expr <- matchSimply (Var x) (StmtCtxt ListComp)
unzip_fn_ty = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty
mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail
-
-
-
\end{code}
%************************************************************************
-- [:e | qss:] = <<[:e | qss:]>> () [:():]
--
dsPArrComp :: [Stmt Id]
- -> LHsExpr Id
- -> Type -- Don't use; called with `undefined' below
-> DsM CoreExpr
-dsPArrComp [ParStmt qss _ _ _] body _ = -- parallel comprehension
- dePArrParComp qss body
+
+-- Special case for parallel comprehension
+dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals
-- Special case for simple generators:
--
-- <<[:e' | p <- e, qs:]>> =
-- <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)
--
-dsPArrComp (BindStmt p e _ _ : qs) body _ = do
+dsPArrComp (BindStmt p e _ _ : qs) = do
filterP <- dsLookupDPHId filterPName
ce <- dsLExpr e
let ety'ce = parrElemType ce
pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false
let gen | isIrrefutableHsPat p = ce
| otherwise = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
- dePArrComp qs body p gen
+ dePArrComp qs p gen
-dsPArrComp qs body _ = do -- no ParStmt in `qs'
+dsPArrComp qs = do -- no ParStmt in `qs'
sglP <- dsLookupDPHId singletonPName
let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]
- dePArrComp qs body (noLoc $ WildPat unitTy) unitArray
+ dePArrComp qs (noLoc $ WildPat unitTy) unitArray
-- the work horse
--
dePArrComp :: [Stmt Id]
- -> LHsExpr Id
-> LPat Id -- the current generator pattern
-> CoreExpr -- the current generator expression
-> DsM CoreExpr
+
+dePArrComp [] _ _ = panic "dePArrComp"
+
--
-- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
--
-dePArrComp [] e' pa cea = do
- mapP <- dsLookupDPHId mapPName
- let ty = parrElemType cea
- (clam, ty'e') <- deLambda ty pa e'
- return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea]
+dePArrComp (LastStmt e' _ : quals) pa cea
+ = ASSERT( null quals )
+ do { mapP <- dsLookupDPHId mapPName
+ ; let ty = parrElemType cea
+ ; (clam, ty'e') <- deLambda ty pa e'
+ ; return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] }
--
-- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
--
-dePArrComp (ExprStmt b _ _ _ : qs) body pa cea = do
+dePArrComp (ExprStmt b _ _ _ : qs) pa cea = do
filterP <- dsLookupDPHId filterPName
let ty = parrElemType cea
(clam,_) <- deLambda ty pa b
- dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea])
+ dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea])
--
-- <<[:e' | p <- e, qs:]>> pa ea =
-- in
-- <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)
--
-dePArrComp (BindStmt p e _ _ : qs) body pa cea = do
+dePArrComp (BindStmt p e _ _ : qs) pa cea = do
filterP <- dsLookupDPHId filterPName
crossMapP <- dsLookupDPHId crossMapPName
ce <- dsLExpr e
let ety'cef = ety'ce -- filter doesn't change the element type
pa' = mkLHsPatTup [pa, p]
- dePArrComp qs body pa' (mkApps (Var crossMapP)
+ dePArrComp qs pa' (mkApps (Var crossMapP)
[Type ety'cea, Type ety'cef, cea, clam])
--
-- <<[:e' | let ds, qs:]>> pa ea =
-- where
-- {x_1, ..., x_n} = DV (ds) -- Defined Variables
--
-dePArrComp (LetStmt ds : qs) body pa cea = do
+dePArrComp (LetStmt ds : qs) pa cea = do
mapP <- dsLookupDPHId mapPName
let xs = collectLocalBinders ds
ty'cea = parrElemType cea
ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr
let pa' = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)]
proj = mkLams [v] ccase
- dePArrComp qs body pa' (mkApps (Var mapP)
+ dePArrComp qs pa' (mkApps (Var mapP)
[Type ty'cea, Type errTy, proj, cea])
--
-- The parser guarantees that parallel comprehensions can only appear as
-- singeltons qualifier lists, which we already special case in the caller.
-- So, encountering one here is a bug.
--
-dePArrComp (ParStmt _ _ _ _ : _) _ _ _ =
+dePArrComp (ParStmt _ _ _ _ : _) _ _ =
panic "DsListComp.dePArrComp: malformed comprehension AST"
-- <<[:e' | qs | qss:]>> pa ea =
-- where
-- {x_1, ..., x_n} = DV (qs)
--
-dePArrParComp :: [([LStmt Id], [Id])] -> LHsExpr Id -> DsM CoreExpr
-dePArrParComp qss body = do
+dePArrParComp :: [([LStmt Id], [Id])] -> [Stmt Id] -> DsM CoreExpr
+dePArrParComp qss quals = do
(pQss, ceQss) <- deParStmt qss
- dePArrComp [] body pQss ceQss
+ dePArrComp quals pQss ceQss
where
deParStmt [] =
-- empty parallel statement lists have no source representation
panic "DsListComp.dePArrComp: Empty parallel list comprehension"
deParStmt ((qs, xs):qss) = do -- first statement
let res_expr = mkLHsVarTuple xs
- cqs <- dsPArrComp (map unLoc qs) res_expr undefined
+ cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
parStmts qss (mkLHsVarPatTup xs) cqs
---
parStmts [] pa cea = return (pa, cea)
let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs]
ty'cea = parrElemType cea
res_expr = mkLHsVarTuple xs
- cqs <- dsPArrComp (map unLoc qs) res_expr undefined
+ cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
let ty'cqs = parrElemType cqs
cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
parStmts qss pa' cea'
-- Entry point for monad comprehension desugaring
--
dsMonadComp :: [LStmt Id] -- the statements
- -> SyntaxExpr Id -- the "return" function
- -> LHsExpr Id -- the body
-> Type -- the final type
-> DsM CoreExpr
-dsMonadComp stmts return_op body res_ty
+dsMonadComp stmts res_ty
= dsMcStmts stmts (DsMonadComp (Left return_op) body m_ty)
where
(m_ty, _) = tcSplitAppTy res_ty
= putSrcSpanDs loc (dsMcStmt stmt lstmts mc)
-dsMcStmt :: Stmt Id
- -> [LStmt Id]
- -> DsMonadComp
- -> DsM CoreExpr
+dsMcStmt :: Stmt Id -> [LStmt Id] -> DsM CoreExpr
+
+dsMcStmt (LastStmt body ret_op) stmts
+ = ASSERT( null stmts )
+ do { body' <- dsLExpr body
+ ; ret_op' <- dsExpr ret_op
+ ; return (App ret_op' body') }
-- [ .. | let binds, stmts ]
-dsMcStmt (LetStmt binds) stmts mc
- = do { rest <- dsMcStmts stmts mc
+dsMcStmt (LetStmt binds) stmts
+ = do { rest <- dsMcStmts stmts
; dsLocalBinds binds rest }
-- [ .. | a <- m, stmts ]
-dsMcStmt (BindStmt pat rhs bind_op fail_op) stmts mc
- = do { rhs' <- dsLExpr rhs
- ; dsMcBindStmt pat rhs' bind_op fail_op stmts mc }
+dsMcStmt (BindStmt pat rhs bind_op fail_op) stmts
+ = do { rhs' <- dsLExpr rhs
+ ; dsMcBindStmt pat rhs' bind_op fail_op stmts }
-- Apply `guard` to the `exp` expression
--
-- [ .. | exp, stmts ]
--
-dsMcStmt (ExprStmt exp then_exp guard_exp _) stmts mc
+dsMcStmt (ExprStmt exp then_exp guard_exp _) stmts
= do { exp' <- dsLExpr exp
; guard_exp' <- dsExpr guard_exp
; then_exp' <- dsExpr then_exp
- ; rest <- dsMcStmts stmts mc
+ ; rest <- dsMcStmts stmts
; return $ mkApps then_exp' [ mkApps guard_exp' [exp']
, rest ] }
--
-- where [| qs |] is the desugared inner monad comprehenion generated by the
-- statements `qs`.
-dsMcStmt (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_op) stmts_rest mc
- = do { (expr, _) <- dsInnerMonadComp (stmts, binders) (mc { mc_return = Left return_op })
- ; let binders_tuple_type = mkBigCoreTupTy $ map idType binders
+dsMcStmt (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_op) stmts_rest
+ = do { expr <- dsInnerMonadComp stmts binders return_op
+ ; let binders_tup_type = mkBigCoreTupTy $ map idType binders
; usingExpr' <- dsLExpr usingExpr
; using_args <- case maybeByExpr of
Nothing -> return [expr]
Just byExpr -> do
byExpr' <- dsLExpr byExpr
us <- newUniqueSupply
- tuple_binder <- newSysLocalDs binders_tuple_type
- let byExprWrapper = mkTupleCase us binders byExpr' tuple_binder (Var tuple_binder)
- return [Lam tuple_binder byExprWrapper, expr]
+ tup_binder <- newSysLocalDs binders_tup_type
+ let byExprWrapper = mkTupleCase us binders byExpr' tup_binder (Var tup_binder)
+ return [Lam tup_binder byExprWrapper, expr]
; let pat = mkBigLHsVarPatTup binders
- rhs = mkApps usingExpr' ((Type binders_tuple_type) : using_args)
+ rhs = mkApps usingExpr' ((Type binders_tup_type) : using_args)
- ; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest mc }
+ ; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest }
-- Group statements desugar like this:
--
+-- [| (q, then group by e using f); rest |]
+-- ---> f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup ->
+-- case unzip n_tup of qv -> [| rest |]
+--
+-- where variables (v1:t1, ..., vk:tk) are bound by q
+-- qv = (v1, ..., vk)
+-- qt = (t1, ..., tk)
+-- (>>=) :: m2 a -> (a -> m3 b) -> m3 b
+-- f :: forall a. (a -> t) -> m1 a -> m2 (n a)
+-- n_tup :: n qt
+-- unzip :: n qt -> (n t1, ..., n tk) (needs Functor n)
+--
-- [| q, then group by e using f |] -> (f (\q_v -> e) [| q |]) >>= (return . (unzip q_v))
--
-- which is equal to
--
-- where unzip is of the form
--
--- unzip :: m (a,b,c,..) -> (m a,m b,m c,..)
--- unzip m_tuple = ( liftM selN1 m_tuple
--- , liftM selN2 m_tuple
+-- unzip :: n (a,b,c,..) -> (n a,n b,n c,..)
+-- unzip m_tuple = ( fmap selN1 m_tuple
+-- , fmap selN2 m_tuple
-- , .. )
-- where selN1 (a,b,c,..) = a
-- selN2 (a,b,c,..) = b
-- ..
--
-dsMcStmt (GroupStmt stmts binderMap by using return_op bind_op liftM_op) stmts_rest mc
+dsMcStmt (GroupStmt stmts binderMap by using return_op bind_op fmap_op) stmts_rest
= do { let (fromBinders, toBinders) = unzip binderMap
- fromBindersTypes = map idType fromBinders
+ fromBindersTypes = map idType fromBinders -- Types ty
fromBindersTupleTy = mkBigCoreTupTy fromBindersTypes
- toBindersTypes = map idType toBinders
+ toBindersTypes = map idType toBinders -- Types (n ty)
toBindersTupleTy = mkBigCoreTupTy toBindersTypes
- m_ty = mc_m_ty mc
-- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
- ; (expr, _) <- dsInnerMonadComp (stmts, fromBinders) (mc { mc_return = Left return_op })
+ ; expr <- dsInnerMonadComp stmts fromBinders return_op
-- Work out what arguments should be supplied to that expression: i.e. is an extraction
-- function required? If so, create that desugared function and add to arguments
; usingArgs <- case by of
Nothing -> return [expr]
Just by_e -> do { by_e' <- dsLExpr by_e
- ; us <- newUniqueSupply
- ; from_tup_id <- newSysLocalDs fromBindersTupleTy
- ; let by_wrap = mkTupleCase us fromBinders by_e'
- from_tup_id (Var from_tup_id)
- ; return [Lam from_tup_id by_wrap, expr] }
+ ; lam <- matchTuple fromBinders by_e'
+ ; return [lam, expr] }
-- Create an unzip function for the appropriate arity and element types
- ; liftM_op' <- dsExpr liftM_op
- ; (unzip_fn, unzip_rhs) <- mkMcUnzipM liftM_op' m_ty fromBindersTypes
+ ; fmap_op' <- dsExpr fmap_op
+ ; (unzip_fn, unzip_rhs) <- mkMcUnzipM fmap_op' m_ty fromBindersTypes
-- Generate the expressions to build the grouped list
-
- ; let -- First we apply the grouping function to the inner monad
- inner_monad_expr = mkApps usingExpr' ((Type fromBindersTupleTy) : usingArgs)
- -- Then we map our "unzip" across it to turn the "monad of tuples" into "tuples of monads"
- -- We make sure we instantiate the type variable "a" to be a "monad of 'from' tuples" and
- -- the "b" to be a "tuple of 'to' monads"!
- unzipped_inner_monad_expr = mkApps liftM_op' -- !
- -- Types:
- [ Type (m_ty `mkAppTy` fromBindersTupleTy), Type toBindersTupleTy
- -- And arguments:
- , Var unzip_fn, inner_monad_expr ]
- -- Then finally we bind the unzip function around that expression
- bound_unzipped_inner_monad_expr = Let (Rec [(unzip_fn, unzip_rhs)]) unzipped_inner_monad_expr
-
- -- Build a pattern that ensures the consumer binds into the NEW binders, which hold monads
- -- rather than single values
- ; let pat = mkBigLHsVarPatTup toBinders
- rhs = bound_unzipped_inner_monad_expr
-
- ; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest mc }
+ -- Build a pattern that ensures the consumer binds into the NEW binders,
+ -- which hold monads rather than single values
+ ; bind_op' <- dsExpr bind_op
+ ; let bind_ty = exprType bind_op' -- m2 (n (a,b,c)) -> (n (a,b,c) -> r1) -> r2
+ n_tup_ty = funArgTy $ funArgTy $ funResultTy bind_ty
+
+ ; body <- dsMcStmts stmts_rest
+ ; n_tup_var <- newSysLocalDs n_tup_ty
+ ; tup_n_var <- newSysLocalDs (mkBigCoreVarTupTy toBinders)
+ ; us <- newUniqueSupply
+ ; let unzip_n_tup = Let (Rec [(unzip_fn, unzip_rhs)]) $
+ App (Var unzip_fn) (Var n_tup_var)
+ -- unzip_n_tup :: (n a, n b, n c)
+ body' = mkTupleCase us toBinders body unzip_n_tup (Var tup_n_var)
+
+ ; return (mkApps bind_op' [rhs', Lam n_tup_var body']) }
-- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel
-- statements, for example:
--
-- [ body | qs1 | qs2 | qs3 ]
--- -> [ body | (bndrs1, (bndrs2, bndrs3)) <- mzip qs1 (mzip qs2 qs3) ]
---
--- where `mzip` is of the form
+-- -> [ body | (bndrs1, (bndrs2, bndrs3))
+-- <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ]
--
--- mzip :: m a -> m b -> m (a,b)
---
-dsMcStmt (ParStmt pairs mzip_op bind_op return_op) stmts_rest mc
- = do { -- Get types for `return`
- return_op' <- dsExpr return_op
- ; let pairs_with_return = map (\tp@(_,b) -> (mkReturn b,tp)) pairs
- mkReturn bndrs = mkApps return_op' [Type (mkBigCoreTupTy (map idType bndrs))]
-
- ; pairs' <- mapM (\(r,tp) -> dsInnerMonadComp tp mc{mc_return = Right r})
- pairs_with_return
-
- ; let (exps, _qual_tys) = unzip pairs'
- -- Types of our `Id`s are getting messed up by `dsInnerMonadComp`
- -- so we construct them by hand:
- qual_tys = map (mkBigCoreTupTy . map idType . snd) pairs
+-- where `mzip` has type
+-- mzip :: forall a b. m a -> m b -> m (a,b)
+-- NB: we need a polymorphic mzip because we call it several times
+dsMcStmt (ParStmt pairs mzip_op bind_op return_op) stmts_rest
+ = do { exps <- mapM ds_inner pairs
+ ; let qual_tys = map (mkBigCoreVarTupTy . snd) pairs
; mzip_op' <- dsExpr mzip_op
; (zip_fn, zip_rhs) <- mkMcZipM mzip_op' (mc_m_ty mc) qual_tys
pat = foldr (\tn tm -> mkBigLHsPatTup [tn, tm]) (last vars) (init vars)
rhs = Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)
- ; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest mc }
+ ; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest }
+ where
+ ds_inner (stmts, bndrs) = dsInnerMonadComp stmts bndrs mono_ret_op
+ where
+ mono_ret_op = HsWrap (WpTyApp (mkBigCoreVarTupTy bndrs)) return_op
-dsMcStmt stmt _ _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
+dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
+
+
+matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr
+-- (matchTuple [a,b,c] body)
+-- returns the Core term
+-- \x. case x of (a,b,c) -> body
+matchTuple ids body
+ = do { us <- newUniqueSupply
+ ; tup_id <- newSysLocalDs (mkBigLHsVarPatTup ids)
+ ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) }
-- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a
-> SyntaxExpr Id
-> SyntaxExpr Id
-> [LStmt Id]
- -> DsMonadComp
-> DsM CoreExpr
-dsMcBindStmt pat rhs' bind_op fail_op stmts mc
- = do { body <- dsMcStmts stmts mc
+dsMcBindStmt pat rhs' bind_op fail_op stmts
+ = do { body <- dsMcStmts stmts
; bind_op' <- dsExpr bind_op
; var <- selectSimpleMatchVarL pat
; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2
showSDoc (ppr (getLoc pat))
-- Desugar nested monad comprehensions, for example in `then..` constructs
-dsInnerMonadComp :: ([LStmt Id], [Id])
- -> DsMonadComp
- -> DsM (CoreExpr, Type)
-dsInnerMonadComp (stmts, bndrs) DsMonadComp{ mc_return, mc_m_ty }
- = do { expr <- dsMcStmts stmts mc'
- ; return (expr, bndrs_tuple_type) }
- where
- bndrs_types = map idType bndrs
- bndrs_tuple_type = mkAppTy mc_m_ty $ mkBigCoreTupTy bndrs_types
- mc' = DsMonadComp mc_return (mkBigLHsVarTup bndrs) mc_m_ty
+-- dsInnerMonadComp quals [a,b,c] ret_op
+-- returns the desugaring of
+-- [ (a,b,c) | quals ]
+
+dsInnerMonadComp :: [LStmt Id]
+ -> [Id] -- Return a tuple of these variables
+ -> LHsExpr Id -- The monomorphic "return" operator
+ -> DsM CoreExpr
+dsInnerMonadComp stmts bndrs ret_op
+ = dsMcStmts (stmts ++ [noLoc (ReturnStmt (mkBigLHsVarTup bndrs) ret_op)])
-- The `unzip` function for `GroupStmt` in a monad comprehensions
--
import BasicTypes
import DataCon
import SrcLoc
+import Util( dropTail )
import Outputable
import FastString
-- because in this context we never use
-- the PatGuard or ParStmt variant
[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
| ExplicitList -- syntactic list
= sep [hang (ptext (sLit "let")) 2 (pprBinds binds),
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)
= brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
HsPar {} -> pp_as_was
HsBracket {} -> pp_as_was
HsBracketOut _ [] -> pp_as_was
- HsDo sc _ _ _ _
+ HsDo sc _ _
| isListCompExpr sc -> pp_as_was
_ -> parens pp_as_was
-- The SyntaxExprs in here are used *only* for do-notation and monad
-- comprehensions, which have rebindable syntax. Otherwise they are unused.
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)
(SyntaxExpr idR) -- The (>>=) operator
(SyntaxExpr idR) -- The fail operator
-- ParStmts only occur in a list/monad comprehension
| ParStmt [([LStmt idL], [idR])]
- (SyntaxExpr idR) -- polymorphic `mzip` for monad comprehensions
+ (SyntaxExpr idR) -- Polymorphic `mzip` for monad comprehensions
(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]
-- After renaming, the ids are the binders bound by the stmts and used
-- because the Id may be *polymorphic*, but
-- the returned thing has to be *monomorphic*,
-- 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)
\end{code}
Note [Monad Comprehensions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Monad comprehensions require seperate functions like 'return' and '>>=' for
-desugaring. These functions are stored in the 'HsDo' expression and the
-statements used in monad comprehensions. For example, the 'return' of the
-'HsDo' expression is used to lift the body of the monad comprehension:
+Monad comprehensions require separate functions like 'return' and
+'>>=' for desugaring. These functions are stored in the statements
+used in monad comprehensions. For example, the 'return' of the 'LastStmt'
+expression is used to lift the body of the monad comprehension:
[ body | stmts ]
=>
ppr stmt = pprStmt stmt
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 (LetStmt binds) = hsep [ptext (sLit "let"), pprBinds binds]
pprStmt (ExprStmt expr _ _ _) = ppr expr
pprBy Nothing = empty
pprBy (Just e) = ptext (sLit "by") <+> ppr e
-pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc
-pprDo DoExpr stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body
-pprDo GhciStmt stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body
-pprDo MDoExpr stmts body = ptext (sLit "mdo") <+> ppr_do_stmts stmts body
-pprDo ListComp stmts body = brackets $ pprComp stmts body
-pprDo PArrComp stmts body = pa_brackets $ pprComp stmts body
-pprDo MonadComp stmts body = brackets $ pprComp stmts body
-pprDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt
+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 MDoExpr stmts = ptext (sLit "mdo") <+> ppr_do_stmts stmts
+pprDo ListComp stmts = brackets $ pprComp stmts
+pprDo PArrComp stmts = pa_brackets $ pprComp stmts
+pprDo MonadComp stmts = brackets $ pprComp stmts
+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,
-- so that we are not vulnerable to layout bugs
-ppr_do_stmts stmts body
- = lbrace <+> pprDeeperList vcat ([ppr s <> semi | s <- stmts] ++ [ppr body])
+ppr_do_stmts stmts
+ = lbrace <+> pprDeeperList vcat ([ppr s <> semi | s <- stmts])
<+> rbrace
ppr_lc_stmts :: OutputableBndr id => [LStmt id] -> [SDoc]
ppr_lc_stmts stmts = [ppr s <> comma | s <- stmts]
-pprComp :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc
-pprComp quals body -- Prints: body | qual1, ..., qualn
- = hang (ppr body <+> char '|') 2 (interpp'SP quals)
+pprComp :: OutputableBndr id => [LStmt id] -> SDoc
+pprComp quals -- Prints: body | qual1, ..., qualn
+ | 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}
%************************************************************************
data HsStmtContext id
= ListComp
- | DoExpr
- | GhciStmt -- A command-line Stmt in GHCi pat <- rhs
- | MDoExpr -- Recursive do-expression
| MonadComp
| 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
| ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt
| TransformStmtCtxt (HsStmtContext id) -- A branch of a transform stmt
mkMatchGroup, mkMatch, mkHsLam, mkHsIf,
mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI,
coiToHsWrapper, mkHsLams, mkHsDictLet,
- mkHsOpApp, mkHsDo, mkHsWrapPat, mkHsWrapPatCoI,
+ mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCoI, mkDoStmts,
nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp,
-- Stmts
- mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt,
+ mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, mkLastStmt,
mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt,
emptyRecStmt, mkRecStmt,
mkHsIntegral :: Integer -> PostTcType -> HsOverLit id
mkHsFractional :: Rational -> 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
mkNPlusKPat :: Located id -> HsOverLit id -> Pat id
mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
+mkLastStmt :: LHsExpr idR -> StmtLR idL idR
mkExprStmt :: LHsExpr idR -> StmtLR idL idR
mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR
noRebindableInfo :: Bool
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 c a b = HsIf (Just noSyntaxExpr) c a b
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
+mkLastStmt expr = LastStmt expr noSyntaxExpr
mkExprStmt expr = ExprStmt expr noSyntaxExpr noSyntaxExpr placeHolderType
mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = []
, recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr
, recS_bind_fn = noSyntaxExpr
- , recS_rec_rets = [] }
+ , recS_rec_rets = [], recS_ret_ty = placeHolderType }
mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
nlWildPat :: LPat id
nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking
-nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
-nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
+nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id
+nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
-- Id Binders for a Stmt... [but what about pattern-sig type vars]?
collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
collectStmtBinders (LetStmt binds) = collectLocalBinders binds
-collectStmtBinders (ExprStmt _ _ _ _) = []
+collectStmtBinders (ExprStmt {}) = []
+collectStmtBinders (LastStmt {}) = []
collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders
$ concatMap fst xs
collectStmtBinders (TransformStmt stmts _ _ _ _ _) = collectLStmtsBinders stmts
hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat
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 (TransformStmt stmts _ _ _ _ _) = hs_lstmts stmts
| 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
| '-' fexp { LL $ NegApp $2 noSyntaxExpr }
- | 'do' stmtlist {% let loc = comb2 $1 $2 in
- checkDo loc (unLoc $2) >>= \ (stmts,body) ->
- 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)) }
+ | 'do' stmtlist { L (comb2 $1 $2) (mkHsDo DoExpr (unLoc $2)) }
+ | 'mdo' stmtlist { L (comb2 $1 $2) (mkHsDo MDoExpr (unLoc $2)) }
+
| scc_annot exp { LL $ if opt_SccProfilingOn
then HsSCC (unLoc $1) $2
else HsPar $2 }
| texp ',' exp '..' { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) }
| texp '..' exp { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) }
| texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) }
- | texp '|' flattenedpquals {% checkMonadComp >>= \ ctxt ->
- return (sL (comb2 $1 $>) $ mkHsDo ctxt (unLoc $3) $1) }
+ | texp '|' flattenedpquals
+ {% checkMonadComp >>= \ ctxt ->
+ return (sL (comb2 $1 $>) $
+ mkHsComp ctxt (unLoc $3) $1) }
lexps :: { Located [LHsExpr RdrName] }
: lexps ',' texp { LL (((:) $! $3) $! unLoc $1) }
(reverse (unLoc $1)) }
| texp '..' exp { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) }
| 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.
-- Statement sequences
stmtlist :: { Located [LStmt RdrName] }
- : '{' stmts '}' { LL (unLoc $2) }
+ : '{' stmts '}' { LL (mkDoStmts (unLoc $2)) }
| vocurly stmts close { $2 }
-- do { ;; s ; s ; ; s ;; }
checkPattern, -- HsExp -> P HsPat
bang_RDR,
checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
- checkDo, -- [Stmt] -> P [Stmt]
- checkMDo, -- [Stmt] -> P [Stmt]
checkMonadComp, -- P (HsStmtContext RdrName)
checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
check loc _ _ = parseErrorSDoc loc
(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.
-- Monad stuff
thenIOName, bindIOName, returnIOName, failIOName,
failMName, bindMName, thenMName, returnMName,
+ fmapName,
-- MonadRec stuff
mfixName,
ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey
geName = methName gHC_CLASSES (fsLit ">=") geClassOpKey
functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey
+fmapName = methName gHC_BASE (fsLit "fmap") fmapClassOpKey
-- Class Monad
monadClassName, thenMName, bindMName, returnMName, failMName :: Name
failMClassOpKey = mkPreludeMiscIdUnique 112
bindMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=)
thenMClassOpKey = mkPreludeMiscIdUnique 114 -- (>>)
+fmapClassOpKey = mkPreludeMiscIdUnique 115
returnMClassOpKey = mkPreludeMiscIdUnique 117
-- Recursive do notation
rnLExpr expr `thenM` \ (expr',fvExpr) ->
return (HsLet binds' expr', fvExpr)
-rnExpr (HsDo do_or_lc stmts body _ _)
- = do { ((stmts', body'), fvs1) <- rnStmts do_or_lc stmts $ \ _ ->
- rnLExpr body
- ; (return_op, fvs2) <-
- if isMonadCompExpr do_or_lc
- then lookupSyntaxName returnMName
- else return (noSyntaxExpr, emptyFVs)
-
- ; return ( HsDo do_or_lc stmts' body' return_op placeHolderType
- , fvs1 `plusFV` fvs2 ) }
+rnExpr (HsDo do_or_lc stmts _)
+ = do { ((stmts', _), fvs) <- rnStmts do_or_lc stmts (\ _ -> return ())
+ ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) }
rnExpr (ExplicitList _ exps)
= rnExprs exps `thenM` \ (exps', fvs) ->
--
-- Renaming a single RecStmt can give a sequence of smaller Stmts
-rnStmts _ [] thing_inside
- = do { (res, fvs) <- thing_inside []
- ; return (([], res), fvs) }
+rnStmts ctxt [] thing_inside
+ = do { addErr (ptext (sLit "Empty") <+> pprStmtContext ctxt)
+ ; (thing, fvs) <- thing_inside []
+ ; return (([], thing), fvs) }
+
+rnStmts MDoExpr stmts thing_inside -- Deal with mdo
+ = -- Behave like do { rec { ...all but last... }; last }
+ do { ((stmts1, (stmts2, thing)), fvs)
+ <- rnStmt MDoExpr (mkRecStmt all_but_last) $ \ bndrs ->
+ do { checkStmt MDoExpr True last_stmt
+ ; rnStmt MDoExpr last_stmt thing_inside }
+ ; return (((stmts1 ++ stmts2), thing), fvs) }
+ where
+ Just (all_but_last, last_stmt) = snocView stmts
rnStmts ctxt (stmt@(L loc _) : stmts) thing_inside
+ | null stmts
+ = setSrcSpan loc $
+ do { let last_stmt = case stmt of
+ ExprStmt e _ _ _ -> LastStmt e noSyntaxExpr
+ ; checkStmt ctxt True {- last stmt -} stmt
+ ; rnStmt ctxt stmt thing_inside }
+
+ | otherwise
= do { ((stmts1, (stmts2, thing)), fvs)
- <- setSrcSpan loc $
- rnStmt ctxt stmt $ \ bndrs1 ->
- rnStmts ctxt stmts $ \ bndrs2 ->
- thing_inside (bndrs1 ++ bndrs2)
+ <- setSrcSpan loc $
+ do { checkStmt ctxt False {- Not last -} stmt
+ ; rnStmt ctxt stmt $ \ bndrs1 ->
+ rnStmts ctxt stmts $ \ bndrs2 ->
+ thing_inside (bndrs1 ++ bndrs2) }
; return (((stmts1 ++ stmts2), thing), fvs) }
-
-rnStmt :: HsStmtContext Name -> LStmt RdrName
+----------------------
+rnStmt :: HsStmtContext Name
+ -> LStmt RdrName
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt Name], thing), FreeVars)
-- Variables bound by the Stmt, and mentioned in thing_inside,
-- do not appear in the result FreeVars
+rnStmt ctxt (L loc (LastStmt expr _)) thing_inside
+ = do { (expr', fv_expr) <- rnLExpr expr
+ ; (ret_op, fvs1) <- lookupSyntaxName 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
fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
- = do { (expr', fv_expr) <- rnLExpr expr
+ = do { checkBindStmt ctxt is_last
+ ; (expr', fv_expr) <- rnLExpr expr
-- The binders do not scope over the expression
; (bind_op, fvs1) <- lookupSyntaxName bindMName
; (fail_op, fvs2) <- lookupSyntaxName failMName
; return (([L loc (LetStmt binds')], thing), fvs) } }
rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
- = do { checkRecStmt ctxt
-
+ = do {
-- Step1: Bring all the binders of the mdo into scope
-- (Remember that this also removes the binders from the
-- finally-returned free-vars.)
; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
rnStmt ctxt (L loc (ParStmt segs _ _ _)) thing_inside
- = do { checkParStmt ctxt
- ; ((mzip_op, fvs1), (bind_op, fvs2), (return_op, fvs3)) <- if isMonadCompExpr ctxt
+ = do { ((mzip_op, fvs1), (bind_op, fvs2), (return_op, fvs3)) <- if isMonadCompExpr ctxt
then (,,) <$> lookupSyntaxName mzipName
<*> lookupSyntaxName bindMName
<*> lookupSyntaxName returnMName
, fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
rnStmt ctxt (L loc (TransformStmt stmts _ using by _ _)) thing_inside
- = do { checkTransformStmt ctxt
-
- ; (using', fvs1) <- rnLExpr using
+ = do { (using', fvs1) <- rnLExpr using
; ((stmts', (by', used_bndrs, thing)), fvs2)
<- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
rnStmt ctxt (L loc (GroupStmt stmts _ by using _ _ _)) thing_inside
- = do { checkTransformStmt ctxt
-
- -- Rename the 'using' expression in the context before the transform is begun
+ = do { -- Rename the 'using' expression in the context before the transform is begun
; (using', fvs1) <- case using of
Left e -> do { (e', fvs) <- rnLExpr e; return (Left e', fvs) }
Right _
; return ((by', used_bndrs, thing), fvs) }
-- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
- ; ((return_op, fvs3), (bind_op, fvs4), (liftM_op, fvs5)) <-
+ ; ((return_op, fvs3), (bind_op, fvs4), (fmap_op, fvs5)) <-
if isMonadCompExpr ctxt
then (,,) <$> lookupSyntaxName returnMName
<*> lookupSyntaxName bindMName
- <*> lookupSyntaxName liftMName
+ <*> lookupSyntaxName fmapName
else return ( (noSyntaxExpr, emptyFVs)
, (noSyntaxExpr, emptyFVs)
, (noSyntaxExpr, emptyFVs) )
-- See Note [GroupStmt binder map] in HsExpr
; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
- ; return (([L loc (GroupStmt stmts' bndr_map by' using' return_op bind_op liftM_op)], thing), all_fvs) }
+ ; return (([L loc (GroupStmt stmts' bndr_map by' using' return_op bind_op fmap_op)], thing), all_fvs) }
type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts
%************************************************************************
\begin{code}
-
----------------------
-- Checking when a particular Stmt is ok
-checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
-checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
-checkLetStmt _ctxt _binds = return ()
+checkStmt :: HsStmtContext Name
+ -> Bool -- True <=> this is the last Stmt in the sequence
+ -> LStmt RdrName
+ -> RnM ()
+checkStmt ctxt is_last (L _ stmt)
+ = do { dflags <- getDOpts
+ ; case okStmt dflags ctxt is_last stmt of
+ Nothing -> return ()
+ Just extr -> addErr (msg $$ extra) }
+ where
+ msg = ptext (sLit "Unexpected") <+> pprStmtCat stmt
+ <+> ptext (sLit "statement in") <+> pprStmtContext ctxt
+
+pprStmtCat :: Stmt a -> SDoc
+pprStmtCat (TransformStmt {}) = ptext (sLit "transform")
+pprStmtCat (GroupStmt {}) = ptext (sLit "group")
+pprStmtCat (LastStmt {}) = ptext (sLit "return expression")
+pprStmtCat (ExprStmt {}) = ptext (sLit "exprssion")
+pprStmtCat (BindStmt {}) = ptext (sLit "binding")
+pprStmtCat (LetStmt {}) = ptext (sLit "let")
+pprStmtCat (RecStmt {}) = ptext (sLit "rec")
+pprStmtCat (ParStmt {}) = ptext (sLit "parallel")
+
+------------
+isOK, notOK :: Maybe SDoc
+isOK = Nothing
+notOK = Just empty
+
+okStmt, okDoStmt, okCompStmt :: DynFlags -> HsStmtContext Name -> Bool
+ -> 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 dflags GhciStmt is_last stmt
+ = case stmt of
+ ExprStmt {} -> isOK
+ BindStmt {} -> isOK
+ LetStmt {} -> isOK
+ _ -> notOK
+
+okStmt dflags (PatGuard {}) is_last stmt
+ = case stmt of
+ ExprStmt {} -> isOK
+ BindStmt {} -> isOK
+ LetStmt {} -> isOK
+ _ -> notOK
+
+okStmt dflags (ParStmtCtxt ctxt) is_last stmt
+ = case stmt of
+ LetStmt (HsIPBinds {}) -> notOK
+ _ -> okStmt dflags ctxt is_last stmt
+
+okStmt dflags (TransformStmtCtxt ctxt) is_last stmt
+ = okStmt dflags ctxt is_last stmt
+
+okStmt ctxt is_last stmt
+ | isDoExpr ctxt = okDoStmt ctxt is_last stmt
+ | isCompExpr ctxt = okCompStmt ctxt is_last stmt
+ | otherwise = pprPanic "okStmt" (pprStmtContext ctxt)
+
+----------------
+okDoStmt dflags ctxt is_last stmt
+ | is_last
+ = case stmt of
+ LastStmt {} -> isOK
+ _ -> Just (ptext (sLit "The last statement in") <+> what <+>
+ ptext (sLIt "construct must be an expression"))
+ where
+ what = case ctxt of
+ DoExpr -> ptext (sLit "a 'do'")
+ MDoExpr -> ptext (sLit "an 'mdo'")
+ _ -> panic "checkStmt"
+
+ | otherwise
+ = case stmt of
+ RecStmt {} -> isOK -- Shouldn't we test a flag?
+ BindStmt {} -> isOK
+ LetStmt {} -> isOK
+ ExprStmt {} -> isOK
+ _ -> notOK
+
+
+----------------
+okCompStmt dflags ctxt is_last stmt
+ | is_last
+ = case stmt of
+ LastStmt {} -> Nothing
+ -> pprPanic "Unexpected stmt" (ppr stmt) -- Not a user error
+
+ | otherwise
+ = case stmt of
+ BindStmt {} -> isOK
+ LetStmt {} -> isOK
+ ExprStmt {} -> isOK
+ RecStmt {} -> notOK
+ ParStmt {}
+ | dopt dflags Opt_ParallelListComp -> isOK
+ | otherwise -> Just (ptext (sLit "Use -XParallelListComp"))
+ TransformStmt {}
+ | dopt dflags Opt_transformListComp -> isOK
+ | otherwise -> Just (ptext (sLit "Use -XTransformListComp"))
+ GroupStmt {}
+ | dopt dflags Opt_transformListComp -> isOK
+ | otherwise -> Just (ptext (sLit "Use -XTransformListComp"))
+
+
+checkStmt :: HsStmtContext Name -> Stmt RdrName -> Maybe SDoc
+-- Non-last stmt
+
+checkStmt (ParStmtCtxt _) (HsIPBinds binds)
+ = Just (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
-- We do not allow implicit-parameter bindings in a parallel
-- list comprehension. I'm not sure what it might mean.
----------
-checkRecStmt :: HsStmtContext Name -> RnM ()
-checkRecStmt MDoExpr = return () -- Recursive stmt ok in 'mdo'
-checkRecStmt DoExpr = return () -- and in 'do'
-checkRecStmt ctxt = addErr msg
- where
- msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
+checkStmt ctxt (RecStmt {})
+ | not (isDoExpr ctxt)
+ = addErr (ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt)
---------
checkParStmt :: HsStmtContext Name -> RnM ()
-- and it maintains uniformity with other rebindable syntax
; return (HsIf (Just fun') pred' b1' b2') }
-tcExpr (HsDo do_or_lc stmts body return_op _) res_ty
- = tcDoStmts do_or_lc stmts body return_op res_ty
+tcExpr (HsDo do_or_lc stmts _) res_ty
+ = tcDoStmts do_or_lc stmts res_ty
tcExpr (HsProc pat cmd) res_ty
= do { (pat', cmd', coi) <- tcProc pat cmd res_ty
single_con_range
= mk_easy_FunBind loc range_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
- nlHsDo ListComp stmts con_expr
+ noLoc (mkHsComp ListComp stmts con_expr)
where
stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
read_nullary_cons
= 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)
(nlList (map mk_pair nullary_cons))]
-- NB For operators the parens around (:=:) are matched by the
------------------------------------------------------------------------
-- Helpers
------------------------------------------------------------------------
- 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 })
- bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
- 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)
+ mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
+ mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b })
+ , nlHsDo DoExpr (ss ++ [mkExprStmt b])]
+ bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
+ 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'
zonkLExpr new_env expr `thenM` \ new_expr ->
returnM (HsLet new_binds new_expr)
-zonkExpr env (HsDo do_or_lc stmts body return_op ty)
- = zonkStmts env stmts `thenM` \ (new_env, new_stmts) ->
- zonkLExpr new_env body `thenM` \ new_body ->
- zonkExpr new_env return_op `thenM` \ new_return ->
+zonkExpr env (HsDo do_or_lc stmts ty)
+ = zonkStmts env stmts `thenM` \ (_, new_stmts) ->
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)
= zonkTcTypeToType env ty `thenM` \ new_ty ->
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_rec_rets = rets })
+ , recS_rec_rets = rets, redS_ret_ty = ret_ty })
= do { new_rvs <- zonkIdBndrs env rvs
; new_lvs <- zonkIdBndrs env lvs
+ ; new_ret_ty <- zonkTcTypeToType env ret_ty
; new_ret_id <- zonkExpr env ret_id
; new_mfix_id <- zonkExpr env mfix_id
; new_bind_id <- zonkExpr env bind_id
RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
, recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
, recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
- , recS_rec_rets = new_rets }) }
+ , recS_rec_rets = new_rets, recS_ret_ty = new_ret_ty }) }
zonkStmt env (ExprStmt expr then_op guard_op ty)
= zonkLExpr env expr `thenM` \ new_expr ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
returnM (env, ExprStmt new_expr new_then new_guard new_ty)
+zonkStmt env (LastStmt expr ret_op)
+ = zonkLExpr env expr `thenM` \ new_expr ->
+ zonkExpr env ret_op `thenM` \ new_ret ->
+ returnM (env, LastStmt new_expr new_ret)
+
zonkStmt env (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_op)
= do { (env', stmts') <- zonkStmts env stmts
; let binders' = zonkIdOccs env' binders
\begin{code}
tcDoStmts :: HsStmtContext Name
-> [LStmt Name]
- -> LHsExpr Name
- -> SyntaxExpr Name -- 'return' function for monad
- -- comprehensions
-> TcRhoType
-> TcM (HsExpr TcId) -- Returns a HsDo
-tcDoStmts ListComp stmts body _ res_ty
+tcDoStmts ListComp stmts res_ty
= do { (coi, elt_ty) <- matchExpectedListTy res_ty
- ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts
- elt_ty $
- tcBody body
+ ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts res_ty
; return $ mkHsWrapCoI coi
- (HsDo ListComp stmts' body' noSyntaxExpr (mkListTy elt_ty)) }
+ (HsDo ListComp stmts' (mkListTy elt_ty)) }
-tcDoStmts PArrComp stmts body _ res_ty
+tcDoStmts PArrComp stmts res_ty
= do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
- ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts
- elt_ty $
- tcBody body
+ ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty
; return $ mkHsWrapCoI coi
- (HsDo PArrComp stmts' body' noSyntaxExpr (mkPArrTy elt_ty)) }
+ (HsDo PArrComp stmts' (mkPArrTy elt_ty)) }
-tcDoStmts DoExpr stmts body _ res_ty
- = do { (stmts', body') <- tcStmts DoExpr tcDoStmt stmts res_ty $
- tcBody body
- ; return (HsDo DoExpr stmts' body' noSyntaxExpr res_ty) }
+tcDoStmts DoExpr stmts res_ty
+ = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty
+ ; return (HsDo DoExpr stmts' res_ty) }
-tcDoStmts MDoExpr stmts body _ res_ty
- = do { (stmts', body') <- tcStmts MDoExpr tcDoStmt stmts res_ty $
- tcBody body
- ; return (HsDo MDoExpr stmts' body' noSyntaxExpr res_ty) }
+tcDoStmts MDoExpr stmts res_ty
+ = do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty
+ ; return (HsDo MDoExpr stmts' res_ty) }
-tcDoStmts MonadComp stmts body return_op res_ty
- = do { (stmts', (body', return_op')) <- tcStmts MonadComp tcMcStmt stmts res_ty $
- tcMcBody body return_op
- ; return $ HsDo MonadComp stmts' body' return_op' res_ty }
+tcDoStmts MonadComp stmts res_ty
+ = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty
+ ; return (HsDo MonadComp stmts' res_ty) }
tcDoStmts ctxt _ _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
-> TcStmtChecker -- NB: higher-rank type
-> [LStmt Name]
-> TcRhoType
- -> (TcRhoType -> TcM thing)
- -> TcM ([LStmt TcId], thing)
+ -> TcM [LStmt TcId]
+tcStmts ctxt stmt_chk stmts res_ty
+ = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_check stmts res_ty $
+ const (return ())
+ ; return stmts' }
+
+tcStmtsAndThen :: HsStmtContext Name
+ -> TcStmtChecker -- NB: higher-rank type
+ -> [LStmt Name]
+ -> TcRhoType
+ -> (TcRhoType -> TcM thing)
+ -> TcM ([LStmt TcId], thing)
-- Note the higher-rank type. stmt_chk is applied at different
-- types in the equations for tcStmts
-tcStmts _ _ [] res_ty thing_inside
+tcStmtsAndThen _ _ [] res_ty thing_inside
= do { thing <- thing_inside res_ty
; return ([], thing) }
-- LetStmts are handled uniformly, regardless of context
-tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
+tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
= do { (binds', (stmts',thing)) <- tcLocalBinds binds $
- tcStmts ctxt stmt_chk stmts res_ty thing_inside
+ tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside
; return (L loc (LetStmt binds') : stmts', thing) }
-- For the vanilla case, handle the location-setting part
-tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
+tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
= do { (stmt', (stmts', thing)) <-
- setSrcSpan loc $
- addErrCtxt (pprStmtInCtxt ctxt stmt) $
- stmt_chk ctxt stmt res_ty $ \ res_ty' ->
- popErrCtxt $
- tcStmts ctxt stmt_chk stmts res_ty' $
+ setSrcSpan loc $
+ addErrCtxt (pprStmtInCtxt ctxt stmt) $
+ stmt_chk ctxt stmt res_ty $ \ res_ty' ->
+ popErrCtxt $
+ tcStmtsAndThen ctxt stmt_chk stmts res_ty' $
thing_inside
; return (L loc stmt' : stmts', thing) }
tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
-> TcStmtChecker
+tcLcStmt m_tc ctxt (LastStmt body _) elt_ty thing_inside
+ = do { body' <- tcMonoExpr body elt_ty
+ ; thing <- thing_inside elt_ty
+ ; return (LastStmt body' noSyntaxExpr, thing) }
+
-- A generator, pat <- rhs
-tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
+tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) elt_ty thing_inside
= do { pat_ty <- newFlexiTyVarTy liftedTypeKind
; rhs' <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty])
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
- thing_inside res_ty
+ thing_inside elt_ty
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
-- A boolean guard
-tcLcStmt _ _ (ExprStmt rhs _ _ _) res_ty thing_inside
+tcLcStmt _ _ (ExprStmt rhs _ _ _) elt_ty thing_inside
= do { rhs' <- tcMonoExpr rhs boolTy
- ; thing <- thing_inside res_ty
+ ; thing <- thing_inside elt_ty
; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) }
-- A parallel set of comprehensions
tcMcStmt :: TcStmtChecker
+tcMcStmt ctxt (LastStmt body return_op) res_ty thing_inside
+ = do { a_ty <- newFlexiTyVarTy liftedTypeKind
+ ; return_op' <- tcSyntaxOp MCompOrigin return_op
+ (a_ty `mkFunTy` res_ty)
+ ; body' <- tcMonoExpr body a_ty
+ ; return (body', return_op') }
+
-- Generators for monad comprehensions ( pat <- rhs )
--
-- [ body | q <- gen ] -> gen :: m a
-- q :: a
--
+
tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
= do { rhs_ty <- newFlexiTyVarTy liftedTypeKind
; pat_ty <- newFlexiTyVarTy liftedTypeKind
; new_res_ty <- newFlexiTyVarTy liftedTypeKind
+
+ -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
; bind_op' <- tcSyntaxOp MCompOrigin bind_op
(mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
- -- If (but only if) the pattern can fail,
- -- typecheck the 'fail' operator
+ -- If (but only if) the pattern can fail, typecheck the 'fail' operator
; fail_op' <- if isIrrefutableHsPat pat
then return noSyntaxExpr
else tcSyntaxOp MCompOrigin fail_op (mkFunTy stringTy new_res_ty)
-- [ body | stmts, then f ] -> f :: forall a. m a -> m a
-- [ body | stmts, then f by e ] -> f :: forall a. (a -> t) -> m a -> m a
--
-tcMcStmt ctxt (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_op) elt_ty thing_inside
+tcMcStmt ctxt (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_op) res_ty thing_inside
= do {
-- We don't know the types of binders yet, so we use this dummy and
-- later unify this type with the `m_bndr_ty`
ty_dummy <- newFlexiTyVarTy liftedTypeKind
; (stmts', (binders', usingExpr', maybeByExpr', return_op', bind_op', thing)) <-
- tcStmts (TransformStmtCtxt ctxt) tcMcStmt stmts ty_dummy $ \elt_ty' -> do
- { (_, (m_ty, _)) <- matchExpectedAppTy elt_ty'
+ tcStmts (TransformStmtCtxt ctxt) tcMcStmt stmts ty_dummy $ \res_ty' -> do
+ { (_, (m_ty, _)) <- matchExpectedAppTy res_ty'
; (usingExpr', maybeByExpr') <-
case maybeByExpr of
Nothing -> do
-- -> ( (a,b,c,..) -> m (a,b,c,..) )
-- -> m (a,b,c,..)
--
- ; let bndr_ty = mkChunkified mkBoxedTupleTy $ map idType bndr_ids
+ ; let bndr_ty = mkBigCoreVarTupTy bndr_ids
m_bndr_ty = m_ty `mkAppTy` bndr_ty
; return_op' <- tcSyntaxOp MCompOrigin return_op
(bndr_ty `mkFunTy` m_bndr_ty)
; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
- m_bndr_ty `mkFunTy` (bndr_ty `mkFunTy` elt_ty)
- `mkFunTy` elt_ty
+ m_bndr_ty `mkFunTy` (bndr_ty `mkFunTy` res_ty)
+ `mkFunTy` res_ty
-- Unify types of the inner comprehension and the binders type
- ; _ <- unifyType elt_ty' m_bndr_ty
+ ; _ <- unifyType res_ty' m_bndr_ty
-- Typecheck the `thing` with out old type (which is the type
-- of the final result of our comprehension)
- ; thing <- thing_inside elt_ty
+ ; thing <- thing_inside res_ty
; return (bndr_ids, usingExpr', maybeByExpr', return_op', bind_op', thing) }
-- [ body | stmts, then group using f ]
-- -> f :: forall a. m a -> m (m a)
--
-tcMcStmt ctxt (GroupStmt stmts bindersMap by using return_op bind_op liftM_op) elt_ty thing_inside
- = do { let (bndr_names, m_bndr_names) = unzip bindersMap
-
- ; (_,(m_ty,_)) <- matchExpectedAppTy elt_ty
- ; let alphaMTy = m_ty `mkAppTy` alphaTy
- alphaMMTy = m_ty `mkAppTy` alphaMTy
-
- -- We don't know the type of the bindings yet. It's not elt_ty!
- ; bndr_ty_dummy <- newFlexiTyVarTy liftedTypeKind
-
- ; (stmts', (bndr_ids, by', using_ty, return_op', bind_op')) <-
- tcStmts (TransformStmtCtxt ctxt) tcMcStmt stmts bndr_ty_dummy $ \elt_ty' -> do
- { (by', using_ty) <-
- case by of
- Nothing -> -- check that using :: forall a. m a -> m (m a)
- return (Nothing, mkForAllTy alphaTyVar $
- alphaMTy `mkFunTy` alphaMMTy)
-
- Just by_e -> -- check that using :: forall a. (a -> t) -> m a -> m (m a)
- -- where by :: t
- do { (by_e', t_ty) <- tcInferRhoNC by_e
- ; return (Just by_e', mkForAllTy alphaTyVar $
- (alphaTy `mkFunTy` t_ty)
- `mkFunTy` alphaMTy
- `mkFunTy` alphaMMTy) }
-
+tcMcStmt ctxt (GroupStmt stmts bindersMap by using return_op bind_op fmap_op) res_ty thing_inside
+ = do { m1_ty <- newFlexiTyVarTy liftedTypeKind
+ ; m2_ty <- newFlexiTyVarTy liftedTypeKind
+ ; n_ty <- newFlexiTyVarTy liftedTypeKind
+ ; tup_ty_var <- newFlexiTyVarTy liftedTypeKind
+ ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
+ ; let (bndr_names, n_bndr_names) = unzip bindersMap
+ m1_tup_ty = m1_ty `mkAppTy` tup_ty_var
+
+ -- '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
+ ; (stmts', (bndr_ids, by_e_ty, return_op')) <-
+ tcStmts (TransformStmtCtxt ctxt) tcMcStmt stmts m1_tup_ty $ \res_ty' -> do
+ { by_e_ty <- mapM tcInferRhoNC by_e
-- Find the Ids (and hence types) of all old binders
; bndr_ids <- tcLookupLocalIds bndr_names
-- 'return' is only used for the binders, so we know its type.
--
-- return :: (a,b,c,..) -> m (a,b,c,..)
- --
- ; let bndr_ty = mkChunkified mkBoxedTupleTy $ map idType bndr_ids
- m_bndr_ty = m_ty `mkAppTy` bndr_ty
- ; return_op' <- tcSyntaxOp MCompOrigin return_op $ bndr_ty `mkFunTy` m_bndr_ty
+ ; return_op' <- tcSyntaxOp MCompOrigin return_op $
+ (mkBigCoreVarTupTy bndr_ids) `mkFunTy` res_ty'
- -- '>>=' is used to pass the grouped binders to the rest of the
- -- comprehension.
- --
- -- (>>=) :: m (m a, m b, m c, ..)
- -- -> ( (m a, m b, m c, ..) -> new_elt_ty )
- -- -> elt_ty
- --
- ; let bndr_m_ty = mkChunkified mkBoxedTupleTy $ map (mkAppTy m_ty . idType) bndr_ids
- m_bndr_m_ty = m_ty `mkAppTy` bndr_m_ty
- ; new_elt_ty <- newFlexiTyVarTy liftedTypeKind
- ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
- m_bndr_m_ty `mkFunTy` (bndr_m_ty `mkFunTy` new_elt_ty)
- `mkFunTy` elt_ty
+ ; return (bndr_ids, by_e_ty, return_op') }
- -- Finally make sure the type of the inner comprehension
- -- represents the types of our binders
- ; _ <- unifyType elt_ty' m_bndr_ty
- ; return (bndr_ids, by', using_ty, return_op', bind_op') }
- ; let mk_m_bndr :: Name -> TcId -> TcId
- mk_m_bndr m_bndr_name bndr_id =
- mkLocalId m_bndr_name (m_ty `mkAppTy` idType bndr_id)
+ ; let tup_ty = mkBigCoreVarTupTy bndr_ids -- (a,b,c)
+ using_arg_ty = m1_ty `mkAppTy` tup_ty -- m1 (a,b,c)
+ n_tup_ty = n_ty `mkAppTy` tup_ty -- n (a,b,c)
+ using_res_ty = m2_ty `mkAppTy` n_tup_ty -- m2 (n (a,b,c))
+ using_fun_ty = using_arg_ty `mkFunTy` using_arg_ty
+
+ -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty
+ -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c))
- -- Ensure that every old binder of type `b` is linked up with its
- -- new binder which should have type `m b`
- m_bndr_ids = zipWith mk_m_bndr m_bndr_names bndr_ids
- bindersMap' = bndr_ids `zip` m_bndr_ids
+ --------------- Typecheck the 'bind' function -------------
+ ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
+ using_res_ty `mkFunTy` (n_tup_ty `mkFunTy` new_res_ty)
+ `mkFunTy` res_ty
- -- See Note [GroupStmt binder map] in HsExpr
+ --------------- Typecheck the 'using' function -------------
+ ; let using_fun_ty = (m1_ty `mkAppTy` alphaTy) `mkFunTy`
+ (m2_ty `mkAppTy` (n_ty `mkAppTy` alphaTy))
+ using_poly_ty = case by_e_ty of
+ Nothing -> mkForAllTy alphaTyVar using_fun_ty
+ -- using :: forall a. m1 a -> m2 (n a)
- ; using' <- case using of
- Left e -> do { e' <- tcPolyExpr e using_ty; return (Left e') }
- Right e -> do { e' <- tcPolyExpr (noLoc e) using_ty; return (Right (unLoc e')) }
+ Just (_,t_ty) -> mkForAllTy alphaTyVar $
+ (alphaTy `mkFunTy` t_ty) `mkFunTy` using_fun_ty
+ -- using :: forall a. (a->t) -> m1 a -> m2 (n a)
+ -- where by :: t
- -- Type check 'liftM' with 'forall a b. (a -> b) -> m_ty a -> m_ty b'
- ; liftM_op' <- fmap unLoc . tcPolyExpr (noLoc liftM_op) $
+ ; using' <- case using of
+ Left e -> do { e' <- tcPolyExpr e using_poly_ty
+ ; return (Left e') }
+ Right e -> do { e' <- tcPolyExpr (noLoc e) using_poly_ty
+ ; return (Right (unLoc e')) }
+ ; coi <- unifyType (applyTy using_poly_ty tup_ty)
+ (case by_e_ty of
+ Nothing -> using_fun_ty
+ Just (_,t_ty) -> (tup_ty `mkFunTy` t_ty) `mkFunTy` using_fun_ty)
+ ; let final_using = mkHsWrapCoI coi (HsWrap (WpTyApp tup_ty) using')
+
+ --------------- Typecheck the 'fmap' function -------------
+ ; fmap_op' <- fmap unLoc . tcPolyExpr (noLoc fmap_op) $
mkForAllTy alphaTyVar $ mkForAllTy betaTyVar $
(alphaTy `mkFunTy` betaTy)
`mkFunTy`
`mkFunTy`
(m_ty `mkAppTy` betaTy)
+ ; let mk_n_bndr :: Name -> TcId -> TcId
+ mk_n_bndr n_bndr_name bndr_id
+ = mkLocalId bndr_name (n_ty `mkAppTy` idType bndr_id)
+
+ -- Ensure that every old binder of type `b` is linked up with its
+ -- new binder which should have type `n b`
+ -- See Note [GroupStmt binder map] in HsExpr
+ n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids
+ bindersMap' = bndr_ids `zip` n_bndr_ids
+
-- Type check the thing in the environment with these new binders and
-- return the result
- ; thing <- tcExtendIdEnv m_bndr_ids (thing_inside elt_ty)
+ ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside res_ty)
- ; return (GroupStmt stmts' bindersMap' by' using' return_op' bind_op' liftM_op', thing) }
+ ; return (GroupStmt stmts' bindersMap'
+ (fmap fst by_e_ty) final_using
+ return_op' bind_op' fmap_op', thing) }
-- Typecheck `ParStmt`. See `tcLcStmt` for more informations about typechecking
-- of `ParStmt`s.
-- -> (m st2 -> m st3 -> m (st2, st3)) -- recursive call
-- -> m (st1, (st2, st3))
--
-tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) elt_ty thing_inside
- = do { (_,(m_ty,_)) <- matchExpectedAppTy elt_ty
+tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_inside
+ = do { (_,(m_ty,_)) <- matchExpectedAppTy res_ty
; (pairs', thing) <- loop m_ty bndr_stmts_s
; let mzip_ty = mkForAllTys [alphaTyVar, betaTyVar] $
; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty
-- Typecheck bind:
- ; let tys = map (mkChunkified mkBoxedTupleTy . map idType . snd) pairs'
+ ; let tys = map (mkBigCoreVarTupTy . snd) pairs'
tuple_ty = mk_tuple_ty tys
; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
(m_ty `mkAppTy` tuple_ty)
`mkFunTy`
- (tuple_ty `mkFunTy` elt_ty)
+ (tuple_ty `mkFunTy` res_ty)
`mkFunTy`
- elt_ty
+ res_ty
; return_op' <- fmap unLoc . tcPolyExpr (noLoc return_op) $
mkForAllTy alphaTyVar $
alphaTy `mkFunTy` (m_ty `mkAppTy` alphaTy)
+ ; return_op' <- tcSyntaxOp MCompOrigin return_op
+ (bndr_ty `mkFunTy` m_bndr_ty)
+
; return (ParStmt pairs' mzip_op' bind_op' return_op', thing) }
where mk_tuple_ty tys = foldr (\tn tm -> mkBoxedTupleTy [tn, tm]) (last tys) (init tys)
-- loop :: Type -- m_ty
-- -> [([LStmt Name], [Name])]
-- -> TcM ([([LStmt TcId], [TcId])], thing)
- loop _ [] = do { thing <- thing_inside elt_ty
+ 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))
- <- tcStmts ctxt tcMcStmt stmts ty_dummy $ \elt_ty' ->
+ <- tcStmts ctxt tcMcStmt stmts ty_dummy $ \res_ty' ->
do { ids <- tcLookupLocalIds names
- ; _ <- unifyType elt_ty' (m_ty `mkAppTy` (mkChunkified mkBoxedTupleTy) (map idType ids))
+ ; _ <- unifyType res_ty' (m_ty `mkAppTy` mkBigCoreVarTupTy ids)
; (pairs', thing) <- loop m_ty pairs
; return (ids, pairs', thing) }
; return ( (stmts', ids) : pairs', thing ) }
tcMcStmt _ stmt _ _
= pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
--- Typecheck 'body' with type 'a' instead of 'm a' like the rest of the
--- statements, ignore the second type argument coming from the tcStmts loop
-tcMcBody :: LHsExpr Name
- -> SyntaxExpr Name
- -> TcRhoType
- -> TcM (LHsExpr TcId, SyntaxExpr TcId)
-tcMcBody body return_op res_ty
- = do { (_, (_, a_ty)) <- matchExpectedAppTy res_ty
- ; body' <- tcMonoExpr body a_ty
- ; return_op' <- tcSyntaxOp MCompOrigin return_op
- (a_ty `mkFunTy` res_ty)
- ; return (body', return_op')
- }
-
-
--------------------------------
-- Do-notation
-- The main excitement here is dealing with rebindable syntax
tcDoStmt :: TcStmtChecker
+tcDoStmt ctxt (LastStmt body _) res_ty thing_inside
+ = do { body' <- tcMonoExpr body res_ty
+ ; thing <- thing_inside body_ty
+ ; return (LastStmt body' noSyntaxExpr, thing) }
+
tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
= do { -- Deal with rebindable syntax:
-- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
, recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
, recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
- , recS_rec_rets = tup_rets }, thing)
+ , recS_rec_rets = tup_rets, recS_ret_ty = stmts_ty }, thing)
}}
tcDoStmt _ stmt _ _
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 $
projects / ghc-hetmet.git / commitdiff