-------------------------
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
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)
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}
%************************************************************************
(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
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
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
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
| 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
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
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
import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
import HsSyn
-import HsBinds ( hsSigDoc, eqHsSig )
import RdrHsSyn
import RnHsSyn
import TcRnMonad
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}
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
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 }
-- 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
-- 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
-- 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:"
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.
---------------------
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}
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, (<$>) )
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 )
-- 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
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
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 }
-- 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
= 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)
-- 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) }
; 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
-- 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
; 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, [])
[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
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)
\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)
import SrcLoc ( Located(..), srcSpanStart, unLoc, noLoc )
import Maybes ( seqMaybe, isJust, mapCatMaybes )
import List ( partition )
+import BasicTypes ( RecFlag(..) )
import Bag
import FastString
\end{code}
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
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
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
; 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
projects / ghc-hetmet.git / commitdiff