From 49bb45807fe94e432224601483cf3577b3f3fb7b Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 6 Dec 1999 15:38:10 +0000 Subject: [PATCH] [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 --- ghc/compiler/hsSyn/HsBinds.lhs | 21 ++++++++++++++++++--- ghc/compiler/hsSyn/HsExpr.lhs | 4 ++++ ghc/compiler/typecheck/TcExpr.lhs | 5 +++-- ghc/compiler/typecheck/TcGenDeriv.lhs | 7 ++----- ghc/compiler/typecheck/TcHsSyn.lhs | 2 +- ghc/compiler/typecheck/TcImprove.lhs | 3 +++ ghc/compiler/typecheck/TcMatches.lhs | 10 +++++----- 7 files changed, 36 insertions(+), 16 deletions(-) diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index c09ccc3..822b4a2 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 -- 1.7.10.4