/compiler/typecheck/TcInteract.lhs
Haskell | 1888 lines | 1420 code | 321 blank | 147 comment | 79 complexity | 7e10f1be1ca6164d68bdd4c6535c6bee MD5 | raw file
Large files files are truncated, but you can click here to view the full file
- \begin{code}
- {-# OPTIONS -fno-warn-tabs #-}
- -- The above warning supression flag is a temporary kludge.
- -- While working on this module you are encouraged to remove it and
- -- detab the module (please do the detabbing in a separate patch). See
- -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
- -- for details
- module TcInteract (
- solveInteractGiven, -- Solves [EvVar],GivenLoc
- solveInteract, -- Solves Cts
- ) where
- #include "HsVersions.h"
- import BasicTypes ()
- import TcCanonical
- import VarSet
- import Type
- import Unify
- import FamInstEnv
- import Coercion( mkAxInstRHS )
- import Var
- import TcType
- import PrelNames (singIClassName, ipClassNameKey )
- import Class
- import TyCon
- import Name
- import FunDeps
- import TcEvidence
- import Outputable
- import TcMType ( zonkTcPredType )
- import TcRnTypes
- import TcErrors
- import TcSMonad
- import Maybes( orElse )
- import Bag
- import Control.Monad ( foldM )
- import VarEnv
- import Control.Monad( when, unless )
- import Pair ()
- import Unique( hasKey )
- import UniqFM
- import FastString ( sLit )
- import DynFlags
- import Util
- \end{code}
- **********************************************************************
- * *
- * Main Interaction Solver *
- * *
- **********************************************************************
- Note [Basic Simplifier Plan]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- 1. Pick an element from the WorkList if there exists one with depth
- less thanour context-stack depth.
- 2. Run it down the 'stage' pipeline. Stages are:
- - canonicalization
- - inert reactions
- - spontaneous reactions
- - top-level intreactions
- Each stage returns a StopOrContinue and may have sideffected
- the inerts or worklist.
-
- The threading of the stages is as follows:
- - If (Stop) is returned by a stage then we start again from Step 1.
- - If (ContinueWith ct) is returned by a stage, we feed 'ct' on to
- the next stage in the pipeline.
- 4. If the element has survived (i.e. ContinueWith x) the last stage
- then we add him in the inerts and jump back to Step 1.
- If in Step 1 no such element exists, we have exceeded our context-stack
- depth and will simply fail.
- \begin{code}
- solveInteractGiven :: CtLoc -> [TcTyVar] -> [EvVar] -> TcS ()
- -- In principle the givens can kick out some wanteds from the inert
- -- resulting in solving some more wanted goals here which could emit
- -- implications. That's why I return a bag of implications. Not sure
- -- if this can happen in practice though.
- solveInteractGiven loc fsks givens
- = do { implics <- solveInteract (fsk_bag `unionBags` given_bag)
- ; ASSERT( isEmptyBag implics )
- return () } -- We do not decompose *given* polymorphic equalities
- -- (forall a. t1 ~ forall a. t2)
- -- What would the evidence look like?!
- -- See Note [Do not decompose given polytype equalities]
- -- in TcCanonical
- where
- given_bag = listToBag [ mkNonCanonical loc $ CtGiven { ctev_evtm = EvId ev_id
- , ctev_pred = evVarPred ev_id }
- | ev_id <- givens ]
- fsk_bag = listToBag [ mkNonCanonical loc $ CtGiven { ctev_evtm = EvCoercion (mkTcReflCo tv_ty)
- , ctev_pred = pred }
- | tv <- fsks
- , let FlatSkol fam_ty = tcTyVarDetails tv
- tv_ty = mkTyVarTy tv
- pred = mkTcEqPred fam_ty tv_ty
- ]
- -- The main solver loop implements Note [Basic Simplifier Plan]
- ---------------------------------------------------------------
- solveInteract :: Cts -> TcS (Bag Implication)
- -- Returns the final InertSet in TcS
- -- Has no effect on work-list or residual-iplications
- solveInteract cts
- = {-# SCC "solveInteract" #-}
- withWorkList cts $
- do { dyn_flags <- getDynFlags
- ; solve_loop (ctxtStkDepth dyn_flags) }
- where
- solve_loop max_depth
- = {-# SCC "solve_loop" #-}
- do { sel <- selectNextWorkItem max_depth
- ; case sel of
- NoWorkRemaining -- Done, successfuly (modulo frozen)
- -> return ()
- MaxDepthExceeded ct -- Failure, depth exceeded
- -> wrapErrTcS $ solverDepthErrorTcS ct
- NextWorkItem ct -- More work, loop around!
- -> do { runSolverPipeline thePipeline ct; solve_loop max_depth } }
- type WorkItem = Ct
- type SimplifierStage = WorkItem -> TcS StopOrContinue
- continueWith :: WorkItem -> TcS StopOrContinue
- continueWith work_item = return (ContinueWith work_item)
- data SelectWorkItem
- = NoWorkRemaining -- No more work left (effectively we're done!)
- | MaxDepthExceeded Ct -- More work left to do but this constraint has exceeded
- -- the max subgoal depth and we must stop
- | NextWorkItem Ct -- More work left, here's the next item to look at
- selectNextWorkItem :: SubGoalDepth -- Max depth allowed
- -> TcS SelectWorkItem
- selectNextWorkItem max_depth
- = updWorkListTcS_return pick_next
- where
- pick_next :: WorkList -> (SelectWorkItem, WorkList)
- pick_next wl
- = case selectWorkItem wl of
- (Nothing,_)
- -> (NoWorkRemaining,wl) -- No more work
- (Just ct, new_wl)
- | ctLocDepth (cc_loc ct) > max_depth -- Depth exceeded
- -> (MaxDepthExceeded ct,new_wl)
- (Just ct, new_wl)
- -> (NextWorkItem ct, new_wl) -- New workitem and worklist
- runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline
- -> WorkItem -- The work item
- -> TcS ()
- -- Run this item down the pipeline, leaving behind new work and inerts
- runSolverPipeline pipeline workItem
- = do { initial_is <- getTcSInerts
- ; traceTcS "Start solver pipeline {" $
- vcat [ ptext (sLit "work item = ") <+> ppr workItem
- , ptext (sLit "inerts = ") <+> ppr initial_is]
- ; bumpStepCountTcS -- One step for each constraint processed
- ; final_res <- run_pipeline pipeline (ContinueWith workItem)
- ; final_is <- getTcSInerts
- ; case final_res of
- Stop -> do { traceTcS "End solver pipeline (discharged) }"
- (ptext (sLit "inerts = ") <+> ppr final_is)
- ; return () }
- ContinueWith ct -> do { traceFireTcS ct (ptext (sLit "Kept as inert:") <+> ppr ct)
- ; traceTcS "End solver pipeline (not discharged) }" $
- vcat [ ptext (sLit "final_item = ") <+> ppr ct
- , pprTvBndrs (varSetElems $ tyVarsOfCt ct)
- , ptext (sLit "inerts = ") <+> ppr final_is]
- ; insertInertItemTcS ct }
- }
- where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue -> TcS StopOrContinue
- run_pipeline [] res = return res
- run_pipeline _ Stop = return Stop
- run_pipeline ((stg_name,stg):stgs) (ContinueWith ct)
- = do { traceTcS ("runStage " ++ stg_name ++ " {")
- (text "workitem = " <+> ppr ct)
- ; res <- stg ct
- ; traceTcS ("end stage " ++ stg_name ++ " }") empty
- ; run_pipeline stgs res
- }
- \end{code}
- Example 1:
- Inert: {c ~ d, F a ~ t, b ~ Int, a ~ ty} (all given)
- Reagent: a ~ [b] (given)
- React with (c~d) ==> IR (ContinueWith (a~[b])) True []
- React with (F a ~ t) ==> IR (ContinueWith (a~[b])) False [F [b] ~ t]
- React with (b ~ Int) ==> IR (ContinueWith (a~[Int]) True []
- Example 2:
- Inert: {c ~w d, F a ~g t, b ~w Int, a ~w ty}
- Reagent: a ~w [b]
- React with (c ~w d) ==> IR (ContinueWith (a~[b])) True []
- React with (F a ~g t) ==> IR (ContinueWith (a~[b])) True [] (can't rewrite given with wanted!)
- etc.
- Example 3:
- Inert: {a ~ Int, F Int ~ b} (given)
- Reagent: F a ~ b (wanted)
- React with (a ~ Int) ==> IR (ContinueWith (F Int ~ b)) True []
- React with (F Int ~ b) ==> IR Stop True [] -- after substituting we re-canonicalize and get nothing
- \begin{code}
- thePipeline :: [(String,SimplifierStage)]
- thePipeline = [ ("canonicalization", TcCanonical.canonicalize)
- , ("spontaneous solve", spontaneousSolveStage)
- , ("interact with inerts", interactWithInertsStage)
- , ("top-level reactions", topReactionsStage) ]
- \end{code}
- *********************************************************************************
- * *
- The spontaneous-solve Stage
- * *
- *********************************************************************************
- \begin{code}
- spontaneousSolveStage :: SimplifierStage
- -- CTyEqCans are always consumed, returning Stop
- spontaneousSolveStage workItem
- = do { mb_solved <- trySpontaneousSolve workItem
- ; case mb_solved of
- SPCantSolve
- | CTyEqCan { cc_tyvar = tv, cc_ev = fl } <- workItem
- -- Unsolved equality
- -> do { n_kicked <- kickOutRewritable (ctEvFlavour fl) tv
- ; traceFireTcS workItem $
- ptext (sLit "Kept as inert") <+> ppr_kicked n_kicked <> colon
- <+> ppr workItem
- ; insertInertItemTcS workItem
- ; return Stop }
- | otherwise
- -> continueWith workItem
- SPSolved new_tv
- -- Post: tv ~ xi is now in TyBinds, no need to put in inerts as well
- -- see Note [Spontaneously solved in TyBinds]
- -> do { n_kicked <- kickOutRewritable Given new_tv
- ; traceFireTcS workItem $
- ptext (sLit "Spontaneously solved") <+> ppr_kicked n_kicked <> colon
- <+> ppr workItem
- ; return Stop } }
- ppr_kicked :: Int -> SDoc
- ppr_kicked 0 = empty
- ppr_kicked n = parens (int n <+> ptext (sLit "kicked out"))
- \end{code}
- Note [Spontaneously solved in TyBinds]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- When we encounter a constraint ([W] alpha ~ tau) which can be spontaneously solved,
- we record the equality on the TyBinds of the TcSMonad. In the past, we used to also
- add a /given/ version of the constraint ([G] alpha ~ tau) to the inert
- canonicals -- and potentially kick out other equalities that mention alpha.
- Then, the flattener only had to look in the inert equalities during flattening of a
- type (TcCanonical.flattenTyVar).
- However it is a bit silly to record these equalities /both/ in the inerts AND the
- TyBinds, so we have now eliminated spontaneously solved equalities from the inerts,
- and only record them in the TyBinds of the TcS monad. The flattener is now consulting
- these binds /and/ the inerts for potentially unsolved or other given equalities.
- \begin{code}
- kickOutRewritable :: CtFlavour -- Flavour of the equality that is
- -- being added to the inert set
- -> TcTyVar -- The new equality is tv ~ ty
- -> TcS Int
- kickOutRewritable new_flav new_tv
- = do { wl <- modifyInertTcS kick_out
- ; traceTcS "kickOutRewritable" $
- vcat [ text "tv = " <+> ppr new_tv
- , ptext (sLit "Kicked out =") <+> ppr wl]
- ; updWorkListTcS (appendWorkList wl)
- ; return (workListSize wl) }
- where
- kick_out :: InertSet -> (WorkList, InertSet)
- kick_out (is@(IS { inert_cans = IC { inert_eqs = tv_eqs
- , inert_dicts = dictmap
- , inert_funeqs = funeqmap
- , inert_irreds = irreds
- , inert_insols = insols } }))
- = (kicked_out, is { inert_cans = inert_cans_in })
- -- NB: Notice that don't rewrite
- -- inert_solved_dicts, and inert_solved_funeqs
- -- optimistically. But when we lookup we have to take the
- -- subsitution into account
- where
- inert_cans_in = IC { inert_eqs = tv_eqs_in
- , inert_dicts = dicts_in
- , inert_funeqs = feqs_in
- , inert_irreds = irs_in
- , inert_insols = insols_in }
- kicked_out = WorkList { wl_eqs = varEnvElts tv_eqs_out
- , wl_funeqs = foldrBag insertDeque emptyDeque feqs_out
- , wl_rest = bagToList (dicts_out `andCts` irs_out
- `andCts` insols_out) }
-
- (tv_eqs_out, tv_eqs_in) = partitionVarEnv kick_out_eq tv_eqs
- (feqs_out, feqs_in) = partCtFamHeadMap kick_out_ct funeqmap
- (dicts_out, dicts_in) = partitionCCanMap kick_out_ct dictmap
- (irs_out, irs_in) = partitionBag kick_out_ct irreds
- (insols_out, insols_in) = partitionBag kick_out_ct insols
- -- Kick out even insolubles; see Note [Kick out insolubles]
- kick_out_ct inert_ct = new_flav `canRewrite` (ctFlavour inert_ct) &&
- (new_tv `elemVarSet` tyVarsOfCt inert_ct)
- -- NB: tyVarsOfCt will return the type
- -- variables /and the kind variables/ that are
- -- directly visible in the type. Hence we will
- -- have exposed all the rewriting we care about
- -- to make the most precise kinds visible for
- -- matching classes etc. No need to kick out
- -- constraints that mention type variables whose
- -- kinds could contain this variable!
- kick_out_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs, cc_ev = ev })
- = (new_flav `canRewrite` inert_flav) -- See Note [Delicate equality kick-out]
- && (new_tv `elemVarSet` kind_vars || -- (1)
- (not (inert_flav `canRewrite` new_flav) && -- (2)
- new_tv `elemVarSet` (extendVarSet (tyVarsOfType rhs) tv)))
- where
- inert_flav = ctEvFlavour ev
- kind_vars = tyVarsOfType (tyVarKind tv) `unionVarSet`
- tyVarsOfType (typeKind rhs)
- kick_out_eq other_ct = pprPanic "kick_out_eq" (ppr other_ct)
- \end{code}
- Note [Kick out insolubles]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~
- Suppose we have an insoluble alpha ~ [alpha], which is insoluble
- because an occurs check. And then we unify alpha := [Int].
- Then we really want to rewrite the insouluble to [Int] ~ [[Int]].
- Now it can be decomposed. Otherwise we end up with a "Can't match
- [Int] ~ [[Int]]" which is true, but a bit confusing because the
- outer type constructors match.
- Note [Delicate equality kick-out]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- When adding an equality (a ~ xi), we kick out an inert type-variable
- equality (b ~ phi) in two cases
- (1) If the new tyvar can rewrite the kind LHS or RHS of the inert
- equality. Example:
- Work item: [W] k ~ *
- Inert: [W] (a:k) ~ ty
- [W] (b:*) ~ c :: k
- We must kick out those blocked inerts so that we rewrite them
- and can subsequently unify.
- (2) If the new tyvar can
- Work item: [G] a ~ b
- Inert: [W] b ~ [a]
- Now at this point the work item cannot be further rewritten by the
- inert (due to the weaker inert flavor). But we can't add the work item
- as-is because the inert set would then have a cyclic substitution,
- when rewriting a wanted type mentioning 'a'. So we must kick the inert out.
- We have to do this only if the inert *cannot* rewrite the work item;
- it it can, then the work item will have been fully rewritten by the
- inert during canonicalisation. So for example:
- Work item: [W] a ~ Int
- Inert: [W] b ~ [a]
- No need to kick out the inert, beause the inert substitution is not
- necessarily idemopotent. See Note [Non-idempotent inert substitution].
- See also point (8) of Note [Detailed InertCans Invariants]
- \begin{code}
- data SPSolveResult = SPCantSolve
- | SPSolved TcTyVar
- -- We solved this /unification/ variable to some type using reflexivity
- -- SPCantSolve means that we can't do the unification because e.g. the variable is untouchable
- -- SPSolved workItem' gives us a new *given* to go on
- -- @trySpontaneousSolve wi@ solves equalities where one side is a
- -- touchable unification variable.
- -- See Note [Touchables and givens]
- trySpontaneousSolve :: WorkItem -> TcS SPSolveResult
- trySpontaneousSolve workItem@(CTyEqCan { cc_ev = gw
- , cc_tyvar = tv1, cc_rhs = xi, cc_loc = d })
- | isGiven gw
- = return SPCantSolve
- | Just tv2 <- tcGetTyVar_maybe xi
- = do { tch1 <- isTouchableMetaTyVarTcS tv1
- ; tch2 <- isTouchableMetaTyVarTcS tv2
- ; case (tch1, tch2) of
- (True, True) -> trySpontaneousEqTwoWay d gw tv1 tv2
- (True, False) -> trySpontaneousEqOneWay d gw tv1 xi
- (False, True) -> trySpontaneousEqOneWay d gw tv2 (mkTyVarTy tv1)
- _ -> return SPCantSolve }
- | otherwise
- = do { tch1 <- isTouchableMetaTyVarTcS tv1
- ; if tch1 then trySpontaneousEqOneWay d gw tv1 xi
- else do { untch <- getUntouchables
- ; traceTcS "Untouchable LHS, can't spontaneously solve workitem" $
- vcat [text "Untouchables =" <+> ppr untch
- , text "Workitem =" <+> ppr workItem ]
- ; return SPCantSolve }
- }
- -- No need for
- -- trySpontaneousSolve (CFunEqCan ...) = ...
- -- See Note [No touchables as FunEq RHS] in TcSMonad
- trySpontaneousSolve _ = return SPCantSolve
- ----------------
- trySpontaneousEqOneWay :: CtLoc -> CtEvidence
- -> TcTyVar -> Xi -> TcS SPSolveResult
- -- tv is a MetaTyVar, not untouchable
- trySpontaneousEqOneWay d gw tv xi
- | not (isSigTyVar tv) || isTyVarTy xi
- , typeKind xi `tcIsSubKind` tyVarKind tv
- = solveWithIdentity d gw tv xi
- | otherwise -- Still can't solve, sig tyvar and non-variable rhs
- = return SPCantSolve
- ----------------
- trySpontaneousEqTwoWay :: CtLoc -> CtEvidence
- -> TcTyVar -> TcTyVar -> TcS SPSolveResult
- -- Both tyvars are *touchable* MetaTyvars so there is only a chance for kind error here
- trySpontaneousEqTwoWay d gw tv1 tv2
- | k1 `tcIsSubKind` k2 && nicer_to_update_tv2
- = solveWithIdentity d gw tv2 (mkTyVarTy tv1)
- | k2 `tcIsSubKind` k1
- = solveWithIdentity d gw tv1 (mkTyVarTy tv2)
- | otherwise
- = return SPCantSolve
- where
- k1 = tyVarKind tv1
- k2 = tyVarKind tv2
- nicer_to_update_tv2 = isSigTyVar tv1 || isSystemName (Var.varName tv2)
- \end{code}
- Note [Kind errors]
- ~~~~~~~~~~~~~~~~~~
- Consider the wanted problem:
- alpha ~ (# Int, Int #)
- where alpha :: ArgKind and (# Int, Int #) :: (#). We can't spontaneously solve this constraint,
- but we should rather reject the program that give rise to it. If 'trySpontaneousEqTwoWay'
- simply returns @CantSolve@ then that wanted constraint is going to propagate all the way and
- get quantified over in inference mode. That's bad because we do know at this point that the
- constraint is insoluble. Instead, we call 'recKindErrorTcS' here, which will fail later on.
- The same applies in canonicalization code in case of kind errors in the givens.
- However, when we canonicalize givens we only check for compatibility (@compatKind@).
- If there were a kind error in the givens, this means some form of inconsistency or dead code.
- You may think that when we spontaneously solve wanteds we may have to look through the
- bindings to determine the right kind of the RHS type. E.g one may be worried that xi is
- @alpha@ where alpha :: ? and a previous spontaneous solving has set (alpha := f) with (f :: *).
- But we orient our constraints so that spontaneously solved ones can rewrite all other constraint
- so this situation can't happen.
- Note [Spontaneous solving and kind compatibility]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- Note that our canonical constraints insist that *all* equalities (tv ~
- xi) or (F xis ~ rhs) require the LHS and the RHS to have *compatible*
- the same kinds. ("compatible" means one is a subKind of the other.)
- - It can't be *equal* kinds, because
- b) wanted constraints don't necessarily have identical kinds
- eg alpha::? ~ Int
- b) a solved wanted constraint becomes a given
- - SPJ thinks that *given* constraints (tv ~ tau) always have that
- tau has a sub-kind of tv; and when solving wanted constraints
- in trySpontaneousEqTwoWay we re-orient to achieve this.
- - Note that the kind invariant is maintained by rewriting.
- Eg wanted1 rewrites wanted2; if both were compatible kinds before,
- wanted2 will be afterwards. Similarly givens.
- Caveat:
- - Givens from higher-rank, such as:
- type family T b :: * -> * -> *
- type instance T Bool = (->)
- f :: forall a. ((T a ~ (->)) => ...) -> a -> ...
- flop = f (...) True
- Whereas we would be able to apply the type instance, we would not be able to
- use the given (T Bool ~ (->)) in the body of 'flop'
- Note [Avoid double unifications]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- The spontaneous solver has to return a given which mentions the unified unification
- variable *on the left* of the equality. Here is what happens if not:
- Original wanted: (a ~ alpha), (alpha ~ Int)
- We spontaneously solve the first wanted, without changing the order!
- given : a ~ alpha [having unified alpha := a]
- Now the second wanted comes along, but he cannot rewrite the given, so we simply continue.
- At the end we spontaneously solve that guy, *reunifying* [alpha := Int]
- We avoid this problem by orienting the resulting given so that the unification
- variable is on the left. [Note that alternatively we could attempt to
- enforce this at canonicalization]
- See also Note [No touchables as FunEq RHS] in TcSMonad; avoiding
- double unifications is the main reason we disallow touchable
- unification variables as RHS of type family equations: F xis ~ alpha.
- \begin{code}
- ----------------
- solveWithIdentity :: CtLoc -> CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult
- -- Solve with the identity coercion
- -- Precondition: kind(xi) is a sub-kind of kind(tv)
- -- Precondition: CtEvidence is Wanted or Derived
- -- See [New Wanted Superclass Work] to see why solveWithIdentity
- -- must work for Derived as well as Wanted
- -- Returns: workItem where
- -- workItem = the new Given constraint
- --
- -- NB: No need for an occurs check here, because solveWithIdentity always
- -- arises from a CTyEqCan, a *canonical* constraint. Its invariants
- -- say that in (a ~ xi), the type variable a does not appear in xi.
- -- See TcRnTypes.Ct invariants.
- solveWithIdentity _d wd tv xi
- = do { let tv_ty = mkTyVarTy tv
- ; traceTcS "Sneaky unification:" $
- vcat [text "Unifies:" <+> ppr tv <+> ptext (sLit ":=") <+> ppr xi,
- text "Coercion:" <+> pprEq tv_ty xi,
- text "Left Kind is:" <+> ppr (typeKind tv_ty),
- text "Right Kind is:" <+> ppr (typeKind xi) ]
- ; let xi' = defaultKind xi
- -- We only instantiate kind unification variables
- -- with simple kinds like *, not OpenKind or ArgKind
- -- cf TcUnify.uUnboundKVar
- ; setWantedTyBind tv xi'
- ; let refl_evtm = EvCoercion (mkTcReflCo xi')
- ; when (isWanted wd) $
- setEvBind (ctev_evar wd) refl_evtm
- ; return (SPSolved tv) }
- \end{code}
- *********************************************************************************
- * *
- The interact-with-inert Stage
- * *
- *********************************************************************************
- Note [
- Note [The Solver Invariant]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
- We always add Givens first. So you might think that the solver has
- the invariant
- If the work-item is Given,
- then the inert item must Given
- But this isn't quite true. Suppose we have,
- c1: [W] beta ~ [alpha], c2 : [W] blah, c3 :[W] alpha ~ Int
- After processing the first two, we get
- c1: [G] beta ~ [alpha], c2 : [W] blah
- Now, c3 does not interact with the the given c1, so when we spontaneously
- solve c3, we must re-react it with the inert set. So we can attempt a
- reaction between inert c2 [W] and work-item c3 [G].
- It *is* true that [Solver Invariant]
- If the work-item is Given,
- AND there is a reaction
- then the inert item must Given
- or, equivalently,
- If the work-item is Given,
- and the inert item is Wanted/Derived
- then there is no reaction
- \begin{code}
- -- Interaction result of WorkItem <~> Ct
- data InteractResult
- = IRWorkItemConsumed { ir_fire :: String } -- Work item discharged by interaction; stop
- | IRReplace { ir_fire :: String } -- Inert item replaced by work item; stop
- | IRInertConsumed { ir_fire :: String } -- Inert item consumed, keep going with work item
- | IRKeepGoing { ir_fire :: String } -- Inert item remains, keep going with work item
- interactWithInertsStage :: WorkItem -> TcS StopOrContinue
- -- Precondition: if the workitem is a CTyEqCan then it will not be able to
- -- react with anything at this stage.
- interactWithInertsStage wi
- = do { traceTcS "interactWithInerts" $ text "workitem = " <+> ppr wi
- ; rels <- extractRelevantInerts wi
- ; traceTcS "relevant inerts are:" $ ppr rels
- ; foldlBagM interact_next (ContinueWith wi) rels }
- where interact_next Stop atomic_inert
- = do { insertInertItemTcS atomic_inert; return Stop }
- interact_next (ContinueWith wi) atomic_inert
- = do { ir <- doInteractWithInert atomic_inert wi
- ; let mk_msg rule keep_doc
- = vcat [ text rule <+> keep_doc
- , ptext (sLit "InertItem =") <+> ppr atomic_inert
- , ptext (sLit "WorkItem =") <+> ppr wi ]
- ; case ir of
- IRWorkItemConsumed { ir_fire = rule }
- -> do { traceFireTcS wi (mk_msg rule (text "WorkItemConsumed"))
- ; insertInertItemTcS atomic_inert
- ; return Stop }
- IRReplace { ir_fire = rule }
- -> do { traceFireTcS atomic_inert
- (mk_msg rule (text "InertReplace"))
- ; insertInertItemTcS wi
- ; return Stop }
- IRInertConsumed { ir_fire = rule }
- -> do { traceFireTcS atomic_inert
- (mk_msg rule (text "InertItemConsumed"))
- ; return (ContinueWith wi) }
- IRKeepGoing {}
- -> do { insertInertItemTcS atomic_inert
- ; return (ContinueWith wi) }
- }
- \end{code}
- \begin{code}
- --------------------------------------------
- doInteractWithInert :: Ct -> Ct -> TcS InteractResult
- -- Identical class constraints.
- doInteractWithInert inertItem@(CDictCan { cc_ev = fl1, cc_class = cls1, cc_tyargs = tys1, cc_loc = loc1 })
- workItem@(CDictCan { cc_ev = fl2, cc_class = cls2, cc_tyargs = tys2, cc_loc = loc2 })
- | cls1 == cls2
- = do { let pty1 = mkClassPred cls1 tys1
- pty2 = mkClassPred cls2 tys2
- inert_pred_loc = (pty1, pprArisingAt loc1)
- work_item_pred_loc = (pty2, pprArisingAt loc2)
- ; let fd_eqns = improveFromAnother inert_pred_loc work_item_pred_loc
- ; fd_work <- rewriteWithFunDeps fd_eqns loc2
- -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok
- -- NB: We do create FDs for given to report insoluble equations that arise
- -- from pairs of Givens, and also because of floating when we approximate
- -- implications. The relevant test is: typecheck/should_fail/FDsFromGivens.hs
- -- Also see Note [When improvement happens]
-
- ; traceTcS "doInteractWithInert:dict"
- (vcat [ text "inertItem =" <+> ppr inertItem
- , text "workItem =" <+> ppr workItem
- , text "fundeps =" <+> ppr fd_work ])
-
- ; case fd_work of
- -- No Functional Dependencies
- [] | eqTypes tys1 tys2 -> solveOneFromTheOther "Cls/Cls" fl1 workItem
- | otherwise -> return (IRKeepGoing "NOP")
- -- Actual Functional Dependencies
- _ | cls1 `hasKey` ipClassNameKey
- , isGiven fl1, isGiven fl2 -- See Note [Shadowing of Implicit Parameters]
- -> return (IRReplace ("Replace IP"))
- -- Standard thing: create derived fds and keep on going. Importantly we don't
- -- throw workitem back in the worklist because this can cause loops. See #5236.
- | otherwise
- -> do { updWorkListTcS (extendWorkListEqs fd_work)
- ; return (IRKeepGoing "Cls/Cls (new fundeps)") } -- Just keep going without droping the inert
- }
-
- -- Two pieces of irreducible evidence: if their types are *exactly identical*
- -- we can rewrite them. We can never improve using this:
- -- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not
- -- mean that (ty1 ~ ty2)
- doInteractWithInert (CIrredEvCan { cc_ev = ifl })
- workItem@(CIrredEvCan { cc_ev = wfl })
- | ctEvPred ifl `eqType` ctEvPred wfl
- = solveOneFromTheOther "Irred/Irred" ifl workItem
- doInteractWithInert ii@(CFunEqCan { cc_ev = ev1, cc_fun = tc1
- , cc_tyargs = args1, cc_rhs = xi1, cc_loc = d1 })
- wi@(CFunEqCan { cc_ev = ev2, cc_fun = tc2
- , cc_tyargs = args2, cc_rhs = xi2, cc_loc = d2 })
- | i_solves_w && (not (w_solves_i && isMetaTyVarTy xi1))
- -- See Note [Carefully solve the right CFunEqCan]
- = ASSERT( lhss_match ) -- extractRelevantInerts ensures this
- do { traceTcS "interact with inerts: FunEq/FunEq" $
- vcat [ text "workItem =" <+> ppr wi
- , text "inertItem=" <+> ppr ii ]
- ; let xev = XEvTerm xcomp xdecomp
- -- xcomp : [(xi2 ~ xi1)] -> (F args ~ xi2)
- xcomp [x] = EvCoercion (co1 `mkTcTransCo` mk_sym_co x)
- xcomp _ = panic "No more goals!"
- -- xdecomp : (F args ~ xi2) -> [(xi2 ~ xi1)]
- xdecomp x = [EvCoercion (mk_sym_co x `mkTcTransCo` co1)]
- ; ctevs <- xCtFlavor ev2 [mkTcEqPred xi2 xi1] xev
- -- No caching! See Note [Cache-caused loops]
- -- Why not (mkTcEqPred xi1 xi2)? See Note [Efficient orientation]
- ; emitWorkNC d2 ctevs
- ; return (IRWorkItemConsumed "FunEq/FunEq") }
- | fl2 `canSolve` fl1
- = ASSERT( lhss_match ) -- extractRelevantInerts ensures this
- do { traceTcS "interact with inerts: FunEq/FunEq" $
- vcat [ text "workItem =" <+> ppr wi
- , text "inertItem=" <+> ppr ii ]
- ; let xev = XEvTerm xcomp xdecomp
- -- xcomp : [(xi2 ~ xi1)] -> [(F args ~ xi1)]
- xcomp [x] = EvCoercion (co2 `mkTcTransCo` evTermCoercion x)
- xcomp _ = panic "No more goals!"
- -- xdecomp : (F args ~ xi1) -> [(xi2 ~ xi1)]
- xdecomp x = [EvCoercion (mkTcSymCo co2 `mkTcTransCo` evTermCoercion x)]
- ; ctevs <- xCtFlavor ev1 [mkTcEqPred xi2 xi1] xev
- -- Why not (mkTcEqPred xi1 xi2)? See Note [Efficient orientation]
- ; emitWorkNC d1 ctevs
- ; return (IRInertConsumed "FunEq/FunEq") }
- where
- lhss_match = tc1 == tc2 && eqTypes args1 args2
- co1 = evTermCoercion $ ctEvTerm ev1
- co2 = evTermCoercion $ ctEvTerm ev2
- mk_sym_co x = mkTcSymCo (evTermCoercion x)
- fl1 = ctEvFlavour ev1
- fl2 = ctEvFlavour ev2
- i_solves_w = fl1 `canSolve` fl2
- w_solves_i = fl2 `canSolve` fl1
-
- doInteractWithInert _ _ = return (IRKeepGoing "NOP")
- \end{code}
- Note [Efficient Orientation]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- Suppose we are interacting two FunEqCans with the same LHS:
- (inert) ci :: (F ty ~ xi_i)
- (work) cw :: (F ty ~ xi_w)
- We prefer to keep the inert (else we pass the work item on down
- the pipeline, which is a bit silly). If we keep the inert, we
- will (a) discharge 'cw'
- (b) produce a new equality work-item (xi_w ~ xi_i)
- Notice the orientation (xi_w ~ xi_i) NOT (xi_i ~ xi_w):
- new_work :: xi_w ~ xi_i
- cw := ci ; sym new_work
- Why? Consider the simplest case when xi1 is a type variable. If
- we generate xi1~xi2, porcessing that constraint will kick out 'ci'.
- If we generate xi2~xi1, there is less chance of that happening.
- Of course it can and should still happen if xi1=a, xi1=Int, say.
- But we want to avoid it happening needlessly.
- Similarly, if we *can't* keep the inert item (because inert is Wanted,
- and work is Given, say), we prefer to orient the new equality (xi_i ~
- xi_w).
- Note [Carefully solve the right CFunEqCan]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- Consider the constraints
- c1 :: F Int ~ a -- Arising from an application line 5
- c2 :: F Int ~ Bool -- Arising from an application line 10
- Suppose that 'a' is a unification variable, arising only from
- flattening. So there is no error on line 5; it's just a flattening
- variable. But there is (or might be) an error on line 10.
- Two ways to combine them, leaving either (Plan A)
- c1 :: F Int ~ a -- Arising from an application line 5
- c3 :: a ~ Bool -- Arising from an application line 10
- or (Plan B)
- c2 :: F Int ~ Bool -- Arising from an application line 10
- c4 :: a ~ Bool -- Arising from an application line 5
- Plan A will unify c3, leaving c1 :: F Int ~ Bool as an error
- on the *totally innocent* line 5. An example is test SimpleFail16
- where the expected/actual message comes out backwards if we use
- the wrong plan.
- The second is the right thing to do. Hence the isMetaTyVarTy
- test when solving pairwise CFunEqCan.
- Note [Shadowing of Implicit Parameters]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- Consider the following example:
- f :: (?x :: Char) => Char
- f = let ?x = 'a' in ?x
- The "let ?x = ..." generates an implication constraint of the form:
- ?x :: Char => ?x :: Char
- Furthermore, the signature for `f` also generates an implication
- constraint, so we end up with the following nested implication:
- ?x :: Char => (?x :: Char => ?x :: Char)
- Note that the wanted (?x :: Char) constraint may be solved in
- two incompatible ways: either by using the parameter from the
- signature, or by using the local definition. Our intention is
- that the local definition should "shadow" the parameter of the
- signature, and we implement this as follows: when we add a new
- given implicit parameter to the inert set, it replaces any existing
- givens for the same implicit parameter.
- This works for the normal cases but it has an odd side effect
- in some pathological programs like this:
- -- This is accepted, the second parameter shadows
- f1 :: (?x :: Int, ?x :: Char) => Char
- f1 = ?x
- -- This is rejected, the second parameter shadows
- f2 :: (?x :: Int, ?x :: Char) => Int
- f2 = ?x
- Both of these are actually wrong: when we try to use either one,
- we'll get two incompatible wnated constraints (?x :: Int, ?x :: Char),
- which would lead to an error.
- I can think of two ways to fix this:
- 1. Simply disallow multiple constratits for the same implicit
- parameter---this is never useful, and it can be detected completely
- syntactically.
- 2. Move the shadowing machinery to the location where we nest
- implications, and add some code here that will produce an
- error if we get multiple givens for the same implicit parameter.
- Note [Cache-caused loops]
- ~~~~~~~~~~~~~~~~~~~~~~~~~
- It is very dangerous to cache a rewritten wanted family equation as 'solved' in our
- solved cache (which is the default behaviour or xCtFlavor), because the interaction
- may not be contributing towards a solution. Here is an example:
- Initial inert set:
- [W] g1 : F a ~ beta1
- Work item:
- [W] g2 : F a ~ beta2
- The work item will react with the inert yielding the _same_ inert set plus:
- i) Will set g2 := g1 `cast` g3
- ii) Will add to our solved cache that [S] g2 : F a ~ beta2
- iii) Will emit [W] g3 : beta1 ~ beta2
- Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2
- and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it
- will set
- g1 := g ; sym g3
- and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but
- remember that we have this in our solved cache, and it is ... g2! In short we
- created the evidence loop:
- g2 := g1 ; g3
- g3 := refl
- g1 := g2 ; sym g3
- To avoid this situation we do not cache as solved any workitems (or inert)
- which did not really made a 'step' towards proving some goal. Solved's are
- just an optimization so we don't lose anything in terms of completeness of
- solving.
- \begin{code}
- solveOneFromTheOther :: String -- Info
- -> CtEvidence -- Inert
- -> Ct -- WorkItem
- -> TcS InteractResult
- -- Preconditions:
- -- 1) inert and work item represent evidence for the /same/ predicate
- -- 2) ip/class/irred evidence (no coercions) only
- solveOneFromTheOther info ifl workItem
- | isDerived wfl
- = return (IRWorkItemConsumed ("Solved[DW] " ++ info))
- | isDerived ifl -- The inert item is Derived, we can just throw it away,
- -- The workItem is inert wrt earlier inert-set items,
- -- so it's safe to continue on from this point
- = return (IRInertConsumed ("Solved[DI] " ++ info))
-
- | CtWanted { ctev_evar = ev_id } <- wfl
- = do { setEvBind ev_id (ctEvTerm ifl); return (IRWorkItemConsumed ("Solved(w) " ++ info)) }
- | CtWanted { ctev_evar = ev_id } <- ifl
- = do { setEvBind ev_id (ctEvTerm wfl); return (IRInertConsumed ("Solved(g) " ++ info)) }
- | otherwise -- If both are Given, we already have evidence; no need to duplicate
- -- But the work item *overrides* the inert item (hence IRReplace)
- -- See Note [Shadowing of Implicit Parameters]
- = return (IRReplace ("Replace(gg) " ++ info))
- where
- wfl = cc_ev workItem
- \end{code}
- Note [Shadowing of Implicit Parameters]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- Consider the following example:
- f :: (?x :: Char) => Char
- f = let ?x = 'a' in ?x
- The "let ?x = ..." generates an implication constraint of the form:
- ?x :: Char => ?x :: Char
- Furthermore, the signature for `f` also generates an implication
- constraint, so we end up with the following nested implication:
- ?x :: Char => (?x :: Char => ?x :: Char)
- Note that the wanted (?x :: Char) constraint may be solved in
- two incompatible ways: either by using the parameter from the
- signature, or by using the local definition. Our intention is
- that the local definition should "shadow" the parameter of the
- signature, and we implement this as follows: when we nest implications,
- we remove any implicit parameters in the outer implication, that
- have the same name as givens of the inner implication.
- Here is another variation of the example:
- f :: (?x :: Int) => Char
- f = let ?x = 'x' in ?x
- This program should also be accepted: the two constraints `?x :: Int`
- and `?x :: Char` never exist in the same context, so they don't get to
- interact to cause failure.
- Note [Superclasses and recursive dictionaries]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- Overlaps with Note [SUPERCLASS-LOOP 1]
- Note [SUPERCLASS-LOOP 2]
- Note [Recursive instances and superclases]
- ToDo: check overlap and delete redundant stuff
- Right before adding a given into the inert set, we must
- produce some more work, that will bring the superclasses
- of the given into scope. The superclass constraints go into
- our worklist.
- When we simplify a wanted constraint, if we first see a matching
- instance, we may produce new wanted work. To (1) avoid doing this work
- twice in the future and (2) to handle recursive dictionaries we may ``cache''
- this item as given into our inert set WITHOUT adding its superclass constraints,
- otherwise we'd be in danger of creating a loop [In fact this was the exact reason
- for doing the isGoodRecEv check in an older version of the type checker].
- But now we have added partially solved constraints to the worklist which may
- interact with other wanteds. Consider the example:
- Example 1:
- class Eq b => Foo a b --- 0-th selector
- instance Eq a => Foo [a] a --- fooDFun
- and wanted (Foo [t] t). We are first going to see that the instance matches
- and create an inert set that includes the solved (Foo [t] t) but not its superclasses:
- d1 :_g Foo [t] t d1 := EvDFunApp fooDFun d3
- Our work list is going to contain a new *wanted* goal
- d3 :_w Eq t
- Ok, so how do we get recursive dictionaries, at all:
- Example 2:
- data D r = ZeroD | SuccD (r (D r));
-
- instance (Eq (r (D r))) => Eq (D r) where
- ZeroD == ZeroD = True
- (SuccD a) == (SuccD b) = a == b
- _ == _ = False;
-
- equalDC :: D [] -> D [] -> Bool;
- equalDC = (==);
- We need to prove (Eq (D [])). Here's how we go:
- d1 :_w Eq (D [])
- by instance decl, holds if
- d2 :_w Eq [D []]
- where d1 = dfEqD d2
- *BUT* we have an inert set which gives us (no superclasses):
- d1 :_g Eq (D [])
- By the instance declaration of Eq we can show the 'd2' goal if
- d3 :_w Eq (D [])
- where d2 = dfEqList d3
- d1 = dfEqD d2
- Now, however this wanted can interact with our inert d1 to set:
- d3 := d1
- and solve the goal. Why was this interaction OK? Because, if we chase the
- evidence of d1 ~~> dfEqD d2 ~~-> dfEqList d3, so by setting d3 := d1 we
- are really setting
- d3 := dfEqD2 (dfEqList d3)
- which is FINE because the use of d3 is protected by the instance function
- applications.
- So, our strategy is to try to put solved wanted dictionaries into the
- inert set along with their superclasses (when this is meaningful,
- i.e. when new wanted goals are generated) but solve a wanted dictionary
- from a given only in the case where the evidence variable of the
- wanted is mentioned in the evidence of the given (recursively through
- the evidence binds) in a protected way: more instance function applications
- than superclass selectors.
- Here are some more examples from GHC's previous type checker
- Example 3:
- This code arises in the context of "Scrap Your Boilerplate with Class"
- class Sat a
- class Data ctx a
- instance Sat (ctx Char) => Data ctx Char -- dfunData1
- instance (Sat (ctx [a]), Data ctx a) => Data ctx [a] -- dfunData2
- class Data Maybe a => Foo a
- instance Foo t => Sat (Maybe t) -- dfunSat
- instance Data Maybe a => Foo a -- dfunFoo1
- instance Foo a => Foo [a] -- dfunFoo2
- instance Foo [Char] -- dfunFoo3
- Consider generating the superclasses of the instance declaration
- instance Foo a => Foo [a]
- So our problem is this
- d0 :_g Foo t
- d1 :_w Data Maybe [t]
- We may add the given in the inert set, along with its superclasses
- [assuming we don't fail because there is a matching instance, see
- topReactionsStage, given case ]
- Inert:
- d0 :_g Foo t
- WorkList
- d01 :_g Data Maybe t -- d2 := EvDictSuperClass d0 0
- d1 :_w Data Maybe [t]
- Then d2 can readily enter the inert, and we also do solving of the wanted
- Inert:
- d0 :_g Foo t
- d1 :_s Data Maybe [t] d1 := dfunData2 d2 d3
- WorkList
- d2 :_w Sat (Maybe [t])
- d3 :_w Data Maybe t
- d01 :_g Data Maybe t
- Now, we may simplify d2 more:
- Inert:
- d0 :_g Foo t
- d1 :_s Data Maybe [t] d1 := dfunData2 d2 d3
- d1 :_g Data Maybe [t]
- d2 :_g Sat (Maybe [t]) d2 := dfunSat d4
- WorkList:
- d3 :_w Data Maybe t
- d4 :_w Foo [t]
- d01 :_g Data Maybe t
- Now, we can just solve d3.
- Inert
- d0 :_g Foo t
- d1 :_s Data Maybe [t] d1 := dfunData2 d2 d3
- d2 :_g Sat (Maybe [t]) d2 := dfunSat d4
- WorkList
- d4 :_w Foo [t]
- d01 :_g Data Maybe t
- And now we can simplify d4 again, but since it has superclasses we *add* them to the worklist:
- Inert
- d0 :_g Foo t
- d1 :_s Data Maybe [t] d1 := dfunData2 d2 d3
- d2 :_g Sat (Maybe [t]) d2 := dfunSat d4
- d4 :_g Foo [t] d4 := dfunFoo2 d5
- WorkList:
- d5 :_w Foo t
- d6 :_g Data Maybe [t] d6 := EvDictSuperClass d4 0
- d01 :_g Data Maybe t
- Now, d5 can be solved! (and its superclass enter scope)
- Inert
- d0 :_g Foo t
- d1 :_s Data Maybe [t] d1 := dfunData2 d2 d3
- d2 :_g Sat (Maybe [t]) d2 := dfunSat d4
- d4 :_g Foo [t] d4 := dfunFoo2 d5
- d5 :_g Foo t d5 := dfunFoo1 d7
- WorkList:
- d7 :_w Data Maybe t
- d6 :_g Data Maybe [t]
- d8 :_g Data Maybe t d8 := EvDictSuperClass d5 0
- d01 :_g Data Maybe t
- Now, two problems:
- [1] Suppose we pick d8 and we react him with d01. Which of the two givens should
- we keep? Well, we *MUST NOT* drop d01 because d8 contains recursive evidence
- that must not be used (look at case interactInert where both inert and workitem
- are givens). So we have several options:
- - Drop the workitem always (this will drop d8)
- This feels very unsafe -- what if the work item was the "good" one
- that should be used later to solve another wanted?
- - Don't drop anyone: the inert set may contain multiple givens!
- [This is currently implemented]
- The "don't drop anyone" seems the most safe thing to do, so now we come to problem 2:
- [2] We have added both d6 and d01 in the inert set, and we are interacting our wanted
- d7. Now the [isRecDictEv] function in the ineration solver
- [case inert-given workitem-wanted] will prevent us from interacting d7 := d8
- precisely because chasing the evidence of d8 leads us to an unguarded use of d7.
- So, no interaction happens there. Then we meet d01 and there is no recursion
- problem there [isRectDictEv] gives us the OK to interact and we do solve d7 := d01!
-
- Note [SUPERCLASS-LOOP 1]
- ~~~~~~~~~~~~~~~~~~~~~~~~
- We have to be very, very careful when generating superclasses, lest we
- accidentally build a loop. Here's an example:
- class S a
- class S a => C a where { opc :: a -> a }
- class S b => D b where { opd :: b -> b }
-
- instance C Int where
- opc = opd
-
- instance D Int where
- opd = opc
- From (instance C Int) we get the constraint set {ds1:S Int, dd:D Int}
- Simplifying, we may well get:
- $dfCInt = :C ds1 (opd dd)
- dd = $dfDInt
- ds1 = $p1 dd
- Notice that we spot that we can extract ds1 from dd.
- Alas! Alack! We can do the same for (instance D Int):
- $dfDInt = :D ds2 (opc dc)
- dc = $dfCInt
- ds2 = $p1 dc
- And now we've defined the superclass in terms of itself.
- Two more nasty cases are in
- tcrun021
- tcrun033
- Solution:
- - Satisfy the superclass context *all by itself*
- (tcSimplifySuperClasses)
- - And do so completely; i.e. no left-over constraints
- to mix with the constraints arising from method declarations
- Note [SUPERCLASS-LOOP 2]
- ~~~~~~~~~~~~~~~~~~~~~~~~
- We need to be careful when adding "the constaint we are trying to prove".
- Suppose we are *given* d1:Ord a, and want to deduce (d2:C [a]) where
- class Ord a => C a where
- instance Ord [a] => C [a] where ...
- Then we'll use the instance decl to deduce C [a] from Ord [a], and then add the
- superclasses of C [a] to avails. But we must not overwrite the binding
- for Ord [a] (which is obtained from Ord a) with a superclass selection or we'll just
- build a loop!
- Here's another variant, immortalised in tcrun020
- class Monad m => C1 m
- class C1 m => C2 m x
- instance C2 Maybe Bool
- For the instance decl we need to build (C1 Maybe), and it's no good if
- we run around and add (C2 Maybe Bool) and its superclasses to the avails
- before we search for C1 Maybe.
- Here's another example
- class Eq b => Foo a b
- instance Eq a => Foo [a] a
- If we are reducing
- (Foo [t] t)
- we'll first deduce that it holds (via the instance decl). We must not
- then overwrite the Eq t constraint with a superclass selection!
- At first I had a gross hack, whereby I simply did not add superclass constraints
- in addWanted, though I did for addGiven and addIrred. This was sub-optimal,
- because it lost legitimate superclass sharing, and it still didn't do the job:
- I found a very obscure program (now tcrun021) in which improvement meant the
- simplifier got two bites a the cherry... so…
Large files files are truncated, but you can click here to view the full file