ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
getDictClassTys, dictPred,
- lookupSimpleInst, LookupInstResult(..), lookupPred,
+ lookupSimpleInst, LookupInstResult(..),
tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
isDict, isClassDict, isMethod, isImplicInst,
isIPDict, isInheritableInst, isMethodOrLit,
- isTyVarDict, isMethodFor, getDefaultableDicts,
+ isTyVarDict, isMethodFor,
zonkInst, zonkInsts,
instToId, instToVar, instName,
import TcMType
import TcType
import Type
-import Class
import Unify
import Module
import Coercion
import Maybes
import Util
import Outputable
+
+import Data.List
\end{code}
isMethodOrLit other = False
\end{code}
-\begin{code}
-getDefaultableDicts :: [Inst] -> ([(Inst, Class, TcTyVar)], TcTyVarSet)
--- Look for free dicts of the form (C tv), even inside implications
--- *and* the set of tyvars mentioned by all *other* constaints
--- This disgustingly ad-hoc function is solely to support defaulting
-getDefaultableDicts insts
- = (concat ps, unionVarSets tvs)
- where
- (ps, tvs) = mapAndUnzip get insts
- get d@(Dict {tci_pred = ClassP cls [ty]})
- | Just tv <- tcGetTyVar_maybe ty = ([(d,cls,tv)], emptyVarSet)
- | otherwise = ([], tyVarsOfType ty)
- get (ImplicInst {tci_tyvars = tvs, tci_wanted = wanteds})
- = ([ up | up@(_,_,tv) <- ups, not (tv `elemVarSet` tv_set)],
- ftvs `minusVarSet` tv_set)
- where
- tv_set = mkVarSet tvs
- (ups, ftvs) = getDefaultableDicts wanteds
- get inst = ([], tyVarsOfInst inst)
-\end{code}
%************************************************************************
%* *
; return (dict:dicts, co_fn <.> WpApp (instToId dict)) }
-------------
-cloneDict :: Inst -> TcM Inst -- Only used for linear implicit params
+cloneDict :: Inst -> TcM Inst
cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
; return (dict {tci_name = setNameUnique nm uniq}) }
cloneDict other = pprPanic "cloneDict" (ppr other)
\begin{code}
mkPredName :: Unique -> InstLoc -> PredType -> Name
mkPredName uniq loc pred_ty
- = mkInternalName uniq occ (srcSpanStart (instLocSpan loc))
+ = mkInternalName uniq occ (instLocSpan loc)
where
occ = case pred_ty of
ClassP cls _ -> mkDictOcc (getOccName cls)
meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
tci_theta = theta, tci_loc = inst_loc}
- loc = srcSpanStart (instLocSpan inst_loc)
+ loc = instLocSpan inst_loc
in
returnM inst
\end{code}
-- 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" <+>
projects / ghc-hetmet.git / blobdiff