import {-# SOURCE #-} TcExpr ( tcExpr )
import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..), StmtCtxt(..),
- collectMonoBinders, andMonoBindList, andMonoBinds
+ Match(..), collectMonoBinders, andMonoBindList, andMonoBinds
)
import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet )
import TcMonad
import Inst ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..),
newDicts, tyVarsOfInst, instToId,
+ getAllFunDepsOfLIE, getIPsOfLIE, zonkFunDeps
)
import TcEnv ( tcExtendLocalValEnv,
newSpecPragmaId, newLocalId,
tcGetGlobalTyVars, tcExtendGlobalTyVars
)
import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts )
-import TcMonoType ( tcHsType, checkSigTyVars,
+import TcImprove ( tcImprove )
+import TcMonoType ( tcHsSigType, checkSigTyVars,
TcSigInfo(..), tcTySig, maybeSig, sigCtxt
)
import TcPat ( tcPat )
import PrelInfo ( main_NAME, ioTyCon_NAME )
-import Id ( Id, mkVanillaId, setInlinePragma )
+import Id ( Id, mkVanillaId, setInlinePragma, idFreeTyVars )
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
-- (must do this before getTyVarsToGen)
checkSigMatch top_lvl binder_names mono_ids tc_ty_sigs `thenTc` \ maybe_sig_theta ->
+ -- IMPROVE the LIE
+ -- Force any unifications dictated by functional dependencies.
+ -- Because unification may happen, it's important that this step
+ -- come before:
+ -- - computing vars over which to quantify
+ -- - zonking the generalized type vars
+ let lie_avail = case maybe_sig_theta of
+ Nothing -> emptyLIE
+ Just (_, la) -> la in
+ tcImprove (lie_avail `plusLIE` lie_req) `thenTc_`
+
-- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
-- The tyvars_not_to_gen are free in the environment, and hence
-- candidates for generalisation, but sometimes the monomorphism
-- 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}
is_elem v vs = isIn "isUnResMono" v vs
-isUnRestrictedGroup sigs (PatMonoBind (VarPatIn v) _ _) = v `is_elem` sigs
isUnRestrictedGroup sigs (PatMonoBind other _ _) = False
isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs
-isUnRestrictedGroup sigs (FunMonoBind _ _ _ _) = True
+isUnRestrictedGroup sigs (FunMonoBind v _ matches _) = any isUnRestrictedMatch matches ||
+ v `is_elem` sigs
isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 &&
isUnRestrictedGroup sigs mb2
isUnRestrictedGroup sigs EmptyMonoBinds = True
+
+isUnRestrictedMatch (Match _ [] Nothing _) = False -- No args, no signature
+isUnRestrictedMatch other = True -- Some args or a signature
\end{code}
-- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK
-- Doesn't affect substitution
- check_one_sig (TySigInfo _ id sig_tyvars _ sig_tau _ _ src_loc)
+ check_one_sig (TySigInfo _ id sig_tyvars sig_theta sig_tau _ _ src_loc)
= tcAddSrcLoc src_loc $
- tcAddErrCtxtM (sigCtxt (sig_msg id) (idType id)) $
- checkSigTyVars sig_tyvars
+ tcAddErrCtxtM (sigCtxt (sig_msg id) sig_tyvars sig_theta sig_tau) $
+ checkSigTyVars sig_tyvars (idFreeTyVars id)
-- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
= 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)]
+ sig_msg id = ptext SLIT("When checking the type signature for") <+> quotes (ppr id)
-- Search for Main.main in the binder_names, return corresponding mono_id
find_main NotTopLevel binder_names mono_ids = Nothing
tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
-- Get and instantiate its alleged specialised type
- tcHsType poly_ty `thenTc` \ sig_ty ->
+ tcHsSigType poly_ty `thenTc` \ sig_ty ->
-- Check that f has a more general type, and build a RHS for
-- the spec-pragma-id at the same time
projects / ghc-hetmet.git / blobdiff