mk_node b@(EvBind var term) = (b, var, free_vars_of term)
free_vars_of :: EvTerm -> [EvVar]
- free_vars_of (EvId v) = [v]
- free_vars_of (EvCast v co) = v : varSetElems (tyVarsOfType co)
- free_vars_of (EvCoercion co) = varSetElems (tyVarsOfType co)
- free_vars_of (EvDFunApp _ _ vs) = vs
- free_vars_of (EvSuperClass d _) = [d]
+ free_vars_of (EvId v) = [v]
+ free_vars_of (EvCast v co) = v : varSetElems (tyVarsOfType co)
+ free_vars_of (EvCoercion co) = varSetElems (tyVarsOfType co)
+ free_vars_of (EvDFunApp _ _ vs _) = vs
+ free_vars_of (EvSuperClass d _) = [d]
dsEvGroup :: SCC EvBind -> DsEvBind
dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n)))
ds_pair (EvBind v r) = (v, dsEvTerm r)
dsEvTerm :: EvTerm -> CoreExpr
-dsEvTerm (EvId v) = Var v
-dsEvTerm (EvCast v co) = Cast (Var v) co
-dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
-dsEvTerm (EvCoercion co) = Type co
+dsEvTerm (EvId v) = Var v
+dsEvTerm (EvCast v co) = Cast (Var v) co
+dsEvTerm (EvDFunApp df tys vars _deps) = Var df `mkTyApps` tys `mkVarApps` vars
+dsEvTerm (EvCoercion co) = Type co
dsEvTerm (EvSuperClass d n)
= ASSERT( isClassPred (classSCTheta cls !! n) )
-- We can only select *dictionary* superclasses
| EvCast EvVar Coercion -- d |> co
| EvDFunApp DFunId -- Dictionary instance application
- [Type] [EvVar]
+ [Type] [EvVar]
+ [EvVar] -- The dependencies, which is generally a bigger list than
+ -- the arguments of the dfun.
+ -- See Note [Dependencies in self dictionaries] in TcSimplify
| EvSuperClass DictId Int -- n'th superclass. Used for both equalities and
-- dictionaries, even though the former have no
ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendType co
ppr (EvCoercion co) = ppr co
ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
- ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys
- , ppr ts ]
+ ppr (EvDFunApp df tys ts deps) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts, ppr deps ]
\end{code}
%************************************************************************
newSCWorkFromFlavored :: EvVar -> CtFlavor -> Class -> [Xi] -> TcS CanonicalCts
-- Returns superclasses, see Note [Adding superclasses]
newSCWorkFromFlavored ev orig_flavor cls xis
- | Given loc <- orig_flavor -- Very important!
- , NoScSkol <- ctLocOrigin loc
- = return emptyCCan
- | otherwise
= do { let (tyvars, sc_theta, _, _) = classBigSig cls
sc_theta1 = substTheta (zipTopTvSubst tyvars xis) sc_theta
; sc_vars <- zipWithM inst_one sc_theta1 [0..]
do { co' <- zonkTcTypeToType env co
; return (EvCast (zonkIdOcc env v) co') }
zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n)
-zonkEvTerm env (EvDFunApp df tys tms)
+zonkEvTerm env (EvDFunApp df tys tms _deps) -- Ignore the dependencies
= do { tys' <- zonkTcTypeToTypes env tys
; let tms' = map (zonkEvVarOcc env) tms
- ; return (EvDFunApp (zonkIdOcc env df) tys' tms') }
+ ; return (EvDFunApp (zonkIdOcc env df) tys' tms' _deps) }
zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
zonkTcEvBinds env (TcEvBinds var) = do { (env', bs') <- zonkEvBindsVar env var
-- to use in each method binding
-- Why? See Note [Subtle interaction of recursion and overlap]
; let self_ev_bind = EvBind self_dict $
- EvDFunApp dfun_id (mkTyVarTys inst_tyvars') dfun_ev_vars
+ EvDFunApp dfun_id (mkTyVarTys inst_tyvars') dfun_ev_vars []
+ -- Empty dependencies [], since it only
+ -- depends on "given" things
-- Deal with 'SPECIALISE instance' pragmas
-- See Note [SPECIALISE instance pragmas]
\begin{code}
-{-
-newGivenSCWork :: EvVar -> GivenLoc -> Class -> [Xi] -> TcS WorkList
-newGivenSCWork ev loc cls xis
- | NoScSkol <- ctLocOrigin loc -- Very important!
- = return emptyWorkList
- | otherwise
- = newImmSCWorkFromFlavored ev (Given loc) cls xis >>= return
-
-newDerivedSCWork :: EvVar -> WantedLoc -> Class -> [Xi] -> TcS WorkList
-newDerivedSCWork ev loc cls xis
- = do { ims <- newImmSCWorkFromFlavored ev flavor cls xis
- ; rec_sc_work ims }
- where
- rec_sc_work :: CanonicalCts -> TcS CanonicalCts
- rec_sc_work cts
- = do { bg <- mapBagM (\c -> do { ims <- imm_sc_work c
- ; recs_ims <- rec_sc_work ims
- ; return $ consBag c recs_ims }) cts
- ; return $ concatBag bg }
- imm_sc_work (CDictCan { cc_id = dv, cc_flavor = fl, cc_class = cls, cc_tyargs = xis })
- = newImmSCWorkFromFlavored dv fl cls xis
- imm_sc_work _ct = return emptyCCan
-
- flavor = Derived loc DerSC
-
--}
-
data LookupInstResult
= NoInstance
; tys <- instDFunTypes mb_inst_tys
; let (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
; if null theta then
- return (GenInst [] (EvDFunApp dfun_id tys []))
+ return (GenInst [] (EvDFunApp dfun_id tys [] []))
else do
{ ev_vars <- instDFunConstraints theta
; let wevs = [WantedEvVar w loc | w <- ev_vars]
- ; return $ GenInst wevs (EvDFunApp dfun_id tys ev_vars) }
+ ; return $ GenInst wevs (EvDFunApp dfun_id tys ev_vars ev_vars) }
+ -- NB: All the dependencies are ev_vars
}
}
\end{code}
mkWantedConstraints, deCanonicaliseWanted,
makeGivens, makeSolvedByInst,
- CtFlavor (..), isWanted, isGiven, isDerived, isDerivedSC, isDerivedByInst,
+ CtFlavor (..), isWanted, isGiven, isDerived,
isGivenCt, isWantedCt, pprFlavorArising,
isFlexiTcsTv,
-- these wanteds
| Wanted WantedLoc -- We have no evidence bindings for this constraint.
-data DerivedOrig = DerSC | DerInst
+data DerivedOrig = DerSC | DerInst | DerSelf
-- Deriveds are either superclasses of other wanteds or deriveds, or partially
--- solved wanteds from instances.
+-- solved wanteds from instances, or 'self' dictionaries containing yet wanted
+-- superclasses.
instance Outputable CtFlavor where
ppr (Given _) = ptext (sLit "[Given]")
isDerived (Derived {}) = True
isDerived _ = False
-isDerivedSC :: CtFlavor -> Bool
-isDerivedSC (Derived _ DerSC) = True
-isDerivedSC _ = False
-
-isDerivedByInst :: CtFlavor -> Bool
-isDerivedByInst (Derived _ DerInst) = True
-isDerivedByInst _ = False
-
pprFlavorArising :: CtFlavor -> SDoc
pprFlavorArising (Derived wl _) = pprArisingAt wl
pprFlavorArising (Wanted wl) = pprArisingAt wl
chase_ev assocs trg curr_grav visited (EvCoercion co)
= chase_co assocs trg curr_grav visited co
- chase_ev assocs trg curr_grav visited (EvDFunApp _ _ ev_vars)
- = do { chase_results <- mapM (chase_ev_var assocs trg (curr_grav+1) visited) ev_vars
- ; return (comb_chase_res Nothing chase_results) }
+ chase_ev assocs trg curr_grav visited (EvDFunApp _ _ _ev_vars ev_deps)
+ = do { chase_results <- mapM (chase_ev_var assocs trg (curr_grav+1) visited) ev_deps
+ -- Notice that we chase the ev_deps and not the ev_vars
+ -- See Note [Dependencies in self dictionaries] in TcSimplify
+ ; return (comb_chase_res Nothing chase_results) }
chase_co assocs trg curr_grav visited co
= -- Look for all the coercion variables in the coercion
import Data.List ( partition )
import Outputable
import FastString
+import Control.Monad ( unless )
\end{code}
***********************************************************************************
When constructing evidence for superclasses in an instance declaration,
- * we MUST have the "self" dictionary available, but
- * we must NOT have its superclasses derived from "self"
+ * we MUST have the "self" dictionary available
Moreover, we must *completely* solve the constraints right now,
not wrap them in an implication constraint to solve later. Why?
looking like
foo :: Ord [Int]
foo = scsel dCInt
-we must not solve the (Ord [Int]) wanted from foo!!
+we must not solve the (Ord [Int]) wanted from foo!
+
+Note [Dependencies in self dictionaries]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Moreover, notice that when solving for a superclass, we record the dependency of
+self on the superclass. This is because this dependency is not evident in the
+EvBind of the self dictionary, which only involves a call to a DFun. Example:
+
+class A a => C a
+instance B a => C a
+
+When we check the instance declaration, we pass in a self dictionary that is merely
+ self = dfun b
+But we will be asked to solve that from:
+ [Given] d : B a
+ [Derived] self : C a
+We can show:
+ [Wanted] sc : A a
+The problem is that self *depends* on the sc variable, but that is not apparent in
+the binding self = dfun b. So we record the extra dependency, using the evidence bind:
+ EvBind self (EvDFunApp dfun [b] [b,sc])
+It is these dependencies that are the ''true'' dependencies in an EvDFunApp, and those
+that we must chase in function isGoodRecEv (in TcSMonad)
\begin{code}
-simplifySuperClass :: EvVar -- The "self" dictionary
- -> WantedConstraints
- -> TcM ()
-simplifySuperClass self wanteds
- = do { wanteds <- mapBagM zonkWanted wanteds
- ; loc <- getCtLoc NoScSkol
- ; ((unsolved_flats,unsolved_impls), frozen_errors, ev_binds)
+simplifySuperClass :: [TyVar]
+ -> [EvVar] -- givens
+ -> EvVar -- the superclass we must solve for
+ -> EvBind -- the 'self' evidence bind
+ -> TcM TcEvBinds
+-- Post:
+-- ev_binds <- simplifySuperClasses tvs inst_givens sc_dict self_ev_bind
+-- Then:
+-- 1) ev_binds already contains self_ev_bind
+-- 2) if successful then ev_binds contains binding for
+-- the wanted superclass, sc_dict
+simplifySuperClass tvs inst_givens sc_dict (EvBind self_dict self_ev)
+ = do { giv_loc <- getCtLoc InstSkol -- For the inst_givens
+ ; want_loc <- getCtLoc ScOrigin -- As wanted/derived (for the superclass and self)
+ ; lcl_env <- getLclTypeEnv
+
+ -- Record the dependency of self_dict to sc_dict, see Note [Dependencies in self dictionaries]
+ ; let wanted = unitBag $ WcEvVar $ WantedEvVar sc_dict want_loc
+ self_ev_with_dep
+ = case self_ev of
+ EvDFunApp df tys insts deps -> EvDFunApp df tys insts (sc_dict:deps)
+ _ -> panic "Self-dictionary not EvDFunApp!"
+
+ -- And solve for it
+ ; ((unsolved_flats, unsolved_implics), frozen_errors, ev_binds)
<- runTcS SimplCheck NoUntouchables $
- do { can_self <- canGivens loc [self]
- ; let inert = foldlBag updInertSet emptyInert can_self
- -- No need for solveInteract; we know it's inert
-
- ; solveWanteds inert wanteds }
-
- ; ASSERT2( isEmptyBag ev_binds, ppr ev_binds )
- reportUnsolved (unsolved_flats,unsolved_impls) frozen_errors }
+ do { -- Record a binding for self_dict that *depends on sc_dict*
+ -- And canonicalise self_dict (which adds its superclasses)
+ -- with a Derived origin, which in turn triggers the
+ -- goodRecEv recursive-evidence check
+ ; setEvBind self_dict self_ev_with_dep
+ ; can_selfs <- mkCanonical (Derived want_loc DerSelf) self_dict
+
+ -- The rest is just like solveImplication
+ ; can_inst_givens <- mkCanonicals (Given giv_loc) inst_givens
+ ; inert <- solveInteract emptyInert $
+ can_inst_givens `andCCan` can_selfs
+ ; solveWanteds inert wanted }
+
+ -- For error reporting, conjure up a fake implication,
+ -- so that we get decent error messages
+ ; let implic = Implic { ic_untch = NoUntouchables
+ , ic_env = lcl_env
+ , ic_skols = mkVarSet tvs
+ , ic_given = inst_givens
+ , ic_wanted = mapBag WcEvVar unsolved_flats
+ , ic_scoped = panic "super1"
+ , ic_binds = panic "super2"
+ , ic_loc = giv_loc }
+ ; ASSERT (isEmptyBag unsolved_implics) -- Impossible to have any implications!
+ unless (isEmptyBag unsolved_flats) $
+ reportUnsolved (emptyBag, unitBag implic) frozen_errors
+
+ ; return (EvBinds ev_binds) }
\end{code}
| RuntimeUnkSkol -- a type variable used to represent an unknown
-- runtime type (used in the GHCi debugger)
- | NoScSkol -- Used for the "self" superclass when solving
- -- superclasses; don't generate superclasses of me
-
| UnkSkol -- Unhelpful info (until I improve it)
-------------------------------------
<+> pprWithCommas ppr ips
pprSkolInfo (ClsSkol cls) = ptext (sLit "the class declaration for") <+> quotes (ppr cls)
pprSkolInfo InstSkol = ptext (sLit "the instance declaration")
-pprSkolInfo NoScSkol = ptext (sLit "the instance declaration (self)")
pprSkolInfo FamInstSkol = ptext (sLit "the family instance declaration")
pprSkolInfo (RuleSkol name) = ptext (sLit "the RULE") <+> doubleQuotes (ftext name)
pprSkolInfo ArrowSkol = ptext (sLit "the arrow form")
projects / ghc-hetmet.git / commitdiff