Simon's hacking on monad-comp; incomplete

2 files changed, 9 insertions, 42 deletions

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index ec8d3fffb3..c42ea0c864 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -1283,14 +1283,9 @@ exp10 :: { LHsExpr RdrName }
    	| 'case' exp 'of' altslist		{ LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
 	| '-' fexp				{ LL $ NegApp $2 noSyntaxExpr }
 
-  	| 'do' stmtlist			{% let loc = comb2 $1 $2 in
-					   checkDo loc (unLoc $2)  >>= \ (stmts,body) ->
-					   return (L loc (mkHsDo DoExpr stmts body)) }
-  	| 'mdo' stmtlist		{% let loc = comb2 $1 $2 in
-					   checkDo loc (unLoc $2)  >>= \ (stmts,body) ->
-                                           return (L loc (mkHsDo MDoExpr
-                                                                 [L loc (mkRecStmt stmts)]
-                                                                 body)) }
+  	| 'do' stmtlist			{ L (comb2 $1 $2) (mkHsDo DoExpr  (unLoc $2)) }
+  	| 'mdo' stmtlist		{ L (comb2 $1 $2) (mkHsDo MDoExpr (unLoc $2)) }
+
         | scc_annot exp		    		{ LL $ if opt_SccProfilingOn
 							then HsSCC (unLoc $1) $2
 							else HsPar $2 }
@@ -1465,8 +1460,10 @@ list :: { LHsExpr RdrName }
 	| texp ',' exp '..' 	{ LL $ ArithSeq noPostTcExpr (FromThen $1 $3) }
 	| texp '..' exp	 	{ LL $ ArithSeq noPostTcExpr (FromTo $1 $3) }
 	| texp ',' exp '..' exp	{ LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) }
-	| texp '|' flattenedpquals	{% checkMonadComp >>= \ ctxt ->
-					   return (sL (comb2 $1 $>) $ mkHsDo ctxt (unLoc $3) $1) }
+	| texp '|' flattenedpquals	
+             {% checkMonadComp >>= \ ctxt ->
+		return (sL (comb2 $1 $>) $ 
+                        mkHsComp ctxt (unLoc $3) $1) }
 
 lexps :: { Located [LHsExpr RdrName] }
 	: lexps ',' texp 		{ LL (((:) $! $3) $! unLoc $1) }
@@ -1538,7 +1535,7 @@ parr :: { LHsExpr RdrName }
 						       (reverse (unLoc $1)) }
 	| texp '..' exp	 		{ LL $ PArrSeq noPostTcExpr (FromTo $1 $3) }
 	| texp ',' exp '..' exp		{ LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) }
-	| texp '|' flattenedpquals	{ LL $ mkHsDo PArrComp (unLoc $3) $1 }
+	| texp '|' flattenedpquals	{ LL $ mkHsComp PArrComp (unLoc $3) $1 }
 
 -- We are reusing `lexps' and `flattenedpquals' from the list case.
 
@@ -1605,7 +1602,7 @@ apats  :: { [LPat RdrName] }
 -- Statement sequences
 
 stmtlist :: { Located [LStmt RdrName] }
-	: '{'         	stmts '}'	{ LL (unLoc $2) }
+	: '{'         	stmts '}'	{ LL (mkDoStmts (unLoc $2)) }
 	|     vocurly   stmts close	{ $2 }
 
 --	do { ;; s ; s ; ; s ;; }
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 0e22c6955e..3b14990ec0 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -40,8 +40,6 @@ module RdrHsSyn (
 	checkPattern,	      -- HsExp -> P HsPat
 	bang_RDR,
 	checkPatterns,	      -- SrcLoc -> [HsExp] -> P [HsPat]
-	checkDo,	      -- [Stmt] -> P [Stmt]
-	checkMDo,	      -- [Stmt] -> P [Stmt]
 	checkMonadComp,       -- P (HsStmtContext RdrName)
 	checkValDef,	      -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
 	checkValSig,	      -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
@@ -613,34 +611,6 @@ checkPred (L spn ty)
     check loc _                        _    = parseErrorSDoc loc
                                 (text "malformed class assertion:" <+> ppr ty)
 
----------------------------------------------------------------------------
--- Checking statements in a do-expression
--- 	We parse   do { e1 ; e2 ; }
--- 	as [ExprStmt e1, ExprStmt e2]
--- checkDo (a) checks that the last thing is an ExprStmt
---	   (b) returns it separately
--- same comments apply for mdo as well
-
-checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
-
-checkDo	 = checkDoMDo "a " "'do'"
-checkMDo = checkDoMDo "an " "'mdo'"
-
-checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
-checkDoMDo _   nm loc []   = parseErrorSDoc loc (text ("Empty " ++ nm ++ " construct"))
-checkDoMDo pre nm _   ss   = do
-  check ss
-  where 
-	check  []                       = panic "RdrHsSyn:checkDoMDo"
-	check  [L _ (ExprStmt e _ _ _)] = return ([], e)
-	check  [L l e] = parseErrorSDoc l
-                         (text ("The last statement in " ++ pre ++ nm ++
-					            " construct must be an expression:")
-                       $$ ppr e)
-	check (s:ss) = do
-	  (ss',e') <-  check ss
-	  return ((s:ss'),e')
-
 -- -------------------------------------------------------------------------
 -- Checking Patterns.