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}
......
......@@ -20,7 +20,7 @@ import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, LHsBind, Sig(..),
LSig, Match(..), IPBind(..), Prag(..),
HsType(..), LHsType, HsExplicitForAll(..), hsLTyVarNames,
isVanillaLSig, sigName, placeHolderNames, isPragLSig,
LPat, GRHSs, MatchGroup(..), isEmptyLHsBinds,
LPat, GRHSs, MatchGroup(..), isEmptyLHsBinds, pprLHsBinds,
collectHsBindBinders, collectPatBinders, pprPatBind
)
import TcHsSyn ( zonkId, (<$>) )
......@@ -59,8 +59,8 @@ import VarSet
import SrcLoc ( Located(..), unLoc, getLoc )
import Bag
import ErrUtils ( Message )
import Digraph ( SCC(..), stronglyConnComp, flattenSCC )
import Maybes ( fromJust, isJust, orElse, catMaybes )
import Digraph ( SCC(..), stronglyConnComp )
import Maybes ( fromJust, isJust, isNothing, orElse, catMaybes )
import Util ( singleton )
import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
RecFlag(..), isNonRec )
......@@ -105,7 +105,7 @@ tcTopBinds :: HsValBinds Name -> TcM (LHsBinds TcId, TcLclEnv)
-- want. The bit we care about is the local bindings
-- and the free type variables thereof
tcTopBinds binds
= do { (ValBindsOut prs, env) <- tcValBinds TopLevel binds getLclEnv
= do { (ValBindsOut prs _, env) <- tcValBinds TopLevel binds getLclEnv
; return (foldr (unionBags . snd) emptyBag prs, env) }
-- The top level bindings are flattened into a giant
-- implicitly-mutually-recursive LHsBinds
......@@ -156,40 +156,12 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
tcCheckRho expr ty `thenM` \ expr' ->
returnM (ip_inst, (IPBind ip' expr'))
------------------------
mkEdges :: (Name -> Bool) -> [LHsBind Name]
-> [(LHsBind Name, BKey, [BKey])]
type BKey = Int -- Just number off the bindings
mkEdges exclude_fn binds
= [ (bind, key, [fromJust mb_key | n <- nameSetToList (bind_fvs (unLoc bind)),
let mb_key = lookupNameEnv key_map n,
isJust mb_key,
not (exclude_fn n) ])
| (bind, key) <- keyd_binds
]
where
keyd_binds = binds `zip` [0::BKey ..]
bind_fvs (FunBind _ _ _ fvs) = fvs
bind_fvs (PatBind _ _ _ fvs) = fvs
bind_fvs bind = pprPanic "mkEdges" (ppr bind)
key_map :: NameEnv BKey -- Which binding it comes from
key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
, bndr <- bindersOfHsBind bind ]
bindersOfHsBind :: HsBind Name -> [Name]
bindersOfHsBind (PatBind pat _ _ _) = collectPatBinders pat
bindersOfHsBind (FunBind (L _ f) _ _ _) = [f]
------------------------
tcValBinds :: TopLevelFlag
-> HsValBinds Name -> TcM thing
-> TcM (HsValBinds TcId, thing)
tcValBinds top_lvl (ValBindsIn binds sigs) thing_inside
tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
= tcAddLetBoundTyVars binds $
-- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE
-- Notice that they scope over
......@@ -199,11 +171,7 @@ tcValBinds top_lvl (ValBindsIn binds sigs) thing_inside
do { -- Typecheck the signature
tc_ty_sigs <- recoverM (returnM []) (tcTySigs sigs)
-- Do the basic strongly-connected component thing
; let { sccs :: [SCC (LHsBind Name)]
; sccs = stronglyConnComp (mkEdges (\n -> False) (bagToList binds))
; prag_fn = mkPragFun sigs
; let { prag_fn = mkPragFun sigs
; sig_fn = lookupSig tc_ty_sigs
; sig_ids = map sig_id tc_ty_sigs }
......@@ -211,13 +179,13 @@ tcValBinds top_lvl (ValBindsIn binds sigs) thing_inside
-- the Ids declared with type signatures
; (binds', thing) <- tcExtendIdEnv sig_ids $
tc_val_binds top_lvl sig_fn prag_fn
sccs thing_inside
binds thing_inside
; return (ValBindsOut binds', thing) }
; return (ValBindsOut binds' sigs, thing) }
------------------------
tc_val_binds :: TopLevelFlag -> TcSigFun -> TcPragFun
-> [SCC (LHsBind Name)] -> TcM thing
-> [(RecFlag, LHsBinds Name)] -> TcM thing
-> TcM ([(RecFlag, LHsBinds TcId)], thing)
-- Typecheck a whole lot of value bindings,
-- one strongly-connected component at a time
......@@ -226,62 +194,94 @@ tc_val_binds top_lvl sig_fn prag_fn [] thing_inside
= do { thing <- thing_inside
; return ([], thing) }
tc_val_binds top_lvl sig_fn prag_fn (scc : sccs) thing_inside
tc_val_binds top_lvl sig_fn prag_fn (group : groups) thing_inside
= do { (group', (groups', thing))
<- tc_group top_lvl sig_fn prag_fn scc $
tc_val_binds top_lvl sig_fn prag_fn sccs thing_inside
<- tc_group top_lvl sig_fn prag_fn group $
tc_val_binds top_lvl sig_fn prag_fn groups thing_inside
; return (group' ++ groups', thing) }
------------------------
tc_group :: TopLevelFlag -> TcSigFun -> TcPragFun
-> SCC (LHsBind Name) -> TcM thing
-> (RecFlag, LHsBinds Name) -> TcM thing
-> TcM ([(RecFlag, LHsBinds TcId)], thing)
-- Typecheck one strongly-connected component of the original program.
-- We get a list of groups back, because there may
-- be specialisations etc as well
tc_group top_lvl sig_fn prag_fn scc@(AcyclicSCC bind) thing_inside
tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
= -- A single non-recursive binding
-- We want to keep non-recursive things non-recursive
-- so that we desugar unlifted bindings correctly
do { (binds, thing) <- tcPolyBinds top_lvl NonRecursive
sig_fn prag_fn scc thing_inside
do { (binds, thing) <- tcPolyBinds top_lvl NonRecursive NonRecursive
sig_fn prag_fn binds thing_inside
; return ([(NonRecursive, b) | b <- binds], thing) }
tc_group top_lvl sig_fn prag_fn scc@(CyclicSCC binds) thing_inside
tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
= -- A recursive strongly-connected component
-- To maximise polymorphism (with -fglasgow-exts), we do a new
-- strongly-connected component analysis, this time omitting
-- any references to variables with type signatures.
--
-- Then we bring into scope all the variables with type signatures
do { traceTc (text "tc_group rec" <+> vcat [ppr b $$ text "--and--" | b <- binds])
do { traceTc (text "tc_group rec" <+> pprLHsBinds binds)
; gla_exts <- doptM Opt_GlasgowExts
; (binds,thing) <- if gla_exts
then go new_sccs
else go1 scc thing_inside
else tc_binds Recursive binds thing_inside
; return ([(Recursive, unionManyBags binds)], thing) }
-- Rec them all together
where
new_sccs :: [SCC (LHsBind Name)]
new_sccs = stronglyConnComp (mkEdges has_sig binds)
new_sccs = stronglyConnComp (mkEdges sig_fn binds)
-- go :: SCC (LHsBind Name) -> TcM ([LHsBind TcId], thing)
go (scc:sccs) = do { (binds1, (binds2, thing)) <- go1 scc (go sccs)
; return (binds1 ++ binds2, thing) }
go [] = do { thing <- thing_inside; return ([], thing) }
go1 scc thing_inside = tcPolyBinds top_lvl Recursive
sig_fn prag_fn scc thing_inside
go1 (AcyclicSCC bind) = tc_binds NonRecursive (unitBag bind)
go1 (CyclicSCC binds) = tc_binds Recursive (listToBag binds)
has_sig :: Name -> Bool
has_sig n = isJust (sig_fn n)
tc_binds rec_tc binds = tcPolyBinds top_lvl Recursive rec_tc sig_fn prag_fn binds
------------------------
mkEdges :: TcSigFun -> LHsBinds Name
-> [(LHsBind Name, BKey, [BKey])]
type BKey = Int -- Just number off the bindings
mkEdges sig_fn binds
= [ (bind, key, [fromJust mb_key | n <- nameSetToList (bind_fvs (unLoc bind)),
let mb_key = lookupNameEnv key_map n,
isJust mb_key,
no_sig n ])
| (bind, key) <- keyd_binds
]
where
no_sig :: Name -> Bool
no_sig n = isNothing (sig_fn n)
keyd_binds = bagToList binds `zip` [0::BKey ..]
bind_fvs (FunBind _ _ _ fvs) = fvs
bind_fvs (PatBind _ _ _ fvs) = fvs
bind_fvs bind = pprPanic "mkEdges" (ppr bind)
key_map :: NameEnv BKey -- Which binding it comes from
key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
, bndr <- bindersOfHsBind bind ]
bindersOfHsBind :: HsBind Name -> [Name]
bindersOfHsBind (PatBind pat _ _ _) = collectPatBinders pat
bindersOfHsBind (FunBind (L _ f) _ _ _) = [f]
------------------------
tcPolyBinds :: TopLevelFlag -> RecFlag
tcPolyBinds :: TopLevelFlag
-> RecFlag -- Whether the group is really recursive
-> RecFlag -- Whether it's recursive for typechecking purposes
-> TcSigFun -> TcPragFun
-> SCC (LHsBind Name)
-> LHsBinds Name
-> TcM thing
-> TcM ([LHsBinds TcId], thing)
......@@ -295,14 +295,14 @@ tcPolyBinds :: TopLevelFlag -> RecFlag
-- in which case the dependency order of the resulting bindings is
-- important.
tcPolyBinds top_lvl is_rec sig_fn prag_fn scc thing_inside
tcPolyBinds top_lvl rec_group rec_tc sig_fn prag_fn scc thing_inside
= -- NB: polymorphic recursion means that a function
-- may use an instance of itself, we must look at the LIE arising
-- from the function's own right hand side. Hence the getLIE
-- encloses the tc_poly_binds.
do { traceTc (text "tcPolyBinds" <+> ppr scc)
-- encloses the tc_poly_binds.
do { traceTc (text "tcPolyBinds" <+> ppr scc)
; ((binds1, poly_ids, thing), lie) <- getLIE $
do { (binds1, poly_ids) <- tc_poly_binds top_lvl is_rec
do { (binds1, poly_ids) <- tc_poly_binds top_lvl rec_group rec_tc
sig_fn prag_fn scc
; thing <- tcExtendIdEnv poly_ids thing_inside
; return (binds1, poly_ids, thing) }
......@@ -320,20 +320,20 @@ tcPolyBinds top_lvl is_rec sig_fn prag_fn scc thing_inside
; return (binds1 ++ [lie_binds], thing) }}
------------------------
tc_poly_binds :: TopLevelFlag -> RecFlag
tc_poly_binds :: TopLevelFlag -- See comments on tcPolyBinds
-> RecFlag -> RecFlag
-> TcSigFun -> TcPragFun
-> SCC (LHsBind Name)
-> LHsBinds Name
-> TcM ([LHsBinds TcId], [TcId])
-- Typechecks the bindings themselves
-- Knows nothing about the scope of the bindings
tc_poly_binds top_lvl is_rec sig_fn prag_fn bind_scc
tc_poly_binds top_lvl rec_group rec_tc sig_fn prag_fn binds
= let
non_rec = case bind_scc of { AcyclicSCC _ -> True; CyclicSCC _ -> False }
binds = flattenSCC bind_scc
binder_names = collectHsBindBinders (listToBag binds)
binder_names = collectHsBindBinders binds
bind_list = bagToList binds
loc = getLoc (head binds)
loc = getLoc (head bind_list)
-- TODO: location a bit awkward, but the mbinds have been
-- dependency analysed and may no longer be adjacent
in
......@@ -346,7 +346,7 @@ tc_poly_binds top_lvl is_rec sig_fn prag_fn bind_scc
-- TYPECHECK THE BINDINGS
; ((binds', mono_bind_infos), lie_req)
<- getLIE (tcMonoBinds binds sig_fn non_rec)
<- getLIE (tcMonoBinds bind_list sig_fn rec_tc)
-- CHECK FOR UNLIFTED BINDINGS
-- These must be non-recursive etc, and are not generalised
......@@ -354,7 +354,7 @@ tc_poly_binds top_lvl is_rec sig_fn prag_fn bind_scc
; zonked_mono_tys <- zonkTcTypes (map getMonoType mono_bind_infos)
; if any isUnLiftedType zonked_mono_tys then
do { -- Unlifted bindings
checkUnliftedBinds top_lvl is_rec binds' mono_bind_infos
checkUnliftedBinds top_lvl rec_group binds' mono_bind_infos
; extendLIEs lie_req
; let exports = zipWith mk_export mono_bind_infos zonked_mono_tys
mk_export (name, Nothing, mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id, [])
......@@ -365,7 +365,7 @@ tc_poly_binds top_lvl is_rec sig_fn prag_fn bind_scc
[poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked
else do -- The normal lifted case: GENERALISE
{ is_unres <- isUnRestrictedGroup binds sig_fn
{ is_unres <- isUnRestrictedGroup bind_list sig_fn
; (tyvars_to_gen, dict_binds, dict_ids)
<- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $
generalise top_lvl is_unres mono_bind_infos lie_req
......@@ -465,10 +465,10 @@ recoveryCode binder_names sig_fn
checkUnliftedBinds :: TopLevelFlag -> RecFlag
-> LHsBinds TcId -> [MonoBindInfo] -> TcM ()
checkUnliftedBinds top_lvl is_rec mbind infos
checkUnliftedBinds top_lvl rec_group mbind infos
= do { checkTc (isNotTopLevel top_lvl)
(unliftedBindErr "Top-level" mbind)
; checkTc (isNonRec is_rec)
; checkTc (isNonRec rec_group)
(unliftedBindErr "Recursive" mbind)
; checkTc (isSingletonBag mbind)
(unliftedBindErr "Multiple" mbind)
......@@ -492,13 +492,14 @@ The signatures have been dealt with already.
\begin{code}
tcMonoBinds :: [LHsBind Name]
-> TcSigFun
-> Bool -- True <=> either the binders are not mentioned
-- in their RHSs or they have type sigs
-> RecFlag -- True <=> the binding is recursive for typechecking purposes
-- i.e. the binders are mentioned in their RHSs, and
-- we are not resuced by a type signature
-> TcM (LHsBinds TcId, [MonoBindInfo])
tcMonoBinds [L b_loc (FunBind (L nm_loc name) inf matches fvs)]
sig_fn -- Single function binding,
True -- binder isn't mentioned in RHS,
NonRecursive -- binder isn't mentioned in RHS,
| Nothing <- sig_fn name -- ...with no type signature
= -- In this very special case we infer the type of the
-- right hand side first (it may have a higher-rank type)
......
......@@ -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