t_b <- (addTickSyntaxExpr hpcSrcSpan bindExpr)
return $ TransformStmt t_s ids t_u t_m t_r t_b
-addTickStmt isGuard (GroupStmt stmts binderMap by using returnExpr bindExpr liftMExpr) = do
- t_s <- (addTickLStmts isGuard stmts)
- t_y <- (fmapMaybeM addTickLHsExprAlways by)
- t_u <- (fmapEitherM addTickLHsExprAlways (addTickSyntaxExpr hpcSrcSpan) using)
- t_f <- (addTickSyntaxExpr hpcSrcSpan returnExpr)
- t_b <- (addTickSyntaxExpr hpcSrcSpan bindExpr)
- t_m <- (addTickSyntaxExpr hpcSrcSpan liftMExpr)
- return $ GroupStmt t_s binderMap t_y t_u t_b t_f t_m
+addTickStmt isGuard stmt@(GroupStmt { grpS_stmts = stmts
+ , grpS_by = by, grpS_using = using
+ , grpS_ret = returnExpr, grpS_bind = bindExpr
+ , grpS_fmap = liftMExpr }) = do
+ t_s <- addTickLStmts isGuard stmts
+ t_y <- fmapMaybeM addTickLHsExprAlways by
+ t_u <- addTickLHsExprAlways using
+ t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
+ t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
+ t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr
+ return $ stmt { grpS_stmts = t_s, grpS_by = t_y, grpS_using = t_u
+ , grpS_ret = t_f, grpS_bind = t_b, grpS_fmap = t_m }
addTickStmt isGuard stmt@(RecStmt {})
= do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
--
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 (HsDo DoExpr stmts _) = dsDo stmts
+dsExpr (HsDo GhciStmt stmts _) = dsDo stmts
+dsExpr (HsDo MDoExpr stmts _) = dsDo stmts
+dsExpr (HsDo MonadComp stmts _) = dsMonadComp stmts
dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
= do { pred <- dsLExpr guard_expr
Haskell 98 report:
\begin{code}
-dsDo :: [LStmt Id]
- -> Type -- Type of the whole expression
- -> DsM CoreExpr
-
-dsDo stmts result_ty
+dsDo :: [LStmt Id] -> DsM CoreExpr
+dsDo stmts
= goL stmts
where
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 _ (LastStmt body _) stmts
+ = ASSERT( null stmts ) dsLExpr body
+ -- The 'return' op isn't used for 'do' expressions
go _ (ExprStmt rhs then_expr _ _) stmts
= do { rhs2 <- dsLExpr rhs
(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)
+ ret_stmt = noLoc $ LastStmt (mkLHsTupleExpr rets) return_op
tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
dsListComp lquals res_ty = do
dflags <- getDOptsDs
let quals = map unLoc lquals
- [elt_ty] = tcTyConAppArgs res_ty
+ elt_ty = case tcTyConAppArgs res_ty of
+ [elt_ty] -> elt_ty
+ _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals)
if not (dopt Opt_EnableRewriteRules dflags) || dopt Opt_IgnoreInterfacePragmas dflags
-- Either rules are switched off, or we are ignoring what there are;
-- of that comprehension that we need in the outer comprehension into such an expression
-- and the type of the elements that it outputs (tuples of binders)
dsInnerListComp :: ([LStmt Id], [Id]) -> DsM (CoreExpr, Type)
-dsInnerListComp (stmts, bndrs) = do
+dsInnerListComp (stmts, bndrs)
= do { expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTup bndrs)])
- bndrs_tuple_type
+ (mkListTy bndrs_tuple_type)
; return (expr, bndrs_tuple_type) }
where
bndrs_tuple_type = mkBigCoreVarTupTy bndrs
-- Given such a statement it gives you back an expression representing how to compute the transformed
-- list and the tuple that you need to bind from that list in order to proceed with your desugaring
dsGroupStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
-dsGroupStmt (GroupStmt stmts binderMap by using _ _ _) = do
+dsGroupStmt (GroupStmt { grpS_stmts = stmts, grpS_bndrs = binderMap
+ , grpS_by = by, grpS_using = using }) = do
let (fromBinders, toBinders) = unzip binderMap
fromBindersTypes = map idType fromBinders
-- 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
- usingExpr' <- dsLExpr (either id noLoc using)
+ usingExpr' <- dsLExpr using
usingArgs <- case by of
Nothing -> return [expr]
Just by_e -> do { by_e' <- dsLExpr by_e
Translation for monad comprehensions
\begin{code}
-
--- | Keep the "context" of a monad comprehension in a small data type to avoid
--- some boilerplate...
-data DsMonadComp = DsMonadComp
- { mc_return :: Either (SyntaxExpr Id) (Expr CoreBndr)
- , mc_body :: LHsExpr Id
- , mc_m_ty :: Type
- }
-
---
-- Entry point for monad comprehension desugaring
---
-dsMonadComp :: [LStmt Id] -- the statements
- -> Type -- the final type
- -> DsM CoreExpr
-dsMonadComp stmts res_ty
- = dsMcStmts stmts (DsMonadComp (Left return_op) body m_ty)
- where
- (m_ty, _) = tcSplitAppTy res_ty
-
-
-dsMcStmts :: [LStmt Id]
- -> DsMonadComp
- -> DsM CoreExpr
-
--- No statements left for desugaring. Desugar the body after calling "return"
--- on it.
-dsMcStmts [] DsMonadComp { mc_return, mc_body }
- = case mc_return of
- Left ret -> dsLExpr $ noLoc ret `nlHsApp` mc_body
- Right ret' -> do
- { body' <- dsLExpr mc_body
- ; return $ mkApps ret' [body'] }
-
--- Otherwise desugar each statement step by step
-dsMcStmts ((L loc stmt) : lstmts) mc
- = putSrcSpanDs loc (dsMcStmt stmt lstmts mc)
+dsMonadComp :: [LStmt Id] -> DsM CoreExpr
+dsMonadComp stmts = dsMcStmts stmts
+dsMcStmts :: [LStmt Id] -> DsM CoreExpr
+dsMcStmts [] = panic "dsMcStmts"
+dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
+---------------
dsMcStmt :: Stmt Id -> [LStmt Id] -> DsM CoreExpr
dsMcStmt (LastStmt body ret_op) stmts
--
-- [| (q, then group by e using f); rest |]
-- ---> f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup ->
--- case unzip n_tup of qv -> [| rest |]
+-- case unzip n_tup of qv' -> [| rest |]
--
-- where variables (v1:t1, ..., vk:tk) are bound by q
-- qv = (v1, ..., vk)
-- 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
---
--- [| q, then group by e using f |] -> liftM (unzip q_v) (f (\q_v -> e) [| q |])
---
--- where unzip is of the form
---
--- 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 fmap_op) stmts_rest
- = do { let (fromBinders, toBinders) = unzip binderMap
- fromBindersTypes = map idType fromBinders -- Types ty
- fromBindersTupleTy = mkBigCoreTupTy fromBindersTypes
- toBindersTypes = map idType toBinders -- Types (n ty)
- toBindersTupleTy = mkBigCoreTupTy toBindersTypes
+
+dsMcStmt (GroupStmt { grpS_stmts = stmts, grpS_bndrs = bndrs
+ , grpS_by = by, grpS_using = using
+ , grpS_ret = return_op, grpS_bind = bind_op
+ , grpS_fmap = fmap_op }) stmts_rest
+ = do { let (from_bndrs, to_bndrs) = unzip bndrs
+ from_bndr_tys = map idType from_bndrs -- Types ty
-- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
- ; expr <- dsInnerMonadComp stmts fromBinders return_op
+ ; expr <- dsInnerMonadComp stmts from_bndrs 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
- ; usingExpr' <- dsLExpr (either id noLoc using)
+ ; usingExpr' <- dsLExpr using
; usingArgs <- case by of
Nothing -> return [expr]
Just by_e -> do { by_e' <- dsLExpr by_e
- ; lam <- matchTuple fromBinders by_e'
+ ; lam <- matchTuple from_bndrs by_e'
; return [lam, expr] }
- -- Create an unzip function for the appropriate arity and element types
- ; fmap_op' <- dsExpr fmap_op
- ; (unzip_fn, unzip_rhs) <- mkMcUnzipM fmap_op' m_ty fromBindersTypes
-
-- Generate the expressions to build the grouped list
-- Build a pattern that ensures the consumer binds into the NEW binders,
-- which hold monads rather than single values
+ ; fmap_op' <- dsExpr fmap_op
; 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)
+ n_tup_ty = funArgTy $ funArgTy $ funResultTy bind_ty -- n (a,b,c)
+ tup_n_ty = mkBigCoreVarTupTy to_bndrs
+
+ ; body <- dsMcStmts stmts_rest
+ ; n_tup_var <- newSysLocalDs n_tup_ty
+ ; tup_n_var <- newSysLocalDs tup_n_ty
+ ; tup_n_expr <- mkMcUnzipM fmap_op' n_tup_var from_bndr_tys
+ ; us <- newUniqueSupply
+ ; let rhs' = mkApps usingExpr' usingArgs
+ body' = mkTupleCase us to_bndrs body tup_n_var tup_n_expr
; return (mkApps bind_op' [rhs', Lam n_tup_var body']) }
-- 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
+ = do { exps_w_tys <- mapM ds_inner pairs -- Pairs (exp :: m ty, ty)
+ ; mzip_op' <- dsExpr mzip_op
; let -- The pattern variables
- vars = map (mkBigLHsVarPatTup . snd) pairs
+ pats = map (mkBigLHsVarPatTup . snd) pairs
-- Pattern with tuples of variables
-- [v1,v2,v3] => (v1, (v2, v3))
- pat = foldr (\tn tm -> mkBigLHsPatTup [tn, tm]) (last vars) (init vars)
- rhs = Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)
+ pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats
+ (rhs, _) = foldr1 (\(e1,t1) (e2,t2) ->
+ (mkApps mzip_op' [Type t1, Type t2, e1, e2],
+ mkBoxedTupleTy [t1,t2]))
+ exps_w_tys
; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest }
where
- ds_inner (stmts, bndrs) = dsInnerMonadComp stmts bndrs mono_ret_op
+ ds_inner (stmts, bndrs) = do { exp <- dsInnerMonadComp stmts bndrs mono_ret_op
+ ; return (exp, tup_ty) }
where
- mono_ret_op = HsWrap (WpTyApp (mkBigCoreVarTupTy bndrs)) return_op
+ mono_ret_op = HsWrap (WpTyApp tup_ty) return_op
+ tup_ty = mkBigCoreVarTupTy bndrs
dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
-- \x. case x of (a,b,c) -> body
matchTuple ids body
= do { us <- newUniqueSupply
- ; tup_id <- newSysLocalDs (mkBigLHsVarPatTup ids)
+ ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids)
; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) }
-
-- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a
-- desugared `CoreExpr`
dsMcBindStmt :: LPat Id
dsInnerMonadComp :: [LStmt Id]
-> [Id] -- Return a tuple of these variables
- -> LHsExpr Id -- The monomorphic "return" operator
+ -> HsExpr Id -- The monomorphic "return" operator
-> DsM CoreExpr
dsInnerMonadComp stmts bndrs ret_op
- = dsMcStmts (stmts ++ [noLoc (ReturnStmt (mkBigLHsVarTup bndrs) ret_op)])
+ = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTup bndrs) ret_op)])
-- The `unzip` function for `GroupStmt` in a monad comprehensions
--
-- , liftM selN2 m_tuple
-- , .. )
--
--- mkMcUnzipM m [t1, t2]
--- = (unzip_fn, \ys :: m (t1, t2) ->
--- ( liftM (selN1 :: (t1, t2) -> t1) ys
--- , liftM (selN2 :: (t1, t2) -> t2) ys
--- ))
---
-mkMcUnzipM :: CoreExpr
- -> Type -- m
- -> [Type] -- [a,b,c,..]
- -> DsM (Id, CoreExpr)
-mkMcUnzipM liftM_op m_ty elt_tys
- = do { ys <- newSysLocalDs monad_tuple_ty
- ; xs <- mapM newSysLocalDs elt_tys
- ; scrut <- newSysLocalDs tuple_tys
-
- ; unzip_fn <- newSysLocalDs unzip_fn_ty
-
- ; let -- Select one Id from our tuple
- selectExpr n = mkLams [scrut] $ mkTupleSelector xs (xs !! n) scrut (Var scrut)
- -- Apply 'selectVar' and 'ys' to 'liftM'
- tupleElem n = mkApps liftM_op
- -- Types (m is figured out by the type checker):
- -- liftM :: forall a b. (a -> b) -> m a -> m b
- [ Type tuple_tys, Type (elt_tys !! n)
- -- Arguments:
- , selectExpr n, Var ys ]
- -- The final expression with the big tuple
- unzip_body = mkBigCoreTup [ tupleElem n | n <- [0..length elt_tys - 1] ]
-
- ; return (unzip_fn, mkLams [ys] unzip_body) }
- where monad_tys = map (m_ty `mkAppTy`) elt_tys -- [m a,m b,m c,..]
- tuple_monad_tys = mkBigCoreTupTy monad_tys -- (m a,m b,m c,..)
- tuple_tys = mkBigCoreTupTy elt_tys -- (a,b,c,..)
- monad_tuple_ty = m_ty `mkAppTy` tuple_tys -- m (a,b,c,..)
- unzip_fn_ty = monad_tuple_ty `mkFunTy` tuple_monad_tys -- m (a,b,c,..) -> (m a,m b,m c,..)
-
--- Generate the `mzip` function for `ParStmt` in monad comprehensions, for
--- example:
---
--- mzip :: m t1
--- -> (m t2 -> m t3 -> m (t2, t3))
--- -> m (t1, (t2, t3))
---
--- mkMcZipM m [t1, t2, t3]
--- = (zip_fn, \(q1::t1) (q2::t2) (q3::t3) ->
--- mzip q1 (mzip q2 q3))
---
-mkMcZipM :: CoreExpr
- -> Type
- -> [Type]
- -> DsM (Id, CoreExpr)
-
-mkMcZipM mzip_op m_ty tys@(_:_:_) -- min. 2 types
- = do { (ids, t1, tuple_ty, zip_body) <- loop tys
- ; zip_fn <- newSysLocalDs $
- (m_ty `mkAppTy` t1)
- `mkFunTy`
- (m_ty `mkAppTy` tuple_ty)
- `mkFunTy`
- (m_ty `mkAppTy` mkBigCoreTupTy [t1, tuple_ty])
- ; return (zip_fn, mkLams ids zip_body) }
-
- where
- -- loop :: [Type] -> DsM ([Id], Type, [Type], CoreExpr)
- loop [t1, t2] = do -- last run of the `loop`
- { ids@[a,b] <- newSysLocalsDs (map (m_ty `mkAppTy`) [t1,t2])
- ; let zip_body = mkApps mzip_op [ Type t1, Type t2 , Var a, Var b ]
- ; return (ids, t1, t2, zip_body) }
-
- loop (t1:tr) = do
- { -- Get ty, ids etc from the "inner" zip
- (ids', t1', t2', zip_body') <- loop tr
-
- ; a <- newSysLocalDs $ m_ty `mkAppTy` t1
- ; let tuple_ty' = mkBigCoreTupTy [t1', t2']
- zip_body = mkApps mzip_op [ Type t1, Type tuple_ty', Var a, zip_body' ]
- ; return ((a:ids'), t1, tuple_ty', zip_body) }
-
--- This case should never happen:
-mkMcZipM _ _ tys = pprPanic "mkMcZipM: unexpected argument" (ppr tys)
+-- mkMcUnzipM fmap ys [t1, t2]
+-- = ( fmap (selN1 :: (t1, t2) -> t1) ys
+-- , fmap (selN2 :: (t1, t2) -> t2) ys )
+
+mkMcUnzipM :: CoreExpr -- fmap
+ -> Id -- Of type n (a,b,c)
+ -> [Type] -- [a,b,c]
+ -> DsM CoreExpr -- Of type (n a, n b, n c)
+mkMcUnzipM fmap_op ys elt_tys
+ = do { 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)
+ , mk_sel i, Var ys]
+
+ mk_sel n = Lam tup_xs $
+ mkTupleSelector xs (xs !! n) tup_xs (Var tup_xs)
+ ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) }
\end{code}
; wrapGenSyms ss z }
-- FIXME: I haven't got the types here right yet
-repE e@(HsDo ctxt sts body _ _)
+repE e@(HsDo ctxt sts _)
| case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False }
= do { (ss,zs) <- repLSts sts;
- body' <- addBinds ss $ repLE body;
- ret <- repNoBindSt body';
- e' <- repDoE (nonEmptyCoreList (zs ++ [ret]));
+ e' <- repDoE (nonEmptyCoreList zs);
wrapGenSyms ss e' }
| ListComp <- ctxt
= do { (ss,zs) <- repLSts sts;
- body' <- addBinds ss $ repLE body;
- ret <- repNoBindSt body';
- e' <- repComp (nonEmptyCoreList (zs ++ [ret]));
+ e' <- repComp (nonEmptyCoreList zs);
wrapGenSyms ss e' }
| otherwise
| null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
| otherwise
= do { stmts' <- cvtStmts stmts
- ; body <- case last stmts' of
- L _ (ExprStmt body _ _ _) -> return body
- stmt' -> failWith (bad_last stmt')
- ; return $ HsDo do_or_lc (init stmts') body noSyntaxExpr void }
+ ; let Just (stmts'', last') = snocView stmts'
+
+ ; last'' <- case last' of
+ L loc (ExprStmt body _ _ _) -> return (L loc (mkLastStmt body))
+ _ -> failWith (bad_last last')
+
+ ; return $ HsDo do_or_lc (stmts'' ++ [last'']) void }
where
- bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprStmtContext do_or_lc <> colon
+ bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon
, nest 2 $ Outputable.ppr stmt
, ptext (sLit "(It should be an expression.)") ]
import DataCon
import SrcLoc
import Util( dropTail )
+import StaticFlags( opt_PprStyle_Debug )
import Outputable
import FastString
-- Not used for GhciStmt, PatGuard, which scope over other stuff
(LHsExpr idR)
(SyntaxExpr idR) -- The return operator, used only for MonadComp
+ -- For ListComp, PArrComp, we use the baked-in 'return'
+ -- For DoExpr, MDoExpr, we don't appply a 'return' at all
-- See Note [Monad Comprehensions]
| BindStmt (LPat idL)
(LHsExpr idR)
- (SyntaxExpr idR) -- The (>>=) operator
+ (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind]
(SyntaxExpr idR) -- The fail operator
-- The fail operator is noSyntaxExpr
-- if the pattern match can't fail
| ExprStmt (LHsExpr idR) -- See Note [ExprStmt]
(SyntaxExpr idR) -- The (>>) operator
- (SyntaxExpr idR) -- The `guard` operator
+ (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp
-- See notes [Monad Comprehensions]
PostTcType -- Element type of the RHS (used for arrows)
(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
- -- after them
+ -- After renaming, the ids are the binders
+ -- bound by the stmts and used after them
-- "qs, then f by e" ==> TransformStmt qs binders f (Just e) (return) (>>=)
-- "qs, then f" ==> TransformStmt qs binders f Nothing (return) (>>=)
| TransformStmt
[LStmt idL] -- Stmts are the ones to the left of the 'then'
- [idR] -- After renaming, the IDs are the binders occurring
+ [idR] -- After renaming, the Ids are the binders occurring
-- within this transform statement that are used after it
(LHsExpr idR) -- "then f"
(SyntaxExpr idR) -- The '(>>=)' operator.
-- See Note [Monad Comprehensions]
- | GroupStmt
- [LStmt idL] -- Stmts to the *left* of the 'group'
- -- which generates the tuples to be grouped
+ | GroupStmt {
+ grpS_stmts :: [LStmt idL], -- Stmts to the *left* of the 'group'
+ -- which generates the tuples to be grouped
- [(idR, idR)] -- See Note [GroupStmt binder map]
+ grpS_bndrs :: [(idR, idR)], -- See Note [GroupStmt binder map]
- (Maybe (LHsExpr idR)) -- "by e" (optional)
+ grpS_by :: Maybe (LHsExpr idR), -- "by e" (optional)
- (Either -- "using f"
- (LHsExpr idR) -- Left f => explicit "using f"
- (SyntaxExpr idR)) -- Right f => implicit; filled in with 'groupWith'
- -- (list comprehensions) or 'groupM' (monad
- -- comprehensions)
+ grpS_using :: LHsExpr idR,
+ grpS_explicit :: Bool, -- True <=> explicit "using f"
+ -- False <=> implicit; grpS_using is filled in with
+ -- 'groupWith' (list comprehensions) or
+ -- 'groupM' (monad comprehensions)
- (SyntaxExpr idR) -- The 'return' function for inner monad
- -- comprehensions
- (SyntaxExpr idR) -- The '(>>=)' operator
- (SyntaxExpr idR) -- The 'liftM' function from Control.Monad for desugaring
- -- See Note [Monad Comprehensions]
+ -- Invariant: if grpS_explicit = False, then grp_by = Just e
+ -- That is, we can have group by e
+ -- group using f
+ -- group by e using f
+
+ grpS_ret :: SyntaxExpr idR, -- The 'return' function for inner monad
+ -- comprehensions
+ grpS_bind :: SyntaxExpr idR, -- The '(>>=)' operator
+ grpS_fmap :: SyntaxExpr idR -- The polymorphic 'fmap' function for desugaring
+ } -- See Note [Monad Comprehensions]
-- Recursive statement (see Note [How RecStmt works] below)
| RecStmt
deriving (Data, Typeable)
\end{code}
+Note [The type of bind in Stmts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Some Stmts, notably BindStmt, keep the (>>=) bind operator.
+We do NOT assume that it has type
+ (>>=) :: m a -> (a -> m b) -> m b
+In some cases (see Trac #303, #1537) it might have a more
+exotic type, such as
+ (>>=) :: m i j a -> (a -> m j k b) -> m i k b
+So we must be careful not to make assumptions about the type.
+In particular, the monad may not be uniform throughout.
+
Note [GroupStmt binder map]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
The [(idR,idR)] in a GroupStmt behaves as follows:
* After renaming:
[ (x27,x27), ..., (z35,z35) ]
These are the variables
- bound by the stmts to the left of the 'group'
+ bound by the stmts to the left of the 'group'
and used either in the 'by' clause,
or in the stmts following the 'group'
Each item is a pair of identical variables.
E :: Bool
Translation: guard E >> ...
-Array comprehensions are handled like list comprehensions -=chak
+Array comprehensions are handled like list comprehensions.
Note [How RecStmt works]
~~~~~~~~~~~~~~~~~~~~~~~~
=>
f [ env | stmts ] >>= \bndrs -> [ body | rest ]
-Normal expressions require the 'Control.Monad.guard' function for boolean
+ExprStmts require the 'Control.Monad.guard' function for boolean
expressions:
[ body | exp, stmts ]
pprStmt (TransformStmt stmts bndrs using by _ _)
= sep (ppr_lc_stmts stmts ++ [pprTransformStmt bndrs using by])
-pprStmt (GroupStmt stmts _ by using _ _ _)
- = sep (ppr_lc_stmts stmts ++ [pprGroupStmt by using])
+pprStmt (GroupStmt { grpS_stmts = stmts, grpS_by = by, grpS_using = using, grpS_explicit = explicit })
+ = sep (ppr_lc_stmts stmts ++ [pprGroupStmt by using explicit])
pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids
, recS_later_ids = later_ids })
, nest 2 (pprBy by)]
pprGroupStmt :: OutputableBndr id => Maybe (LHsExpr id)
- -> Either (LHsExpr id) (SyntaxExpr is)
+ -> LHsExpr id -> Bool
-> SDoc
-pprGroupStmt by using
- = sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 (ppr_using using)]
+pprGroupStmt by using explicit
+ = sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 pp_using ]
where
- ppr_using (Right _) = empty
- ppr_using (Left e) = ptext (sLit "using") <+> ppr e
+ pp_using | explicit = ptext (sLit "using") <+> ppr using
+ | otherwise = empty
pprBy :: OutputableBndr id => Maybe (LHsExpr id) -> SDoc
pprBy Nothing = empty
-- Print a bunch of do stmts, with explicit braces and semicolons,
-- so that we are not vulnerable to layout bugs
ppr_do_stmts stmts
- = lbrace <+> pprDeeperList vcat ([ppr s <> semi | s <- stmts])
+ = lbrace <+> pprDeeperList vcat (punctuate semi (map ppr stmts))
<+> rbrace
ppr_lc_stmts :: OutputableBndr id => [LStmt id] -> [SDoc]
\begin{code}
isDoExpr :: HsStmtContext id -> Bool
-isDoExpr DoExpr = True
-isDoExpr MDoExpr = True
-isDoExpr _ = False
+isDoExpr DoExpr = True
+isDoExpr MDoExpr = True
+isDoExpr GhciStmt = True
+isDoExpr _ = False
isListCompExpr :: HsStmtContext id -> Bool
isListCompExpr ListComp = True
pprMatchContextNoun (StmtCtxt ctxt) = ptext (sLit "pattern binding in")
$$ pprStmtContext ctxt
-pprStmtContext :: Outputable id => HsStmtContext id -> SDoc
+-----------------
+pprAStmtContext, pprStmtContext :: Outputable id => HsStmtContext id -> SDoc
+pprAStmtContext ctxt = article <+> pprStmtContext ctxt
+ where
+ pp_an = ptext (sLit "an")
+ pp_a = ptext (sLit "a")
+ article = case ctxt of
+ MDoExpr -> pp_an
+ PArrComp -> pp_an
+ GhciStmt -> pp_an
+ _ -> pp_a
+
+
+-----------------
+pprStmtContext GhciStmt = ptext (sLit "interactive GHCi command")
+pprStmtContext DoExpr = ptext (sLit "'do' expression")
+pprStmtContext MDoExpr = ptext (sLit "'mdo' expression")
+pprStmtContext ListComp = ptext (sLit "list comprehension")
+pprStmtContext MonadComp = ptext (sLit "monad comprehension")
+pprStmtContext PArrComp = ptext (sLit "array comprehension")
+pprStmtContext (PatGuard ctxt) = ptext (sLit "pattern guard for") $$ pprMatchContext ctxt
+
+-- Drop the inner contexts when reporting errors, else we get
+-- Unexpected transform statement
+-- in a transformed branch of
+-- transformed branch of
+-- transformed branch of monad comprehension
pprStmtContext (ParStmtCtxt c)
- = sep [ptext (sLit "a parallel branch of"), pprStmtContext c]
+ | opt_PprStyle_Debug = sep [ptext (sLit "parallel branch of"), pprAStmtContext c]
+ | otherwise = pprStmtContext c
pprStmtContext (TransformStmtCtxt c)
- = sep [ptext (sLit "a transformed branch of"), pprStmtContext c]
-pprStmtContext (PatGuard ctxt)
- = ptext (sLit "a pattern guard for") $$ pprMatchContext ctxt
-pprStmtContext GhciStmt = ptext (sLit "an interactive GHCi command")
-pprStmtContext DoExpr = ptext (sLit "a 'do' expression")
-pprStmtContext MDoExpr = ptext (sLit "an 'mdo' expression")
-pprStmtContext ListComp = ptext (sLit "a list comprehension")
-pprStmtContext MonadComp = ptext (sLit "a monad comprehension")
-pprStmtContext PArrComp = ptext (sLit "an array comprehension")
-
-{-
-pprMatchRhsContext (FunRhs fun) = ptext (sLit "a right-hand side of function") <+> quotes (ppr fun)
-pprMatchRhsContext CaseAlt = ptext (sLit "the body of a case alternative")
-pprMatchRhsContext PatBindRhs = ptext (sLit "the right-hand side of a pattern binding")
-pprMatchRhsContext LambdaExpr = ptext (sLit "the body of a lambda")
-pprMatchRhsContext ProcExpr = ptext (sLit "the body of a proc")
-pprMatchRhsContext other = panic "pprMatchRhsContext" -- RecUpd, StmtCtxt
-
--- Used for the result statement of comprehension
--- e.g. the 'e' in [ e | ... ]
--- or the 'r' in f x = r
-pprStmtResultContext (PatGuard ctxt) = pprMatchRhsContext ctxt
-pprStmtResultContext other = ptext (sLit "the result of") <+> pprStmtContext other
--}
+ | opt_PprStyle_Debug = sep [ptext (sLit "transformed branch of"), pprAStmtContext c]
+ | otherwise = pprStmtContext c
+
-- Used to generate the string for a *runtime* error message
matchContextErrString :: Outputable id => HsMatchContext id -> SDoc
pprStmtInCtxt :: (OutputableBndr idL, OutputableBndr idR)
=> HsStmtContext idL -> StmtLR idL idR -> SDoc
-pprStmtInCtxt ctxt stmt = hang (ptext (sLit "In a stmt of") <+> pprStmtContext ctxt <> colon)
+pprStmtInCtxt ctxt stmt = hang (ptext (sLit "In a stmt of") <+> pprAStmtContext ctxt <> colon)
4 (ppr_stmt stmt)
where
-- For Group and Transform Stmts, don't print the nested stmts!
- ppr_stmt (GroupStmt _ _ by using _ _ _) = pprGroupStmt by using
+ ppr_stmt (GroupStmt { grpS_by = by, grpS_using = using
+ , grpS_explicit = explicit }) = pprGroupStmt by using explicit
ppr_stmt (TransformStmt _ bndrs using by _ _) = pprTransformStmt bndrs using by
ppr_stmt stmt = pprStmt stmt
\end{code}
data HsOverLit id -- An overloaded literal
= OverLit {
ol_val :: OverLitVal,
- ol_rebindable :: Bool, --
+ ol_rebindable :: Bool, -- Note [ol_rebindable]
ol_witness :: SyntaxExpr id, -- Note [Overloaded literal witnesses]
ol_type :: PostTcType }
deriving (Data, Typeable)
This dual role is unusual, because we're replacing 'fromInteger' with
a call to fromInteger. Reason: it allows commoning up of the fromInteger
-calls, which wouldn't be possible if the desguarar made the application
+calls, which wouldn't be possible if the desguarar made the application.
The PostTcType in each branch records the type the overload literal is
found to have.
-- Stmts
mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, mkLastStmt,
- mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt,
+ emptyGroupStmt, mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt,
emptyRecStmt, mkRecStmt,
-- Template Haskell
mkGroupByStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
-mkGroupUsingStmt stmts usingExpr = GroupStmt stmts [] Nothing (Left usingExpr) noSyntaxExpr noSyntaxExpr noSyntaxExpr
-mkGroupByStmt stmts byExpr = GroupStmt stmts [] (Just byExpr) (Right noSyntaxExpr) noSyntaxExpr noSyntaxExpr noSyntaxExpr
-mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt stmts [] (Just byExpr) (Left usingExpr) noSyntaxExpr noSyntaxExpr noSyntaxExpr
+emptyGroupStmt :: StmtLR idL idR
+emptyGroupStmt = GroupStmt { grpS_stmts = [], grpS_bndrs = [], grpS_explicit = False
+ , grpS_by = Nothing, grpS_using = noLoc noSyntaxExpr
+ , grpS_ret = noSyntaxExpr, grpS_bind = noSyntaxExpr
+ , grpS_fmap = noSyntaxExpr }
+mkGroupUsingStmt ss u = emptyGroupStmt { grpS_stmts = ss, grpS_explicit = True, grpS_using = u }
+mkGroupByStmt ss b = emptyGroupStmt { grpS_stmts = ss, grpS_by = Just b }
+mkGroupByUsingStmt ss b u = emptyGroupStmt { grpS_stmts = ss, grpS_by = Just b
+ , grpS_explicit = True, grpS_using = u }
mkLastStmt expr = LastStmt expr noSyntaxExpr
mkExprStmt expr = ExprStmt expr noSyntaxExpr noSyntaxExpr placeHolderType
collectStmtBinders (LastStmt {}) = []
collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders
$ concatMap fst xs
-collectStmtBinders (TransformStmt stmts _ _ _ _ _) = collectLStmtsBinders stmts
-collectStmtBinders (GroupStmt stmts _ _ _ _ _ _) = collectLStmtsBinders stmts
-collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
+collectStmtBinders (TransformStmt stmts _ _ _ _ _) = collectLStmtsBinders stmts
+collectStmtBinders (GroupStmt { grpS_stmts = stmts }) = collectLStmtsBinders stmts
+collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
----------------- Patterns --------------------------
hs_stmt (LastStmt {}) = emptyNameSet
hs_stmt (ParStmt xs _ _ _) = hs_lstmts $ concatMap fst xs
- hs_stmt (TransformStmt stmts _ _ _ _ _) = hs_lstmts stmts
- hs_stmt (GroupStmt stmts _ _ _ _ _ _) = hs_lstmts stmts
- hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss
+ hs_stmt (TransformStmt stmts _ _ _ _ _) = hs_lstmts stmts
+ hs_stmt (GroupStmt { grpS_stmts = stmts }) = hs_lstmts stmts
+ hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss
hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds
hs_local_binds (HsIPBinds _) = emptyNameSet
( "RankNTypes", Opt_RankNTypes, nop ),
( "ImpredicativeTypes", Opt_ImpredicativeTypes, nop),
( "TypeOperators", Opt_TypeOperators, nop ),
- ( "RecursiveDo", Opt_RecursiveDo,
+ ( "RecursiveDo", Opt_RecursiveDo, -- Enables 'mdo'
deprecatedForExtension "DoRec"),
- ( "DoRec", Opt_DoRec, nop ),
+ ( "DoRec", Opt_DoRec, nop ), -- Enables 'rec' keyword
( "Arrows", Opt_Arrows, nop ),
( "ParallelArrays", Opt_ParallelArrays, nop ),
( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ),
inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey
-- Base classes (Eq, Ord, Functor)
-eqClassName, eqName, ordClassName, geName, functorClassName :: Name
+fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name
eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey
eqName = methName gHC_CLASSES (fsLit "==") eqClassOpKey
ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey
fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey,
enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey,
enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey,
- failMClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey
+ failMClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey,
+ fmapClassOpKey
:: Unique
fromIntegerClassOpKey = mkPreludeMiscIdUnique 102
minusClassOpKey = mkPreludeMiscIdUnique 103
import LoadIface ( loadInterfaceForName )
import UniqSet
import Data.List
-import Util ( isSingleton )
+import Util ( isSingleton, snocView )
import ListSetOps ( removeDups )
import Outputable
import SrcLoc
return (HsLet binds' expr', fvExpr)
rnExpr (HsDo do_or_lc stmts _)
- = do { ((stmts', _), fvs) <- rnStmts do_or_lc stmts (\ _ -> return ())
+ = do { ((stmts', _), fvs) <- rnStmts do_or_lc stmts (\ _ -> return ((), emptyFVs))
; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) }
rnExpr (ExplicitList _ exps)
convertOpFormsCmd (HsLet binds cmd)
= HsLet binds (convertOpFormsLCmd cmd)
-convertOpFormsCmd (HsDo ctxt stmts body return_op ty)
- = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
- (convertOpFormsLCmd body)
- (convertOpFormsCmd return_op) ty
+convertOpFormsCmd (HsDo ctxt stmts ty)
+ = HsDo ctxt (map (fmap convertOpFormsStmt) stmts) ty
-- Anything else is unchanged. This includes HsArrForm (already done),
-- things with no sub-commands, and illegal commands (which will be
methodNamesCmd (HsIf _ _ c1 c2)
= methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
-methodNamesCmd (HsLet _ c) = methodNamesLCmd c
-
-methodNamesCmd (HsDo _ stmts body _ _)
- = methodNamesStmts stmts `plusFV` methodNamesLCmd body
-
-methodNamesCmd (HsApp c _) = methodNamesLCmd c
-
-methodNamesCmd (HsLam match) = methodNamesMatch match
+methodNamesCmd (HsLet _ c) = methodNamesLCmd c
+methodNamesCmd (HsDo _ stmts _) = methodNamesStmts stmts
+methodNamesCmd (HsApp c _) = methodNamesLCmd c
+methodNamesCmd (HsLam match) = methodNamesMatch match
methodNamesCmd (HsCase _ matches)
= methodNamesMatch matches `addOneFV` choiceAName
methodNamesLStmt = methodNamesStmt . unLoc
methodNamesStmt :: StmtLR Name Name -> FreeVars
+methodNamesStmt (LastStmt cmd _) = methodNamesLCmd cmd
methodNamesStmt (ExprStmt cmd _ _ _) = methodNamesLCmd cmd
methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
\begin{code}
rnStmts :: HsStmtContext Name -> [LStmt RdrName]
- -> ([Name] -> RnM (thing, FreeVars))
- -> RnM (([LStmt Name], thing), FreeVars)
+ -> ([Name] -> RnM (thing, FreeVars))
+ -> RnM (([LStmt Name], thing), FreeVars)
-- Variables bound by the Stmts, and mentioned in thing_inside,
-- do not appear in the result FreeVars
---
--- Renaming a single RecStmt can give a sequence of smaller Stmts
rnStmts ctxt [] thing_inside
- = do { addErr (ptext (sLit "Empty") <+> pprStmtContext ctxt)
+ = do { checkEmptyStmts 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 ->
+ <- rnStmt MDoExpr (noLoc $ mkRecStmt all_but_last) $ \ _ ->
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
+rnStmts ctxt (lstmt@(L loc stmt) : lstmts) thing_inside
+ | null lstmts
= 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 }
+ do { -- Turn a final ExprStmt into a LastStmt
+ -- This is the first place it's convenient to do this
+ -- (In principle the parser could do it, but it's
+ -- just not very convenient to do so.)
+ let stmt' | okEmpty ctxt
+ = lstmt
+ | otherwise
+ = case stmt of
+ ExprStmt e _ _ _ -> L loc (mkLastStmt e)
+ _ -> lstmt
+ ; checkStmt ctxt True {- last stmt -} stmt'
+ ; rnStmt ctxt stmt' thing_inside }
| otherwise
= do { ((stmts1, (stmts2, thing)), fvs)
<- setSrcSpan loc $
- do { checkStmt ctxt False {- Not last -} stmt
- ; rnStmt ctxt stmt $ \ bndrs1 ->
- rnStmts ctxt stmts $ \ bndrs2 ->
+ do { checkStmt ctxt False {- Not last -} lstmt
+ ; rnStmt ctxt lstmt $ \ bndrs1 ->
+ rnStmts ctxt lstmts $ \ bndrs2 ->
thing_inside (bndrs1 ++ bndrs2) }
; return (((stmts1 ++ stmts2), thing), fvs) }
-- 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
+rnStmt _ (L loc (LastStmt expr _)) thing_inside
= do { (expr', fv_expr) <- rnLExpr expr
; (ret_op, fvs1) <- lookupSyntaxName returnMName
; (thing, fvs3) <- thing_inside []
fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
- = do { checkBindStmt ctxt is_last
- ; (expr', fv_expr) <- rnLExpr expr
+ = do { (expr', fv_expr) <- rnLExpr expr
-- The binders do not scope over the expression
; (bind_op, fvs1) <- lookupSyntaxName bindMName
; (fail_op, fvs2) <- lookupSyntaxName failMName
-- fv_expr shouldn't really be filtered by the rnPatsAndThen
-- but it does not matter because the names are unique
-rnStmt ctxt (L loc (LetStmt binds)) thing_inside
- = do { checkLetStmt ctxt binds
- ; rnLocalBindsAndThen binds $ \binds' -> do
+rnStmt _ (L loc (LetStmt binds)) thing_inside
+ = do { rnLocalBindsAndThen binds $ \binds' -> do
{ (thing, fvs) <- thing_inside (collectLocalBinders binds')
; return (([L loc (LetStmt binds')], thing), fvs) } }
-rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
+rnStmt _ (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
; return (([L loc (TransformStmt stmts' used_bndrs using' by' return_op bind_op)], thing),
fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
-rnStmt ctxt (L loc (GroupStmt stmts _ by using _ _ _)) thing_inside
+rnStmt ctxt (L loc (GroupStmt { grpS_stmts = stmts, grpS_by = by, grpS_explicit = explicit
+ , grpS_using = using })) thing_inside
= 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 _
- | isMonadCompExpr ctxt ->
- do { (e', fvs) <- lookupSyntaxName groupMName
- ; return (Right e', fvs) }
- | otherwise ->
- do { (e', fvs) <- lookupSyntaxName groupWithName
- ; return (Right e', fvs) }
+ let implicit_name | isMonadCompExpr ctxt = groupMName
+ | otherwise = groupWithName
+ ; (using', fvs1) <- if explicit
+ then rnLExpr using
+ else do { (e,fvs) <- lookupSyntaxName implicit_name
+ ; return (noLoc e, fvs) }
-- Rename the stmts and the 'by' expression
-- Keep track of the variables mentioned in the 'by' expression
-- 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 fmap_op)], thing), all_fvs) }
+ ; return (([L loc (GroupStmt { grpS_stmts = stmts', grpS_bndrs = bndr_map
+ , grpS_by = by', grpS_using = using', grpS_explicit = explicit
+ , grpS_ret = return_op, grpS_bind = bind_op
+ , grpS_fmap = fmap_op })], thing), all_fvs) }
type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts
-- so we don't bother to compute it accurately in the other cases
-> RnM [(LStmtLR Name RdrName, FreeVars)]
-rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b c)) = return [(L loc (ExprStmt expr a b c),
- -- this is actually correct
- emptyFVs)]
+rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b c))
+ = return [(L loc (ExprStmt expr a b c), emptyFVs)]
+
+rn_rec_stmt_lhs _ (L loc (LastStmt expr a))
+ = return [(L loc (LastStmt expr a), emptyFVs)]
rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
= do
-- Rename a Stmt that is inside a RecStmt (or mdo)
-- Assumes all binders are already in scope
-- Turns each stmt into a singleton Stmt
+rn_rec_stmt _ (L loc (LastStmt expr _)) _
+ = do { (expr', fv_expr) <- rnLExpr expr
+ ; (ret_op, fvs1) <- lookupSyntaxName returnMName
+ ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
+ L loc (LastStmt expr' ret_op))] }
+
rn_rec_stmt _ (L loc (ExprStmt expr _ _ _)) _
= rnLExpr expr `thenM` \ (expr', fvs) ->
lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
%************************************************************************
\begin{code}
+checkEmptyStmts :: HsStmtContext Name -> RnM ()
+-- We've seen an empty sequence of Stmts... is that ok?
+checkEmptyStmts ctxt
+ = unless (okEmpty ctxt) (addErr (emptyErr ctxt))
+
+okEmpty :: HsStmtContext Name -> Bool
+okEmpty (PatGuard {}) = True
+okEmpty _ = False
+
+emptyErr :: HsStmtContext Name -> SDoc
+emptyErr (ParStmtCtxt {}) = ptext (sLit "Empty statement group in parallel comprehension")
+emptyErr (TransformStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'")
+emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt
+
----------------------
-- Checking when a particular Stmt is ok
checkStmt :: HsStmtContext Name
checkStmt ctxt is_last (L _ stmt)
= do { dflags <- getDOpts
; case okStmt dflags ctxt is_last stmt of
- Nothing -> return ()
- Just extr -> addErr (msg $$ extra) }
+ Nothing -> return ()
+ Just extra -> addErr (msg $$ extra) }
where
- msg = ptext (sLit "Unexpected") <+> pprStmtCat stmt
- <+> ptext (sLit "statement in") <+> pprStmtContext ctxt
+ msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement")
+ , ptext (sLit "in") <+> pprAStmtContext ctxt ]
pprStmtCat :: Stmt a -> SDoc
pprStmtCat (TransformStmt {}) = ptext (sLit "transform")
-> 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
+okStmt _ (PatGuard {}) _ stmt
= case stmt of
ExprStmt {} -> isOK
BindStmt {} -> isOK
LetStmt {} -> isOK
_ -> notOK
-okStmt dflags (ParStmtCtxt ctxt) is_last stmt
+okStmt dflags (ParStmtCtxt ctxt) _ stmt
= case stmt of
LetStmt (HsIPBinds {}) -> notOK
- _ -> okStmt dflags ctxt is_last stmt
+ _ -> okStmt dflags ctxt False stmt
+ -- NB: is_last=False in recursive
+ -- call; the branches of of a Par
+ -- not finish with a LastStmt
-okStmt dflags (TransformStmtCtxt ctxt) is_last stmt
- = okStmt dflags ctxt is_last stmt
+okStmt dflags (TransformStmtCtxt ctxt) _ stmt
+ = okStmt dflags ctxt False 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)
+okStmt dflags ctxt is_last stmt
+ | isDoExpr ctxt = okDoStmt dflags ctxt is_last stmt
+ | isListCompExpr ctxt = okCompStmt dflags 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"
+ _ -> Just (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt
+ <+> ptext (sLit "must be an expression"))
| otherwise
= case stmt of
- RecStmt {} -> isOK -- Shouldn't we test a flag?
+ RecStmt {}
+ | Opt_DoRec `xopt` dflags -> isOK
+ | otherwise -> Just (ptext (sLit "Use -XDoRec"))
BindStmt {} -> isOK
LetStmt {} -> isOK
ExprStmt {} -> isOK
----------------
-okCompStmt dflags ctxt is_last stmt
+okCompStmt dflags _ is_last stmt
| is_last
= case stmt of
LastStmt {} -> Nothing
- -> pprPanic "Unexpected stmt" (ppr stmt) -- Not a user error
+ _ -> 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
+ | Opt_ParallelListComp `xopt` dflags -> isOK
| otherwise -> Just (ptext (sLit "Use -XParallelListComp"))
TransformStmt {}
- | dopt dflags Opt_transformListComp -> isOK
+ | Opt_TransformListComp `xopt` dflags -> isOK
| otherwise -> Just (ptext (sLit "Use -XTransformListComp"))
GroupStmt {}
- | dopt dflags Opt_transformListComp -> isOK
+ | Opt_TransformListComp `xopt` dflags -> 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.
-
-checkStmt ctxt (RecStmt {})
- | not (isDoExpr ctxt)
- = addErr (ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt)
-
----------
-checkParStmt :: HsStmtContext Name -> RnM ()
-checkParStmt _
- = do { monad_comp <- xoptM Opt_MonadComprehensions
- ; unless monad_comp $ do
- { parallel_list_comp <- xoptM Opt_ParallelListComp
- ; checkErr parallel_list_comp msg }
- }
- where
- msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp or -XMonadComprehensions")
-
----------
-checkTransformStmt :: HsStmtContext Name -> RnM ()
-checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the
- -- desugarer will break when we come to operate on a parallel array
- = do { transform_list_comp <- xoptM Opt_TransformListComp
- ; checkErr transform_list_comp msg }
- where
- msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp or -XMonadComprehensions")
-checkTransformStmt MonadComp -- Monad comprehensions are always fine, since the
- -- MonadComprehensions flag will already be turned on
- = do { return () }
-checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
-checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
-checkTransformStmt ctxt = addErr msg
- where
- msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
+ LastStmt {} -> notOK
+ RecStmt {} -> notOK
---------
checkTupleSection :: [HsTupArg RdrName] -> RnM ()
; return (GRHSs grhss' binds') }
tc_grhs res_ty (GRHS guards body)
- = do { (guards', rhs') <- tcStmts pg_ctxt tcGuardStmt guards res_ty $
+ = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $
tcGuardedCmd env body stk'
; return (GRHS guards' rhs') }
-------------------------------------------
-- Do notation
-tc_cmd env cmd@(HsDo do_or_lc stmts body _ _ty) (cmd_stk, res_ty)
+tc_cmd env cmd@(HsDo do_or_lc stmts _) (cmd_stk, res_ty)
= do { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd)
- ; (stmts', body') <- tcStmts do_or_lc (tcMDoStmt tc_rhs) stmts res_ty $
- tcGuardedCmd env body []
- ; return (HsDo do_or_lc stmts' body' noSyntaxExpr res_ty) }
+ ; stmts' <- tcStmts do_or_lc (tcMDoStmt tc_rhs) stmts res_ty
+ ; return (HsDo do_or_lc stmts' res_ty) }
where
tc_rhs rhs = do { ty <- newFlexiTyVarTy liftedTypeKind
; rhs' <- tcCmd env rhs ([], ty)
read_nullary_cons
= case nullary_cons of
[] -> []
- [con] -> [nlHsDo DoExpr (match_con con ++ [mkExprStmt (result_expr con [])])]
+ [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]
_ -> [nlHsApp (nlHsVar choose_RDR)
(nlList (map mk_pair nullary_cons))]
-- NB For operators the parens around (:=:) are matched by the
------------------------------------------------------------------------
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])]
+ , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt 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)
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, redS_ret_ty = ret_ty })
+ , recS_rec_rets = rets, recS_ret_ty = ret_ty })
= do { new_rvs <- zonkIdBndrs env rvs
; new_lvs <- zonkIdBndrs env lvs
; new_ret_ty <- zonkTcTypeToType env ret_ty
; bind_op' <- zonkExpr env' bind_op
; return (env', TransformStmt stmts' binders' usingExpr' maybeByExpr' return_op' bind_op') }
-zonkStmt env (GroupStmt stmts binderMap by using return_op bind_op liftM_op)
+zonkStmt env (GroupStmt { grpS_stmts = stmts, grpS_bndrs = binderMap
+ , grpS_by = by, grpS_explicit = explicit, grpS_using = using
+ , grpS_ret = return_op, grpS_bind = bind_op, grpS_fmap = liftM_op })
= do { (env', stmts') <- zonkStmts env stmts
; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
; by' <- fmapMaybeM (zonkLExpr env') by
- ; using' <- fmapEitherM (zonkLExpr env) (zonkExpr env) using
+ ; using' <- zonkLExpr env using
; return_op' <- zonkExpr env' return_op
; bind_op' <- zonkExpr env' bind_op
; liftM_op' <- zonkExpr env' liftM_op
; let env'' = extendZonkEnv env' (map snd binderMap')
- ; return (env'', GroupStmt stmts' binderMap' by' using' return_op' bind_op' liftM_op') }
+ ; return (env'', GroupStmt { grpS_stmts = stmts', grpS_bndrs = binderMap'
+ , grpS_by = by', grpS_explicit = explicit, grpS_using = using'
+ , grpS_ret = return_op', grpS_bind = bind_op', grpS_fmap = liftM_op' }) }
where
zonkBinderMapEntry env (oldBinder, newBinder) = do
let oldBinder' = zonkIdOcc env oldBinder
\begin{code}
module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
TcMatchCtxt(..),
- tcStmts, tcDoStmts, tcBody,
+ tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,
tcDoStmt, tcMDoStmt, tcGuardStmt
) where
tcGRHS :: TcMatchCtxt -> TcRhoType -> GRHS Name -> TcM (GRHS TcId)
tcGRHS ctxt res_ty (GRHS guards rhs)
- = do { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
+ = do { (guards', rhs') <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $
mc_body ctxt rhs
; return (GRHS guards' rhs') }
where
-> TcM (HsExpr TcId) -- Returns a HsDo
tcDoStmts ListComp stmts res_ty
= do { (coi, elt_ty) <- matchExpectedListTy res_ty
- ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts res_ty
+ ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty
; return $ mkHsWrapCoI coi
(HsDo ListComp stmts' (mkListTy elt_ty)) }
= do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty
; return (HsDo MonadComp stmts' res_ty) }
-tcDoStmts ctxt _ _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
+tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
tcBody :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId)
tcBody body res_ty
-> TcRhoType
-> TcM [LStmt TcId]
tcStmts ctxt stmt_chk stmts res_ty
- = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_check stmts res_ty $
+ = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $
const (return ())
; return stmts' }
tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
-> TcStmtChecker
-tcLcStmt m_tc ctxt (LastStmt body _) elt_ty thing_inside
+tcLcStmt _ _ (LastStmt body _) elt_ty thing_inside
= do { body' <- tcMonoExpr body elt_ty
- ; thing <- thing_inside elt_ty
+ ; thing <- thing_inside (panic "tcLcStmt: thing_inside")
; return (LastStmt body' noSyntaxExpr, thing) }
-- A generator, pat <- rhs
loop ((stmts, names) : pairs)
= do { (stmts', (ids, pairs', thing))
- <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
+ <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
do { ids <- tcLookupLocalIds names
; (pairs', thing) <- loop pairs
; return (ids, pairs', thing) }
tcLcStmt m_tc ctxt (TransformStmt stmts binders usingExpr maybeByExpr _ _) elt_ty thing_inside = do
(stmts', (binders', usingExpr', maybeByExpr', thing)) <-
- tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
+ tcStmtsAndThen (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
let alphaListTy = mkTyConApp m_tc [alphaTy]
(usingExpr', maybeByExpr') <-
return (TransformStmt stmts' binders' usingExpr' maybeByExpr' noSyntaxExpr noSyntaxExpr, thing)
-tcLcStmt m_tc ctxt (GroupStmt stmts bindersMap by using _ _ _) elt_ty thing_inside
+tcLcStmt m_tc ctxt (GroupStmt { grpS_stmts = stmts, grpS_bndrs = bindersMap
+ , grpS_by = by, grpS_using = using
+ , grpS_explicit = explicit }) elt_ty thing_inside
= do { let (bndr_names, list_bndr_names) = unzip bindersMap
; (stmts', (bndr_ids, by', using_ty, elt_ty')) <-
- tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
+ tcStmtsAndThen (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
(by', using_ty) <-
case by of
Nothing -> -- check that using :: forall a. [a] -> [[a]]
bindersMap' = bndr_ids `zip` list_bndr_ids
-- See Note [GroupStmt binder map] in HsExpr
- ; 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')) }
+ ; using' <- tcPolyExpr using using_ty
-- Type check the thing in the environment with
-- these new binders and return the result
; thing <- tcExtendIdEnv list_bndr_ids (thing_inside elt_ty')
- ; return (GroupStmt stmts' bindersMap' by' using' noSyntaxExpr noSyntaxExpr noSyntaxExpr, thing) }
+ ; return (emptyGroupStmt { grpS_stmts = stmts', grpS_bndrs = bindersMap'
+ , grpS_by = by', grpS_using = using'
+ , grpS_explicit = explicit }, thing) }
where
alphaListTy = mkTyConApp m_tc [alphaTy]
alphaListListTy = mkTyConApp m_tc [alphaListTy]
tcMcStmt :: TcStmtChecker
-tcMcStmt ctxt (LastStmt body return_op) res_ty thing_inside
+tcMcStmt _ (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') }
+ ; thing <- thing_inside (panic "tcMcStmt: thing_inside")
+ ; return (LastStmt body' return_op', thing) }
-- Generators for monad comprehensions ( pat <- rhs )
--
ty_dummy <- newFlexiTyVarTy liftedTypeKind
; (stmts', (binders', usingExpr', maybeByExpr', return_op', bind_op', thing)) <-
- tcStmts (TransformStmtCtxt ctxt) tcMcStmt stmts ty_dummy $ \res_ty' -> do
+ tcStmtsAndThen (TransformStmtCtxt ctxt) tcMcStmt stmts ty_dummy $ \res_ty' -> do
{ (_, (m_ty, _)) <- matchExpectedAppTy res_ty'
; (usingExpr', maybeByExpr') <-
case maybeByExpr of
-- [ 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 fmap_op) res_ty thing_inside
- = do { m1_ty <- newFlexiTyVarTy liftedTypeKind
- ; m2_ty <- newFlexiTyVarTy liftedTypeKind
- ; n_ty <- newFlexiTyVarTy liftedTypeKind
+tcMcStmt ctxt (GroupStmt { grpS_stmts = stmts, grpS_bndrs = bindersMap
+ , grpS_by = by, grpS_using = using, grpS_explicit = explicit
+ , grpS_ret = return_op, grpS_bind = bind_op
+ , grpS_fmap = fmap_op }) res_ty thing_inside
+ = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind
+ ; m1_ty <- newFlexiTyVarTy star_star_kind
+ ; m2_ty <- newFlexiTyVarTy star_star_kind
+ ; n_ty <- newFlexiTyVarTy star_star_kind
; tup_ty_var <- newFlexiTyVarTy liftedTypeKind
; new_res_ty <- newFlexiTyVarTy liftedTypeKind
; let (bndr_names, n_bndr_names) = unzip bindersMap
-- 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
+ tcStmtsAndThen (TransformStmtCtxt ctxt) tcMcStmt stmts m1_tup_ty $ \res_ty' -> do
+ { by_e_ty <- case by of
+ Nothing -> return Nothing
+ Just e -> do { e_ty <- tcInferRhoNC e; return (Just e_ty) }
-- Find the Ids (and hence types) of all old binders
; bndr_ids <- tcLookupLocalIds bndr_names
`mkFunTy` res_ty
--------------- Typecheck the 'using' function -------------
- ; let using_fun_ty = (m1_ty `mkAppTy` alphaTy) `mkFunTy`
+ ; let poly_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
+ Nothing -> mkForAllTy alphaTyVar poly_fun_ty
-- using :: forall a. m1 a -> m2 (n a)
Just (_,t_ty) -> mkForAllTy alphaTyVar $
- (alphaTy `mkFunTy` t_ty) `mkFunTy` using_fun_ty
+ (alphaTy `mkFunTy` t_ty) `mkFunTy` poly_fun_ty
-- using :: forall a. (a->t) -> m1 a -> m2 (n a)
-- where by :: t
- ; 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')) }
+ ; using' <- tcPolyExpr using using_poly_ty
; 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')
+ ; let final_using = fmap (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`
- (m_ty `mkAppTy` alphaTy)
- `mkFunTy`
- (m_ty `mkAppTy` betaTy)
+ (alphaTy `mkFunTy` betaTy)
+ `mkFunTy` (n_ty `mkAppTy` alphaTy)
+ `mkFunTy` (n_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)
+ = mkLocalId n_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`
-- return the result
; thing <- tcExtendIdEnv n_bndr_ids (thing_inside res_ty)
- ; return (GroupStmt stmts' bindersMap'
- (fmap fst by_e_ty) final_using
- return_op' bind_op' fmap_op', thing) }
+ ; return (GroupStmt { grpS_stmts = stmts', grpS_bndrs = bindersMap'
+ , grpS_by = fmap fst by_e_ty, grpS_using = final_using
+ , grpS_ret = return_op', grpS_bind = bind_op'
+ , grpS_fmap = fmap_op', grpS_explicit = explicit }, thing) }
-- Typecheck `ParStmt`. See `tcLcStmt` for more informations about typechecking
-- of `ParStmt`s.
--
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?
+
; (pairs', thing) <- loop m_ty bndr_stmts_s
; let mzip_ty = mkForAllTys [alphaTyVar, betaTyVar] $
; 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)
+ where mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
-- loop :: Type -- m_ty
-- -> [([LStmt Name], [Name])]
= 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 $ \res_ty' ->
+ <- 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
tcDoStmt :: TcStmtChecker
-tcDoStmt ctxt (LastStmt body _) res_ty thing_inside
- = do { body' <- tcMonoExpr body res_ty
- ; thing <- thing_inside body_ty
+tcDoStmt _ (LastStmt body _) res_ty thing_inside
+ = do { body' <- tcMonoExprNC body res_ty
+ ; thing <- thing_inside (panic "tcDoStmt: thing_inside")
; return (LastStmt body' noSyntaxExpr, thing) }
tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
; tcExtendIdEnv tup_ids $ do
{ stmts_ty <- newFlexiTyVarTy liftedTypeKind
; (stmts', (ret_op', tup_rets))
- <- tcStmts ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty ->
+ <- tcStmtsAndThen ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty ->
do { tup_rets <- zipWithM tcCheckId tup_names tup_elt_tys
-- Unify the types of the "final" Ids (which may
-- be polymorphic) with those of "knot-tied" Ids
, 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
+ ; tcExtendIdEnv rec_ids $ do
{ (stmts', (later_ids, rec_rets))
- <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ _res_ty' ->
+ <- 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
-- some of them with polymorphic things with the same Name
-- (see note [RecStmt] in HsExpr)
- ; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets, thing)
+ ; 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}
let {
ret_ty = mkListTy unitTy ;
io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
- tc_io_stmts stmts = tcStmts GhciStmt tcDoStmt stmts io_ret_ty ;
-
+ tc_io_stmts stmts = tcStmtsAndThen GhciStmt tcDoStmt stmts io_ret_ty ;
names = collectLStmtsBinders stmts ;
+ } ;
+
+ -- OK, we're ready to typecheck the stmts
+ traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
+ ((tc_stmts, ids), lie) <- captureConstraints $
+ tc_io_stmts stmts $ \ _ ->
+ mapM tcLookupId names ;
+ -- Look up the names right in the middle,
+ -- where they will all be in scope
- -- mk_return builds the expression
+ -- Simplify the context
+ traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
+ const_binds <- checkNoErrs (simplifyInteractive lie) ;
+ -- checkNoErrs ensures that the plan fails if context redn fails
+
+ traceTc "TcRnDriver.tcGhciStmts: done" empty ;
+ let { -- mk_return builds the expression
-- returnIO @ [()] [coerce () x, .., coerce () z]
--
-- Despite the inconvenience of building the type applications etc,
-- then the type checker would instantiate x..z, and we wouldn't
-- get their *polymorphic* values. (And we'd get ambiguity errs
-- if they were overloaded, since they aren't applied to anything.)
- mk_return ids = nlHsApp (nlHsTyApp ret_id [ret_ty])
- (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
+ ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty])
+ (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy])
- (nlHsVar id)
- } ;
-
- -- OK, we're ready to typecheck the stmts
- traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
- ((tc_stmts, ids), lie) <- captureConstraints $ tc_io_stmts stmts $ \ _ ->
- mapM tcLookupId names ;
- -- Look up the names right in the middle,
- -- where they will all be in scope
-
- -- Simplify the context
- traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
- const_binds <- checkNoErrs (simplifyInteractive lie) ;
- -- checkNoErrs ensures that the plan fails if context redn fails
-
- traceTc "TcRnDriver.tcGhciStmts: done" empty ;
+ (nlHsVar id) ;
+ stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]
+ } ;
return (ids, mkHsDictLet (EvBinds const_binds) $
- noLoc (HsDo GhciStmt tc_stmts (mk_return ids) noSyntaxExpr io_ret_ty))
+ noLoc (HsDo GhciStmt stmts io_ret_ty))
}
\end{code}
projects / ghc-hetmet.git / commitdiff