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, getTcSTyBindsMap,
37 newFlattenSkolemTy, -- Flatten skolems
40 instDFunTypes, -- Instantiation
47 getDefaultInfo, getDynFlags,
49 matchClass, matchFam, MatchInstResult (..),
52 pprEq, -- Smaller utils, re-exported from TcM
53 -- TODO (DV): these are only really used in the
54 -- instance matcher in TcSimplify. I am wondering
55 -- if the whole instance matcher simply belongs
59 mkWantedFunDepEqns -- Instantiation of 'Equations' from FunDeps
63 #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 )
97 import HsBinds -- for TcEvBinds stuff
108 %************************************************************************
110 %* Canonical constraints *
112 %* These are the constraints the low-level simplifier works with *
114 %************************************************************************
117 -- Types without any type functions inside. However, note that xi
118 -- types CAN contain unexpanded type synonyms; however, the
119 -- (transitive) expansions of those type synonyms will not contain any
121 type Xi = Type -- In many comments, "xi" ranges over Xi
123 type CanonicalCts = Bag CanonicalCt
126 -- Atomic canonical constraints
127 = CDictCan { -- e.g. Num xi
129 cc_flavor :: CtFlavor,
134 | CIPCan { -- ?x::tau
135 -- See note [Canonical implicit parameter constraints].
137 cc_flavor :: CtFlavor,
138 cc_ip_nm :: IPName Name,
139 cc_ip_ty :: TcTauType
142 | CTyEqCan { -- tv ~ xi (recall xi means function free)
144 -- * tv not in tvs(xi) (occurs check)
145 -- * If tv is a MetaTyVar, then typeKind xi <: typeKind tv
146 -- a skolem, then typeKind xi = typeKind tv
148 cc_flavor :: CtFlavor,
153 | CFunEqCan { -- F xis ~ xi
154 -- Invariant: * isSynFamilyTyCon cc_fun
155 -- * cc_rhs is not a touchable unification variable
156 -- See Note [No touchables as FunEq RHS]
157 -- * typeKind (TyConApp cc_fun cc_tyargs) == typeKind cc_rhs
159 cc_flavor :: CtFlavor,
160 cc_fun :: TyCon, -- A type function
161 cc_tyargs :: [Xi], -- Either under-saturated or exactly saturated
162 cc_rhs :: Xi -- *never* over-saturated (because if so
163 -- we should have decomposed)
167 makeGivens :: CanonicalCts -> CanonicalCts
168 makeGivens = mapBag (\ct -> ct { cc_flavor = mkGivenFlavor (cc_flavor ct) UnkSkol })
169 -- The UnkSkol doesn't matter because these givens are
170 -- not contradictory (else we'd have rejected them already)
172 makeSolved :: CanonicalCt -> CanonicalCt
173 -- Record that a constraint is now solved
175 -- Given, Derived -> no-op
177 | Wanted loc <- cc_flavor ct = ct { cc_flavor = Derived loc }
180 mkWantedConstraints :: CanonicalCts -> Bag Implication -> WantedConstraints
181 mkWantedConstraints flats implics
182 = mapBag (WcEvVar . deCanonicaliseWanted) flats `unionBags` mapBag WcImplic implics
184 deCanonicaliseWanted :: CanonicalCt -> WantedEvVar
185 deCanonicaliseWanted ct
186 = WARN( not (isWanted $ cc_flavor ct), ppr ct )
187 let Wanted loc = cc_flavor ct
188 in WantedEvVar (cc_id ct) loc
190 tyVarsOfCanonical :: CanonicalCt -> TcTyVarSet
191 tyVarsOfCanonical (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) = extendVarSet (tyVarsOfType xi) tv
192 tyVarsOfCanonical (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys)
193 tyVarsOfCanonical (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
194 tyVarsOfCanonical (CIPCan { cc_ip_ty = ty }) = tyVarsOfType ty
196 tyVarsOfCanonicals :: CanonicalCts -> TcTyVarSet
197 tyVarsOfCanonicals = foldrBag (unionVarSet . tyVarsOfCanonical) emptyVarSet
199 instance Outputable CanonicalCt where
200 ppr (CDictCan d fl cls tys)
201 = ppr fl <+> ppr d <+> dcolon <+> pprClassPred cls tys
202 ppr (CIPCan ip fl ip_nm ty)
203 = ppr fl <+> ppr ip <+> dcolon <+> parens (ppr ip_nm <> dcolon <> ppr ty)
204 ppr (CTyEqCan co fl tv ty)
205 = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyVarTy tv, ty)
206 ppr (CFunEqCan co fl tc tys ty)
207 = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyConApp tc tys, ty)
211 Note [No touchables as FunEq RHS]
212 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
213 Notice that (F xis ~ beta), where beta is an touchable unification
214 variable, is not canonical. Why?
215 * If (F xis ~ beta) was the only wanted constraint, we'd
216 definitely want to spontaneously-unify it
218 * But suppose we had an earlier wanted (beta ~ Int), and
219 have already spontaneously unified it. Then we have an
220 identity given (id : beta ~ Int) in the inert set.
222 * But (F xis ~ beta) does not react with that given (because we
223 don't subsitute on the RHS of a function equality). So there's a
224 serious danger that we'd spontaneously unify it a second time.
228 Note [Canonical implicit parameter constraints]
229 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
230 The type in a canonical implicit parameter constraint doesn't need to
231 be a xi (type-function-free type) since we can defer the flattening
232 until checking this type for equality with another type. If we
233 encounter two IP constraints with the same name, they MUST have the
234 same type, and at that point we can generate a flattened equality
235 constraint between the types. (On the other hand, the types in two
236 class constraints for the same class MAY be equal, so they need to be
237 flattened in the first place to facilitate comparing them.)
240 singleCCan :: CanonicalCt -> CanonicalCts
243 andCCan :: CanonicalCts -> CanonicalCts -> CanonicalCts
246 extendCCans :: CanonicalCts -> CanonicalCt -> CanonicalCts
247 extendCCans = snocBag
249 andCCans :: [CanonicalCts] -> CanonicalCts
250 andCCans = unionManyBags
252 emptyCCan :: CanonicalCts
255 isEmptyCCan :: CanonicalCts -> Bool
256 isEmptyCCan = isEmptyBag
259 %************************************************************************
262 The "flavor" of a canonical constraint
264 %************************************************************************
268 = Given GivenLoc -- We have evidence for this constraint in TcEvBinds
269 | Derived WantedLoc -- We have evidence for this constraint in TcEvBinds;
270 -- *however* this evidence can contain wanteds, so
271 -- it's valid only provisionally to the solution of
273 | Wanted WantedLoc -- We have no evidence bindings for this constraint.
275 instance Outputable CtFlavor where
276 ppr (Given _) = ptext (sLit "[Given]")
277 ppr (Wanted _) = ptext (sLit "[Wanted]")
278 ppr (Derived _) = ptext (sLit "[Derived]")
280 isWanted :: CtFlavor -> Bool
281 isWanted (Wanted {}) = True
284 isGiven :: CtFlavor -> Bool
285 isGiven (Given {}) = True
288 isDerived :: CtFlavor -> Bool
289 isDerived (Derived {}) = True
292 canRewrite :: CtFlavor -> CtFlavor -> Bool
293 -- canRewrite ctid1 ctid2
294 -- The constraint ctid1 can be used to rewrite ctid2
295 canRewrite (Given {}) _ = True
296 canRewrite (Derived {}) (Wanted {}) = True
297 canRewrite (Derived {}) (Derived {}) = True
298 canRewrite (Wanted {}) (Wanted {}) = True
299 canRewrite _ _ = False
301 joinFlavors :: CtFlavor -> CtFlavor -> CtFlavor
302 joinFlavors (Wanted loc) _ = Wanted loc
303 joinFlavors _ (Wanted loc) = Wanted loc
304 joinFlavors (Derived loc) _ = Derived loc
305 joinFlavors _ (Derived loc) = Derived loc
306 joinFlavors (Given loc) _ = Given loc
308 mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
309 mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk)
310 mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk)
311 mkGivenFlavor (Given loc) sk = Given (setCtLocOrigin loc sk)
315 %************************************************************************
317 %* The TcS solver monad *
319 %************************************************************************
323 The TcS monad is a weak form of the main Tc monad
327 * allocate new variables
328 * fill in evidence variables
330 Filling in a dictionary evidence variable means to create a binding
331 for it, so TcS carries a mutable location where the binding can be
332 added. This is initialised from the innermost implication constraint.
337 tcs_ev_binds :: EvBindsVar,
340 tcs_ty_binds :: IORef (TyVarEnv (TcTyVar, TcType)),
341 -- Global type bindings
343 tcs_context :: SimplContext
347 = SimplInfer -- Inferring type of a let-bound thing
348 | SimplRuleLhs -- Inferring type of a RULE lhs
349 | SimplInteractive -- Inferring type at GHCi prompt
350 | SimplCheck -- Checking a type signature or RULE rhs
352 instance Outputable SimplContext where
353 ppr SimplInfer = ptext (sLit "SimplInfer")
354 ppr SimplRuleLhs = ptext (sLit "SimplRuleLhs")
355 ppr SimplInteractive = ptext (sLit "SimplInteractive")
356 ppr SimplCheck = ptext (sLit "SimplCheck")
358 isInteractive :: SimplContext -> Bool
359 isInteractive SimplInteractive = True
360 isInteractive _ = False
362 simplEqsOnly :: SimplContext -> Bool
363 -- Simplify equalities only, not dictionaries
364 -- This is used for the LHS of rules; ee
365 -- Note [Simplifying RULE lhs constraints] in TcSimplify
366 simplEqsOnly SimplRuleLhs = True
367 simplEqsOnly _ = False
369 performDefaulting :: SimplContext -> Bool
370 performDefaulting SimplInfer = False
371 performDefaulting SimplRuleLhs = False
372 performDefaulting SimplInteractive = True
373 performDefaulting SimplCheck = True
376 newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a }
378 instance Functor TcS where
379 fmap f m = TcS $ fmap f . unTcS m
381 instance Monad TcS where
382 return x = TcS (\_ -> return x)
383 fail err = TcS (\_ -> fail err)
384 m >>= k = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs)
386 -- Basic functionality
387 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
388 wrapTcS :: TcM a -> TcS a
389 -- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS,
390 -- and TcS is supposed to have limited functionality
391 wrapTcS = TcS . const -- a TcM action will not use the TcEvBinds
393 wrapErrTcS :: TcM a -> TcS a
394 -- The thing wrapped should just fail
395 -- There's no static check; it's up to the user
396 -- Having a variant for each error message is too painful
399 wrapWarnTcS :: TcM a -> TcS a
400 -- The thing wrapped should just add a warning, or no-op
401 -- There's no static check; it's up to the user
402 wrapWarnTcS = wrapTcS
404 failTcS, panicTcS :: SDoc -> TcS a
405 failTcS = wrapTcS . TcM.failWith
406 panicTcS doc = pprPanic "TcCanonical" doc
408 traceTcS :: String -> SDoc -> TcS ()
409 traceTcS herald doc = TcS $ \_env -> TcM.traceTc herald doc
411 traceTcS0 :: String -> SDoc -> TcS ()
412 traceTcS0 herald doc = TcS $ \_env -> TcM.traceTcN 0 herald doc
414 runTcS :: SimplContext
415 -> TcTyVarSet -- Untouchables
416 -> TcS a -- What to run
417 -> TcM (a, Bag EvBind)
418 runTcS context untouch tcs
419 = do { ty_binds_var <- TcM.newTcRef emptyVarEnv
420 ; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds
421 ; let env = TcSEnv { tcs_ev_binds = ev_binds_var
422 , tcs_ty_binds = ty_binds_var
423 , tcs_context = context }
425 -- Run the computation
426 ; res <- TcM.setUntouchables untouch (unTcS tcs env)
428 -- Perform the type unifications required
429 ; ty_binds <- TcM.readTcRef ty_binds_var
430 ; mapM_ do_unification (varEnvElts ty_binds)
433 ; ev_binds <- TcM.readTcRef evb_ref
434 ; return (res, evBindMapBinds ev_binds) }
436 do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
439 nestImplicTcS :: EvBindsVar -> TcTyVarSet -> TcS a -> TcS a
440 nestImplicTcS ref untouch tcs
441 = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds, tcs_context = ctxt } ->
443 nest_env = TcSEnv { tcs_ev_binds = ref
444 , tcs_ty_binds = ty_binds
445 , tcs_context = ctxtUnderImplic ctxt }
447 TcM.setUntouchables untouch (unTcS tcs nest_env)
449 ctxtUnderImplic :: SimplContext -> SimplContext
450 -- See Note [Simplifying RULE lhs constraints] in TcSimplify
451 ctxtUnderImplic SimplRuleLhs = SimplCheck
452 ctxtUnderImplic ctxt = ctxt
454 tryTcS :: TcTyVarSet -> TcS a -> TcS a
455 -- Like runTcS, but from within the TcS monad
456 -- Ignore all the evidence generated, and do not affect caller's evidence!
458 = TcS (\env -> do { ty_binds_var <- TcM.newTcRef emptyVarEnv
459 ; ev_binds_var <- TcM.newTcEvBinds
460 ; let env1 = env { tcs_ev_binds = ev_binds_var
461 , tcs_ty_binds = ty_binds_var }
462 ; TcM.setUntouchables untch (unTcS tcs env1) })
465 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
467 getDynFlags :: TcS DynFlags
468 getDynFlags = wrapTcS TcM.getDOpts
470 getTcSContext :: TcS SimplContext
471 getTcSContext = TcS (return . tcs_context)
473 getTcEvBinds :: TcS EvBindsVar
474 getTcEvBinds = TcS (return . tcs_ev_binds)
476 getTcSTyBinds :: TcS (IORef (TyVarEnv (TcTyVar, TcType)))
477 getTcSTyBinds = TcS (return . tcs_ty_binds)
479 getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType))
480 getTcSTyBindsMap = getTcSTyBinds >>= wrapTcS . (TcM.readTcRef)
483 getTcEvBindsBag :: TcS EvBindMap
485 = do { EvBindsVar ev_ref _ <- getTcEvBinds
486 ; wrapTcS $ TcM.readTcRef ev_ref }
488 setWantedCoBind :: CoVar -> Coercion -> TcS ()
489 setWantedCoBind cv co
490 = setEvBind cv (EvCoercion co)
491 -- Was: wrapTcS $ TcM.writeWantedCoVar cv co
493 setDerivedCoBind :: CoVar -> Coercion -> TcS ()
494 setDerivedCoBind cv co
495 = setEvBind cv (EvCoercion co)
497 setWantedTyBind :: TcTyVar -> TcType -> TcS ()
498 -- Add a type binding
499 setWantedTyBind tv ty
500 = do { ref <- getTcSTyBinds
502 do { ty_binds <- TcM.readTcRef ref
503 ; TcM.writeTcRef ref (extendVarEnv ty_binds tv (tv,ty)) } }
505 setIPBind :: EvVar -> EvTerm -> TcS ()
506 setIPBind = setEvBind
508 setDictBind :: EvVar -> EvTerm -> TcS ()
509 setDictBind = setEvBind
511 setEvBind :: EvVar -> EvTerm -> TcS ()
514 = do { tc_evbinds <- getTcEvBinds
515 ; wrapTcS (TcM.addTcEvBind tc_evbinds ev rhs) }
517 newTcEvBindsTcS :: TcS EvBindsVar
518 newTcEvBindsTcS = wrapTcS (TcM.newTcEvBinds)
520 warnTcS :: CtLoc orig -> Bool -> SDoc -> TcS ()
521 warnTcS loc warn_if doc
522 | warn_if = wrapTcS $ TcM.setCtLoc loc $ TcM.addWarnTc doc
523 | otherwise = return ()
525 getDefaultInfo :: TcS (SimplContext, [Type], (Bool, Bool))
527 = do { ctxt <- getTcSContext
528 ; (tys, flags) <- wrapTcS (TcM.tcGetDefaultTys (isInteractive ctxt))
529 ; return (ctxt, tys, flags) }
531 -- Just get some environments needed for instance looking up and matching
532 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
534 getInstEnvs :: TcS (InstEnv, InstEnv)
535 getInstEnvs = wrapTcS $ Inst.tcGetInstEnvs
537 getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)
538 getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs
540 getTopEnv :: TcS HscEnv
541 getTopEnv = wrapTcS $ TcM.getTopEnv
543 getGblEnv :: TcS TcGblEnv
544 getGblEnv = wrapTcS $ TcM.getGblEnv
546 getUntouchablesTcS :: TcS TcTyVarSet
547 getUntouchablesTcS = wrapTcS $ TcM.getUntouchables
549 -- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
550 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
552 checkWellStagedDFun :: PredType -> DFunId -> WantedLoc -> TcS ()
553 checkWellStagedDFun pred dfun_id loc
554 = wrapTcS $ TcM.setCtLoc loc $
555 do { use_stage <- TcM.getStage
556 ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }
558 pp_thing = ptext (sLit "instance for") <+> quotes (ppr pred)
559 bind_lvl = TcM.topIdLvl dfun_id
561 pprEq :: TcType -> TcType -> SDoc
562 pprEq ty1 ty2 = pprPred $ mkEqPred (ty1,ty2)
564 isTouchableMetaTyVar :: TcTyVar -> TcS Bool
565 -- is touchable variable!
566 isTouchableMetaTyVar v
567 | isMetaTyVar v = wrapTcS $ do { untch <- TcM.isUntouchable v;
568 ; return (not untch) }
569 | otherwise = return False
573 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
575 newFlattenSkolemTy :: TcType -> TcS TcType
576 newFlattenSkolemTy ty = mkTyVarTy <$> newFlattenSkolemTyVar ty
577 where newFlattenSkolemTyVar :: TcType -> TcS TcTyVar
578 newFlattenSkolemTyVar ty
579 = wrapTcS $ do { uniq <- TcM.newUnique
580 ; let name = mkSysTvName uniq (fsLit "f")
582 mkTcTyVar name (typeKind ty) (FlatSkol ty)
586 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
588 instDFunTypes :: [Either TyVar TcType] -> TcS [TcType]
589 instDFunTypes mb_inst_tys =
590 let inst_tv :: Either TyVar TcType -> TcS Type
591 inst_tv (Left tv) = wrapTcS $ TcM.tcInstTyVar tv >>= return . mkTyVarTy
592 inst_tv (Right ty) = return ty
593 in mapM inst_tv mb_inst_tys
596 instDFunConstraints :: TcThetaType -> TcS [EvVar]
597 instDFunConstraints preds = wrapTcS $ TcM.newWantedEvVars preds
600 -- Superclasses and recursive dictionaries
601 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
603 newGivOrDerEvVar :: TcPredType -> EvTerm -> TcS EvVar
604 newGivOrDerEvVar pty evtrm
605 = do { ev <- wrapTcS $ TcM.newEvVar pty
609 newGivOrDerCoVar :: TcType -> TcType -> Coercion -> TcS EvVar
610 -- Note we create immutable variables for given or derived, since we
611 -- must bind them to TcEvBinds (because their evidence may involve
612 -- superclasses). However we should be able to override existing
613 -- 'derived' evidence, even in TcEvBinds
614 newGivOrDerCoVar ty1 ty2 co
615 = do { cv <- newCoVar ty1 ty2
616 ; setEvBind cv (EvCoercion co)
619 newWantedCoVar :: TcType -> TcType -> TcS EvVar
620 newWantedCoVar ty1 ty2 = wrapTcS $ TcM.newWantedCoVar ty1 ty2
622 newKindConstraint :: TcType -> Kind -> TcS (CoVar, TcType)
623 newKindConstraint ty kind = wrapTcS $ TcM.newKindConstraint ty kind
625 newCoVar :: TcType -> TcType -> TcS EvVar
626 newCoVar ty1 ty2 = wrapTcS $ TcM.newCoVar ty1 ty2
628 newIPVar :: IPName Name -> TcType -> TcS EvVar
629 newIPVar nm ty = wrapTcS $ TcM.newIP nm ty
631 newDictVar :: Class -> [TcType] -> TcS EvVar
632 newDictVar cl tys = wrapTcS $ TcM.newDict cl tys
637 isGoodRecEv :: EvVar -> WantedEvVar -> TcS Bool
638 -- In a call (isGoodRecEv ev wv), we are considering solving wv
639 -- using some term that involves ev, such as:
640 -- by setting wv = ev
641 -- or wv = EvCast x |> ev
643 -- But that would be Very Bad if the evidence for 'ev' mentions 'wv',
644 -- in an "unguarded" way. So isGoodRecEv looks at the evidence ev
645 -- recursively through the evidence binds, to see if uses of 'wv' are guarded.
647 -- Guarded means: more instance calls than superclass selections. We
648 -- compute this by chasing the evidence, adding +1 for every instance
649 -- call (constructor) and -1 for every superclass selection (destructor).
651 -- See Note [Superclasses and recursive dictionaries] in TcInteract
652 isGoodRecEv ev_var (WantedEvVar wv _)
653 = do { tc_evbinds <- getTcEvBindsBag
654 ; mb <- chase_ev_var tc_evbinds wv 0 [] ev_var
655 ; return $ case mb of
657 Just min_guardedness -> min_guardedness > 0
660 where chase_ev_var :: EvBindMap -- Evidence binds
661 -> EvVar -- Target variable whose gravity we want to return
662 -> Int -- Current gravity
663 -> [EvVar] -- Visited nodes
664 -> EvVar -- Current node
666 chase_ev_var assocs trg curr_grav visited orig
667 | trg == orig = return $ Just curr_grav
668 | orig `elem` visited = return $ Nothing
669 | Just (EvBind _ ev_trm) <- lookupEvBind assocs orig
670 = chase_ev assocs trg curr_grav (orig:visited) ev_trm
672 {- No longer needed: evidence is in the EvBinds
673 | isTcTyVar orig && isMetaTyVar orig
674 = do { meta_details <- wrapTcS $ TcM.readWantedCoVar orig
675 ; case meta_details of
676 Flexi -> return Nothing
677 Indirect tyco -> chase_ev assocs trg curr_grav
678 (orig:visited) (EvCoercion tyco)
681 | otherwise = return Nothing
683 chase_ev assocs trg curr_grav visited (EvId v)
684 = chase_ev_var assocs trg curr_grav visited v
685 chase_ev assocs trg curr_grav visited (EvSuperClass d_id _)
686 = chase_ev_var assocs trg (curr_grav-1) visited d_id
687 chase_ev assocs trg curr_grav visited (EvCast v co)
688 = do { m1 <- chase_ev_var assocs trg curr_grav visited v
689 ; m2 <- chase_co assocs trg curr_grav visited co
690 ; return (comb_chase_res Nothing [m1,m2]) }
692 chase_ev assocs trg curr_grav visited (EvCoercion co)
693 = chase_co assocs trg curr_grav visited co
694 chase_ev assocs trg curr_grav visited (EvDFunApp _ _ ev_vars)
695 = do { chase_results <- mapM (chase_ev_var assocs trg (curr_grav+1) visited) ev_vars
696 ; return (comb_chase_res Nothing chase_results) }
698 chase_co assocs trg curr_grav visited co
699 = -- Look for all the coercion variables in the coercion
700 -- chase them, and combine the results. This is OK since the
701 -- coercion will not contain any superclass terms -- anything
702 -- that involves dictionaries will be bound in assocs.
703 let co_vars = foldVarSet (\v vrs -> if isCoVar v then (v:vrs) else vrs) []
705 in do { chase_results <- mapM (chase_ev_var assocs trg curr_grav visited) co_vars
706 ; return (comb_chase_res Nothing chase_results) }
708 comb_chase_res f [] = f
709 comb_chase_res f (Nothing:rest) = comb_chase_res f rest
710 comb_chase_res Nothing (Just n:rest) = comb_chase_res (Just n) rest
711 comb_chase_res (Just m) (Just n:rest) = comb_chase_res (Just (min n m)) rest
714 -- Matching and looking up classes and family instances
715 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
717 data MatchInstResult mi
718 = MatchInstNo -- No matching instance
719 | MatchInstSingle mi -- Single matching instance
720 | MatchInstMany -- Multiple matching instances
723 matchClass :: Class -> [Type] -> TcS (MatchInstResult (DFunId, [Either TyVar TcType]))
724 -- Look up a class constraint in the instance environment
726 = do { let pred = mkClassPred clas tys
727 ; instEnvs <- getInstEnvs
728 ; case lookupInstEnv instEnvs clas tys of {
729 ([], unifs) -- Nothing matches
730 -> do { traceTcS "matchClass not matching"
731 (vcat [ text "dict" <+> ppr pred,
732 text "unifs" <+> ppr unifs ])
735 ([(ispec, inst_tys)], []) -- A single match
736 -> do { let dfun_id = is_dfun ispec
737 ; traceTcS "matchClass success"
738 (vcat [text "dict" <+> ppr pred,
739 text "witness" <+> ppr dfun_id
740 <+> ppr (idType dfun_id) ])
741 -- Record that this dfun is needed
742 ; record_dfun_usage dfun_id
743 ; return $ MatchInstSingle (dfun_id, inst_tys)
745 (matches, unifs) -- More than one matches
746 -> do { traceTcS "matchClass multiple matches, deferring choice"
747 (vcat [text "dict" <+> ppr pred,
748 text "matches" <+> ppr matches,
749 text "unifs" <+> ppr unifs])
750 ; return MatchInstMany
754 where record_dfun_usage :: Id -> TcS ()
755 record_dfun_usage dfun_id
756 = do { hsc_env <- getTopEnv
757 ; let dfun_name = idName dfun_id
758 dfun_mod = ASSERT( isExternalName dfun_name )
760 ; if isInternalName dfun_name || -- Internal name => defined in this module
761 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
762 then return () -- internal, or in another package
763 else do updInstUses dfun_id
766 updInstUses :: Id -> TcS ()
768 = do { tcg_env <- getGblEnv
769 ; wrapTcS $ TcM.updMutVar (tcg_inst_uses tcg_env)
770 (`addOneToNameSet` idName dfun_id)
775 -> TcS (MatchInstResult (TyCon, [Type]))
777 = do { mb <- wrapTcS $ TcM.tcLookupFamInst tycon args
779 Nothing -> return MatchInstNo
780 Just res -> return $ MatchInstSingle res
781 -- DV: We never return MatchInstMany, since tcLookupFamInst never returns
782 -- multiple matches. Check.
786 -- Functional dependencies, instantiation of equations
787 -------------------------------------------------------
789 mkWantedFunDepEqns :: WantedLoc -> [(Equation, (PredType, SDoc), (PredType, SDoc))]
791 mkWantedFunDepEqns _ [] = return []
792 mkWantedFunDepEqns loc eqns
793 = do { traceTcS "Improve:" (vcat (map pprEquationDoc eqns))
794 ; wevvars <- mapM to_work_item eqns
795 ; return $ concat wevvars }
797 to_work_item :: (Equation, (PredType,SDoc), (PredType,SDoc)) -> TcS [WantedEvVar]
798 to_work_item ((qtvs, pairs), _, _)
799 = do { (_, _, tenv) <- wrapTcS $ TcM.tcInstTyVars (varSetElems qtvs)
800 ; mapM (do_one tenv) pairs }
802 do_one tenv (ty1, ty2) = do { let sty1 = substTy tenv ty1
803 sty2 = substTy tenv ty2
804 ; ev <- newWantedCoVar sty1 sty2
805 ; return (WantedEvVar ev loc) }
807 pprEquationDoc :: (Equation, (PredType, SDoc), (PredType, SDoc)) -> SDoc
808 pprEquationDoc (eqn, (p1, _), (p2, _))
809 = vcat [pprEquation eqn, nest 2 (ppr p1), nest 2 (ppr p2)]