[project @ 1999-12-06 15:38:05 by simonpj]

Some minor tidying-up that should remove an occurrence
of an empty Let Rec that confused CoreLint.dumpLoc.

Simon

diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index c09ccc3..822b4a2 100644 (file)
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -60,6 +60,10 @@ nullBinds :: HsBinds id pat -> Bool
 nullBinds EmptyBinds           = True
 nullBinds (ThenBinds b1 b2)    = nullBinds b1 && nullBinds b2
 nullBinds (MonoBind b _ _)     = nullMonoBinds b
+
+mkMonoBind :: MonoBinds id pat -> [Sig id] -> RecFlag -> HsBinds id pat
+mkMonoBind EmptyMonoBinds _ _ = EmptyBinds
+mkMonoBind mbinds sigs is_rec = MonoBind mbinds sigs is_rec
 \end{code}
 
 \begin{code}
@@ -151,10 +155,11 @@ So the desugarer tries to do a better job:
                                      in (fm,gm)
 
 \begin{code}
-nullMonoBinds :: MonoBinds id pat -> Bool
+-- We keep the invariant that a MonoBinds is only empty 
+-- if it is exactly EmptyMonoBinds
 
+nullMonoBinds :: MonoBinds id pat -> Bool
 nullMonoBinds EmptyMonoBinds        = True
-nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
 nullMonoBinds other_monobind        = False
 
 andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
@@ -163,7 +168,17 @@ andMonoBinds mb EmptyMonoBinds = mb
 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
 
 andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
-andMonoBindList binds = foldr AndMonoBinds EmptyMonoBinds binds
+andMonoBindList binds
+  = loop1 binds
+  where
+    loop1 [] = EmptyMonoBinds
+    loop1 (EmptyMonoBinds : binds) = loop1 binds
+    loop1 (b:bs) = loop2 b bs
+
+       -- acc is non-empty
+    loop2 acc [] = acc
+    loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
+    loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
 \end{code}
 
 \begin{code}

diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index 128c812..ef2153f 100644 (file)
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -453,6 +453,10 @@ data Stmt id pat
                SrcLoc
 
   | ReturnStmt (HsExpr id pat)         -- List comps only, at the end
+
+consLetStmt :: HsBinds id pat -> [Stmt id pat] -> [Stmt id pat]
+consLetStmt EmptyBinds stmts = stmts
+consLetStmt binds      stmts = LetStmt binds : stmts
 \end{code}
 
 \begin{code}

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 0a6b2c0..5f6096c 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -9,7 +9,8 @@ module TcExpr ( tcApp, tcExpr, tcPolyExpr, tcId ) where
 #include "HsVersions.h"
 
 import HsSyn           ( HsExpr(..), HsLit(..), ArithSeqInfo(..), 
-                         HsBinds(..), Stmt(..), StmtCtxt(..)
+                         HsBinds(..), Stmt(..), StmtCtxt(..),
+                         mkMonoBind
                        )
 import RnHsSyn         ( RenamedHsExpr, RenamedRecordBinds )
 import TcHsSyn         ( TcExpr, TcRecordBinds,
@@ -395,7 +396,7 @@ tcMonoExpr (HsLet binds expr) res_ty
   where
     tc_expr = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
              returnTc (expr', lie)
-    combiner is_rec bind expr = HsLet (MonoBind bind [] is_rec) expr
+    combiner is_rec bind expr = HsLet (mkMonoBind bind [] is_rec) expr
 
 tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty
   = tcAddSrcLoc src_loc                        $

diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index ebb0144..f3b7a7f 100644 (file)
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -29,7 +29,7 @@ module TcGenDeriv (
 import HsSyn           ( InPat(..), HsExpr(..), MonoBinds(..),
                          Match(..), GRHSs(..), Stmt(..), HsLit(..),
                          HsBinds(..), StmtCtxt(..), HsType(..),
-                         unguardedRHS, mkSimpleMatch
+                         unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList
                        )
 import RdrHsSyn                ( mkOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
 import RdrName         ( RdrName, mkSrcUnqual )
@@ -1170,10 +1170,7 @@ mk_easy_FunMonoBind loc fun pats binds expr
   = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
 
 mk_easy_Match loc pats binds expr
-  = mk_match loc pats expr (mkbind binds)
-  where
-    mkbind [] = EmptyBinds
-    mkbind bs = MonoBind (foldr1 AndMonoBinds bs) [] Recursive
+  = mk_match loc pats expr (mkMonoBind (andMonoBindList binds) [] Recursive)
        -- The renamer expects everything in its input to be a
        -- "recursive" MonoBinds, and it is its job to sort things out
        -- from there.

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 98c4a90..e3b11ca 100644 (file)
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -235,7 +235,7 @@ zonkBinds binds
            fixNF_Tc (\ ~(_, new_ids) ->
                tcExtendGlobalValEnv (bagToList new_ids)        $
                zonkMonoBinds bind                              `thenNF_Tc` \ (new_bind, new_ids) ->
-               thing_inside (MonoBind new_bind [] is_rec)      `thenNF_Tc` \ stuff ->
+               thing_inside (mkMonoBind new_bind [] is_rec)    `thenNF_Tc` \ stuff ->
                returnNF_Tc (stuff, new_ids)
            )                                                   `thenNF_Tc` \ (stuff, _) ->
           returnNF_Tc stuff

diff --git a/ghc/compiler/typecheck/TcImprove.lhs b/ghc/compiler/typecheck/TcImprove.lhs
index 0250a30..a81e874 100644 (file)
--- a/ghc/compiler/typecheck/TcImprove.lhs
+++ b/ghc/compiler/typecheck/TcImprove.lhs
@@ -3,6 +3,9 @@ module TcImprove ( tcImprove ) where
 
 #include "HsVersions.h"
 
+import InstEnv         ( InstEnv )             -- Reqd for 4.02; InstEnv is a synonym, and
+                                               -- 4.02 doesn't "see" it soon enough
+
 import Type            ( tyVarsOfTypes )
 import Class           ( classInstEnv, classExtraBigSig )
 import Unify           ( matchTys )

diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs
index 8a27ea5..484aa3c 100644 (file)
--- a/ghc/compiler/typecheck/TcMatches.lhs
+++ b/ghc/compiler/typecheck/TcMatches.lhs
@@ -12,7 +12,8 @@ import {-# SOURCE #-} TcExpr( tcExpr )
 
 import HsSyn           ( HsBinds(..), Match(..), GRHSs(..), GRHS(..),
                          MonoBinds(..), StmtCtxt(..), Stmt(..),
-                         pprMatch, getMatchLoc
+                         pprMatch, getMatchLoc, consLetStmt,
+                         mkMonoBind
                        )
 import RnHsSyn         ( RenamedMatch, RenamedGRHSs, RenamedStmt )
 import TcHsSyn         ( TcMatch, TcGRHSs, TcStmt )
@@ -212,7 +213,7 @@ tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
        -- glue_on just avoids stupid dross
 glue_on _ EmptyMonoBinds grhss = grhss         -- The common case
 glue_on is_rec mbinds (GRHSs grhss binds ty)
-  = GRHSs grhss (MonoBind mbinds [] is_rec `ThenBinds` binds) ty
+  = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
 
 tcGRHSs :: RenamedGRHSs
        -> TcType -> StmtCtxt
@@ -341,8 +342,7 @@ tcStmts do_or_lc m (stmt@(BindStmt pat exp src_loc) : stmts) elt_ty
        lie_avail stmts_lie                     `thenTc` \ (final_lie, dict_binds) ->
 
     returnTc (BindStmt pat' exp' src_loc : 
-               LetStmt (MonoBind dict_binds [] Recursive) :
-                 stmts',
+               consLetStmt (mkMonoBind dict_binds [] Recursive) stmts',
              lie_req `plusLIE` final_lie)
 
 tcStmts do_or_lc m (LetStmt binds : stmts) elt_ty
@@ -351,7 +351,7 @@ tcStmts do_or_lc m (LetStmt binds : stmts) elt_ty
        binds
        (tcStmts do_or_lc m stmts elt_ty)
      where
-       combine is_rec binds' stmts' = LetStmt (MonoBind binds' [] is_rec) : stmts'
+       combine is_rec binds' stmts' = consLetStmt (mkMonoBind binds' [] is_rec) stmts'
 
 
 isDoStmt DoStmt = True