\begin{code}
module TcBinds ( tcLocalBinds, tcTopBinds,
- tcHsBootSigs, tcMonoBinds,
+ tcHsBootSigs, tcMonoBinds, tcPolyBinds,
TcPragFun, tcSpecPrag, tcPrags, mkPragFun,
TcSigInfo(..), TcSigFun, mkTcSigFun,
badBootDeclErr ) where
import VarEnv
import TysPrim
import Id
-import IdInfo
-import Var hiding (mkLocalId)
+import Var
import Name
import NameSet
import NameEnv
where
tc_boot_sig (TypeSig (L _ name) ty)
= do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
- ; return (mkVanillaGlobal name sigma_ty vanillaIdInfo) }
+ ; return (mkVanillaGlobal name sigma_ty) }
-- Notice that we make GlobalIds, not LocalIds
tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups)
; ty_sigs = filter isVanillaLSig sigs
; sig_fn = mkTcSigFun ty_sigs }
- ; poly_ids <- mapM tcTySig ty_sigs
+ ; poly_ids <- checkNoErrs (mapAndRecoverM tcTySig ty_sigs)
-- No recovery from bad signatures, because the type sigs
-- may bind type variables, so proceeding without them
-- can lead to a cascade of errors
-- the Ids declared with type signatures
; poly_rec <- doptM Opt_RelaxedPolyRec
; (binds', thing) <- tcExtendIdEnv poly_ids $
- tc_val_binds poly_rec top_lvl sig_fn prag_fn
+ tcBindGroups poly_rec top_lvl sig_fn prag_fn
binds thing_inside
; return (ValBindsOut binds' sigs, thing) }
------------------------
-tc_val_binds :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun
+tcBindGroups :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun
-> [(RecFlag, LHsBinds Name)] -> TcM thing
-> TcM ([(RecFlag, LHsBinds TcId)], thing)
-- Typecheck a whole lot of value bindings,
-- one strongly-connected component at a time
+-- Here a "strongly connected component" has the strightforward
+-- meaning of a group of bindings that mention each other,
+-- ignoring type signatures (that part comes later)
-tc_val_binds _ _ _ _ [] thing_inside
+tcBindGroups _ _ _ _ [] thing_inside
= do { thing <- thing_inside
; return ([], thing) }
-tc_val_binds poly_rec top_lvl sig_fn prag_fn (group : groups) thing_inside
+tcBindGroups poly_rec top_lvl sig_fn prag_fn (group : groups) thing_inside
= do { (group', (groups', thing))
<- tc_group poly_rec top_lvl sig_fn prag_fn group $
- tc_val_binds poly_rec top_lvl sig_fn prag_fn groups thing_inside
+ tcBindGroups poly_rec top_lvl sig_fn prag_fn groups thing_inside
; return (group' ++ groups', thing) }
------------------------
; return ([(Recursive, unionManyBags binds1)], thing) }
| otherwise -- Recursive group, with gla-exts
- = -- To maximise polymorphism (with -fglasgow-exts), we do a new
+ = -- To maximise polymorphism (with -XRelaxedPolyRec), we do a new
-- strongly-connected-component analysis, this time omitting
-- any references to variables with type signatures.
--
- -- Notice that the bindInsts thing covers *all* the bindings in the original
- -- group at once; an earlier one may use a later one!
+ -- Notice that the bindInsts thing covers *all* the bindings in
+ -- the original group at once; an earlier one may use a later one!
do { traceTc (text "tc_group rec" <+> pprLHsBinds binds)
; (binds1,thing) <- bindLocalInsts top_lvl $
- go (stronglyConnComp (mkEdges sig_fn binds))
+ go (stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds))
; return ([(Recursive, unionManyBags binds1)], thing) }
-- Rec them all together
where
-- Note that the scoped_tvs and the (sig_tvs sig)
-- may have different Names. That's quite ok.
+ ; traceTc (text "tcMoonBinds" <+> ppr scoped_tvs $$ ppr tc_sig)
; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs $
tcMatchesFun mono_name inf matches mono_ty
+ -- Note that "mono_ty" might actually be a polymorphic type,
+ -- if the original function had a signature like
+ -- forall a. Eq a => forall b. Ord b => ....
+ -- But that's ok: tcMatchesFun can deal with that
+ -- It happens, too! See Note [Polymorphic methods] in TcClassDcl.
; let fun_bind' = FunBind { fun_id = L nm_loc mono_id,
fun_infix = inf, fun_matches = matches',
<+> ptext (sLit "is unified with another quantified type variable")
<+> quotes (ppr tidy_tv2)
; failWithTcM (env2, msg) }
- where
\end{code}
tcInstSig use_skols name
= do { poly_id <- tcLookupId name -- Cannot fail; the poly ids are put into
-- scope when starting the binding group
- ; let skol_info = SigSkol (FunSigCtxt name)
- inst_tyvars = tcInstSigTyVars use_skols skol_info
- ; (tvs, theta, tau) <- tcInstType inst_tyvars (idType poly_id)
+ ; let skol_info = SigSkol (FunSigCtxt name)
+ ; (tvs, theta, tau) <- tcInstSigType use_skols skol_info (idType poly_id)
; loc <- getInstLoc (SigOrigin skol_info)
; return (TcSigInfo { sig_id = poly_id,
sig_tvs = tvs, sig_theta = theta, sig_tau = tau,
projects / ghc-hetmet.git / blobdiff