ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
getDictClassTys, dictPred,
- lookupSimpleInst, LookupInstResult(..), lookupPred,
+ lookupSimpleInst, LookupInstResult(..),
tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
isDict, isClassDict, isMethod, isImplicInst,
-- Check for duplicate instance decls
; let { (matches, _) = lookupInstEnv inst_envs cls tys'
; dup_ispecs = [ dup_ispec
- | (_, dup_ispec) <- matches
+ | (dup_ispec, _) <- matches
, let (_,_,_,dup_tys) = instanceHead dup_ispec
, isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
-- Find memebers of the match list which ispec itself matches.
= do { mb_result <- lookupPred pred
; case mb_result of {
Nothing -> return NoInstance ;
- Just (tenv, dfun_id) -> do
-
- -- tenv is a substitution that instantiates the dfun_id
- -- 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
+ Just (dfun_id, mb_inst_tys) -> do
+
{ use_stage <- getStage
; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
(topIdLvl dfun_id) use_stage
-- the substitution, tenv. For example:
-- instance C X a => D X where ...
-- (presumably there's a functional dependency in class C)
- -- Hence the open_tvs to instantiate any un-substituted tyvars.
- ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
- open_tvs = filter (`notElemTvSubst` tenv) tyvars
- ; open_tvs' <- mappM tcInstTyVar open_tvs
+ -- Hence mb_inst_tys :: Either TyVar TcType
+
+ ; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
+ inst_tv (Right ty) = return ty
+ ; tys <- mappM inst_tv mb_inst_tys
; let
- 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
+ (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
src_loc = instLocSpan loc
dfun = HsVar dfun_id
- tys = substTyVars tenv' tyvars
; if null theta then
returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
else do
}}}}
---------------
-lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
+lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
-- Look up a class constraint in the instance environment
lookupPred pred@(ClassP clas tys)
= do { eps <- getEps
; tcg_env <- getGblEnv
; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
; case lookupInstEnv inst_envs clas tys of {
- ([(tenv, ispec)], [])
+ ([(ispec, inst_tys)], [])
-> do { let dfun_id = is_dfun ispec
; traceTc (text "lookupInst success" <+>
vcat [text "dict" <+> ppr pred,
<+> ppr (idType dfun_id) ])
-- Record that this dfun is needed
; record_dfun_usage dfun_id
- ; return (Just (tenv, dfun_id)) } ;
+ ; return (Just (dfun_id, inst_tys)) } ;
(matches, unifs)
-> do { traceTc (text "lookupInst fail" <+>
quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst dict))),
ptext SLIT("Use -fallow-incoherent-instances to use the first choice above")])]
where
- ispecs = [ispec | (_, ispec) <- matches]
+ ispecs = [ispec | (ispec, _) <- matches]
mk_no_inst_err insts
| null insts = empty
thing we are looking up can have an arbitrary "flexi" part.
\begin{code}
-lookupInstEnv :: (InstEnv -- External package inst-env
- ,InstEnv) -- Home-package inst-env
- -> Class -> [Type] -- What we are looking for
- -> ([(TvSubst, Instance)], -- Successful matches
- [Instance]) -- These don't match but do unify
- -- The second component of the tuple happens when we look up
- -- Foo [a]
- -- in an InstEnv that has entries for
- -- Foo [Int]
- -- Foo [b]
- -- Then which we choose would depend on the way in which 'a'
- -- is instantiated. So we report that Foo [b] is a match (mapping b->a)
- -- but Foo [Int] is a unifier. This gives the caller a better chance of
- -- giving a suitable error messagen
+type InstTypes = [Either TyVar Type]
+ -- Right ty => Instantiate with this type
+ -- Left tv => Instantiate with any type of this tyvar's kind
+
+type InstMatch = (Instance, InstTypes)
+\end{code}
+
+Note [InstTypes: instantiating types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A successful match is an Instance, together with the types at which
+ the dfun_id in the Instance should be instantiated
+The instantiating types are (Mabye Type)s because the dfun
+might have some tyvars that *only* appear in arguments
+ dfun :: forall a b. C a b, Ord b => D [a]
+When we match this against D [ty], we return the instantiating types
+ [Right ty, Left b]
+where the Nothing indicates that 'b' can be freely instantiated.
+(The caller instantiates it to a flexi type variable, which will presumably
+ presumably later become fixed via functional dependencies.)
+
+\begin{code}
+lookupInstEnv :: (InstEnv, InstEnv) -- External and home package inst-env
+ -> Class -> [Type] -- What we are looking for
+ -> ([InstMatch], -- Successful matches
+ [Instance]) -- These don't match but do unify
+
+-- The second component of the result pair happens when we look up
+-- Foo [a]
+-- in an InstEnv that has entries for
+-- Foo [Int]
+-- Foo [b]
+-- Then which we choose would depend on the way in which 'a'
+-- is instantiated. So we report that Foo [b] is a match (mapping b->a)
+-- but Foo [Int] is a unifier. This gives the caller a better chance of
+-- giving a suitable error messagen
lookupInstEnv (pkg_ie, home_ie) cls tys
= (pruned_matches, all_unifs)
-> find [] [] insts
--------------
+ lookup_tv :: TvSubst -> TyVar -> Either TyVar Type
+ -- See Note [InstTypes: instantiating types]
+ lookup_tv subst tv = case lookupTyVar subst tv of
+ Just ty -> Right ty
+ Nothing -> Left tv
+
find ms us [] = (ms, us)
find ms us (item@(Instance { is_tcs = mb_tcs, is_tvs = tpl_tvs,
is_tys = tpl_tys, is_flag = oflag,
= find ms us rest
| Just subst <- tcMatchTys tpl_tvs tpl_tys tys
- = find ((subst,item):ms) us rest
+ = let
+ (dfun_tvs, _) = tcSplitForAllTys (idType dfun)
+ in
+ ASSERT( all (`elemVarSet` tpl_tvs) dfun_tvs ) -- Check invariant
+ find ((item, map (lookup_tv subst) dfun_tvs) : ms) us rest
-- Does not match, so next check whether the things unify
-- See Note [overlapping instances] above
-- on the grounds that the correct instance depends on the instantiation of 'a'
---------------
-insert_overlapping :: (TvSubst, Instance) -> [(TvSubst, Instance)]
- -> [(TvSubst, Instance)]
+insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch]
-- Add a new solution, knocking out strictly less specific ones
insert_overlapping new_item [] = [new_item]
insert_overlapping new_item (item:items)
new_beats_old = new_item `beats` item
old_beats_new = item `beats` new_item
- (_, instA) `beats` (_, instB)
+ (instA, _) `beats` (instB, _)
= overlap_ok &&
isJust (tcMatchTys (is_tvs instB) (is_tys instB) (is_tys instA))
-- A beats B if A is more specific than B, and B admits overlap
ppr Nothing = ptext SLIT("Nothing")
ppr (Just x) = ptext SLIT("Just") <+> ppr x
+instance (Outputable a, Outputable b) => Outputable (Either a b) where
+ ppr (Left x) = ptext SLIT("Left") <+> ppr x
+ ppr (Right y) = ptext SLIT("Right") <+> ppr y
+
-- ToDo: may not be used
instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
ppr (x,y,z) =
projects / ghc-hetmet.git / commitdiff