This big patch re-factors the way in which arrow-syntax is handled

All the work was done by Dan Winograd-Cort.

The main thing is that arrow comamnds now have their own
data type HsCmd (defined in HsExpr).  Previously it was
punned with the HsExpr type, which was jolly confusing,
and made it hard to do anything arrow-specific.

To make this work, we now parameterise
  * MatchGroup
  * Match
  * GRHSs, GRHS
  * StmtLR and friends
over the "body", that is the kind of thing they
enclose.  This "body" parameter can be instantiated to
either LHsExpr or LHsCmd respectively.

Everything else is really a knock-on effect; there should
be no change (yet!) in behaviour.  But it should be a sounder
basis for fixing bugs.

9 files changed, 169 insertions, 196 deletions

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index d92f2d1dd7..551355cb62 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -585,19 +585,19 @@ addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id)
 addTickTupArg (Present e)  = do { e' <- addTickLHsExpr e; return (Present e') }
 addTickTupArg (Missing ty) = return (Missing ty)
 
-addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id -> TM (MatchGroup Id)
+addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id))
 addTickMatchGroup is_lam (MatchGroup matches ty) = do
   let isOneOfMany = matchesOneOfMany matches
   matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
   return $ MatchGroup matches' ty
 
-addTickMatch :: Bool -> Bool -> Match Id -> TM (Match Id)
+addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id))
 addTickMatch isOneOfMany isLambda (Match pats opSig gRHSs) =
   bindLocals (collectPatsBinders pats) $ do
     gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
     return $ Match pats opSig gRHSs'
 
-addTickGRHSs :: Bool -> Bool -> GRHSs Id -> TM (GRHSs Id)
+addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id))
 addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do
   bindLocals binders $ do
     local_binds' <- addTickHsLocalBinds local_binds
@@ -606,7 +606,7 @@ addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do
   where
     binders = collectLocalBinders local_binds
 
-addTickGRHS :: Bool -> Bool -> GRHS Id -> TM (GRHS Id)
+addTickGRHS :: Bool -> Bool -> GRHS Id (LHsExpr Id) -> TM (GRHS Id (LHsExpr Id))
 addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do
   (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
                         (addTickGRHSBody isOneOfMany isLambda expr)
@@ -624,20 +624,20 @@ addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
     _otherwise ->
        addTickLHsExprRHS expr
 
-addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id]
+addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM [ExprLStmt Id]
 addTickLStmts isGuard stmts = do
   (stmts, _) <- addTickLStmts' isGuard stmts (return ())
   return stmts
 
-addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a
-               -> TM ([LStmt Id], a)
+addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM a
+               -> TM ([ExprLStmt Id], a)
 addTickLStmts' isGuard lstmts res
   = bindLocals (collectLStmtsBinders lstmts) $
     do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
        ; a <- res
        ; return (lstmts', a) }
 
-addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
+addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id (LHsExpr Id) -> TM (Stmt Id (LHsExpr Id))
 addTickStmt _isGuard (LastStmt e ret) = do
         liftM2 LastStmt
                 (addTickLHsExpr e)
@@ -648,8 +648,8 @@ addTickStmt _isGuard (BindStmt pat e bind fail) = do
                 (addTickLHsExprRHS e)
                 (addTickSyntaxExpr hpcSrcSpan bind)
                 (addTickSyntaxExpr hpcSrcSpan fail)
-addTickStmt isGuard (ExprStmt e bind' guard' ty) = do
-        liftM4 ExprStmt
+addTickStmt isGuard (BodyStmt e bind' guard' ty) = do
+        liftM4 BodyStmt
                 (addTick isGuard e)
                 (addTickSyntaxExpr hpcSrcSpan bind')
                 (addTickSyntaxExpr hpcSrcSpan guard')
@@ -751,63 +751,65 @@ addTickLHsCmd (L pos c0) = do
         return $ L pos c1
 
 addTickHsCmd :: HsCmd Id -> TM (HsCmd Id)
-addTickHsCmd (HsLam matchgroup) =
-        liftM HsLam (addTickCmdMatchGroup matchgroup)
-addTickHsCmd (HsApp c e) =
-        liftM2 HsApp (addTickLHsCmd c) (addTickLHsExpr e)
+addTickHsCmd (HsCmdLam matchgroup) =
+        liftM HsCmdLam (addTickCmdMatchGroup matchgroup)
+addTickHsCmd (HsCmdApp c e) =
+        liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e)
+{-
 addTickHsCmd (OpApp e1 c2 fix c3) =
         liftM4 OpApp
                 (addTickLHsExpr e1)
                 (addTickLHsCmd c2)
                 (return fix)
                 (addTickLHsCmd c3)
-addTickHsCmd (HsPar e) = liftM HsPar (addTickLHsCmd e)
-addTickHsCmd (HsCase e mgs) =
-        liftM2 HsCase
+-}
+addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e)
+addTickHsCmd (HsCmdCase e mgs) =
+        liftM2 HsCmdCase
                 (addTickLHsExpr e)
                 (addTickCmdMatchGroup mgs)
-addTickHsCmd (HsIf cnd e1 c2 c3) =
-        liftM3 (HsIf cnd)
+addTickHsCmd (HsCmdIf cnd e1 c2 c3) =
+        liftM3 (HsCmdIf cnd)
                 (addBinTickLHsExpr (BinBox CondBinBox) e1)
                 (addTickLHsCmd c2)
                 (addTickLHsCmd c3)
-addTickHsCmd (HsLet binds c) =
+addTickHsCmd (HsCmdLet binds c) =
         bindLocals (collectLocalBinders binds) $
-        liftM2 HsLet
+        liftM2 HsCmdLet
                 (addTickHsLocalBinds binds) -- to think about: !patterns.
                 (addTickLHsCmd c)
-addTickHsCmd (HsDo cxt stmts srcloc)
+addTickHsCmd (HsCmdDo stmts srcloc)
   = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
-       ; return (HsDo cxt stmts' srcloc) }
+       ; return (HsCmdDo stmts' srcloc) }
 
-addTickHsCmd (HsArrApp   e1 e2 ty1 arr_ty lr) =
-        liftM5 HsArrApp
+addTickHsCmd (HsCmdArrApp   e1 e2 ty1 arr_ty lr) =
+        liftM5 HsCmdArrApp
                (addTickLHsExpr e1)
                (addTickLHsExpr e2)
                (return ty1)
                (return arr_ty)
                (return lr)
-addTickHsCmd (HsArrForm e fix cmdtop) =
-        liftM3 HsArrForm
+addTickHsCmd (HsCmdArrForm e fix cmdtop) =
+        liftM3 HsCmdArrForm
                (addTickLHsExpr e)
                (return fix)
                (mapM (liftL (addTickHsCmdTop)) cmdtop)
 
 -- Others should never happen in a command context.
-addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)
+--addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)
 
-addTickCmdMatchGroup :: MatchGroup Id -> TM (MatchGroup Id)
+addTickCmdMatchGroup :: MatchGroup Id (LHsCmd Id) -> TM (MatchGroup Id (LHsCmd Id))
 addTickCmdMatchGroup (MatchGroup matches ty) = do
   matches' <- mapM (liftL addTickCmdMatch) matches
   return $ MatchGroup matches' ty
 
-addTickCmdMatch :: Match Id -> TM (Match Id)
+addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id))
 addTickCmdMatch (Match pats opSig gRHSs) =
   bindLocals (collectPatsBinders pats) $ do
     gRHSs' <- addTickCmdGRHSs gRHSs
     return $ Match pats opSig gRHSs'
 
-addTickCmdGRHSs :: GRHSs Id -> TM (GRHSs Id)
+addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id))
 addTickCmdGRHSs (GRHSs guarded local_binds) = do
   bindLocals binders $ do
     local_binds' <- addTickHsLocalBinds local_binds
@@ -816,7 +818,7 @@ addTickCmdGRHSs (GRHSs guarded local_binds) = do
   where
     binders = collectLocalBinders local_binds
 
-addTickCmdGRHS :: GRHS Id -> TM (GRHS Id)
+addTickCmdGRHS :: GRHS Id (LHsCmd Id) -> TM (GRHS Id (LHsCmd Id))
 -- The *guards* are *not* Cmds, although the body is
 -- C.f. addTickGRHS for the BinBox stuff
 addTickCmdGRHS (GRHS stmts cmd)
@@ -824,12 +826,12 @@ addTickCmdGRHS (GRHS stmts cmd)
                                    stmts (addTickLHsCmd cmd)
        ; return $ GRHS stmts' expr' }
 
-addTickLCmdStmts :: [LStmt Id] -> TM [LStmt Id]
+addTickLCmdStmts :: [LStmt Id (LHsCmd Id)] -> TM [LStmt Id (LHsCmd Id)]
 addTickLCmdStmts stmts = do
   (stmts, _) <- addTickLCmdStmts' stmts (return ())
   return stmts
 
-addTickLCmdStmts' :: [LStmt Id] -> TM a -> TM ([LStmt Id], a)
+addTickLCmdStmts' :: [LStmt Id (LHsCmd Id)] -> TM a -> TM ([LStmt Id (LHsCmd Id)], a)
 addTickLCmdStmts' lstmts res
   = bindLocals binders $ do
         lstmts' <- mapM (liftL addTickCmdStmt) lstmts
@@ -838,7 +840,7 @@ addTickLCmdStmts' lstmts res
   where
         binders = collectLStmtsBinders lstmts
 
-addTickCmdStmt :: Stmt Id -> TM (Stmt Id)
+addTickCmdStmt :: Stmt Id (LHsCmd Id) -> TM (Stmt Id (LHsCmd Id))
 addTickCmdStmt (BindStmt pat c bind fail) = do
         liftM4 BindStmt
                 (addTickLPat pat)
@@ -849,8 +851,8 @@ addTickCmdStmt (LastStmt c ret) = do
         liftM2 LastStmt
                 (addTickLHsCmd c)
                 (addTickSyntaxExpr hpcSrcSpan ret)
-addTickCmdStmt (ExprStmt c bind' guard' ty) = do
-        liftM4 ExprStmt
+addTickCmdStmt (BodyStmt c bind' guard' ty) = do
+        liftM4 BodyStmt
                 (addTickLHsCmd c)
                 (addTickSyntaxExpr hpcSrcSpan bind')
                 (addTickSyntaxExpr hpcSrcSpan guard')
@@ -1143,7 +1145,7 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
 
 
 \begin{code}
-matchesOneOfMany :: [LMatch Id] -> Bool
+matchesOneOfMany :: [LMatch Id body] -> Bool
 matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
   where
         matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
index 1da6a77976..66e29f8348 100644
--- a/compiler/deSugar/DsArrows.lhs
+++ b/compiler/deSugar/DsArrows.lhs
@@ -50,31 +50,37 @@ import Outputable
 import Bag
 import VarSet
 import SrcLoc
-
+import ListSetOps( assocDefault )
+import FastString
 import Data.List
 \end{code}
 
 \begin{code}
 data DsCmdEnv = DsCmdEnv {
-	meth_binds :: [CoreBind],
 	arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
     }
 
-mkCmdEnv :: SyntaxTable Id -> DsM DsCmdEnv
-mkCmdEnv ids = do
-    (meth_binds, ds_meths) <- dsSyntaxTable ids
-    return $ DsCmdEnv {
-               meth_binds = meth_binds,
-               arr_id     = Var (lookupEvidence ds_meths arrAName),
-               compose_id = Var (lookupEvidence ds_meths composeAName),
-               first_id   = Var (lookupEvidence ds_meths firstAName),
-               app_id     = Var (lookupEvidence ds_meths appAName),
-               choice_id  = Var (lookupEvidence ds_meths choiceAName),
-               loop_id    = Var (lookupEvidence ds_meths loopAName)
-             }
-
-bindCmdEnv :: DsCmdEnv -> CoreExpr -> CoreExpr
-bindCmdEnv ids body = foldr Let body (meth_binds ids)
+mkCmdEnv :: CmdSyntaxTable Id -> DsM ([CoreBind], DsCmdEnv)
+-- See Note [CmdSyntaxTable] in HsExpr
+mkCmdEnv tc_meths
+  = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths
+       ; return (meth_binds, DsCmdEnv {
+               arr_id     = Var (find_meth prs arrAName),
+               compose_id = Var (find_meth prs composeAName),
+               first_id   = Var (find_meth prs firstAName),
+               app_id     = Var (find_meth prs appAName),
+               choice_id  = Var (find_meth prs choiceAName),
+               loop_id    = Var (find_meth prs loopAName)
+             }) }
+  where
+    mk_bind (std_name, expr)
+      = do { rhs <- dsExpr expr
+           ; id <- newSysLocalDs (exprType rhs)
+           ; return (NonRec id rhs, (std_name, id)) }
+ 
+    find_meth prs std_name
+      = assocDefault (mk_panic std_name) prs std_name
+    mk_panic std_name = pprPanic "mkCmdEnv" (ptext (sLit "Not found:") <+> ppr std_name)
 
 -- arr :: forall b c. (b -> c) -> a b c
 do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
@@ -245,7 +251,7 @@ dsProcExpr
 	-> LHsCmdTop Id
 	-> DsM CoreExpr
 dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) = do
-    meth_ids <- mkCmdEnv ids
+    (meth_binds, meth_ids) <- mkCmdEnv ids
     let locals = mkVarSet (collectPatBinders pat)
     (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals [] cmd_ty cmd
     let env_ty = mkBigCoreVarTupTy env_ids
@@ -256,7 +262,7 @@ dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) = do
         proc_code = do_map_arrow meth_ids pat_ty env_ty cmd_ty
                     (Lam var match_code)
                     core_cmd
-    return (bindCmdEnv meth_ids proc_code)
+    return (mkLets meth_binds proc_code)
 dsProcExpr _ c = pprPanic "dsProcExpr" (ppr c)
 \end{code}
 
@@ -289,7 +295,7 @@ dsCmd   :: DsCmdEnv		-- arrow combinators
 --		---> arr (\ ((xs)*ts) -> (arg*ts)) >>> f
 
 dsCmd ids local_vars stack res_ty
-        (HsArrApp arrow arg arrow_ty HsFirstOrderApp _)
+        (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _)
         env_ids = do
     let
         (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
@@ -315,7 +321,7 @@ dsCmd ids local_vars stack res_ty
 --		---> arr (\ ((xs)*ts) -> (f,(arg*ts))) >>> app
 
 dsCmd ids local_vars stack res_ty
-        (HsArrApp arrow arg arrow_ty HsHigherOrderApp _)
+        (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _)
         env_ids = do
     let
         (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
@@ -344,7 +350,7 @@ dsCmd ids local_vars stack res_ty
 --
 --		---> arr (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) >>> c
 
-dsCmd ids local_vars stack res_ty (HsApp cmd arg) env_ids = do
+dsCmd ids local_vars stack res_ty (HsCmdApp cmd arg) env_ids = do
     core_arg <- dsLExpr arg
     let
         arg_ty = exprType core_arg
@@ -375,7 +381,7 @@ dsCmd ids local_vars stack res_ty (HsApp cmd arg) env_ids = do
 --		---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c
 
 dsCmd ids local_vars stack res_ty
-        (HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _))
+        (HsCmdLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _))
         env_ids = do
     let
         pat_vars = mkVarSet (collectPatsBinders pats)
@@ -402,7 +408,7 @@ dsCmd ids local_vars stack res_ty
     return (do_map_arrow ids in_ty in_ty' res_ty select_code core_body,
             free_vars `minusVarSet` pat_vars)
 
-dsCmd ids local_vars stack res_ty (HsPar cmd) env_ids
+dsCmd ids local_vars stack res_ty (HsCmdPar cmd) env_ids
   = dsLCmd ids local_vars stack res_ty cmd env_ids
 
 --	A, xs |- e :: Bool
@@ -415,7 +421,7 @@ dsCmd ids local_vars stack res_ty (HsPar cmd) env_ids
 --			if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>>
 --		     c1 ||| c2
 
-dsCmd ids local_vars stack res_ty (HsIf mb_fun cond then_cmd else_cmd)
+dsCmd ids local_vars stack res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
         env_ids = do
     core_cond <- dsLExpr cond
     (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack res_ty then_cmd
@@ -476,7 +482,7 @@ case bodies, containing the following fields:
    bodies with |||.
 
 \begin{code}
-dsCmd ids local_vars stack res_ty (HsCase exp (MatchGroup matches match_ty))
+dsCmd ids local_vars stack res_ty (HsCmdCase exp (MatchGroup matches match_ty))
         env_ids = do
     stack_ids <- mapM newSysLocalDs stack
 
@@ -535,7 +541,7 @@ dsCmd ids local_vars stack res_ty (HsCase exp (MatchGroup matches match_ty))
 --
 --		---> arr (\ ((xs)*ts) -> let binds in ((ys)*ts)) >>> c
 
-dsCmd ids local_vars stack res_ty (HsLet binds body) env_ids = do
+dsCmd ids local_vars stack res_ty (HsCmdLet binds body) env_ids = do
     let
         defined_vars = mkVarSet (collectLocalBinders binds)
         local_vars' = defined_vars `unionVarSet` local_vars
@@ -554,7 +560,7 @@ dsCmd ids local_vars stack res_ty (HsLet binds body) env_ids = do
                         core_body,
         exprFreeIds core_binds `intersectVarSet` local_vars)
 
-dsCmd ids local_vars [] res_ty (HsDo _ctxt stmts _) env_ids
+dsCmd ids local_vars [] res_ty (HsCmdDo stmts _) env_ids
   = dsCmdDo ids local_vars res_ty stmts env_ids
 
 --	A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t
@@ -562,16 +568,16 @@ dsCmd ids local_vars [] res_ty (HsDo _ctxt stmts _) env_ids
 --	-----------------------------------
 --	A | xs |- (|e c1 ... cn|) :: [ts] t	---> e [t_xs] c1 ... cn
 
-dsCmd _ids local_vars _stack _res_ty (HsArrForm op _ args) env_ids = do
+dsCmd _ids local_vars _stack _res_ty (HsCmdArrForm op _ args) env_ids = do
     let env_ty = mkBigCoreVarTupTy env_ids
     core_op <- dsLExpr op
     (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
     return (mkApps (App core_op (Type env_ty)) core_args,
             unionVarSets fv_sets)
 
-dsCmd ids local_vars stack res_ty (HsTick tickish expr) env_ids = do
-    (expr1,id_set) <- dsLCmd ids local_vars stack res_ty expr env_ids
-    return (Tick tickish expr1, id_set)
+--dsCmd ids local_vars stack res_ty (HsTick tickish expr) env_ids = do
+--    (expr1,id_set) <- dsLCmd ids local_vars stack res_ty expr env_ids
+--    return (Tick tickish expr1, id_set)
 
 dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
 
@@ -586,7 +592,7 @@ dsTrimCmdArg
 	-> DsM (CoreExpr,	-- desugared expression
 		IdSet)		-- subset of local vars that occur free
 dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack cmd_ty ids)) = do
-    meth_ids <- mkCmdEnv ids
+    (meth_binds, meth_ids) <- mkCmdEnv ids
     (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack cmd_ty cmd
     stack_ids <- mapM newSysLocalDs stack
     trim_code <- matchEnvStack env_ids stack_ids (buildEnvStack env_ids' stack_ids)
@@ -595,7 +601,7 @@ dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack cmd_ty ids)) = do
         in_ty' = envStackType env_ids' stack
         arg_code = if env_ids' == env_ids then core_cmd else
                 do_map_arrow meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
-    return (bindCmdEnv meth_ids arg_code, free_vars)
+    return (mkLets meth_binds arg_code, free_vars)
 
 -- Given A | xs |- c :: [ts] t, builds c with xs fed back.
 -- Typically needs to be prefixed with arr (\p -> ((xs)*ts))
@@ -638,7 +644,7 @@ Translation of command judgements of the form
 dsCmdDo :: DsCmdEnv		-- arrow combinators
 	-> IdSet		-- set of local vars available to this statement
 	-> Type			-- return type of the statement
-	-> [LStmt Id]		-- statements to desugar
+	-> [CmdLStmt Id]        -- statements to desugar
 	-> [Id]			-- list of vars in the input to this statement
 				-- This is typically fed back,
 				-- so don't pull on it too early
@@ -673,7 +679,7 @@ A statement maps one local environment to another, and is represented
 as an arrow from one tuple type to another.  A statement sequence is
 translated to a composition of such arrows.
 \begin{code}
-dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> LStmt Id -> [Id]
+dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt Id -> [Id]
            -> DsM (CoreExpr, IdSet)
 dsCmdLStmt ids local_vars out_ids cmd env_ids
   = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids
@@ -682,7 +688,7 @@ dsCmdStmt
 	:: DsCmdEnv		-- arrow combinators
 	-> IdSet		-- set of local vars available to this statement
 	-> [Id]			-- list of vars in the output of this statement
-	-> Stmt Id		-- statement to desugar
+	-> CmdStmt Id           -- statement to desugar
 	-> [Id]			-- list of vars in the input to this statement
 				-- This is typically fed back,
 				-- so don't pull on it too early
@@ -697,7 +703,7 @@ dsCmdStmt
 --		---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>>
 --			arr snd >>> ss
 
-dsCmdStmt ids local_vars out_ids (ExprStmt cmd _ _ c_ty) env_ids = do
+dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do
     (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] c_ty cmd
     core_mux <- matchEnvStack env_ids []
         (mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup out_ids))
@@ -860,7 +866,7 @@ dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)
 dsRecCmd
         :: DsCmdEnv		-- arrow combinators
         -> IdSet		-- set of local vars available to this statement
-        -> [LStmt Id]		-- list of statements inside the RecCmd
+        -> [CmdLStmt Id]        -- list of statements inside the RecCmd
         -> [Id]			-- list of vars defined here and used later
         -> [HsExpr Id]		-- expressions corresponding to later_ids
         -> [Id]			-- list of vars fed back through the loop
@@ -938,7 +944,7 @@ dsfixCmdStmts
 	:: DsCmdEnv		-- arrow combinators
 	-> IdSet		-- set of local vars available to this statement
 	-> [Id]			-- output vars of these statements
-	-> [LStmt Id]		-- statements to desugar
+	-> [CmdLStmt Id]        -- statements to desugar
 	-> DsM (CoreExpr,	-- desugared expression
 		IdSet,		-- subset of local vars that occur free
 		[Id])		-- same local vars as a list
@@ -950,7 +956,7 @@ dsCmdStmts
 	:: DsCmdEnv		-- arrow combinators
 	-> IdSet		-- set of local vars available to this statement
 	-> [Id]			-- output vars of these statements
-	-> [LStmt Id]		-- statements to desugar
+	-> [CmdLStmt Id]        -- statements to desugar
 	-> [Id]			-- list of vars in the input to these statements
 	-> DsM (CoreExpr,	-- desugared expression
 		IdSet)		-- subset of local vars that occur free
@@ -995,28 +1001,28 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys"
 List of leaf expressions, with set of variables bound in each
 
 \begin{code}
-leavesMatch :: LMatch Id -> [(LHsExpr Id, IdSet)]
+leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)]
 leavesMatch (L _ (Match pats _ (GRHSs grhss binds)))
   = let
 	defined_vars = mkVarSet (collectPatsBinders pats)
 			`unionVarSet`
 		       mkVarSet (collectLocalBinders binds)
     in
-    [(expr, 
+    [(body, 
       mkVarSet (collectLStmtsBinders stmts) 
 	`unionVarSet` defined_vars) 
-    | L _ (GRHS stmts expr) <- grhss]
+    | L _ (GRHS stmts body) <- grhss]
 \end{code}
 
 Replace the leaf commands in a match
 
 \begin{code}
 replaceLeavesMatch
-	:: Type			-- new result type
-	-> [LHsExpr Id]	-- replacement leaf expressions of that type
-	-> LMatch Id	-- the matches of a case command
-	-> ([LHsExpr Id],-- remaining leaf expressions
-	    LMatch Id)	-- updated match
+        :: Type                                 -- new result type
+        -> [Located (body' Id)]                 -- replacement leaf expressions of that type
+        -> LMatch Id (Located (body Id))        -- the matches of a case command
+        -> ([Located (body' Id)],               -- remaining leaf expressions
+            LMatch Id (Located (body' Id)))     -- updated match
 replaceLeavesMatch _res_ty leaves (L loc (Match pat mt (GRHSs grhss binds)))
   = let
 	(leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
@@ -1024,10 +1030,10 @@ replaceLeavesMatch _res_ty leaves (L loc (Match pat mt (GRHSs grhss binds)))
     (leaves', L loc (Match pat mt (GRHSs grhss' binds)))
 
 replaceLeavesGRHS
-	:: [LHsExpr Id]	-- replacement leaf expressions of that type
-	-> LGRHS Id	-- rhss of a case command
-	-> ([LHsExpr Id],-- remaining leaf expressions
-	    LGRHS Id)	-- updated GRHS
+        :: [Located (body' Id)]                 -- replacement leaf expressions of that type
+        -> LGRHS Id (Located (body Id))         -- rhss of a case command
+        -> ([Located (body' Id)],               -- remaining leaf expressions
+            LGRHS Id (Located (body' Id)))      -- updated GRHS
 replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _))
   = (leaves, L loc (GRHS stmts leaf))
 replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"
@@ -1113,16 +1119,16 @@ add_ev_bndr (EvBind b _) bs | isId b    = b:bs
                             | otherwise = bs
   -- A worry: what about coercion variable binders??
 
-collectLStmtsBinders :: [LStmt Id] -> [Id]
+collectLStmtsBinders :: [LStmt Id body] -> [Id]
 collectLStmtsBinders = concatMap collectLStmtBinders
 
-collectLStmtBinders :: LStmt Id -> [Id]
+collectLStmtBinders :: LStmt Id body -> [Id]
 collectLStmtBinders = collectStmtBinders . unLoc
 
-collectStmtBinders :: Stmt Id -> [Id]
+collectStmtBinders :: Stmt Id body -> [Id]
 collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
-collectStmtBinders (ExprStmt {})        = []
+collectStmtBinders (BodyStmt {})        = []
 collectStmtBinders (LastStmt {})        = []
 collectStmtBinders (ParStmt xs _ _)     = collectLStmtsBinders
                                         $ [ s | ParStmtBlock ss _ _ <- xs, s <- ss]
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index a7501594e6..88df581844 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -324,12 +324,12 @@ dsExpr (HsLet binds body) = do
 -- 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 (HsDo ListComp  stmts res_ty) = dsListComp stmts res_ty
-dsExpr (HsDo PArrComp  stmts _)      = dsPArrComp (map unLoc stmts)
-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 (HsDo ListComp     stmts res_ty) = dsListComp stmts res_ty
+dsExpr (HsDo PArrComp     stmts _)      = dsPArrComp (map unLoc stmts)
+dsExpr (HsDo DoExpr       stmts _)      = dsDo stmts 
+dsExpr (HsDo GhciStmtCtxt 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
@@ -719,7 +719,7 @@ handled in DsListComp).  Basically does the translation given in the
 Haskell 98 report:
 
 \begin{code}
-dsDo :: [LStmt Id] -> DsM CoreExpr
+dsDo :: [ExprLStmt Id] -> DsM CoreExpr
 dsDo stmts
   = goL stmts
   where
@@ -730,7 +730,7 @@ dsDo stmts
       = ASSERT( null stmts ) dsLExpr body
         -- The 'return' op isn't used for 'do' expressions
 
-    go _ (ExprStmt rhs then_expr _ _) stmts
+    go _ (BodyStmt rhs then_expr _ _) stmts
       = do { rhs2 <- dsLExpr rhs
            ; warnDiscardedDoBindings rhs (exprType rhs2) 
            ; then_expr2 <- dsExpr then_expr
diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs
index 9e84e46e9f..1af39d1a0f 100644
--- a/compiler/deSugar/DsGRHSs.lhs
+++ b/compiler/deSugar/DsGRHSs.lhs
@@ -40,7 +40,7 @@ producing an expression with a runtime error in the corner if
 necessary.  The type argument gives the type of the @ei@.
 
 \begin{code}
-dsGuarded :: GRHSs Id -> Type -> DsM CoreExpr
+dsGuarded :: GRHSs Id (LHsExpr Id) -> Type -> DsM CoreExpr
 
 dsGuarded grhss rhs_ty = do
     match_result <- dsGRHSs PatBindRhs [] grhss rhs_ty
@@ -52,7 +52,7 @@ In contrast, @dsGRHSs@ produces a @MatchResult@.
 
 \begin{code}
 dsGRHSs :: HsMatchContext Name -> [Pat Id]      -- These are to build a MatchContext from
-        -> GRHSs Id                             -- Guarded RHSs
+        -> GRHSs Id (LHsExpr Id)                -- Guarded RHSs
         -> Type                                 -- Type of RHS
         -> DsM MatchResult
 dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty = do
@@ -66,7 +66,7 @@ dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty = do
     --
     return match_result2
 
-dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id -> DsM MatchResult
+dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id (LHsExpr Id) -> DsM MatchResult
 dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs))
   = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty
 \end{code}
@@ -79,31 +79,31 @@ dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs))
 %************************************************************************
 
 \begin{code}
-matchGuards :: [Stmt Id]                -- Guard
-            -> HsStmtContext Name       -- Context
-            -> LHsExpr Id               -- RHS
-            -> Type                     -- Type of RHS of guard
+matchGuards :: [GuardStmt Id]       -- Guard
+            -> HsStmtContext Name   -- Context
+            -> LHsExpr Id           -- RHS
+            -> Type                 -- Type of RHS of guard
             -> DsM MatchResult
 
--- See comments with HsExpr.Stmt re what an ExprStmt means
+-- See comments with HsExpr.Stmt re what a BodyStmt means
 -- Here we must be in a guard context (not do-expression, nor list-comp)
 
 matchGuards [] _ rhs _
   = do  { core_rhs <- dsLExpr rhs
         ; return (cantFailMatchResult core_rhs) }
 
-        -- ExprStmts must be guards
+        -- BodyStmts must be guards
         -- Turn an "otherwise" guard is a no-op.  This ensures that
         -- you don't get a "non-exhaustive eqns" message when the guards
         -- finish in "otherwise".
         -- NB:  The success of this clause depends on the typechecker not
         --      wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
         --      If it does, you'll get bogus overlap warnings
-matchGuards (ExprStmt e _ _ _ : stmts) ctx rhs rhs_ty
+matchGuards (BodyStmt e _ _ _ : stmts) ctx rhs rhs_ty
   | Just addTicks <- isTrueLHsExpr e = do
     match_result <- matchGuards stmts ctx rhs rhs_ty
     return (adjustMatchResultDs addTicks match_result)
-matchGuards (ExprStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do
+matchGuards (BodyStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do
     match_result <- matchGuards stmts ctx rhs rhs_ty
     pred_expr <- dsLExpr expr
     return (mkGuardedMatchResult pred_expr match_result)
diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs
index efe14f2678..b590a92057 100644
--- a/compiler/deSugar/DsListComp.lhs
+++ b/compiler/deSugar/DsListComp.lhs
@@ -43,7 +43,7 @@ turned on'' (if you read Gill {\em et al.}'s paper on the subject).
 There will be at least one ``qualifier'' in the input.
 
 \begin{code}
-dsListComp :: [LStmt Id]
+dsListComp :: [ExprLStmt Id]
            -> Type              -- Type of entire list
            -> DsM CoreExpr
 dsListComp lquals res_ty = do
@@ -89,7 +89,7 @@ dsInnerListComp (ParStmtBlock stmts bndrs _)
 -- This function factors out commonality between the desugaring strategies for GroupStmt.
 -- 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
-dsTransStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
+dsTransStmt :: ExprStmt Id -> DsM (CoreExpr, LPat Id)
 dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap
                        , trS_by = by, trS_using = using }) = do
     let (from_bndrs, to_bndrs) = unzip binderMap
@@ -204,7 +204,7 @@ with the Unboxed variety.
 
 \begin{code}
 
-deListComp :: [Stmt Id] -> CoreExpr -> DsM CoreExpr
+deListComp :: [ExprStmt Id] -> CoreExpr -> DsM CoreExpr
 
 deListComp [] _ = panic "deListComp"
 
@@ -215,7 +215,7 @@ deListComp (LastStmt body _ : quals) list
        ; return (mkConsExpr (exprType core_body) core_body list) }
 
         -- Non-last: must be a guard
-deListComp (ExprStmt guard _ _ _ : quals) list = do  -- rule B above
+deListComp (BodyStmt guard _ _ _ : quals) list = do  -- rule B above
     core_guard <- dsLExpr guard
     core_rest <- deListComp quals list
     return (mkIfThenElse core_guard core_rest list)
@@ -256,7 +256,7 @@ deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
 \begin{code}
 deBindComp :: OutPat Id
            -> CoreExpr
-           -> [Stmt Id]
+           -> [ExprStmt Id]
            -> CoreExpr
            -> DsM (Expr Id)
 deBindComp pat core_list1 quals core_list2 = do
@@ -309,8 +309,8 @@ TE[ e | p <- l , q ] c n = let
 \end{verbatim}
 
 \begin{code}
-dfListComp :: Id -> Id -- 'c' and 'n'
-        -> [Stmt Id]   -- the rest of the qual's
+dfListComp :: Id -> Id      -- 'c' and 'n'
+        -> [ExprStmt Id]    -- the rest of the qual's
         -> DsM CoreExpr
 
 dfListComp _ _ [] = panic "dfListComp"
@@ -321,7 +321,7 @@ dfListComp c_id n_id (LastStmt body _ : quals)
        ; return (mkApps (Var c_id) [core_body, Var n_id]) }
 
         -- Non-last: must be a guard
-dfListComp c_id n_id (ExprStmt guard _ _ _  : quals) = do
+dfListComp c_id n_id (BodyStmt guard _ _ _  : quals) = do
     core_guard <- dsLExpr guard
     core_rest <- dfListComp c_id n_id quals
     return (mkIfThenElse core_guard core_rest (Var n_id))
@@ -347,8 +347,8 @@ dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"
 dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"
 
 dfBindComp :: Id -> Id          -- 'c' and 'n'
-       -> (LPat Id, CoreExpr)
-           -> [Stmt Id]                 -- the rest of the qual's
+           -> (LPat Id, CoreExpr)
+           -> [ExprStmt Id]     -- the rest of the qual's
            -> DsM CoreExpr
 dfBindComp c_id n_id (pat, core_list1) quals = do
     -- find the required type
@@ -469,7 +469,7 @@ mkUnzipBind _ elt_tys
 --
 --   [:e | qss:] = <<[:e | qss:]>> () [:():]
 --
-dsPArrComp :: [Stmt Id]
+dsPArrComp :: [ExprStmt Id]
             -> DsM CoreExpr
 
 -- Special case for parallel comprehension
@@ -505,7 +505,7 @@ dsPArrComp qs = do -- no ParStmt in `qs'
 
 -- the work horse
 --
-dePArrComp :: [Stmt Id]
+dePArrComp :: [ExprStmt Id]
            -> LPat Id           -- the current generator pattern
            -> CoreExpr          -- the current generator expression
            -> DsM CoreExpr
@@ -524,7 +524,7 @@ dePArrComp (LastStmt e' _ : quals) pa cea
 --
 --  <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
 --
-dePArrComp (ExprStmt b _ _ _ : qs) pa cea = do
+dePArrComp (BodyStmt b _ _ _ : qs) pa cea = do
     filterP <- dsDPHBuiltin filterPVar
     let ty = parrElemType cea
     (clam,_) <- deLambda ty pa b
@@ -601,7 +601,7 @@ dePArrComp (RecStmt   {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt"
 --    where
 --      {x_1, ..., x_n} = DV (qs)
 --
-dePArrParComp :: [ParStmtBlock Id Id] -> [Stmt Id] -> DsM CoreExpr
+dePArrParComp :: [ParStmtBlock Id Id] -> [ExprStmt Id] -> DsM CoreExpr
 dePArrParComp qss quals = do
     (pQss, ceQss) <- deParStmt qss
     dePArrComp quals pQss ceQss
@@ -663,15 +663,15 @@ Translation for monad comprehensions
 
 \begin{code}
 -- Entry point for monad comprehension desugaring
-dsMonadComp :: [LStmt Id] -> DsM CoreExpr
+dsMonadComp :: [ExprLStmt Id] -> DsM CoreExpr
 dsMonadComp stmts = dsMcStmts stmts
 
-dsMcStmts :: [LStmt Id] -> DsM CoreExpr
+dsMcStmts :: [ExprLStmt Id] -> DsM CoreExpr
 dsMcStmts []                    = panic "dsMcStmts"
 dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
 
 ---------------
-dsMcStmt :: Stmt Id -> [LStmt Id] -> DsM CoreExpr
+dsMcStmt :: ExprStmt Id -> [ExprLStmt Id] -> DsM CoreExpr
 
 dsMcStmt (LastStmt body ret_op) stmts
   = ASSERT( null stmts )
@@ -693,7 +693,7 @@ dsMcStmt (BindStmt pat rhs bind_op fail_op) stmts
 --
 --   [ .. | exp, stmts ]
 --
-dsMcStmt (ExprStmt exp then_exp guard_exp _) stmts
+dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts
   = do { exp'       <- dsLExpr exp
        ; guard_exp' <- dsExpr guard_exp
        ; then_exp'  <- dsExpr then_exp
@@ -801,7 +801,7 @@ dsMcBindStmt :: LPat Id
              -> CoreExpr        -- ^ the desugared rhs of the bind statement
              -> SyntaxExpr Id
              -> SyntaxExpr Id
-             -> [LStmt Id]
+             -> [ExprLStmt Id]
              -> DsM CoreExpr
 dsMcBindStmt pat rhs' bind_op fail_op stmts
   = do  { body     <- dsMcStmts stmts
@@ -836,7 +836,7 @@ dsMcBindStmt pat rhs' bind_op fail_op stmts
 -- returns the desugaring of
 --       [ (a,b,c) | quals ]
 
-dsInnerMonadComp :: [LStmt Id]
+dsInnerMonadComp :: [ExprLStmt Id]
                  -> [Id]        -- Return a tuple of these variables
                  -> HsExpr Id   -- The monomorphic "return" operator
                  -> DsM CoreExpr
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 15dab47ca1..d9e851ae62 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -922,7 +922,7 @@ repE (HsLet bs e)         = do { (ss,ds) <- repBinds bs
 
 -- FIXME: I haven't got the types here right yet
 repE e@(HsDo ctxt sts _)
- | case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False }
+ | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
  = do { (ss,zs) <- repLSts sts;
         e'      <- repDoE (nonEmptyCoreList zs);
         wrapGenSyms ss e' }
@@ -980,7 +980,7 @@ repE e 			 = notHandled "Expression form" (ppr e)
 -----------------------------------------------------------------------------
 -- Building representations of auxillary structures like Match, Clause, Stmt,
 
-repMatchTup ::  LMatch Name -> DsM (Core TH.MatchQ)
+repMatchTup ::  LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ)
 repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =
   do { ss1 <- mkGenSyms (collectPatBinders p)
      ; addBinds ss1 $ do {
@@ -992,7 +992,7 @@ repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =
      ; wrapGenSyms (ss1++ss2) match }}}
 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
 
-repClauseTup ::  LMatch Name -> DsM (Core TH.ClauseQ)
+repClauseTup ::  LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ)
 repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
   do { ss1 <- mkGenSyms (collectPatsBinders ps)
      ; addBinds ss1 $ do {
@@ -1003,23 +1003,23 @@ repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
      ; clause <- repClause ps1 gs ds
      ; wrapGenSyms (ss1++ss2) clause }}}
 
-repGuards ::  [LGRHS Name] ->  DsM (Core TH.BodyQ)
+repGuards ::  [LGRHS Name (LHsExpr Name)] ->  DsM (Core TH.BodyQ)
 repGuards [L _ (GRHS [] e)]
-  = do { a <- repLE e
-       ; repNormal a }
-repGuards alts
-  = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
-       ; body <- repGuarded (nonEmptyCoreList alts')
-       ; wrapGenSyms (concat binds) body }
-
-repLGRHS :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
-repLGRHS (L _ (GRHS [L _ (ExprStmt guard _ _ _)] rhs))
-  = do { guarded <- repLNormalGE guard rhs
+  = do {a <- repLE e; repNormal a }
+repGuards other
+  = do { zs <- mapM repLGRHS other
+       ; let (xs, ys) = unzip zs
+       ; gd <- repGuarded (nonEmptyCoreList ys)
+       ; wrapGenSyms (concat xs) gd }
+
+repLGRHS :: LGRHS Name (LHsExpr Name) -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
+repLGRHS (L _ (GRHS [L _ (BodyStmt e1 _ _ _)] e2))
+  = do { guarded <- repLNormalGE e1 e2
        ; return ([], guarded) }
-repLGRHS (L _ (GRHS stmts rhs))
-  = do { (gs, stmts') <- repLSts stmts
-       ; rhs'         <- addBinds gs $ repLE rhs
-       ; guarded      <- repPatGE (nonEmptyCoreList stmts') rhs'
+repLGRHS (L _ (GRHS ss rhs))
+  = do { (gs, ss') <- repLSts ss
+       ; rhs' <- addBinds gs $ repLE rhs
+       ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'
        ; return (gs, guarded) }
 
 repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
@@ -1055,10 +1055,10 @@ repFields (HsRecFields { rec_flds = flds })
 -- The helper function repSts computes the translation of each sub expression
 -- and a bunch of prefix bindings denoting the dynamic renaming.
 
-repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
+repLSts :: [LStmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])
 repLSts stmts = repSts (map unLoc stmts)
 
-repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
+repSts :: [Stmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])
 repSts (BindStmt p e _ _ : ss) =
    do { e2 <- repLE e
       ; ss1 <- mkGenSyms (collectPatBinders p)
@@ -1072,7 +1072,7 @@ repSts (LetStmt bs : ss) =
       ; z <- repLetSt ds
       ; (ss2,zs) <- addBinds ss1 (repSts ss)
       ; return (ss1++ss2, z : zs) }
-repSts (ExprStmt e _ _ _ : ss) =
+repSts (BodyStmt e _ _ _ : ss) =
    do { e2 <- repLE e
       ; z <- repNoBindSt e2
       ; (ss2,zs) <- repSts ss
@@ -1190,7 +1190,7 @@ rep_bind (L _ (AbsBinds {}))  = panic "rep_bind: AbsBinds"
 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
 -- (\ p1 .. pn -> exp) by causing an error.
 
-repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
+repLambda :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ExpQ)
 repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
  = do { let bndrs = collectPatsBinders ps ;
       ; ss  <- mkGenSyms bndrs
diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 0053484b13..0b14946793 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -39,8 +39,6 @@ module DsUtils (
 
         mkSelectorBinds,
 
-        dsSyntaxTable, lookupEvidence,
-
 	selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
         mkOptTickBox, mkBinaryTickBox
     ) where
@@ -48,7 +46,6 @@ module DsUtils (
 #include "HsVersions.h"
 
 import {-# SOURCE #-}	Match ( matchSimply )
-import {-# SOURCE #-}	DsExpr( dsExpr )
 
 import HsSyn
 import TcHsSyn
@@ -60,7 +57,6 @@ import CoreUtils
 import MkCore
 import MkId
 import Id
-import Name
 import Literal
 import TyCon
 import DataCon
@@ -75,7 +71,6 @@ import PrelNames
 import Outputable
 import SrcLoc
 import Util
-import ListSetOps
 import DynFlags
 import FastString
 
@@ -85,36 +80,6 @@ import Control.Monad    ( zipWithM )
 
 %************************************************************************
 %*									*
-		Rebindable syntax
-%*									*
-%************************************************************************
-
-\begin{code}
-dsSyntaxTable :: SyntaxTable Id 
-	       -> DsM ([CoreBind], 	-- Auxiliary bindings
-		       [(Name,Id)])	-- Maps the standard name to its value
-
-dsSyntaxTable rebound_ids = do
-    (binds_s, prs) <- mapAndUnzipM mk_bind rebound_ids
-    return (concat binds_s, prs)
-  where
-        -- The cheapo special case can happen when we 
-        -- make an intermediate HsDo when desugaring a RecStmt
-    mk_bind (std_name, HsVar id) = return ([], (std_name, id))
-    mk_bind (std_name, expr) = do
-           rhs <- dsExpr expr
-           id <- newSysLocalDs (exprType rhs)
-           return ([NonRec id rhs], (std_name, id))
-
-lookupEvidence :: [(Name, Id)] -> Name -> Id
-lookupEvidence prs std_name
-  = assocDefault (mk_panic std_name) prs std_name
-  where
-    mk_panic std_name = pprPanic "dsSyntaxTable" (ptext (sLit "Not found:") <+> ppr std_name)
-\end{code}
-
-%************************************************************************
-%*									*
 \subsection{ Selecting match variables}
 %*									*
 %************************************************************************
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index adb9099c14..c650e103a8 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -664,9 +664,9 @@ Call @match@ with all of this information!
 \end{enumerate}
 
 \begin{code}
-matchWrapper :: HsMatchContext Name	-- For shadowing warning messages
-	     -> MatchGroup Id		-- Matches being desugared
-	     -> DsM ([Id], CoreExpr) 	-- Results
+matchWrapper :: HsMatchContext Name             -- For shadowing warning messages
+	     -> MatchGroup Id (LHsExpr Id)      -- Matches being desugared
+	     -> DsM ([Id], CoreExpr)            -- Results
 \end{code}
 
  There is one small problem with the Lambda Patterns, when somebody
diff --git a/compiler/deSugar/Match.lhs-boot b/compiler/deSugar/Match.lhs-boot
index d10cda961e..66ecc8aba6 100644
--- a/compiler/deSugar/Match.lhs-boot
+++ b/compiler/deSugar/Match.lhs-boot
@@ -4,7 +4,7 @@ import Var      ( Id )
 import TcType   ( Type )
 import DsMonad  ( DsM, EquationInfo, MatchResult )
 import CoreSyn  ( CoreExpr )
-import HsSyn    ( LPat, HsMatchContext, MatchGroup )
+import HsSyn    ( LPat, HsMatchContext, MatchGroup, LHsExpr )
 import Name     ( Name )
 
 match   :: [Id]
@@ -14,7 +14,7 @@ match   :: [Id]
 
 matchWrapper
         :: HsMatchContext Name
-        -> MatchGroup Id
+        -> MatchGroup Id (LHsExpr Id)
         -> DsM ([Id], CoreExpr)
 
 matchSimply