summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2011-05-02 09:02:18 +0100
committerSimon Peyton Jones <simonpj@microsoft.com>2011-05-02 09:02:18 +0100
commitd76d9636aeebe933d160157331b8c8c0087e73ac (patch)
tree0ec300ed4ff53f293bee81ebaf0e69c9dfb5a1c0
parent4ac2bb39dffb4b825ece73b349ff0d56d79092d7 (diff)
downloadhaskell-d76d9636aeebe933d160157331b8c8c0087e73ac.tar.gz
More hacking on monad-comp; now works
Diffstat
-rw-r--r--compiler/deSugar/Coverage.lhs20
-rw-r--r--compiler/deSugar/DsExpr.lhs25
-rw-r--r--compiler/deSugar/DsListComp.lhs246
-rw-r--r--compiler/deSugar/DsMeta.hs10
-rw-r--r--compiler/hsSyn/Convert.lhs13
-rw-r--r--compiler/hsSyn/HsExpr.lhs152
-rw-r--r--compiler/hsSyn/HsLit.lhs4
-rw-r--r--compiler/hsSyn/HsUtils.lhs26
-rw-r--r--compiler/main/DynFlags.hs4
-rw-r--r--compiler/prelude/PrelNames.lhs5
-rw-r--r--compiler/rename/RnExpr.lhs225
-rw-r--r--compiler/typecheck/TcArrows.lhs9
-rw-r--r--compiler/typecheck/TcGenDeriv.lhs4
-rw-r--r--compiler/typecheck/TcHsSyn.lhs12
-rw-r--r--compiler/typecheck/TcMatches.lhs113
-rw-r--r--compiler/typecheck/TcRnDriver.lhs45
16 files changed, 412 insertions, 501 deletions
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 711f66e9ab..30be2aa1f0 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -463,14 +463,18 @@ addTickStmt isGuard (TransformStmt stmts ids usingExpr maybeByExpr returnExpr bi
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)
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index c55c2d4c74..418bda5275 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -327,10 +327,10 @@ dsExpr (HsLet binds body) = do
--
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
@@ -694,21 +694,16 @@ handled in DsListComp). Basically does the translation given in the
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
@@ -753,7 +748,7 @@ dsDo stmts result_ty
(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
diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs
index 1ecab67e10..63cae938d0 100644
--- a/compiler/deSugar/DsListComp.lhs
+++ b/compiler/deSugar/DsListComp.lhs
@@ -54,7 +54,9 @@ dsListComp :: [LStmt Id]
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;
@@ -82,9 +84,9 @@ dsListComp lquals res_ty = do
-- 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
@@ -117,7 +119,8 @@ dsTransformStmt (TransformStmt stmts binders usingExpr maybeByExpr _ _)
-- 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
@@ -130,7 +133,7 @@ dsGroupStmt (GroupStmt stmts binderMap by using _ _ _) = do
-- 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
@@ -688,45 +691,15 @@ parrElemType 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
@@ -785,7 +758,7 @@ dsMcStmt (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_op) s
--
-- [| (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)
@@ -794,61 +767,42 @@ dsMcStmt (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_op) s
-- 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']) }
@@ -864,23 +818,26 @@ dsMcStmt (GroupStmt stmts binderMap by using return_op bind_op fmap_op) stmts_re
-- 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)
@@ -891,10 +848,9 @@ matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr
-- \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
@@ -936,10 +892,10 @@ dsMcBindStmt pat rhs' bind_op fail_op stmts
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
--
@@ -948,85 +904,25 @@ dsInnerMonadComp stmts bndrs ret_op
-- , 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}
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 2c1939ff73..e68173a59d 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -721,19 +721,15 @@ repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
; 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
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index c9cbfeffb5..5933e9d5fa 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -522,12 +522,15 @@ cvtHsDo do_or_lc stmts
| 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.)") ]
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index f7b693f157..cf9c0d7402 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -24,6 +24,7 @@ import BasicTypes
import DataCon
import SrcLoc
import Util( dropTail )
+import StaticFlags( opt_PprStyle_Debug )
import Outputable
import FastString
@@ -836,17 +837,19 @@ data StmtLR idL idR
-- 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)
@@ -859,16 +862,15 @@ data StmtLR idL idR
(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"
@@ -880,25 +882,30 @@ data StmtLR idL idR
(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
@@ -937,6 +944,17 @@ data StmtLR idL idR
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:
@@ -946,7 +964,7 @@ 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.
@@ -986,7 +1004,7 @@ depends on the context. Consider the following contexts:
E :: Bool
Translation: guard E >> ...
-Array comprehensions are handled like list comprehensions -=chak
+Array comprehensions are handled like list comprehensions.
Note [How RecStmt works]
~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1045,7 +1063,7 @@ In transform and grouping statements ('then ..' and 'then group ..') the
=>
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 ]
@@ -1082,8 +1100,8 @@ pprStmt (ParStmt stmtss _ _ _) = hsep (map doStmts stmtss)
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 })
@@ -1099,13 +1117,13 @@ pprTransformStmt bndrs using by
, 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
@@ -1124,7 +1142,7 @@ 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
- = 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]
@@ -1269,9 +1287,10 @@ data HsStmtContext id
\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
@@ -1320,34 +1339,40 @@ pprMatchContextNoun ProcExpr = ptext (sLit "arrow abstraction")
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
@@ -1377,11 +1402,12 @@ pprMatchInCtxt ctxt match = hang (ptext (sLit "In") <+> pprMatchContext ctxt <>
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}
diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs
index c29083c63b..4a565ff8ba 100644
--- a/compiler/hsSyn/HsLit.lhs
+++ b/compiler/hsSyn/HsLit.lhs
@@ -63,7 +63,7 @@ instance Eq HsLit where
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)
@@ -101,7 +101,7 @@ This witness should replace the literal.
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.
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 0d91e9f796..de883f25a5 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -43,7 +43,7 @@ module HsUtils(
-- Stmts
mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, mkLastStmt,
- mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt,
+ emptyGroupStmt, mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt,
emptyRecStmt, mkRecStmt,
-- Template Haskell
@@ -238,9 +238,15 @@ mkGroupUsingStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL id
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
@@ -512,9 +518,9 @@ collectStmtBinders (ExprStmt {}) = []
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 --------------------------
@@ -659,9 +665,9 @@ lStmtsImplicits = hs_lstmts
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
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index ba862c5430..ffdb1446a9 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -1625,9 +1625,9 @@ xFlags = [
( "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 ),
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 421ec45536..e1d287a9f0 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -607,7 +607,7 @@ inlineIdName :: Name
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
@@ -1299,7 +1299,8 @@ unboundKey = mkPreludeMiscIdUnique 101
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
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index e3e92bcfd0..d1dd222be7 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -40,7 +40,7 @@ import RdrName
import LoadIface ( loadInterfaceForName )
import UniqSet
import Data.List
-import Util ( isSingleton )
+import Util ( isSingleton, snocView )
import ListSetOps ( removeDups )
import Outputable
import SrcLoc
@@ -225,7 +225,7 @@ rnExpr (HsLet binds expr)
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)
@@ -440,10 +440,8 @@ convertOpFormsCmd (HsIf f exp c1 c2)
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
@@ -495,14 +493,10 @@ methodNamesCmd (HsPar c) = methodNamesLCmd c
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
@@ -538,6 +532,7 @@ methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
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
@@ -639,42 +634,48 @@ rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
\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) }
@@ -686,7 +687,7 @@ rnStmt :: HsStmtContext Name
-- 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 []
@@ -704,8 +705,7 @@ rnStmt ctxt (L loc (ExprStmt expr _ _ _)) 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
@@ -716,13 +716,12 @@ rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
-- 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
@@ -803,17 +802,15 @@ rnStmt ctxt (L loc (TransformStmt stmts _ using by _ _)) thing_inside
; 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
@@ -841,7 +838,10 @@ rnStmt ctxt (L loc (GroupStmt stmts _ by using _ _ _)) thing_inside
-- 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
@@ -958,9 +958,11 @@ rn_rec_stmt_lhs :: MiniFixityEnv
-- 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
@@ -1014,6 +1016,12 @@ rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt
-- 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) ->
@@ -1198,6 +1206,20 @@ program.
%************************************************************************
\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
@@ -1207,11 +1229,11 @@ 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")
@@ -1232,49 +1254,42 @@ 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
+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
@@ -1282,68 +1297,28 @@ okDoStmt dflags ctxt is_last stmt
----------------
-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 ()
diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs
index 8fdb47cdd3..5d9273880f 100644
--- a/compiler/typecheck/TcArrows.lhs
+++ b/compiler/typecheck/TcArrows.lhs
@@ -206,18 +206,17 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig
; 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)
diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index f7e5d39c94..dba87d224f 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -893,7 +893,7 @@ gen_Read_binds get_fixity loc tycon
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
@@ -967,7 +967,7 @@ gen_Read_binds get_fixity loc tycon
------------------------------------------------------------------------
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)
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 518582fa6a..769227150c 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -743,7 +743,7 @@ zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op return_op)
zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
, 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
@@ -782,16 +782,20 @@ zonkStmt env (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_o
; 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
diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index 60bf7e2c3e..820e5172ce 100644
--- a/compiler/typecheck/TcMatches.lhs
+++ b/compiler/typecheck/TcMatches.lhs
@@ -8,7 +8,7 @@ TcMatches: Typecheck some @Matches@
\begin{code}
module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
TcMatchCtxt(..),
- tcStmts, tcDoStmts, tcBody,
+ tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,
tcDoStmt, tcMDoStmt, tcGuardStmt
) where
@@ -224,7 +224,7 @@ tcGRHSs ctxt (GRHSs grhss binds) res_ty
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
@@ -245,7 +245,7 @@ tcDoStmts :: HsStmtContext Name
-> 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)) }
@@ -267,7 +267,7 @@ 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)
+tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
tcBody :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId)
tcBody body res_ty
@@ -298,7 +298,7 @@ tcStmts :: HsStmtContext Name
-> 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' }
@@ -357,9 +357,9 @@ tcGuardStmt _ stmt _ _
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
@@ -407,7 +407,7 @@ tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside
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) }
@@ -415,7 +415,7 @@ tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside
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') <-
@@ -442,11 +442,13 @@ tcLcStmt m_tc ctxt (TransformStmt stmts binders usingExpr maybeByExpr _ _) elt_t
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]]
@@ -471,14 +473,14 @@ tcLcStmt m_tc ctxt (GroupStmt stmts bindersMap by using _ _ _) elt_ty thing_insi
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]
@@ -496,12 +498,13 @@ tcLcStmt _ _ stmt _ _
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 )
--
@@ -561,7 +564,7 @@ tcMcStmt ctxt (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_
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
@@ -627,10 +630,14 @@ tcMcStmt ctxt (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_
-- [ 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
@@ -640,8 +647,10 @@ tcMcStmt ctxt (GroupStmt stmts bindersMap by using return_op bind_op fmap_op) re
-- 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
@@ -671,40 +680,34 @@ tcMcStmt ctxt (GroupStmt stmts bindersMap by using return_op bind_op fmap_op) re
`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`
@@ -716,9 +719,10 @@ tcMcStmt ctxt (GroupStmt stmts bindersMap by using return_op bind_op fmap_op) re
-- 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.
@@ -733,6 +737,8 @@ tcMcStmt ctxt (GroupStmt stmts bindersMap by using return_op bind_op fmap_op) re
--
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] $
@@ -757,12 +763,10 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_insi
; 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])]
@@ -774,7 +778,7 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_insi
= 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
@@ -790,9 +794,9 @@ tcMcStmt _ stmt _ _
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
@@ -849,7 +853,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
; 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
@@ -916,9 +920,9 @@ tcMDoStmt tc_rhs ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames
, recS_rec_ids = recNames }) res_ty thing_inside
= do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
; let rec_ids = zipWith mkLocalId recNames rec_tys
- ; tcExtendIdEnv rec_ids $ do
+ ; 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
@@ -930,12 +934,13 @@ tcMDoStmt tc_rhs ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = 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}
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index b9f7913d44..7b1d5a60c3 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -1269,11 +1269,25 @@ tcGhciStmts stmts
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,
@@ -1284,27 +1298,14 @@ tcGhciStmts stmts
-- 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}
View Lorry Controller Status