Commit 49bb4580 authored by simonpj's avatar simonpj
Browse files

[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
parent fbdd694d
......@@ -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}
......
......@@ -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}
......
......@@ -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 $
......
......@@ -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.
......
......@@ -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
......
......@@ -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 )
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment