import TcMonad
import Inst ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..),
newDicts, tyVarsOfInst, instToId,
+ getAllFunDepsOfLIE, getIPsOfLIE, zonkFunDeps
)
import TcEnv ( tcExtendLocalValEnv,
newSpecPragmaId, newLocalId,
import Id ( Id, mkVanillaId, setInlinePragma )
import Var ( idType, idName )
-import IdInfo ( IdInfo, vanillaIdInfo, setInlinePragInfo, InlinePragInfo(..) )
+import IdInfo ( setInlinePragInfo, InlinePragInfo(..) )
import Name ( Name, getName, getOccName, getSrcLoc )
import NameSet
import Type ( mkTyVarTy, tyVarsOfTypes, mkTyConApp,
splitSigmaTy, mkForAllTys, mkFunTys, getTyVar,
- mkDictTy, splitRhoTy, mkForAllTy, isUnLiftedType,
+ mkPredTy, splitRhoTy, mkForAllTy, isUnLiftedType,
isUnboxedType, unboxedTypeKind, boxedTypeKind
)
+import FunDeps ( tyVarFunDep, oclose )
import Var ( TyVar, tyVarKind )
import VarSet
import Bag
-- SIMPLIFY THE LIE
tcExtendGlobalTyVars tyvars_not_to_gen (
- if null real_tyvars_to_gen_list then
- -- No polymorphism, so no need to simplify context
+ let ips = getIPsOfLIE lie_req in
+ if null real_tyvars_to_gen_list && (null ips || not is_unrestricted) then
+ -- No polymorphism, and no IPs, so no need to simplify context
returnTc (lie_req, EmptyMonoBinds, [])
else
case maybe_sig_theta of
-- NB: no signatures => no polymorphic recursion, so no
-- need to use lie_avail (which will be empty anyway)
tcSimplify (text "tcBinds1" <+> ppr binder_names)
- top_lvl real_tyvars_to_gen lie_req `thenTc` \ (lie_free, dict_binds, lie_bound) ->
+ real_tyvars_to_gen lie_req `thenTc` \ (lie_free, dict_binds, lie_bound) ->
returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound))
Just (sig_theta, lie_avail) ->
-- BUILD RESULTS
returnTc (
+ -- pprTrace "binding.." (ppr ((dicts_bound, dict_binds), exports, [idType poly_id | (_, poly_id, _) <- exports])) $
AbsBinds real_tyvars_to_gen_list
dicts_bound
exports
= tcGetGlobalTyVars `thenNF_Tc` \ free_tyvars ->
zonkTcTypes mono_id_tys `thenNF_Tc` \ zonked_mono_id_tys ->
let
- tyvars_to_gen = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars
+ body_tyvars = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars
in
if is_unrestricted
then
- returnNF_Tc (emptyVarSet, tyvars_to_gen)
+ let fds = getAllFunDepsOfLIE lie in
+ zonkFunDeps fds `thenNF_Tc` \ fds' ->
+ let tvFundep = tyVarFunDep fds'
+ extended_tyvars = oclose tvFundep body_tyvars in
+ -- pprTrace "gTVTG" (ppr (lie, body_tyvars, extended_tyvars)) $
+ returnNF_Tc (emptyVarSet, extended_tyvars)
else
-- This recover and discard-errs is to avoid duplicate error
-- messages; this, after all, is an "extra" call to tcSimplify
- recoverNF_Tc (returnNF_Tc (emptyVarSet, tyvars_to_gen)) $
+ recoverNF_Tc (returnNF_Tc (emptyVarSet, body_tyvars)) $
discardErrsTc $
- tcSimplify (text "getTVG") NotTopLevel tyvars_to_gen lie `thenTc` \ (_, _, constrained_dicts) ->
+ tcSimplify (text "getTVG") body_tyvars lie `thenTc` \ (_, _, constrained_dicts) ->
let
-- ASSERT: dicts_sig is already zonked!
constrained_tyvars = foldrBag (unionVarSet . tyVarsOfInst) emptyVarSet constrained_dicts
- reduced_tyvars_to_gen = tyvars_to_gen `minusVarSet` constrained_tyvars
+ reduced_tyvars_to_gen = body_tyvars `minusVarSet` constrained_tyvars
in
returnTc (constrained_tyvars, reduced_tyvars_to_gen)
\end{code}
= tcAddSrcLoc src_loc $
checkTc (null theta) (mainContextsErr id)
- mk_dict_tys theta = [mkDictTy c ts | (c,ts) <- theta]
+ mk_dict_tys theta = map mkPredTy theta
sig_msg id tidy_ty = sep [ptext SLIT("When checking the type signature"),
nest 4 (ppr id <+> dcolon <+> ppr tidy_ty)]