instLoc, getDictClassTys, dictPred,
lookupInst, LookupInstResult(..),
- tcExtendLocalInstEnv, tcGetInstEnvs,
+ tcExtendLocalInstEnv, tcGetInstEnvs,
isDict, isClassDict, isMethod,
isLinearInst, linearInstType, isIPDict, isInheritableInst,
import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
import InstEnv ( DFunId, InstEnv, lookupInstEnv, checkFunDeps, extendInstEnv )
import TcIface ( loadImportedInsts )
-import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType,
- zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
+import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType,
+ tcInstTyVar, tcInstType, tcSkolType
)
-import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcTyVar,
- PredType(..), typeKind,
+import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcTyVar, TcPredType,
+ PredType(..), SkolemInfo(..), typeKind, mkSigmaTy,
tcSplitForAllTys, tcSplitForAllTys,
- tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy,
+ tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy, tcSplitDFunHead,
isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
pprPred, pprParendType, pprThetaArrow, pprTheta, pprClassPred
)
-import Type ( substTy, substTys, substTyWith, substTheta, zipTopTvSubst )
-import Unify ( matchTys )
+import Type ( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSubst,
+ notElemTvSubst, extendTvSubstList )
+import Unify ( tcMatchTys )
import Kind ( isSubKind )
+import Packages ( isHomeModule )
import HscTypes ( ExternalPackageState(..) )
import CoreFVs ( idFreeTyVars )
import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName )
import Id ( Id, idName, idType, mkUserLocal, mkLocalId )
import PrelInfo ( isStandardClass, isNoDictClass )
-import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName,
- isInternalName, setNameUnique, mkSystemNameEncoded )
+import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
+ isInternalName, setNameUnique, mkSystemVarNameEncoded )
import NameSet ( addOneToNameSet )
import Literal ( inIntRange )
-import Var ( TyVar, tyVarKind )
-import VarEnv ( TidyEnv, emptyTidyEnv, lookupVarEnv )
+import Var ( TyVar, tyVarKind, setIdType )
+import VarEnv ( TidyEnv, emptyTidyEnv )
import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
import TysWiredIn ( floatDataCon, doubleDataCon )
import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
= getInstLoc orig `thenM` \ loc ->
newUnique `thenM` \ new_uniq ->
let
- lit_nm = mkSystemNameEncoded new_uniq FSLIT("lit")
+ lit_nm = mkSystemVarNameEncoded new_uniq FSLIT("lit")
-- The "encoded" bit means that we don't need to z-encode
-- the string every time we call this!
lit_inst = LitInst lit_nm lit expected_ty loc
-- Check that the proposed new instance is OK,
-- and then add it to the home inst env
addInst dflags home_ie dfun
- = do { -- Load imported instances, so that we report
+ = do { -- Instantiate the dfun type so that we extend the instance
+ -- envt with completely fresh template variables
+ -- This is important because the template variables must
+ -- not overlap with anything in the things being looked up
+ -- (since we do unification).
+ -- We use tcSkolType because we don't want to allocate fresh
+ -- *meta* type variables.
+ (tvs', theta', tau') <- tcSkolType (InstSkol dfun) (idType dfun)
+ ; let (cls, tys') = tcSplitDFunHead tau'
+ dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
+
+ -- Load imported instances, so that we report
-- duplicates correctly
- let (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
- ; pkg_ie <- loadImportedInsts cls tys
+ ; pkg_ie <- loadImportedInsts cls tys'
-- Check functional dependencies
- ; case checkFunDeps (pkg_ie, home_ie) dfun of
+ ; case checkFunDeps (pkg_ie, home_ie) dfun' of
Just dfuns -> funDepErr dfun dfuns
Nothing -> return ()
-- Check for duplicate instance decls
- -- We instantiate the dfun type because the instance lookup
- -- requires nice fresh types in the thing to be looked up
- ; (tvs', _, tenv) <- tcInstTyVars tvs
- ; let { tys' = substTys tenv tys
- ; (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys'
+ ; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys'
; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
- isJust (matchTys (mkVarSet tvs) tys' dup_tys)] }
+ isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
-- Find memebers of the match list which
-- dfun itself matches. If the match is 2-way, it's a duplicate
; case dup_dfuns of
[] -> return ()
-- OK, now extend the envt
- ; return (extendInstEnv home_ie dfun) }
+ ; return (extendInstEnv home_ie dfun') }
traceDFuns dfuns
where
loc = getSrcLoc dfun
\end{code}
+
%************************************************************************
%* *
%************************************************************************
\begin{code}
-data LookupInstResult s
+data LookupInstResult
= NoInstance
| SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal
| GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
-lookupInst :: Inst -> TcM (LookupInstResult s)
+lookupInst :: Inst -> TcM LookupInstResult
-- It's important that lookupInst does not put any new stuff into
-- the LIE. Instead, any Insts needed by the lookup are returned in
-- the LookupInstResult, where they can be further processed by tcSimplify
lookupInst (Dict _ _ _) = returnM NoInstance
-----------------
+instantiate_dfun :: TvSubst -> DFunId -> TcPredType -> InstLoc -> TcM LookupInstResult
instantiate_dfun tenv dfun_id pred loc
= -- tenv is a substitution that instantiates the dfun_id
- -- to match the requested result type. However, the dfun
- -- might have some tyvars that only appear in arguments
+ -- to match the requested result type.
+ --
+ -- We ASSUME that the dfun is quantified over the very same tyvars
+ -- that are bound by the tenv.
+ --
+ -- However, the dfun
+ -- might have some tyvars that *only* appear in arguments
-- dfun :: forall a b. C a b, Ord b => D [a]
-- We instantiate b to a flexi type variable -- it'll presumably
-- become fixed later via functional dependencies
-- Record that this dfun is needed
record_dfun_usage dfun_id `thenM_`
+ getStage `thenM` \ use_stage ->
+ checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
+ (topIdLvl dfun_id) use_stage `thenM_`
+
-- It's possible that not all the tyvars are in
-- the substitution, tenv. For example:
-- instance C X a => D X where ...
-- (presumably there's a functional dependency in class C)
- -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
- getStage `thenM` \ use_stage ->
- checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
- (topIdLvl dfun_id) use_stage `thenM_`
+ -- Hence the open_tvs to instantiate any un-substituted tyvars.
let
(tyvars, rho) = tcSplitForAllTys (idType dfun_id)
- mk_ty_arg tv = case lookupVarEnv tenv tv of
- Just ty -> returnM ty
- Nothing -> tcInstTyVar tv `thenM` \ tc_tv ->
- returnM (mkTyVarTy tc_tv)
+ open_tvs = filter (`notElemTvSubst` tenv) tyvars
in
- mappM mk_ty_arg tyvars `thenM` \ ty_args ->
+ mappM tcInstTyVar open_tvs `thenM` \ open_tvs' ->
let
- dfun_rho = substTy (zipTopTvSubst tyvars ty_args) rho
- -- Since the tyvars are freshly made,
- -- they cannot possibly be captured by
- -- any existing for-alls. Hence zipTopTyVarSubst
+ tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
+ -- Since the open_tvs' are freshly made, they cannot possibly be captured by
+ -- any nested for-alls in rho. So the in-scope set is unchanged
+ dfun_rho = substTy tenv' rho
(theta, _) = tcSplitPhiTy dfun_rho
- ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id)) ty_args
+ ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id))
+ (map (substTyVar tenv') tyvars)
in
if null theta then
returnM (SimpleInst ty_app)
in
returnM (GenInst dicts rhs)
-record_dfun_usage dfun_id
- | isInternalName dfun_name = return () -- From this module
- | not (isHomePackageName dfun_name) = return () -- From another package package
- | otherwise = getGblEnv `thenM` \ tcg_env ->
- updMutVar (tcg_inst_uses tcg_env)
+record_dfun_usage dfun_id = do
+ dflags <- getDOpts
+ let dfun_name = idName dfun_id
+ dfun_mod = nameModule dfun_name
+ if isInternalName dfun_name || not (isHomeModule dflags dfun_mod)
+ then return () -- internal, or in another package
+ else do tcg_env <- getGblEnv
+ updMutVar (tcg_inst_uses tcg_env)
(`addOneToNameSet` idName dfun_id)
- where
- dfun_name = idName dfun_id
tcGetInstEnvs :: TcM (InstEnv, InstEnv)
-- Gets both the external-package inst-env