Commit e3a4d6c3 authored by simonpj's avatar simonpj

[project @ 2005-08-10 11:05:06 by simonpj]

It turned out that doing all binding dependency analysis in the typechecker
meant that the renamer's unused-binding error messages got worse.  So now
I've put the first dep anal back into the renamer, while the second (which
is specific to type checking) remains in the type checker.

I've also made the pretty printer sort the decls back into source order
before printing them (except with -dppr-debug).

Fixes rn041.
parent 31578e22
......@@ -83,7 +83,7 @@ dsLocalBinds (HsIPBinds binds) body = dsIPBinds binds body
-------------------------
dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
dsValBinds (ValBindsOut binds) body = foldrDs ds_val_bind body binds
dsValBinds (ValBindsOut binds _) body = foldrDs ds_val_bind body binds
-------------------------
dsIPBinds (IPBinds ip_binds dict_binds) body
......@@ -680,7 +680,7 @@ dsMDo tbl stmts body result_ty
go (new_bind_stmt : let_stmt : stmts)
where
new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app
let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)]))
let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
-- Remove the later_ids that appear (without fancy coercions)
......
......@@ -20,9 +20,10 @@ import Name ( Name )
import NameSet ( NameSet, elemNameSet )
import BasicTypes ( IPName, RecFlag(..), Activation(..), Fixity )
import Outputable
import SrcLoc ( Located(..), unLoc )
import SrcLoc ( Located(..), SrcSpan, unLoc )
import Util ( sortLe )
import Var ( TyVar, DictId, Id )
import Bag ( Bag, emptyBag, isEmptyBag, bagToList, unionBags )
import Bag ( Bag, emptyBag, isEmptyBag, bagToList, unionBags, unionManyBags )
\end{code}
%************************************************************************
......@@ -45,9 +46,9 @@ data HsValBinds id -- Value bindings (not implicit parameters)
(LHsBinds id) [LSig id] -- Not dependency analysed
-- Recursive by default
| ValBindsOut -- After typechecking
| ValBindsOut -- After renaming
[(RecFlag, LHsBinds id)] -- Dependency analysed
[LSig Name]
type LHsBinds id = Bag (LHsBind id)
type DictBinds id = LHsBinds id -- Used for dictionary or method bindings
......@@ -115,17 +116,32 @@ instance OutputableBndr id => Outputable (HsLocalBinds id) where
instance OutputableBndr id => Outputable (HsValBinds id) where
ppr (ValBindsIn binds sigs)
= vcat [vcat (map ppr sigs),
vcat (map ppr (bagToList binds))
-- *not* pprLHsBinds because we don't want braces; 'let' and
-- 'where' include a list of HsBindGroups and we don't want
-- several groups of bindings each with braces around.
]
ppr (ValBindsOut sccs) = vcat (map ppr_scc sccs)
where
ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
pp_rec Recursive = ptext SLIT("rec")
pp_rec NonRecursive = ptext SLIT("nonrec")
= pprValBindsForUser binds sigs
ppr (ValBindsOut sccs sigs)
= getPprStyle $ \ sty ->
if debugStyle sty then -- Print with sccs showing
vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
else
pprValBindsForUser (unionManyBags (map snd sccs)) sigs
where
ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
pp_rec Recursive = ptext SLIT("rec")
pp_rec NonRecursive = ptext SLIT("nonrec")
-- *not* pprLHsBinds because we don't want braces; 'let' and
-- 'where' include a list of HsBindGroups and we don't want
-- several groups of bindings each with braces around.
-- Sort by location before printing
pprValBindsForUser binds sigs
= vcat (map snd (sort_by_loc decls))
where
decls :: [(SrcSpan, SDoc)]
decls = [(loc, ppr sig) | L loc sig <- sigs] ++
[(loc, ppr bind) | L loc bind <- bagToList binds]
sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls
pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc
pprLHsBinds binds
......@@ -142,12 +158,12 @@ isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds
isEmptyLocalBinds EmptyLocalBinds = True
isEmptyValBinds :: HsValBinds a -> Bool
isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs
isEmptyValBinds (ValBindsOut ds) = null ds
isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs
isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
emptyValBindsIn, emptyValBindsOut :: HsValBinds a
emptyValBindsIn = ValBindsIn emptyBag []
emptyValBindsOut = ValBindsOut []
emptyValBindsOut = ValBindsOut [] []
emptyLHsBinds :: LHsBinds id
emptyLHsBinds = emptyBag
......@@ -159,8 +175,8 @@ isEmptyLHsBinds = isEmptyBag
plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
= ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
plusHsValBinds (ValBindsOut ds1) (ValBindsOut ds2)
= ValBindsOut (ds1 ++ ds2)
plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
= ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
\end{code}
What AbsBinds means
......
......@@ -100,7 +100,7 @@ mkHsDictLet binds expr
| isEmptyLHsBinds binds = expr
| otherwise = L (getLoc expr) (HsLet (HsValBinds val_binds) expr)
where
val_binds = ValBindsOut [(Recursive, binds)]
val_binds = ValBindsOut [(Recursive, binds)] []
mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
-- Used for constructing dictinoary terms etc, so no locations
......@@ -279,8 +279,8 @@ collectLocalBinders (HsIPBinds _) = []
collectLocalBinders EmptyLocalBinds = []
collectHsValBinders :: HsValBinds name -> [Located name]
collectHsValBinders (ValBindsIn binds sigs) = collectHsBindLocatedBinders binds
collectHsValBinders (ValBindsOut binds) = foldr collect_one [] binds
collectHsValBinders (ValBindsIn binds sigs) = collectHsBindLocatedBinders binds
collectHsValBinders (ValBindsOut binds sigs) = foldr collect_one [] binds
where
collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds
......@@ -312,8 +312,8 @@ collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
Get all the pattern type signatures out of a bunch of bindings
\begin{code}
collectSigTysFromHsBinds :: [LHsBind name] -> [LHsType name]
collectSigTysFromHsBinds binds = concat (map collectSigTysFromHsBind binds)
collectSigTysFromHsBinds :: LHsBinds name -> [LHsType name]
collectSigTysFromHsBinds binds = concatMap collectSigTysFromHsBind (bagToList binds)
collectSigTysFromHsBind :: LHsBind name -> [LHsType name]
collectSigTysFromHsBind bind
......
......@@ -21,7 +21,6 @@ module RnBinds (
import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
import HsSyn
import HsBinds ( hsSigDoc, eqHsSig )
import RdrHsSyn
import RnHsSyn
import TcRnMonad
......@@ -41,9 +40,11 @@ import PrelNames ( isUnboundName )
import RdrName ( RdrName, rdrNameOcc )
import SrcLoc ( mkSrcSpan, Located(..), unLoc )
import ListSetOps ( findDupsEq )
import BasicTypes ( RecFlag(..) )
import Digraph ( SCC(..), stronglyConnComp )
import Bag
import Outputable
import Maybes ( orElse )
import Maybes ( orElse, fromJust, isJust )
import Monad ( foldM )
\end{code}
......@@ -177,7 +178,7 @@ rnTopBindsBoot (ValBindsIn mbinds sigs)
rnTopBindsSrc :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses)
rnTopBindsSrc binds@(ValBindsIn mbinds _)
= bindPatSigTyVars (collectSigTysFromHsBinds (bagToList mbinds)) $ \ _ ->
= bindPatSigTyVars (collectSigTysFromHsBinds mbinds) $ \ _ ->
-- Hmm; by analogy with Ids, this doesn't look right
-- Top-level bound type vars should really scope over
-- everything, but we only scope them over the other bindings
......@@ -185,7 +186,7 @@ rnTopBindsSrc binds@(ValBindsIn mbinds _)
do { (binds', dus) <- rnValBinds noTrim binds
-- Warn about missing signatures,
; let { ValBindsIn _ sigs' = binds'
; let { ValBindsOut _ sigs' = binds'
; ty_sig_vars = mkNameSet [ unLoc n | L _ (Sig n _) <- sigs']
; un_sigd_bndrs = duDefs dus `minusNameSet` ty_sig_vars }
......@@ -253,7 +254,7 @@ rnValBindsAndThen binds@(ValBindsIn mbinds sigs) thing_inside
-- current scope, inventing new names for the new binders
-- This also checks that the names form a set
bindLocatedLocalsRn doc mbinders_w_srclocs $ \ bndrs ->
bindPatSigTyVarsFV (collectSigTysFromHsBinds (bagToList mbinds)) $
bindPatSigTyVarsFV (collectSigTysFromHsBinds mbinds) $
-- Then install local fixity declarations
-- Notice that they scope over thing_inside too
......@@ -267,12 +268,7 @@ rnValBindsAndThen binds@(ValBindsIn mbinds sigs) thing_inside
-- Final error checking
let
all_uses = duUses bind_dus `plusFV` result_fvs
unused_bndrs = [ b | b <- bndrs, not (b `elemNameSet` all_uses)]
in
warnUnusedLocalBinds unused_bndrs `thenM_`
returnM (result, delListFromNameSet all_uses bndrs)
all_uses = duUses bind_dus `plusFV` result_fvs
-- duUses: It's important to return all the uses, not the 'real uses'
-- used for warning about unused bindings. Otherwise consider:
-- x = 3
......@@ -280,6 +276,12 @@ rnValBindsAndThen binds@(ValBindsIn mbinds sigs) thing_inside
-- If we don't "see" the dependency of 'y' on 'x', we may put the
-- bindings in the wrong order, and the type checker will complain
-- that x isn't in scope
unused_bndrs = [ b | b <- bndrs, not (b `elemNameSet` all_uses)]
in
warnUnusedLocalBinds unused_bndrs `thenM_`
returnM (result, delListFromNameSet all_uses bndrs)
where
mbinders_w_srclocs = collectHsBindLocatedBinders mbinds
doc = text "In the binding group for:"
......@@ -294,21 +296,46 @@ rnValBinds :: (FreeVars -> FreeVars)
rnValBinds trim (ValBindsIn mbinds sigs)
= do { sigs' <- rename_sigs sigs
; let { rn_bind = wrapLocFstM (rnBind sig_fn trim)
; sig_fn = mkSigTvFn sigs' }
; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds
; (mbinds', du_bag) <- mapAndUnzipBagM rn_bind mbinds
; let (binds', bind_dus) = depAnalBinds binds_w_dus
; let defs, uses :: NameSet
(defs, uses) = foldrBag plus (emptyNameSet, emptyNameSet) du_bag
plus (ds1,us1) (ds2,us2) = (ds1 `unionNameSets` ds2,
us1 `unionNameSets` us2)
; check_sigs (okBindSig (duDefs bind_dus)) sigs'
; check_sigs (okBindSig defs) sigs'
; return (ValBindsOut binds' sigs',
usesOnly (hsSigsFVs sigs') `plusDU` bind_dus) }
---------------------
depAnalBinds :: Bag (LHsBind Name, [Name], Uses)
-> ([(RecFlag, LHsBinds Name)], DefUses)
-- Dependency analysis; this is important so that unused-binding
-- reporting is accurate
depAnalBinds binds_w_dus
= (map get_binds sccs, map get_du sccs)
where
sccs = stronglyConnComp edges
keyd_nodes = bagToList binds_w_dus `zip` [0::Int ..]
edges = [ (node, key, [fromJust mb_key | n <- nameSetToList uses,
let mb_key = lookupNameEnv key_map n,
isJust mb_key ])
| (node@(_,_,uses), key) <- keyd_nodes ]
key_map :: NameEnv Int -- Which binding it comes from
key_map = mkNameEnv [(bndr, key) | ((_, bndrs, _), key) <- keyd_nodes
, bndr <- bndrs ]
get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind)
get_binds (CyclicSCC binds_w_dus) = (Recursive, listToBag [b | (b,d,u) <- binds_w_dus])
get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses)
get_du (CyclicSCC binds_w_dus) = (Just defs, uses)
where
defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs]
uses = unionManyNameSets [u | (_,_,u) <- binds_w_dus]
; traceRn (text "rnValBind" <+> (ppr defs $$ ppr uses))
; return (ValBindsIn mbinds' sigs',
[(Just defs, uses `plusFV` hsSigsFVs sigs')]) }
---------------------
-- Bind the top-level forall'd type variables in the sigs.
......@@ -348,31 +375,30 @@ trimWith bndrs = intersectNameSet (mkNameSet bndrs)
---------------------
rnBind :: (Name -> [Name]) -- Signature tyvar function
-> (FreeVars -> FreeVars) -- Trimming function for rhs free vars
-> HsBind RdrName
-> RnM (HsBind Name, (Defs, Uses))
rnBind sig_fn trim (PatBind pat grhss ty _)
= do { (pat', pat_fvs) <- rnLPat pat
-> LHsBind RdrName
-> RnM (LHsBind Name, [Name], Uses)
rnBind sig_fn trim (L loc (PatBind pat grhss ty _))
= setSrcSpan loc $
do { (pat', pat_fvs) <- rnLPat pat
; let bndrs = collectPatBinders pat'
; (grhss', fvs) <- bindSigTyVarsFV (concatMap sig_fn bndrs) $
rnGRHSs PatBindRhs grhss
; return (PatBind pat' grhss' ty (trim fvs),
(mkNameSet bndrs, pat_fvs `plusFV` fvs)) }
; return (L loc (PatBind pat' grhss' ty (trim fvs)), bndrs, pat_fvs `plusFV` fvs) }
rnBind sig_fn trim (FunBind name inf matches _)
= do { new_name <- lookupLocatedBndrRn name
; let { plain_name = unLoc new_name
; bndrs = unitNameSet plain_name }
rnBind sig_fn trim (L loc (FunBind name inf matches _))
= setSrcSpan loc $
do { new_name <- lookupLocatedBndrRn name
; let plain_name = unLoc new_name
; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
rnMatchGroup (FunRhs plain_name) matches
; checkPrecMatch inf plain_name matches'
; return (FunBind new_name inf matches' (trim fvs),
(bndrs, fvs))
; return (L loc (FunBind new_name inf matches' (trim fvs)), [plain_name], fvs)
}
\end{code}
......
This diff is collapsed.
......@@ -60,6 +60,7 @@ import ListSetOps ( equivClassesByUniq, minusList )
import SrcLoc ( Located(..), srcSpanStart, unLoc, noLoc )
import Maybes ( seqMaybe, isJust, mapCatMaybes )
import List ( partition )
import BasicTypes ( RecFlag(..) )
import Bag
import FastString
\end{code}
......@@ -356,7 +357,7 @@ tcMethodBind inst_tyvars inst_theta avail_insts prag_fn
tcExtendTyVarEnv inst_tyvars (
addErrCtxt (methodCtxt sel_id) $
getLIE $
tcMonoBinds [meth_bind] lookup_sig True
tcMonoBinds [meth_bind] lookup_sig Recursive
) `thenM` \ ((meth_bind, mono_bind_infos), meth_lie) ->
-- Now do context reduction. We simplify wrt both the local tyvars
......
......@@ -278,9 +278,9 @@ zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds))
zonkValBinds :: ZonkEnv -> HsValBinds TcId -> TcM (ZonkEnv, HsValBinds Id)
zonkValBinds env bs@(ValBindsIn _ _)
= panic "zonkValBinds" -- Not in typechecker output
zonkValBinds env (ValBindsOut binds)
zonkValBinds env (ValBindsOut binds sigs)
= do { (env1, new_binds) <- go env binds
; return (env1, ValBindsOut new_binds) }
; return (env1, ValBindsOut new_binds sigs) }
where
go env [] = return (env, [])
go env ((r,b):bs) = do { (env1, b') <- zonkRecMonoBinds env b
......
......@@ -55,7 +55,7 @@ import NameEnv
import PrelNames ( genUnitTyConName )
import TysWiredIn ( mkListTy, listTyCon, mkPArrTy, parrTyCon, tupleTyCon )
import Bag ( bagToList )
import BasicTypes ( Boxity(..) )
import BasicTypes ( Boxity(..), RecFlag )
import SrcLoc ( Located(..), unLoc, noLoc, srcSpanStart )
import UniqSupply ( uniqsFromSupply )
import Outputable
......@@ -762,11 +762,11 @@ tcHsPatSigType ctxt hs_ty
; return (tyvars, sig_ty) }
}
tcAddLetBoundTyVars :: LHsBinds Name -> TcM a -> TcM a
tcAddLetBoundTyVars :: [(RecFlag,LHsBinds Name)] -> TcM a -> TcM a
-- Turgid funciton, used for type variables bound by the patterns of a let binding
tcAddLetBoundTyVars binds thing_inside
= go (collectSigTysFromHsBinds (bagToList binds)) thing_inside
= go (concatMap (collectSigTysFromHsBinds . snd) binds) thing_inside
where
go [] thing_inside = thing_inside
go (hs_ty:hs_tys) thing_inside
......
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