[project @ 2002-06-05 14:39:27 by simonpj]

---------------------------------------
	Add rebindable syntax for do-notation
		(this time, on the HEAD)
	---------------------------------------

Make do-notation use rebindable syntax, so that -fno-implicit-prelude
makes do-notation use whatever (>>=), (>>), return, fail are in scope,
rather than the Prelude versions.

On the way, combine HsDo and HsDoOut into one constructor in HsSyn,
and tidy up type checking of HsDo.

ghc/compiler/deSugar/DsExpr.lhs

@@ -266,18 +266,18 @@ dsExpr (HsWith expr binds is_with)
 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
 -- because the interpretation of `stmts' depends on what sort of thing it is.
 --
-dsExpr (HsDoOut ListComp stmts _ result_ty src_loc)
+dsExpr (HsDo ListComp stmts _ result_ty src_loc)
   =	-- Special case for list comprehensions
     putSrcLocDs src_loc $
     dsListComp stmts elt_ty
   where
     (_, [elt_ty]) = tcSplitTyConApp result_ty
 
-dsExpr (HsDoOut DoExpr stmts ids result_ty src_loc)
+dsExpr (HsDo DoExpr stmts ids result_ty src_loc)
   = putSrcLocDs src_loc $
     dsDo DoExpr stmts ids result_ty
 
-dsExpr (HsDoOut PArrComp stmts _ result_ty src_loc)
+dsExpr (HsDo PArrComp stmts _ result_ty src_loc)
   =	-- Special case for array comprehensions
     putSrcLocDs src_loc $
     dsPArrComp stmts elt_ty
@@ -542,7 +542,6 @@ dsExpr (DictApp expr dicts)	-- becomes a curried application
 
 #ifdef DEBUG
 -- HsSyn constructs that just shouldn't be here:
-dsExpr (HsDo _ _ _)	    = panic "dsExpr:HsDo"
 dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"
 dsExpr (ArithSeqIn _)	    = panic "dsExpr:ArithSeqIn"
 dsExpr (PArrSeqIn _)	    = panic "dsExpr:PArrSeqIn"
@@ -571,7 +570,7 @@ dsDo do_or_lc stmts ids@[return_id, fail_id, bind_id, then_id] result_ty
 	-- For ExprStmt, see the comments near HsExpr.Stmt about 
 	-- exactly what ExprStmts mean!
 	--
-	-- In dsDo we can only see DoStmt and ListComp (no gaurds)
+	-- In dsDo we can only see DoStmt and ListComp (no guards)
 
 	go [ResultStmt expr locn]
 	  | is_do     = do_expr expr locn
@@ -607,7 +606,7 @@ dsDo do_or_lc stmts ids@[return_id, fail_id, bind_id, then_id] result_ty
                                    (HsLit (HsString (mkFastString msg)))
 	        msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
 		main_match = mkSimpleMatch [pat] 
-					   (HsDoOut do_or_lc stmts ids result_ty locn)
+					   (HsDo do_or_lc stmts ids result_ty locn)
 					   result_ty locn
 		the_matches
 		  | failureFreePat pat = [main_match]

ghc/compiler/hsSyn/HsExpr.lhs

@@ -90,13 +90,10 @@ data HsExpr id pat
 
   | HsDo	HsDoContext
 		[Stmt id pat]	-- "do":one or more stmts
-		SrcLoc
-
-  | HsDoOut	HsDoContext
-		[Stmt id pat]	-- "do":one or more stmts
-		[id]		-- ids for [return,fail,>>=,>>]
+		[id]		-- Ids for [return,fail,>>=,>>]
 				--	Brutal but simple
-		Type		-- Type of the whole expression
+				-- Before type checking, used for rebindable syntax
+		PostTcType	-- Type of the whole expression
 		SrcLoc
 
   | ExplicitList		-- syntactic list
@@ -310,8 +307,7 @@ ppr_expr (HsWith expr binds is_with)
   = sep [hang (ptext SLIT("let")) 2 (pp_ipbinds binds),
 	 hang (ptext SLIT("in"))  2 (ppr expr)]
 
-ppr_expr (HsDo do_or_list_comp stmts _)        = pprDo do_or_list_comp stmts
-ppr_expr (HsDoOut do_or_list_comp stmts _ _ _) = pprDo do_or_list_comp stmts
+ppr_expr (HsDo do_or_list_comp stmts _ _ _) = pprDo do_or_list_comp stmts
 
 ppr_expr (ExplicitList _ exprs)
   = brackets (fsep (punctuate comma (map ppr_expr exprs)))

ghc/compiler/parser/Parser.y

 {-								-*-haskell-*-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.98 2002/05/27 15:28:08 simonpj Exp $
+$Id: Parser.y,v 1.99 2002/06/05 14:39:28 simonpj Exp $
 
 Haskell grammar.
 
@@ -987,7 +987,7 @@ exp10 :: { RdrNameHsExpr }
    	| 'case' srcloc exp 'of' altslist	{ HsCase $3 $5 $2 }
 	| '-' fexp				{ mkHsNegApp $2 }
   	| srcloc 'do' stmtlist			{% checkDo $3  `thenP` \ stmts ->
-						   returnP (HsDo DoExpr stmts $1) }
+						   returnP (mkHsDo DoExpr stmts $1) }
 
 	| '_ccall_'    ccallid aexps0		{ HsCCall $2 $3 PlayRisky False placeHolderType }
 	| '_ccall_GC_' ccallid aexps0		{ HsCCall $2 $3 (PlaySafe False) False placeHolderType }
@@ -1071,9 +1071,9 @@ list :: { RdrNameHsExpr }
 	| exp srcloc pquals		{% let { body [qs] = qs;
 					         body  qss = [ParStmt (map reverse qss)] }
 					   in
-					   returnP ( HsDo ListComp
-							   (reverse (ResultStmt $1 $2 : body $3))
-							   $2
+					   returnP ( mkHsDo ListComp
+							    (reverse (ResultStmt $1 $2 : body $3))
+							    $2
 						  )
 					}
 
@@ -1113,10 +1113,10 @@ parr :: { RdrNameHsExpr }
 							   (map reverse qss)]}
 					   in
 					   returnP $ 
-					     HsDo PArrComp 
-						  (reverse (ResultStmt $1 $2 
-							    : body $3))
-						  $2
+					     mkHsDo PArrComp 
+						    (reverse (ResultStmt $1 $2 
+							     : body $3))
+						    $2
 					}
 
 -- We are reusing `lexps' and `pquals' from the list case.

ghc/compiler/parser/RdrHsSyn.lhs

@@ -48,6 +48,7 @@ module RdrHsSyn (
  
 	mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl,
 	mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional,
+	mkHsDo,
 
 	cvBinds,
 	cvMonoBindsAndSigs,
@@ -61,12 +62,14 @@ module RdrHsSyn (
 import HsSyn		-- Lots of it
 import OccName		( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
                           mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
-			  mkGenOcc2, 
+			  mkGenOcc2, mkVarOcc
                       	)
-import PrelNames	( minusName, negateName, fromIntegerName, fromRationalName )
+import PrelNames	( unboundKey )
+import Name		( mkInternalName )
 import RdrName		( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, isRdrTyVar )
 import List		( nub )
 import BasicTypes	( RecFlag(..) )
+import SrcLoc		( builtinSrcLoc )
 import Class            ( DefMeth (..) )
 \end{code}
 
@@ -241,7 +244,7 @@ mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr
 mkHsNegApp (HsLit (HsIntPrim i))    = HsLit (HsIntPrim (-i))    
 mkHsNegApp (HsLit (HsFloatPrim i))  = HsLit (HsFloatPrim (-i))  
 mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i)) 
-mkHsNegApp expr		  	    = NegApp expr negateName
+mkHsNegApp expr	    		    = NegApp expr     placeHolderName
 \end{code}
 
 A useful function for building @OpApps@.  The operator is always a
@@ -255,9 +258,14 @@ These are the bits of syntax that contain rebindable names
 See RnEnv.lookupSyntaxName
 
 \begin{code}
-mkHsIntegral   i = HsIntegral   i fromIntegerName
-mkHsFractional f = HsFractional f fromRationalName
-mkNPlusKPat n k  = NPlusKPatIn n k minusName
+mkHsIntegral   i      = HsIntegral   i  placeHolderName
+mkHsFractional f      = HsFractional f  placeHolderName
+mkNPlusKPat n k       = NPlusKPatIn n k placeHolderName
+mkHsDo ctxt stmts loc = HsDo ctxt stmts [] placeHolderType loc
+
+placeHolderName = mkInternalName unboundKey 
+			(mkVarOcc FSLIT("syntaxPlaceHolder")) 
+			builtinSrcLoc
 \end{code}
 
 

ghc/compiler/rename/RnEnv.lhs

@@ -608,11 +608,13 @@ At the moment this just happens for
   * fromInteger, fromRational on literals (in expressions and patterns)
   * negate (in expressions)
   * minus  (arising from n+k patterns)
+  * "do" notation
 
 We store the relevant Name in the HsSyn tree, in 
   * HsIntegral/HsFractional	
   * NegApp
   * NPlusKPatIn
+  * HsDo
 respectively.  Initially, we just store the "standard" name (PrelNames.fromIntegralName,
 fromRationalName etc), but the renamer changes this to the appropriate user
 name if Opt_NoImplicitPrelude is on.  That is what lookupSyntaxName does.
@@ -621,15 +623,18 @@ name if Opt_NoImplicitPrelude is on.  That is what lookupSyntaxName does.
 lookupSyntaxName :: Name 	-- The standard name
 	         -> RnMS Name	-- Possibly a non-standard name
 lookupSyntaxName std_name
-  = doptRn Opt_NoImplicitPrelude	`thenRn` \ no_prelude -> 
+  = getModeRn				`thenRn` \ mode ->
+    case mode of {
+	InterfaceMode -> returnRn std_name ;	-- Happens for 'derived' code
+						-- where we don't want to rebind
+   	other ->
+
+    doptRn Opt_NoImplicitPrelude	`thenRn` \ no_prelude -> 
     if not no_prelude then
 	returnRn std_name	-- Normal case
     else
-    let
-	rdr_name = mkRdrUnqual (nameOccName std_name)
 	-- Get the similarly named thing from the local environment
-    in
-    lookupOccRn rdr_name
+    lookupOccRn (mkRdrUnqual (nameOccName std_name)) }
 \end{code}
 
 

ghc/compiler/rename/RnExpr.lhs

@@ -39,7 +39,9 @@ import PrelNames	( hasKey, assertIdKey,
 			  replicatePName, mapPName, filterPName,
 			  falseDataConName, trueDataConName, crossPName,
 			  zipPName, lengthPName, indexPName, toPName,
-			  enumFromToPName, enumFromThenToPName )
+			  enumFromToPName, enumFromThenToPName, 
+			  fromIntegerName, fromRationalName, minusName, negateName,
+			  failMName, bindMName, thenMName, returnMName )
 import TysPrim		( charPrimTyCon, addrPrimTyCon, intPrimTyCon, 
 			  floatPrimTyCon, doublePrimTyCon )
 import TysWiredIn	( intTyCon )
@@ -101,12 +103,12 @@ rnPat (NPatIn lit mb_neg)
 	      fvs1 `plusFV` fvs2 `addOneFV` eqClassName)	
 	-- Needed to find equality on pattern
 
-rnPat (NPlusKPatIn name lit minus)
+rnPat (NPlusKPatIn name lit _)
   = rnOverLit lit			`thenRn` \ (lit', fvs) ->
     lookupBndrRn name			`thenRn` \ name' ->
-    lookupSyntaxName minus		`thenRn` \ minus' ->
-    returnRn (NPlusKPatIn name' lit' minus', 
-	      fvs `addOneFV` ordClassName `addOneFV` minus')
+    lookupSyntaxName minusName		`thenRn` \ minus ->
+    returnRn (NPlusKPatIn name' lit' minus, 
+	      fvs `addOneFV` ordClassName `addOneFV` minus)
 
 rnPat (LazyPatIn pat)
   = rnPat pat		`thenRn` \ (pat', fvs) ->
@@ -339,11 +341,11 @@ rnExpr (OpApp e1 op _ e2)
     returnRn (final_e,
 	      fv_e1 `plusFV` fv_op `plusFV` fv_e2)
 
-rnExpr (NegApp e neg_name)
+rnExpr (NegApp e _)
   = rnExpr e			`thenRn` \ (e', fv_e) ->
-    lookupSyntaxName neg_name	`thenRn` \ neg_name' ->
-    mkNegAppRn e' neg_name'	`thenRn` \ final_e ->
-    returnRn (final_e, fv_e `addOneFV` neg_name')
+    lookupSyntaxName negateName	`thenRn` \ neg_name ->
+    mkNegAppRn e' neg_name	`thenRn` \ final_e ->
+    returnRn (final_e, fv_e `addOneFV` neg_name)
 
 rnExpr (HsPar e)
   = rnExpr e 		`thenRn` \ (e', fvs_e) ->
@@ -391,16 +393,27 @@ rnExpr (HsWith expr binds is_with)
     rnIPBinds binds		`thenRn` \ (binds',fvBinds) ->
     returnRn (HsWith expr' binds' is_with, fvExpr `plusFV` fvBinds)
 
-rnExpr e@(HsDo do_or_lc stmts src_loc)
+rnExpr e@(HsDo do_or_lc stmts _ ty src_loc)
   = pushSrcLocRn src_loc $
     rnStmts stmts			`thenRn` \ ((_, stmts'), fvs) ->
-	-- check the statement list ends in an expression
+
+	-- Check the statement list ends in an expression
     case last stmts' of {
 	ResultStmt _ _ -> returnRn () ;
 	_              -> addErrRn (doStmtListErr e)
     }					`thenRn_`
-    returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs)
+
+	-- Generate the rebindable syntax for the monad
+    (case do_or_lc of
+	DoExpr -> mapRn lookupSyntaxName monad_names
+	other  -> returnRn []
+    )					`thenRn` \ monad_names' ->
+
+    returnRn (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc, 
+	      fvs `plusFV` implicit_fvs)
   where
+    monad_names = [returnMName, failMName, bindMName, thenMName]
+
     implicit_fvs = case do_or_lc of
       PArrComp -> mkFVs [replicatePName, mapPName, filterPName,
 			 falseDataConName, trueDataConName, crossPName,
@@ -845,10 +858,10 @@ litFVs (HsLitLit l bogus_ty)  = returnRn (unitFV cCallableClassName)
 litFVs lit		      = pprPanic "RnExpr.litFVs" (ppr lit)	-- HsInteger and HsRat only appear 
 									-- in post-typechecker translations
 
-rnOverLit (HsIntegral i from_integer_name)
-  = lookupSyntaxName from_integer_name	`thenRn` \ from_integer_name' ->
+rnOverLit (HsIntegral i _)
+  = lookupSyntaxName fromIntegerName	`thenRn` \ from_integer_name ->
     if inIntRange i then
-	returnRn (HsIntegral i from_integer_name', unitFV from_integer_name')
+	returnRn (HsIntegral i from_integer_name, unitFV from_integer_name)
     else let
 	fvs = mkFVs [plusIntegerName, timesIntegerName]
 	-- Big integer literals are built, using + and *, 
@@ -857,10 +870,10 @@ rnOverLit (HsIntegral i from_integer_name)
 	--	they are used to construct the argument to fromInteger, 
 	--	which is the rebindable one.]
     in
-    returnRn (HsIntegral i from_integer_name', fvs `addOneFV` from_integer_name')
+    returnRn (HsIntegral i from_integer_name, fvs `addOneFV` from_integer_name)
 
-rnOverLit (HsFractional i from_rat_name)
-  = lookupSyntaxName from_rat_name						`thenRn` \ from_rat_name' ->
+rnOverLit (HsFractional i _)
+  = lookupSyntaxName fromRationalName		`thenRn` \ from_rat_name ->
     let
 	fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName]
 	-- We have to make sure that the Ratio type is imported with
@@ -871,7 +884,7 @@ rnOverLit (HsFractional i from_rat_name)
 	-- The plus/times integer operations may be needed to construct the numerator
 	-- and denominator (see DsUtils.mkIntegerLit)
     in
-    returnRn (HsFractional i from_rat_name', fvs `addOneFV` from_rat_name')
+    returnRn (HsFractional i from_rat_name, fvs `addOneFV` from_rat_name)
 \end{code}
 
 %************************************************************************

ghc/compiler/typecheck/TcExpr.lhs

@@ -38,7 +38,7 @@ import TcMType		( tcInstTyVars, tcInstType, newHoleTyVarTy, zapToType,
 			  newTyVarTy, newTyVarTys, zonkTcType, readHoleResult )
 import TcType		( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv),
 			  tcSplitFunTys, tcSplitTyConApp, mkTyVarTys,
-			  isSigmaTy, mkFunTy, mkAppTy, mkTyConTy, mkFunTys,
+			  isSigmaTy, mkFunTy, mkAppTy, mkFunTys,
 			  mkTyConApp, mkClassPred, tcFunArgTy,
 			  tyVarsOfTypes, isLinearPred,
 			  liftedTypeKind, openTypeKind, mkArrowKind,
@@ -54,13 +54,13 @@ import Name		( Name )
 import TyCon		( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons )
 import Subst		( mkTopTyVarSubst, substTheta, substTy )
 import VarSet		( emptyVarSet, elemVarSet )
-import TysWiredIn	( boolTy, mkListTy, mkPArrTy, listTyCon, parrTyCon )
+import TysWiredIn	( boolTy, mkListTy, mkPArrTy )
 import PrelNames	( cCallableClassName, 
 			  cReturnableClassName, 
 			  enumFromName, enumFromThenName, 
 			  enumFromToName, enumFromThenToName,
 			  enumFromToPName, enumFromThenToPName,
-			  thenMName, bindMName, failMName, returnMName, ioTyConName
+			  ioTyConName
 			)
 import ListSetOps	( minusList )
 import CmdLineOpts
@@ -336,8 +336,8 @@ tcMonoExpr (HsIf pred b1 b2 src_loc) res_ty
 \end{code}
 
 \begin{code}
-tcMonoExpr expr@(HsDo do_or_lc stmts src_loc) res_ty
-  = tcDoStmts do_or_lc stmts src_loc res_ty
+tcMonoExpr expr@(HsDo do_or_lc stmts method_names _ src_loc) res_ty
+  = tcAddSrcLoc src_loc (tcDoStmts do_or_lc stmts method_names src_loc res_ty)
 \end{code}
 
 \begin{code}
@@ -820,51 +820,30 @@ tcExpr_id expr         = newHoleTyVarTy			`thenNF_Tc` \ id_ty ->
 %************************************************************************
 
 \begin{code}
--- I don't like this lumping together of do expression and list/array
--- comprehensions; creating the monad instances is entirely pointless in the
--- latter case; I'll leave the list case as it is for the moment, but handle
--- arrays extra (would be better to handle arrays and lists together, though)
--- -=chak
---
-tcDoStmts PArrComp stmts src_loc res_ty
-  =
-    ASSERT( notNull stmts )
-    tcAddSrcLoc src_loc	$
-
-    unifyPArrTy res_ty			      `thenTc` \elt_ty              ->
-    let tc_ty = mkTyConTy parrTyCon
-	m_ty  = (mkPArrTy, elt_ty)
-    in
-    tcStmts (DoCtxt PArrComp) m_ty stmts      `thenTc` \(stmts', stmts_lie) ->
-    returnTc (HsDoOut PArrComp stmts'
-		      undefined 	-- don't touch!
-		      res_ty src_loc,
+tcDoStmts PArrComp stmts method_names src_loc res_ty
+  = unifyPArrTy res_ty			  `thenTc` \elt_ty              ->
+    tcStmts (DoCtxt PArrComp) 
+	    (mkPArrTy, elt_ty) stmts      `thenTc` \(stmts', stmts_lie) ->
+    returnTc (HsDo PArrComp stmts'
+		   []		 	-- Unused
+		   res_ty src_loc,
 	      stmts_lie)
 
-tcDoStmts do_or_lc stmts src_loc res_ty
-  =	-- get the Monad and MonadZero classes
-	-- create type consisting of a fresh monad tyvar
-    ASSERT( notNull stmts )
-    tcAddSrcLoc src_loc	$
-
-	-- If it's a comprehension we're dealing with, 
-	-- force it to be a list comprehension.
-	-- (as of Haskell 98, monad comprehensions are no more.)
-	-- Similarily, array comprehensions must involve parallel arrays types
-	--   -=chak
-    (case do_or_lc of
-       ListComp -> unifyListTy res_ty			`thenTc` \ elt_ty ->
-		   returnNF_Tc (mkTyConTy listTyCon, (mkListTy, elt_ty))
-
-       PArrComp -> panic "TcExpr.tcDoStmts: How did we get here?!?"
+tcDoStmts ListComp stmts method_names src_loc res_ty
+  = unifyListTy res_ty			`thenTc` \ elt_ty ->
+    tcStmts (DoCtxt ListComp) 
+	    (mkListTy, elt_ty) stmts	`thenTc` \ (stmts', stmts_lie) ->
+    returnTc (HsDo ListComp stmts'
+		   []			-- Unused
+		   res_ty src_loc,
+	      stmts_lie)
 
-       _	-> newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind)	`thenNF_Tc` \ m_ty ->
-		   newTyVarTy liftedTypeKind 					`thenNF_Tc` \ elt_ty ->
-		   unifyTauTy res_ty (mkAppTy m_ty elt_ty)			`thenTc_`
-		   returnNF_Tc (m_ty, (mkAppTy m_ty, elt_ty))
-    )							`thenNF_Tc` \ (tc_ty, m_ty) ->
+tcDoStmts DoExpr stmts method_names src_loc res_ty
+  = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind)	`thenNF_Tc` \ tc_ty ->
+    newTyVarTy liftedTypeKind 					`thenNF_Tc` \ elt_ty ->
+    unifyTauTy res_ty (mkAppTy tc_ty elt_ty)			`thenTc_`
 
-    tcStmts (DoCtxt do_or_lc) m_ty stmts		`thenTc`   \ (stmts', stmts_lie) ->
+    tcStmts (DoCtxt DoExpr) (mkAppTy tc_ty, elt_ty) stmts	`thenTc`   \ (stmts', stmts_lie) ->
 
 	-- Build the then and zero methods in case we need them
 	-- It's important that "then" and "return" appear just once in the final LIE,
@@ -874,12 +853,11 @@ tcDoStmts do_or_lc stmts src_loc res_ty
 	--	then = then
 	-- where the second "then" sees that it already exists in the "available" stuff.
 	--
-    mapNF_Tc (newMethodFromName DoOrigin tc_ty)
-	     [returnMName, failMName, bindMName, thenMName]	`thenNF_Tc` \ insts ->
+    mapNF_Tc (newMethodFromName DoOrigin tc_ty) method_names	`thenNF_Tc` \ insts ->
 
-    returnTc (HsDoOut do_or_lc stmts'
-		      (map instToId insts)
-		      res_ty src_loc,
+    returnTc (HsDo DoExpr stmts'
+		   (map instToId insts)
+		   res_ty src_loc,
 	      stmts_lie `plusLIE` mkLIE insts)
 \end{code}
 

ghc/compiler/typecheck/TcGenDeriv.lhs

@@ -31,8 +31,8 @@ import HsSyn		( InPat(..), HsExpr(..), MonoBinds(..),
 			  HsBinds(..), HsType(..), HsDoContext(..),
 			  unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType
 			)
-import RdrHsSyn		( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
 import RdrName		( RdrName, mkUnqual )
+import RdrHsSyn		( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat, mkHsDo )
 import BasicTypes	( RecFlag(..), Fixity(..), FixityDirection(..)
 			, maxPrecedence
 			, Boxity(..)
@@ -685,7 +685,7 @@ gen_Ix_binds tycon
     single_con_range
       = mk_easy_FunMonoBind tycon_loc range_RDR 
 	  [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed] [] $
-	HsDo ListComp stmts tycon_loc
+	mkHsDo ListComp stmts tycon_loc
       where
 	stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
 		++
@@ -802,8 +802,8 @@ gen_Read_binds get_fixity tycon
     read_nullary_cons 
       = case nullary_cons of
     	    []    -> []
-    	    [con] -> [HsDo DoExpr [bindLex (ident_pat (data_con_str con)),
-    		      result_stmt con []] loc]
+    	    [con] -> [mkHsDo DoExpr [bindLex (ident_pat (data_con_str con)),
+		    		     result_stmt con []] loc]
             _     -> [HsApp (HsVar choose_RDR) 
     		   	    (ExplicitList placeHolderType (map mk_pair nullary_cons))]
     
@@ -812,7 +812,7 @@ gen_Read_binds get_fixity tycon
 				Boxed
     
     read_non_nullary_con data_con
-      = mkHsApps prec_RDR [mkHsIntLit prec, HsDo DoExpr stmts loc]
+      = mkHsApps prec_RDR [mkHsIntLit prec, mkHsDo DoExpr stmts loc]
       where
        	stmts | is_infix 	  = infix_stmts
      	      | length labels > 0 = lbl_stmts

ghc/compiler/typecheck/TcHsSyn.lhs

@@ -482,13 +482,11 @@ zonkExpr (HsWith expr binds is_with)
 	      zonkExpr e		`thenNF_Tc` \ e' ->
 	      returnNF_Tc (n', e')
 
-zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
-
-zonkExpr (HsDoOut do_or_lc stmts ids ty src_loc)
+zonkExpr (HsDo do_or_lc stmts ids ty src_loc)
   = zonkStmts stmts 		`thenNF_Tc` \ new_stmts ->
     zonkTcTypeToType ty		`thenNF_Tc` \ new_ty   ->
     mapNF_Tc zonkIdOcc ids	`thenNF_Tc` \ new_ids ->
-    returnNF_Tc (HsDoOut do_or_lc new_stmts new_ids new_ty src_loc)
+    returnNF_Tc (HsDo do_or_lc new_stmts new_ids new_ty src_loc)
 
 zonkExpr (ExplicitList ty exprs)
   = zonkTcTypeToType ty		`thenNF_Tc` \ new_ty ->

ghc/compiler/typecheck/TcMatches.lhs

@@ -39,7 +39,7 @@ import BasicTypes	( RecFlag(..) )
 import VarSet
 import Var		( Id )
 import Bag
-import Util		( isSingleton, lengthExceeds )
+import Util		( isSingleton, lengthExceeds, notNull )
 import Outputable
 
 import List		( nub )
@@ -338,7 +338,8 @@ group.  But that's fine; there's no shadowing to worry about.
 
 \begin{code}
 tcStmts do_or_lc m_ty stmts
-  = tcStmtsAndThen (:) do_or_lc m_ty stmts (returnTc ([], emptyLIE))
+  = ASSERT( notNull stmts )
+    tcStmtsAndThen (:) do_or_lc m_ty stmts (returnTc ([], emptyLIE))
 
 tcStmtsAndThen
 	:: (TcStmt -> thing -> thing)	-- Combiner

ghc/compiler/typecheck/TcModule.lhs

@@ -213,8 +213,8 @@ tc_stmts names stmts
     traceTc (text "tcs 4") `thenNF_Tc_`
 
     returnTc (mkHsLet const_binds $
-	      HsDoOut DoExpr tc_stmts io_ids
-		      (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc,
+	      HsDo DoExpr tc_stmts io_ids
+		   (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc,
 	      ids)
   where
     combine stmt (ids, stmts) = (ids, stmt:stmts)