Revive 'mdo' expressions, per discussion in Trac #4148

Summary:
  - mdo expressions are enabled by RecursiveDo pragma

  - mdo expressions perform full segmentation

  - 'rec' groups inside 'do' are changed so they do *not*
    perform any segmentation.

  - Both 'mdo' and 'rec' are enabled by 'RecursiveDo'
    'DoRec' is deprecated in favour of 'RecursiveDo'
    (The 'rec' keyword is also enabled by 'Arrows', as now.)

Thanks to Levent for doing all the work

3 files changed, 22 insertions, 19 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index c45bb2df95..179a40c751 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -448,7 +448,6 @@ data ExtensionFlag
    | Opt_MonadComprehensions
    | Opt_GeneralizedNewtypeDeriving
    | Opt_RecursiveDo
-   | Opt_DoRec
    | Opt_PostfixOperators
    | Opt_TupleSections
    | Opt_PatternGuards
@@ -2028,9 +2027,9 @@ xFlags = [
   ( "ImpredicativeTypes",               Opt_ImpredicativeTypes, nop),
   ( "TypeOperators",                    Opt_TypeOperators, nop ),
   ( "ExplicitNamespaces",               Opt_ExplicitNamespaces, nop ),
-  ( "RecursiveDo",                      Opt_RecursiveDo,     -- Enables 'mdo'
-    deprecatedForExtension "DoRec"),
-  ( "DoRec",                            Opt_DoRec, nop ),    -- Enables 'rec' keyword
+  ( "RecursiveDo",                      Opt_RecursiveDo, nop ),  -- Enables 'mdo' and 'rec'
+  ( "DoRec",                            Opt_RecursiveDo, 
+     deprecatedForExtension "RecursiveDo" ),
   ( "Arrows",                           Opt_Arrows, nop ),
   ( "ParallelArrays",                   Opt_ParallelArrays, nop ),
   ( "TemplateHaskell",                  Opt_TemplateHaskell, checkTemplateHaskellOk ),
@@ -2276,7 +2275,7 @@ glasgowExtsFlags = [
            , Opt_RankNTypes
            , Opt_TypeOperators
            , Opt_ExplicitNamespaces
-           , Opt_DoRec
+           , Opt_RecursiveDo
            , Opt_ParallelListComp
            , Opt_EmptyDataDecls
            , Opt_KindSignatures
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index e40f7b2f11..2f9c75ca03 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -658,7 +658,8 @@ reservedWordsFM = listToUFM $
          ( "capi",           ITcapiconv,      bit cApiFfiBit),
          ( "prim",           ITprimcallconv,  bit ffiBit),
 
-         ( "rec",            ITrec,           bit recBit),
+         ( "rec",            ITrec,           bit arrowsBit .|. 
+                                              bit recursiveDoBit),
          ( "proc",           ITproc,          bit arrowsBit)
      ]
 
@@ -1826,8 +1827,6 @@ inRulePragBit :: Int
 inRulePragBit = 19
 rawTokenStreamBit :: Int
 rawTokenStreamBit = 20 -- producing a token stream with all comments included
-recBit :: Int
-recBit = 22 -- rec
 alternativeLayoutRuleBit :: Int
 alternativeLayoutRuleBit = 23
 relaxedLayoutBit :: Int
@@ -1937,8 +1936,6 @@ mkPState flags buf loc =
                .|. magicHashBit                `setBitIf` xopt Opt_MagicHash                flags
                .|. kindSigsBit                 `setBitIf` xopt Opt_KindSignatures           flags
                .|. recursiveDoBit              `setBitIf` xopt Opt_RecursiveDo              flags
-               .|. recBit                      `setBitIf` xopt Opt_DoRec                    flags
-               .|. recBit                      `setBitIf` xopt Opt_Arrows                   flags
                .|. unicodeSyntaxBit            `setBitIf` xopt Opt_UnicodeSyntax            flags
                .|. unboxedTuplesBit            `setBitIf` xopt Opt_UnboxedTuples            flags
                .|. datatypeContextsBit         `setBitIf` xopt Opt_DatatypeContexts         flags
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 7ff7c7adec..c5bf23fc3a 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -753,7 +753,7 @@ rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
 		-- Step 3: Group together the segments to make bigger segments
 		--	   Invariant: in the result, no segment uses a variable
 		--	   	      bound in a later segment
-	    grouped_segs = glomSegments segs_w_fwd_refs
+	    grouped_segs = glomSegments ctxt segs_w_fwd_refs
 
 		-- Step 4: Turn the segments into Stmts
 		--	   Use RecStmt when and only when there are fwd refs
@@ -1101,15 +1101,20 @@ addFwdRefs pairs
 --	{ rec { x <- ...y...; p <- z ; y <- ...x... ; 
 --		q <- x ; z <- y } ; 
 -- 	  r <- x }
+--
+-- NB. June 7 2012: We only glom segments that appear in
+-- an explicit mdo; and leave those found in "do rec"'s intact.
+-- See http://hackage.haskell.org/trac/ghc/ticket/4148 for
+-- the discussion leading to this design choice.
 
-glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
+glomSegments :: HsStmtContext Name -> [Segment (LStmt Name)] -> [Segment [LStmt Name]]
 
-glomSegments [] = []
-glomSegments ((defs,uses,fwds,stmt) : segs)
+glomSegments _ [] = []
+glomSegments ctxt ((defs,uses,fwds,stmt) : segs)
 	-- Actually stmts will always be a singleton
   = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others
   where
-    segs'	     = glomSegments segs
+    segs'	     = glomSegments ctxt segs
     (extras, others) = grab uses segs'
     (ds, us, fs, ss) = unzip4 extras
     
@@ -1127,7 +1132,9 @@ glomSegments ((defs,uses,fwds,stmt) : segs)
 	= (reverse yeses, reverse noes)
 	where
 	  (noes, yeses) 	  = span not_needed (reverse dus)
-	  not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
+	  not_needed (defs,_,_,_) = case ctxt of
+	  		              MDoExpr -> not (intersectsNameSet defs uses)
+				      _	      -> False  -- unless we're in mdo, we *need* everything
 
 
 ----------------------------------------------------
@@ -1297,9 +1304,9 @@ okParStmt dflags ctxt stmt
 okDoStmt dflags ctxt stmt
   = case stmt of
        RecStmt {}
-         | Opt_DoRec `xopt` dflags -> isOK
-         | ArrowExpr <- ctxt       -> isOK	-- Arrows allows 'rec'
-         | otherwise               -> Just (ptext (sLit "Use -XDoRec"))
+         | Opt_RecursiveDo `xopt` dflags -> isOK
+         | ArrowExpr <- ctxt -> isOK	-- Arrows allows 'rec'
+         | otherwise         -> Just (ptext (sLit "Use -XRecursiveDo"))
        BindStmt {} -> isOK
        LetStmt {}  -> isOK
        ExprStmt {} -> isOK