More hacking on monad-comp; now works

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 711f66e..30be2aa 100644 (file)
--- 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
 
     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)
 
 addTickStmt isGuard stmt@(RecStmt {})
   = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index c55c2d4..418bda5 100644 (file)
--- 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 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
 
 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}
 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)
   
   = 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
 
     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
                                                  (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
         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 1ecab67..63cae93 100644 (file)
--- 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
 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;
     
     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)
 -- 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)]) 
   = 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
        ; 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)
 -- 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
     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
     
     -- 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
     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}
 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
 -- 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
 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 -> 
 --
 --   [| (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)
 --
 -- 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)
 --         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
 
        -- 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
 
        -- 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
        ; 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] }
 
                                         ; 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
        -- 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
        ; 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']) }
 
                   
        ; 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
 -- 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
 
        ; 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))
              -- 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
 
        ; 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 
        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)
 
 
 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
 --  \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)) }
 
        ; 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
 -- 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
 
 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
                  -> 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
 --
 
 -- The `unzip` function for `GroupStmt` in a monad comprehensions
 --

@@ -948,85 +904,25 @@ dsInnerMonadComp stmts bndrs ret_op
 --                   , liftM selN2 m_tuple
 --                   , .. )
 --
 --                   , 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}
 \end{code}

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 2c1939f..e68173a 100644 (file)
--- 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
                               ; 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; 
  | 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; 
         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
         wrapGenSyms ss e' }
 
   | otherwise

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index c9cbfef..5933e9d 100644 (file)
--- 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
   | 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
   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.)") ]
                
                          , 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 f7b693f..cf9c0d7 100644 (file)
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -24,6 +24,7 @@ import BasicTypes
 import DataCon
 import SrcLoc
 import Util( dropTail )
 import DataCon
 import SrcLoc
 import Util( dropTail )

+import StaticFlags( opt_PprStyle_Debug )

 import Outputable
 import FastString
 
 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
               -- 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)
                                  -- 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 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)
 
                               -- 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]
              (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'
 
 
   -- "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"
                        -- 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]
 
          (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
 
   -- Recursive statement (see Note [How RecStmt works] below)
   | RecStmt

@@ -937,6 +944,17 @@ data StmtLR idL idR
   deriving (Data, Typeable)
 \end{code}
 
   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:
 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 
   * 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.
        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 >> ...
 
                 E :: Bool
           Translation: guard E >> ...
 

-Array comprehensions are handled like list comprehensions -=chak
+Array comprehensions are handled like list comprehensions.

 
 Note [How RecStmt works]
 ~~~~~~~~~~~~~~~~~~~~~~~~
 
 Note [How RecStmt works]
 ~~~~~~~~~~~~~~~~~~~~~~~~

@@ -1045,7 +1063,7 @@ In transform and grouping statements ('then ..' and 'then group ..') the
    =>
   f [ env | stmts ] >>= \bndrs -> [ body | rest ]
 
    =>
   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 ]
 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 (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 })
 
 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)
         , nest 2 (pprBy by)]
 
 pprGroupStmt :: OutputableBndr id => Maybe (LHsExpr id)

-                                  -> Either (LHsExpr id) (SyntaxExpr is)
+                                  -> LHsExpr id -> Bool

                                  -> SDoc
                                  -> 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
   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
 
 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 
 -- 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]
            <+> rbrace
 
 ppr_lc_stmts :: OutputableBndr id => [LStmt id] -> [SDoc]

@@ -1269,9 +1287,10 @@ data HsStmtContext id
 
 \begin{code}
 isDoExpr :: HsStmtContext id -> Bool
 
 \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
 
 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
 
 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)
 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)
 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
 
 -- 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 :: (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!
                          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}
     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 c29083c..4a565ff 100644 (file)
--- 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, 
 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)
        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
 
 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.
 
 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 0d91e9f..de883f2 100644 (file)
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -43,7 +43,7 @@ module HsUtils(
 
   -- Stmts
   mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, mkLastStmt,
 
   -- Stmts
   mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, mkLastStmt,

-  mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt, 
+  emptyGroupStmt, mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt, 

   emptyRecStmt, mkRecStmt, 
 
   -- Template Haskell
   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
 
 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
 
 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 (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 --------------------------
 
 
 ----------------- Patterns --------------------------

@@ -659,9 +665,9 @@ lStmtsImplicits = hs_lstmts
     hs_stmt (LastStmt {})        = emptyNameSet
     hs_stmt (ParStmt xs _ _ _)   = hs_lstmts $ concatMap fst xs
     
     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
     
     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 ba862c5..ffdb144 100644 (file)
--- 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 ),
   ( "RankNTypes",                       Opt_RankNTypes, nop ),
   ( "ImpredicativeTypes",               Opt_ImpredicativeTypes, nop), 
   ( "TypeOperators",                    Opt_TypeOperators, nop ),

-  ( "RecursiveDo",                      Opt_RecursiveDo,
+  ( "RecursiveDo",                      Opt_RecursiveDo,     -- Enables 'mdo'

     deprecatedForExtension "DoRec"),
     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 ),
   ( "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 421ec45..e1d287a 100644 (file)
--- 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)
 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
 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,
 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
     :: Unique
 fromIntegerClassOpKey        = mkPreludeMiscIdUnique 102
 minusClassOpKey                      = mkPreludeMiscIdUnique 103

diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index e3e92bc..d1dd222 100644 (file)
--- 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 LoadIface       ( loadInterfaceForName )
 import UniqSet
 import Data.List

-import Util            ( isSingleton )
+import Util            ( isSingleton, snocView )

 import ListSetOps      ( removeDups )
 import Outputable
 import SrcLoc
 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 _)
     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)
        ; 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 (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
 
 -- 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 (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
 
 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
 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
 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]
 
 \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
 -- 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
 
 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) 
        ; (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
 
              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 $
   = 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                         $
 
   | 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) }
 
                     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
 
 -- 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 []
   = 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
                  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
                -- 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
 
        -- 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) }  }
 
        { (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
   = 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) }
         
        ; 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
   = 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
 
          -- 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)
             -- 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
 
 
 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)]
 
                    -- 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 
 
 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
        -- 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) ->
 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}
 %************************************************************************
 
 \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
 ---------------------- 
 -- 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 
 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
   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")
 
 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
                              -> 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
 
   = 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
   = 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
 
 ----------------
 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
 
   | 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
        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
   | 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
 
   | otherwise
   = case stmt of
        BindStmt {} -> isOK
        LetStmt {}  -> isOK
        ExprStmt {} -> isOK

-       RecStmt {}  -> notOK

        ParStmt {} 
        ParStmt {} 

-         | dopt dflags Opt_ParallelListComp -> isOK
+         | Opt_ParallelListComp `xopt` dflags -> isOK

          | otherwise -> Just (ptext (sLit "Use -XParallelListComp"))
        TransformStmt {} 
          | otherwise -> Just (ptext (sLit "Use -XParallelListComp"))
        TransformStmt {} 

-         | dopt dflags Opt_transformListComp -> isOK
+         | Opt_TransformListComp `xopt` dflags -> isOK

          | otherwise -> Just (ptext (sLit "Use -XTransformListComp"))
        GroupStmt {} 
          | otherwise -> Just (ptext (sLit "Use -XTransformListComp"))
        GroupStmt {} 

-         | dopt dflags Opt_transformListComp -> isOK
+         | Opt_TransformListComp `xopt` dflags -> isOK

          | otherwise -> Just (ptext (sLit "Use -XTransformListComp"))
          | 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 ()
 
 ---------
 checkTupleSection :: [HsTupArg RdrName] -> RnM ()

diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs
index 8fdb47c..5d92738 100644 (file)
--- 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)
             ; 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
 
                                  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)
   = 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)
   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 f7e5d39..dba87d2 100644 (file)
--- 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
            []    -> []
     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
             _     -> [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 })
     ------------------------------------------------------------------------
     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)
     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 518582f..7692271 100644 (file)
--- 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
 
 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
   = 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') }
     
     ; 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
   = 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_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
   where
     zonkBinderMapEntry env (oldBinder, newBinder) = do 
         let oldBinder' = zonkIdOcc env oldBinder

diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index 60bf7e2..820e517 100644 (file)
--- 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(..), 
 \begin{code}
 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
                   TcMatchCtxt(..), 

-                  tcStmts, tcDoStmts, tcBody,
+                  tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,

                   tcDoStmt, tcMDoStmt, tcGuardStmt
        ) where
 
                   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)
 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
                             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
          -> 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)) }
 
        ; 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) }
 
   = 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
 
 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
        -> 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' }
 
                         const (return ())
        ; return stmts' }
 

@@ -357,9 +357,9 @@ tcGuardStmt _ stmt _ _
 tcLcStmt :: TyCon      -- The list/Parray type constructor ([] or PArray)
         -> TcStmtChecker
 
 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
   = 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
        ; 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))
 
     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) }
                   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)) <- 
 
 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') <- 
             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)
 
 
     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')) <-
   = 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]]
                (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
             
              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')
 
              -- 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]
   where
     alphaListTy = mkTyConApp m_tc [alphaTy]
     alphaListListTy = mkTyConApp m_tc [alphaListTy]

@@ -496,12 +498,13 @@ tcLcStmt _ _ stmt _ _
 
 tcMcStmt :: TcStmtChecker
 
 
 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
   = 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 )
 --
 
 -- 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)) <- 
           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
                   { (_, (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)
 --
 --   [ 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
        ; 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')) <-
             -- 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
 
                 -- 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 -------------
                                              `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
                                      (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 $
                                 -- 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 :: 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)
        ; 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 $
 
        --------------- 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 
 
        ; 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`
 
              -- 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 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.
 
 -- 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
 --
 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] $
         ; (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' <- 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) }
 
 
         ; 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])]
 
        -- 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))
          = 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
                       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 :: 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
        ; 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))
         ; 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
                    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
                                , 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))
        { (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
                        -- 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)
 
                --      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)
        }}
 
 tcMDoStmt _ _ stmt _ _
   = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)

-

 \end{code}
 
 
 \end{code}
 
 

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index b9f7913..7b1d5a6 100644 (file)
--- 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] ;
        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 ;
            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,
                --      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.)
                -- 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])
            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) $
        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}
 
     }
 \end{code}