2 -- Type definitions for the constraint solver
5 -- Canonical constraints
6 CanonicalCts, emptyCCan, andCCan, andCCans,
7 singleCCan, extendCCans, isEmptyCCan,
8 CanonicalCt(..), Xi, tyVarsOfCanonical, tyVarsOfCanonicals,
9 mkWantedConstraints, deCanonicaliseWanted,
10 makeGivens, makeSolved,
12 CtFlavor (..), isWanted, isGiven, isDerived, canRewrite,
13 joinFlavors, mkGivenFlavor,
15 TcS, runTcS, failTcS, panicTcS, traceTcS, traceTcS0, -- Basic functionality
16 tryTcS, nestImplicTcS, wrapErrTcS, wrapWarnTcS,
17 SimplContext(..), isInteractive, simplEqsOnly, performDefaulting,
19 -- Creation of evidence variables
21 newWantedCoVar, newGivOrDerCoVar, newGivOrDerEvVar,
22 newIPVar, newDictVar, newKindConstraint,
24 -- Setting evidence variables
25 setWantedCoBind, setDerivedCoBind,
26 setIPBind, setDictBind, setEvBind,
32 getInstEnvs, getFamInstEnvs, -- Getting the environments
33 getTopEnv, getGblEnv, getTcEvBinds, getUntouchablesTcS,
34 getTcEvBindsBag, getTcSContext, getTcSTyBinds,
37 newFlattenSkolemTy, -- Flatten skolems
39 instDFunTypes, -- Instantiation
46 getDefaultInfo, getDynFlags,
48 matchClass, matchFam, MatchInstResult (..),
51 pprEq, -- Smaller utils, re-exported from TcM
52 -- TODO (DV): these are only really used in the
53 -- instance matcher in TcSimplify. I am wondering
54 -- if the whole instance matcher simply belongs
58 mkWantedFunDepEqns -- Instantiation of 'Equations' from FunDeps
62 #include "HsVersions.h"
73 import NameSet ( addOneToNameSet )
75 import qualified TcRnMonad as TcM
76 import qualified TcMType as TcM
77 import qualified TcEnv as TcM
78 ( checkWellStaged, topIdLvl, tcLookupFamInst, tcGetDefaultTys )
94 import HsBinds -- for TcEvBinds stuff
105 %************************************************************************
107 %* Canonical constraints *
109 %* These are the constraints the low-level simplifier works with *
111 %************************************************************************
114 -- Types without any type functions inside. However, note that xi
115 -- types CAN contain unexpanded type synonyms; however, the
116 -- (transitive) expansions of those type synonyms will not contain any
118 type Xi = Type -- In many comments, "xi" ranges over Xi
120 type CanonicalCts = Bag CanonicalCt
123 -- Atomic canonical constraints
124 = CDictCan { -- e.g. Num xi
126 cc_flavor :: CtFlavor,
131 | CIPCan { -- ?x::tau
132 -- See note [Canonical implicit parameter constraints].
134 cc_flavor :: CtFlavor,
135 cc_ip_nm :: IPName Name,
136 cc_ip_ty :: TcTauType
139 | CTyEqCan { -- tv ~ xi (recall xi means function free)
141 -- * tv not in tvs(xi) (occurs check)
142 -- * If tv is a MetaTyVar, then typeKind xi <: typeKind tv
143 -- a skolem, then typeKind xi = typeKind tv
145 cc_flavor :: CtFlavor,
150 | CFunEqCan { -- F xis ~ xi
151 -- Invariant: * isSynFamilyTyCon cc_fun
152 -- * cc_rhs is not a touchable unification variable
153 -- See Note [No touchables as FunEq RHS]
154 -- * typeKind (TyConApp cc_fun cc_tyargs) == typeKind cc_rhs
156 cc_flavor :: CtFlavor,
157 cc_fun :: TyCon, -- A type function
158 cc_tyargs :: [Xi], -- Either under-saturated or exactly saturated
159 cc_rhs :: Xi -- *never* over-saturated (because if so
160 -- we should have decomposed)
164 makeGivens :: CanonicalCts -> CanonicalCts
165 makeGivens = mapBag (\ct -> ct { cc_flavor = mkGivenFlavor (cc_flavor ct) UnkSkol })
166 -- The UnkSkol doesn't matter because these givens are
167 -- not contradictory (else we'd have rejected them already)
169 makeSolved :: CanonicalCt -> CanonicalCt
170 -- Record that a constraint is now solved
172 -- Given, Derived -> no-op
174 | Wanted loc <- cc_flavor ct = ct { cc_flavor = Derived loc }
177 mkWantedConstraints :: CanonicalCts -> Bag Implication -> WantedConstraints
178 mkWantedConstraints flats implics
179 = mapBag (WcEvVar . deCanonicaliseWanted) flats `unionBags` mapBag WcImplic implics
181 deCanonicaliseWanted :: CanonicalCt -> WantedEvVar
182 deCanonicaliseWanted ct
183 = WARN( not (isWanted $ cc_flavor ct), ppr ct )
184 let Wanted loc = cc_flavor ct
185 in WantedEvVar (cc_id ct) loc
187 tyVarsOfCanonical :: CanonicalCt -> TcTyVarSet
188 tyVarsOfCanonical (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) = extendVarSet (tyVarsOfType xi) tv
189 tyVarsOfCanonical (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys)
190 tyVarsOfCanonical (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
191 tyVarsOfCanonical (CIPCan { cc_ip_ty = ty }) = tyVarsOfType ty
193 tyVarsOfCanonicals :: CanonicalCts -> TcTyVarSet
194 tyVarsOfCanonicals = foldrBag (unionVarSet . tyVarsOfCanonical) emptyVarSet
196 instance Outputable CanonicalCt where
197 ppr (CDictCan d fl cls tys)
198 = ppr fl <+> ppr d <+> dcolon <+> pprClassPred cls tys
199 ppr (CIPCan ip fl ip_nm ty)
200 = ppr fl <+> ppr ip <+> dcolon <+> parens (ppr ip_nm <> dcolon <> ppr ty)
201 ppr (CTyEqCan co fl tv ty)
202 = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyVarTy tv, ty)
203 ppr (CFunEqCan co fl tc tys ty)
204 = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyConApp tc tys, ty)
208 Note [No touchables as FunEq RHS]
209 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
210 Notice that (F xis ~ beta), where beta is an touchable unification
211 variable, is not canonical. Why?
212 * If (F xis ~ beta) was the only wanted constraint, we'd
213 definitely want to spontaneously-unify it
215 * But suppose we had an earlier wanted (beta ~ Int), and
216 have already spontaneously unified it. Then we have an
217 identity given (id : beta ~ Int) in the inert set.
219 * But (F xis ~ beta) does not react with that given (because we
220 don't subsitute on the RHS of a function equality). So there's a
221 serious danger that we'd spontaneously unify it a second time.
225 Note [Canonical implicit parameter constraints]
226 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
227 The type in a canonical implicit parameter constraint doesn't need to
228 be a xi (type-function-free type) since we can defer the flattening
229 until checking this type for equality with another type. If we
230 encounter two IP constraints with the same name, they MUST have the
231 same type, and at that point we can generate a flattened equality
232 constraint between the types. (On the other hand, the types in two
233 class constraints for the same class MAY be equal, so they need to be
234 flattened in the first place to facilitate comparing them.)
237 singleCCan :: CanonicalCt -> CanonicalCts
240 andCCan :: CanonicalCts -> CanonicalCts -> CanonicalCts
243 extendCCans :: CanonicalCts -> CanonicalCt -> CanonicalCts
244 extendCCans = snocBag
246 andCCans :: [CanonicalCts] -> CanonicalCts
247 andCCans = unionManyBags
249 emptyCCan :: CanonicalCts
252 isEmptyCCan :: CanonicalCts -> Bool
253 isEmptyCCan = isEmptyBag
256 %************************************************************************
259 The "flavor" of a canonical constraint
261 %************************************************************************
265 = Given GivenLoc -- We have evidence for this constraint in TcEvBinds
266 | Derived WantedLoc -- We have evidence for this constraint in TcEvBinds;
267 -- *however* this evidence can contain wanteds, so
268 -- it's valid only provisionally to the solution of
270 | Wanted WantedLoc -- We have no evidence bindings for this constraint.
272 instance Outputable CtFlavor where
273 ppr (Given _) = ptext (sLit "[Given]")
274 ppr (Wanted _) = ptext (sLit "[Wanted]")
275 ppr (Derived _) = ptext (sLit "[Derived]")
277 isWanted :: CtFlavor -> Bool
278 isWanted (Wanted {}) = True
281 isGiven :: CtFlavor -> Bool
282 isGiven (Given {}) = True
285 isDerived :: CtFlavor -> Bool
286 isDerived (Derived {}) = True
289 canRewrite :: CtFlavor -> CtFlavor -> Bool
290 -- canRewrite ctid1 ctid2
291 -- The constraint ctid1 can be used to rewrite ctid2
292 canRewrite (Given {}) _ = True
293 canRewrite (Derived {}) (Wanted {}) = True
294 canRewrite (Derived {}) (Derived {}) = True
295 canRewrite (Wanted {}) (Wanted {}) = True
296 canRewrite _ _ = False
298 joinFlavors :: CtFlavor -> CtFlavor -> CtFlavor
299 joinFlavors (Wanted loc) _ = Wanted loc
300 joinFlavors _ (Wanted loc) = Wanted loc
301 joinFlavors (Derived loc) _ = Derived loc
302 joinFlavors _ (Derived loc) = Derived loc
303 joinFlavors (Given loc) _ = Given loc
305 mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
306 mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk)
307 mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk)
308 mkGivenFlavor (Given loc) sk = Given (setCtLocOrigin loc sk)
312 %************************************************************************
314 %* The TcS solver monad *
316 %************************************************************************
320 The TcS monad is a weak form of the main Tc monad
324 * allocate new variables
325 * fill in evidence variables
327 Filling in a dictionary evidence variable means to create a binding
328 for it, so TcS carries a mutable location where the binding can be
329 added. This is initialised from the innermost implication constraint.
334 tcs_ev_binds :: EvBindsVar,
337 tcs_ty_binds :: IORef (Bag (TcTyVar, TcType)),
338 -- Global type bindings
340 tcs_context :: SimplContext
344 = SimplInfer -- Inferring type of a let-bound thing
345 | SimplRuleLhs -- Inferring type of a RULE lhs
346 | SimplInteractive -- Inferring type at GHCi prompt
347 | SimplCheck -- Checking a type signature or RULE rhs
349 instance Outputable SimplContext where
350 ppr SimplInfer = ptext (sLit "SimplInfer")
351 ppr SimplRuleLhs = ptext (sLit "SimplRuleLhs")
352 ppr SimplInteractive = ptext (sLit "SimplInteractive")
353 ppr SimplCheck = ptext (sLit "SimplCheck")
355 isInteractive :: SimplContext -> Bool
356 isInteractive SimplInteractive = True
357 isInteractive _ = False
359 simplEqsOnly :: SimplContext -> Bool
360 -- Simplify equalities only, not dictionaries
361 -- This is used for the LHS of rules; ee
362 -- Note [Simplifying RULE lhs constraints] in TcSimplify
363 simplEqsOnly SimplRuleLhs = True
364 simplEqsOnly _ = False
366 performDefaulting :: SimplContext -> Bool
367 performDefaulting SimplInfer = False
368 performDefaulting SimplRuleLhs = False
369 performDefaulting SimplInteractive = True
370 performDefaulting SimplCheck = True
373 newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a }
375 instance Functor TcS where
376 fmap f m = TcS $ fmap f . unTcS m
378 instance Monad TcS where
379 return x = TcS (\_ -> return x)
380 fail err = TcS (\_ -> fail err)
381 m >>= k = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs)
383 -- Basic functionality
384 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
385 wrapTcS :: TcM a -> TcS a
386 -- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS,
387 -- and TcS is supposed to have limited functionality
388 wrapTcS = TcS . const -- a TcM action will not use the TcEvBinds
390 wrapErrTcS :: TcM a -> TcS a
391 -- The thing wrapped should just fail
392 -- There's no static check; it's up to the user
393 -- Having a variant for each error message is too painful
396 wrapWarnTcS :: TcM a -> TcS a
397 -- The thing wrapped should just add a warning, or no-op
398 -- There's no static check; it's up to the user
399 wrapWarnTcS = wrapTcS
401 failTcS, panicTcS :: SDoc -> TcS a
402 failTcS = wrapTcS . TcM.failWith
403 panicTcS doc = pprPanic "TcCanonical" doc
405 traceTcS :: String -> SDoc -> TcS ()
406 traceTcS herald doc = TcS $ \_env -> TcM.traceTc herald doc
408 traceTcS0 :: String -> SDoc -> TcS ()
409 traceTcS0 herald doc = TcS $ \_env -> TcM.traceTcN 0 herald doc
411 runTcS :: SimplContext
412 -> TcTyVarSet -- Untouchables
413 -> TcS a -- What to run
414 -> TcM (a, Bag EvBind)
415 runTcS context untouch tcs
416 = do { ty_binds_var <- TcM.newTcRef emptyBag
417 ; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds
418 ; let env = TcSEnv { tcs_ev_binds = ev_binds_var
419 , tcs_ty_binds = ty_binds_var
420 , tcs_context = context }
422 -- Run the computation
423 ; res <- TcM.setUntouchables untouch (unTcS tcs env)
425 -- Perform the type unifications required
426 ; ty_binds <- TcM.readTcRef ty_binds_var
427 ; mapBagM_ do_unification ty_binds
430 ; ev_binds <- TcM.readTcRef evb_ref
431 ; return (res, evBindMapBinds ev_binds) }
433 do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
435 nestImplicTcS :: EvBindsVar -> TcTyVarSet -> TcS a -> TcS a
436 nestImplicTcS ref untouch tcs
437 = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds, tcs_context = ctxt } ->
439 nest_env = TcSEnv { tcs_ev_binds = ref
440 , tcs_ty_binds = ty_binds
441 , tcs_context = ctxtUnderImplic ctxt }
443 TcM.setUntouchables untouch (unTcS tcs nest_env)
445 ctxtUnderImplic :: SimplContext -> SimplContext
446 -- See Note [Simplifying RULE lhs constraints] in TcSimplify
447 ctxtUnderImplic SimplRuleLhs = SimplCheck
448 ctxtUnderImplic ctxt = ctxt
450 tryTcS :: TcTyVarSet -> TcS a -> TcS a
451 -- Like runTcS, but from within the TcS monad
452 -- Ignore all the evidence generated, and do not affect caller's evidence!
454 = TcS (\env -> do { ty_binds_var <- TcM.newTcRef emptyBag
455 ; ev_binds_var <- TcM.newTcEvBinds
456 ; let env1 = env { tcs_ev_binds = ev_binds_var
457 , tcs_ty_binds = ty_binds_var }
458 ; TcM.setUntouchables untch (unTcS tcs env1) })
461 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
463 getDynFlags :: TcS DynFlags
464 getDynFlags = wrapTcS TcM.getDOpts
466 getTcSContext :: TcS SimplContext
467 getTcSContext = TcS (return . tcs_context)
469 getTcEvBinds :: TcS EvBindsVar
470 getTcEvBinds = TcS (return . tcs_ev_binds)
472 getTcSTyBinds :: TcS (IORef (Bag (TcTyVar, TcType)))
473 getTcSTyBinds = TcS (return . tcs_ty_binds)
475 getTcEvBindsBag :: TcS EvBindMap
477 = do { EvBindsVar ev_ref _ <- getTcEvBinds
478 ; wrapTcS $ TcM.readTcRef ev_ref }
480 setWantedCoBind :: CoVar -> Coercion -> TcS ()
481 setWantedCoBind cv co
482 = setEvBind cv (EvCoercion co)
483 -- Was: wrapTcS $ TcM.writeWantedCoVar cv co
485 setDerivedCoBind :: CoVar -> Coercion -> TcS ()
486 setDerivedCoBind cv co
487 = setEvBind cv (EvCoercion co)
489 setWantedTyBind :: TcTyVar -> TcType -> TcS ()
490 -- Add a type binding
491 setWantedTyBind tv ty
492 = do { ref <- getTcSTyBinds
494 do { ty_binds <- TcM.readTcRef ref
495 ; TcM.writeTcRef ref (ty_binds `snocBag` (tv,ty)) } }
497 setIPBind :: EvVar -> EvTerm -> TcS ()
498 setIPBind = setEvBind
500 setDictBind :: EvVar -> EvTerm -> TcS ()
501 setDictBind = setEvBind
503 setEvBind :: EvVar -> EvTerm -> TcS ()
506 = do { tc_evbinds <- getTcEvBinds
507 ; wrapTcS (TcM.addTcEvBind tc_evbinds ev rhs) }
509 newTcEvBindsTcS :: TcS EvBindsVar
510 newTcEvBindsTcS = wrapTcS (TcM.newTcEvBinds)
512 warnTcS :: CtLoc orig -> Bool -> SDoc -> TcS ()
513 warnTcS loc warn_if doc
514 | warn_if = wrapTcS $ TcM.setCtLoc loc $ TcM.addWarnTc doc
515 | otherwise = return ()
517 getDefaultInfo :: TcS (SimplContext, [Type], (Bool, Bool))
519 = do { ctxt <- getTcSContext
520 ; (tys, flags) <- wrapTcS (TcM.tcGetDefaultTys (isInteractive ctxt))
521 ; return (ctxt, tys, flags) }
523 -- Just get some environments needed for instance looking up and matching
524 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
526 getInstEnvs :: TcS (InstEnv, InstEnv)
527 getInstEnvs = wrapTcS $ Inst.tcGetInstEnvs
529 getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)
530 getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs
532 getTopEnv :: TcS HscEnv
533 getTopEnv = wrapTcS $ TcM.getTopEnv
535 getGblEnv :: TcS TcGblEnv
536 getGblEnv = wrapTcS $ TcM.getGblEnv
538 getUntouchablesTcS :: TcS TcTyVarSet
539 getUntouchablesTcS = wrapTcS $ TcM.getUntouchables
541 -- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
542 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
544 checkWellStagedDFun :: PredType -> DFunId -> WantedLoc -> TcS ()
545 checkWellStagedDFun pred dfun_id loc
546 = wrapTcS $ TcM.setCtLoc loc $
547 do { use_stage <- TcM.getStage
548 ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }
550 pp_thing = ptext (sLit "instance for") <+> quotes (ppr pred)
551 bind_lvl = TcM.topIdLvl dfun_id
553 pprEq :: TcType -> TcType -> SDoc
554 pprEq ty1 ty2 = pprPred $ mkEqPred (ty1,ty2)
556 isTouchableMetaTyVar :: TcTyVar -> TcS Bool
557 -- is touchable variable!
558 isTouchableMetaTyVar v
559 | isMetaTyVar v = wrapTcS $ do { untch <- TcM.isUntouchable v;
560 ; return (not untch) }
561 | otherwise = return False
565 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
567 newFlattenSkolemTy :: TcType -> TcS TcType
568 newFlattenSkolemTy ty = mkTyVarTy <$> newFlattenSkolemTyVar ty
569 where newFlattenSkolemTyVar :: TcType -> TcS TcTyVar
570 newFlattenSkolemTyVar ty
571 = wrapTcS $ do { uniq <- TcM.newUnique
572 ; let name = mkSysTvName uniq (fsLit "f")
573 ; return $ mkTcTyVar name (typeKind ty) (FlatSkol ty)
577 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
579 instDFunTypes :: [Either TyVar TcType] -> TcS [TcType]
580 instDFunTypes mb_inst_tys =
581 let inst_tv :: Either TyVar TcType -> TcS Type
582 inst_tv (Left tv) = wrapTcS $ TcM.tcInstTyVar tv >>= return . mkTyVarTy
583 inst_tv (Right ty) = return ty
584 in mapM inst_tv mb_inst_tys
587 instDFunConstraints :: TcThetaType -> TcS [EvVar]
588 instDFunConstraints preds = wrapTcS $ TcM.newWantedEvVars preds
591 -- Superclasses and recursive dictionaries
592 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
594 newGivOrDerEvVar :: TcPredType -> EvTerm -> TcS EvVar
595 newGivOrDerEvVar pty evtrm
596 = do { ev <- wrapTcS $ TcM.newEvVar pty
600 newGivOrDerCoVar :: TcType -> TcType -> Coercion -> TcS EvVar
601 -- Note we create immutable variables for given or derived, since we
602 -- must bind them to TcEvBinds (because their evidence may involve
603 -- superclasses). However we should be able to override existing
604 -- 'derived' evidence, even in TcEvBinds
605 newGivOrDerCoVar ty1 ty2 co
606 = do { cv <- newCoVar ty1 ty2
607 ; setEvBind cv (EvCoercion co)
610 newWantedCoVar :: TcType -> TcType -> TcS EvVar
611 newWantedCoVar ty1 ty2 = wrapTcS $ TcM.newWantedCoVar ty1 ty2
613 newKindConstraint :: TcType -> Kind -> TcS (CoVar, TcType)
614 newKindConstraint ty kind = wrapTcS $ TcM.newKindConstraint ty kind
616 newCoVar :: TcType -> TcType -> TcS EvVar
617 newCoVar ty1 ty2 = wrapTcS $ TcM.newCoVar ty1 ty2
619 newIPVar :: IPName Name -> TcType -> TcS EvVar
620 newIPVar nm ty = wrapTcS $ TcM.newIP nm ty
622 newDictVar :: Class -> [TcType] -> TcS EvVar
623 newDictVar cl tys = wrapTcS $ TcM.newDict cl tys
628 isGoodRecEv :: EvVar -> WantedEvVar -> TcS Bool
629 -- In a call (isGoodRecEv ev wv), we are considering solving wv
630 -- using some term that involves ev, such as:
631 -- by setting wv = ev
632 -- or wv = EvCast x |> ev
634 -- But that would be Very Bad if the evidence for 'ev' mentions 'wv',
635 -- in an "unguarded" way. So isGoodRecEv looks at the evidence ev
636 -- recursively through the evidence binds, to see if uses of 'wv' are guarded.
638 -- Guarded means: more instance calls than superclass selections. We
639 -- compute this by chasing the evidence, adding +1 for every instance
640 -- call (constructor) and -1 for every superclass selection (destructor).
642 -- See Note [Superclasses and recursive dictionaries] in TcInteract
643 isGoodRecEv ev_var (WantedEvVar wv _)
644 = do { tc_evbinds <- getTcEvBindsBag
645 ; mb <- chase_ev_var tc_evbinds wv 0 [] ev_var
646 ; return $ case mb of
648 Just min_guardedness -> min_guardedness > 0
651 where chase_ev_var :: EvBindMap -- Evidence binds
652 -> EvVar -- Target variable whose gravity we want to return
653 -> Int -- Current gravity
654 -> [EvVar] -- Visited nodes
655 -> EvVar -- Current node
657 chase_ev_var assocs trg curr_grav visited orig
658 | trg == orig = return $ Just curr_grav
659 | orig `elem` visited = return $ Nothing
660 | Just (EvBind _ ev_trm) <- lookupEvBind assocs orig
661 = chase_ev assocs trg curr_grav (orig:visited) ev_trm
663 {- No longer needed: evidence is in the EvBinds
664 | isTcTyVar orig && isMetaTyVar orig
665 = do { meta_details <- wrapTcS $ TcM.readWantedCoVar orig
666 ; case meta_details of
667 Flexi -> return Nothing
668 Indirect tyco -> chase_ev assocs trg curr_grav
669 (orig:visited) (EvCoercion tyco)
672 | otherwise = return Nothing
674 chase_ev assocs trg curr_grav visited (EvId v)
675 = chase_ev_var assocs trg curr_grav visited v
676 chase_ev assocs trg curr_grav visited (EvSuperClass d_id _)
677 = chase_ev_var assocs trg (curr_grav-1) visited d_id
678 chase_ev assocs trg curr_grav visited (EvCast v co)
679 = do { m1 <- chase_ev_var assocs trg curr_grav visited v
680 ; m2 <- chase_co assocs trg curr_grav visited co
681 ; return (comb_chase_res Nothing [m1,m2]) }
683 chase_ev assocs trg curr_grav visited (EvCoercion co)
684 = chase_co assocs trg curr_grav visited co
685 chase_ev assocs trg curr_grav visited (EvDFunApp _ _ ev_vars)
686 = do { chase_results <- mapM (chase_ev_var assocs trg (curr_grav+1) visited) ev_vars
687 ; return (comb_chase_res Nothing chase_results) }
689 chase_co assocs trg curr_grav visited co
690 = -- Look for all the coercion variables in the coercion
691 -- chase them, and combine the results. This is OK since the
692 -- coercion will not contain any superclass terms -- anything
693 -- that involves dictionaries will be bound in assocs.
694 let co_vars = foldVarSet (\v vrs -> if isCoVar v then (v:vrs) else vrs) []
696 in do { chase_results <- mapM (chase_ev_var assocs trg curr_grav visited) co_vars
697 ; return (comb_chase_res Nothing chase_results) }
699 comb_chase_res f [] = f
700 comb_chase_res f (Nothing:rest) = comb_chase_res f rest
701 comb_chase_res Nothing (Just n:rest) = comb_chase_res (Just n) rest
702 comb_chase_res (Just m) (Just n:rest) = comb_chase_res (Just (min n m)) rest
705 -- Matching and looking up classes and family instances
706 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
708 data MatchInstResult mi
709 = MatchInstNo -- No matching instance
710 | MatchInstSingle mi -- Single matching instance
711 | MatchInstMany -- Multiple matching instances
714 matchClass :: Class -> [Type] -> TcS (MatchInstResult (DFunId, [Either TyVar TcType]))
715 -- Look up a class constraint in the instance environment
717 = do { let pred = mkClassPred clas tys
718 ; instEnvs <- getInstEnvs
719 ; case lookupInstEnv instEnvs clas tys of {
720 ([], unifs) -- Nothing matches
721 -> do { traceTcS "matchClass not matching"
722 (vcat [ text "dict" <+> ppr pred,
723 text "unifs" <+> ppr unifs ])
726 ([(ispec, inst_tys)], []) -- A single match
727 -> do { let dfun_id = is_dfun ispec
728 ; traceTcS "matchClass success"
729 (vcat [text "dict" <+> ppr pred,
730 text "witness" <+> ppr dfun_id
731 <+> ppr (idType dfun_id) ])
732 -- Record that this dfun is needed
733 ; record_dfun_usage dfun_id
734 ; return $ MatchInstSingle (dfun_id, inst_tys)
736 (matches, unifs) -- More than one matches
737 -> do { traceTcS "matchClass multiple matches, deferring choice"
738 (vcat [text "dict" <+> ppr pred,
739 text "matches" <+> ppr matches,
740 text "unifs" <+> ppr unifs])
741 ; return MatchInstMany
745 where record_dfun_usage :: Id -> TcS ()
746 record_dfun_usage dfun_id
747 = do { hsc_env <- getTopEnv
748 ; let dfun_name = idName dfun_id
749 dfun_mod = ASSERT( isExternalName dfun_name )
751 ; if isInternalName dfun_name || -- Internal name => defined in this module
752 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
753 then return () -- internal, or in another package
754 else do updInstUses dfun_id
757 updInstUses :: Id -> TcS ()
759 = do { tcg_env <- getGblEnv
760 ; wrapTcS $ TcM.updMutVar (tcg_inst_uses tcg_env)
761 (`addOneToNameSet` idName dfun_id)
766 -> TcS (MatchInstResult (TyCon, [Type]))
768 = do { mb <- wrapTcS $ TcM.tcLookupFamInst tycon args
770 Nothing -> return MatchInstNo
771 Just res -> return $ MatchInstSingle res
772 -- DV: We never return MatchInstMany, since tcLookupFamInst never returns
773 -- multiple matches. Check.
777 -- Functional dependencies, instantiation of equations
778 -------------------------------------------------------
780 mkWantedFunDepEqns :: WantedLoc -> [(Equation, (PredType, SDoc), (PredType, SDoc))]
782 mkWantedFunDepEqns _ [] = return []
783 mkWantedFunDepEqns loc eqns
784 = do { traceTcS "Improve:" (vcat (map pprEquationDoc eqns))
785 ; wevvars <- mapM to_work_item eqns
786 ; return $ concat wevvars }
788 to_work_item :: (Equation, (PredType,SDoc), (PredType,SDoc)) -> TcS [WantedEvVar]
789 to_work_item ((qtvs, pairs), _, _)
790 = do { (_, _, tenv) <- wrapTcS $ TcM.tcInstTyVars (varSetElems qtvs)
791 ; mapM (do_one tenv) pairs }
793 do_one tenv (ty1, ty2) = do { let sty1 = substTy tenv ty1
794 sty2 = substTy tenv ty2
795 ; ev <- newWantedCoVar sty1 sty2
796 ; return (WantedEvVar ev loc) }
798 pprEquationDoc :: (Equation, (PredType, SDoc), (PredType, SDoc)) -> SDoc
799 pprEquationDoc (eqn, (p1, _), (p2, _))
800 = vcat [pprEquation eqn, nest 2 (ppr p1), nest 2 (ppr p2)]