    {-# LANGUAGE CPP #-}

    {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
    {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}

    module GHC.Tc.Solver.Interact (
         solveSimpleGivens,   -- Solves [Ct]
         solveSimpleWanteds,  -- Solves Cts
      ) where

    #include "HsVersions.h"

    import GHC.Prelude
    import GHC.Types.Basic ( SwapFlag(..),
                             infinity, IntWithInf, intGtLimit )
    import GHC.Tc.Solver.Canonical
    import GHC.Types.Var.Set
    import GHC.Core.Type as Type
    import GHC.Core.InstEnv         ( DFunInstType )

    import GHC.Types.Var
    import GHC.Tc.Utils.TcType
    import GHC.Builtin.Names ( coercibleTyConKey, heqTyConKey, eqTyConKey, ipClassKey )
    import GHC.Core.Coercion.Axiom ( CoAxBranch (..), CoAxiom (..), TypeEqn, fromBranches, sfInteractInert, sfInteractTop )
    import GHC.Core.Class
    import GHC.Core.TyCon
    import GHC.Tc.Instance.FunDeps
    import GHC.Tc.Instance.Family
    import GHC.Tc.Instance.Class ( InstanceWhat(..), safeOverlap )
    import GHC.Core.FamInstEnv
    import GHC.Core.Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX )

    import GHC.Tc.Types.Evidence
    import GHC.Utils.Outputable
    import GHC.Utils.Panic

    import GHC.Tc.Types
    import GHC.Tc.Types.Constraint
    import GHC.Core.Predicate
    import GHC.Tc.Types.Origin
    import GHC.Tc.Utils.TcMType( promoteMetaTyVarTo )
    import GHC.Tc.Solver.Monad
    import GHC.Data.Bag
    import GHC.Utils.Monad ( concatMapM, foldlM )

    import GHC.Core
    import Data.List( partition, deleteFirstsBy )
    import GHC.Types.SrcLoc
    import GHC.Types.Var.Env

    import Control.Monad
    import GHC.Data.Maybe( isJust )
    import GHC.Data.Pair (Pair(..))
    import GHC.Types.Unique( hasKey )
    import GHC.Driver.Session
    import GHC.Utils.Misc
    import qualified GHC.LanguageExtensions as LangExt
    import Data.List.NonEmpty ( NonEmpty(..) )

    import Control.Monad.Trans.Class
    import Control.Monad.Trans.Maybe

    {-
    **********************************************************************
    *                                                                    *
    *                      Main Interaction Solver                       *
    *                                                                    *
    **********************************************************************

    Note [Basic Simplifier Plan]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    1. Pick an element from the WorkList if there exists one with depth
       less than our context-stack depth.

    2. Run it down the 'stage' pipeline. Stages are:
          - canonicalization
          - inert reactions
          - spontaneous reactions
          - top-level interactions
       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 it 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.
    -}

    solveSimpleGivens :: [Ct] -> TcS ()
    solveSimpleGivens :: [Ct] -> TcS ()
    solveSimpleGivens [Ct]
    givens
      | [Ct] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Ct]
    givens  -- Shortcut for common case
      = () -> TcS ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
      | Bool
    otherwise
      = do { String -> SDoc -> TcS ()
    traceTcS String
    "solveSimpleGivens {" ([Ct] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Ct]
    givens)
           ; [Ct] -> TcS ()
    go [Ct]
    givens
           ; String -> SDoc -> TcS ()
    traceTcS String
    "End solveSimpleGivens }" SDoc
    empty }
      where
        go :: [Ct] -> TcS ()
    go [Ct]
    givens = do { Cts -> TcS ()
    solveSimples ([Ct] -> Cts
    forall a. [a] -> Bag a
    listToBag [Ct]
    givens)
                       ; [Ct]
    new_givens <- TcS [Ct]
    runTcPluginsGiven
                       ; Bool -> TcS () -> TcS ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when ([Ct] -> Bool
    forall (f :: * -> *) a. Foldable f => f a -> Bool
    notNull [Ct]
    new_givens) (TcS () -> TcS ()) -> TcS () -> TcS ()
    forall a b. (a -> b) -> a -> b
    $
                         [Ct] -> TcS ()
    go [Ct]
    new_givens }

    solveSimpleWanteds :: Cts -> TcS WantedConstraints
    -- The result is not necessarily zonked
    solveSimpleWanteds :: Cts -> TcS WantedConstraints
    solveSimpleWanteds Cts
    simples
      = do { String -> SDoc -> TcS ()
    traceTcS String
    "solveSimpleWanteds {" (Cts -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Cts
    simples)
           ; DynFlags
    dflags <- TcS DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
           ; (Int
    n,WantedConstraints
    wc) <- Int
    -> TypeSize -> WantedConstraints -> TcS (Int, WantedConstraints)
    go Int
    1 (DynFlags -> TypeSize
    solverIterations DynFlags
    dflags) (WantedConstraints
    emptyWC { wc_simple :: Cts
    wc_simple = Cts
    simples })
           ; String -> SDoc -> TcS ()
    traceTcS String
    "solveSimpleWanteds end }" (SDoc -> TcS ()) -> SDoc -> TcS ()
    forall a b. (a -> b) -> a -> b
    $
                 [SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "iterations =" SDoc -> SDoc -> SDoc
    <+> Int -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Int
    n
                      , String -> SDoc
    text String
    "residual =" SDoc -> SDoc -> SDoc
    <+> WantedConstraints -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr WantedConstraints
    wc ]
           ; WantedConstraints -> TcS WantedConstraints
    forall (m :: * -> *) a. Monad m => a -> m a
    return WantedConstraints
    wc }
      where
        go :: Int -> IntWithInf -> WantedConstraints -> TcS (Int, WantedConstraints)
        go :: Int
    -> TypeSize -> WantedConstraints -> TcS (Int, WantedConstraints)
    go Int
    n TypeSize
    limit WantedConstraints
    wc
          | Int
    n Int -> TypeSize -> Bool
    `intGtLimit` TypeSize
    limit
          = SDoc -> TcS (Int, WantedConstraints)
    forall a. SDoc -> TcS a
    failTcS (SDoc -> Int -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "solveSimpleWanteds: too many iterations"
                           SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    parens (String -> SDoc
    text String
    "limit =" SDoc -> SDoc -> SDoc
    <+> TypeSize -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TypeSize
    limit))
                        Int
    2 ([SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit"
                                , String -> SDoc
    text String
    "Simples =" SDoc -> SDoc -> SDoc
    <+> Cts -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Cts
    simples
                                , String -> SDoc
    text String
    "WC ="      SDoc -> SDoc -> SDoc
    <+> WantedConstraints -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr WantedConstraints
    wc ]))

         | Cts -> Bool
    forall a. Bag a -> Bool
    isEmptyBag (WantedConstraints -> Cts
    wc_simple WantedConstraints
    wc)
         = (Int, WantedConstraints) -> TcS (Int, WantedConstraints)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Int
    n,WantedConstraints
    wc)

         | Bool
    otherwise
         = do { -- Solve
                WantedConstraints
    wc1 <- WantedConstraints -> TcS WantedConstraints
    solve_simple_wanteds WantedConstraints
    wc

                -- Run plugins
              ; (Bool
    rerun_plugin, WantedConstraints
    wc2) <- WantedConstraints -> TcS (Bool, WantedConstraints)
    runTcPluginsWanted WantedConstraints
    wc1

              ; if Bool
    rerun_plugin
                then do { String -> SDoc -> TcS ()
    traceTcS String
    "solveSimple going round again:" (Bool -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Bool
    rerun_plugin)
                        ; Int
    -> TypeSize -> WantedConstraints -> TcS (Int, WantedConstraints)
    go (Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1) TypeSize
    limit WantedConstraints
    wc2 }   -- Loop
                else (Int, WantedConstraints) -> TcS (Int, WantedConstraints)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Int
    n, WantedConstraints
    wc2) }           -- Done

    solve_simple_wanteds :: WantedConstraints -> TcS WantedConstraints
    -- Try solving these constraints
    -- Affects the unification state (of course) but not the inert set
    -- The result is not necessarily zonked
    solve_simple_wanteds :: WantedConstraints -> TcS WantedConstraints
    solve_simple_wanteds (WC { wc_simple :: WantedConstraints -> Cts
    wc_simple = Cts
    simples1, wc_impl :: WantedConstraints -> Bag Implication
    wc_impl = Bag Implication
    implics1, wc_holes :: WantedConstraints -> Bag Hole
    wc_holes = Bag Hole
    holes })
      = TcS WantedConstraints -> TcS WantedConstraints
    forall a. TcS a -> TcS a
    nestTcS (TcS WantedConstraints -> TcS WantedConstraints)
    -> TcS WantedConstraints -> TcS WantedConstraints
    forall a b. (a -> b) -> a -> b
    $
        do { Cts -> TcS ()
    solveSimples Cts
    simples1
           ; (Bag Implication
    implics2, Cts
    unsolved) <- TcS (Bag Implication, Cts)
    getUnsolvedInerts
           ; WantedConstraints -> TcS WantedConstraints
    forall (m :: * -> *) a. Monad m => a -> m a
    return (WC { wc_simple :: Cts
    wc_simple = Cts
    unsolved
                        , wc_impl :: Bag Implication
    wc_impl   = Bag Implication
    implics1 Bag Implication -> Bag Implication -> Bag Implication
    forall a. Bag a -> Bag a -> Bag a
    `unionBags` Bag Implication
    implics2
                        , wc_holes :: Bag Hole
    wc_holes  = Bag Hole
    holes }) }

    {- Note [The solveSimpleWanteds loop]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Solving a bunch of simple constraints is done in a loop,
    (the 'go' loop of 'solveSimpleWanteds'):
      1. Try to solve them
      2. Try the plugin
      3. If the plugin wants to run again, go back to step 1
    -}

    -- The main solver loop implements Note [Basic Simplifier Plan]
    ---------------------------------------------------------------
    solveSimples :: Cts -> TcS ()
    -- Returns the final InertSet in TcS
    -- Has no effect on work-list or residual-implications
    -- The constraints are initially examined in left-to-right order

    solveSimples :: Cts -> TcS ()
    solveSimples Cts
    cts
      = {-# SCC "solveSimples" #-}
        do { (WorkList -> WorkList) -> TcS ()
    updWorkListTcS (\WorkList
    wl -> (Ct -> WorkList -> WorkList) -> WorkList -> Cts -> WorkList
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr Ct -> WorkList -> WorkList
    extendWorkListCt WorkList
    wl Cts
    cts)
           ; TcS ()
    solve_loop }
      where
        solve_loop :: TcS ()
    solve_loop
          = {-# SCC "solve_loop" #-}
            do { Maybe Ct
    sel <- TcS (Maybe Ct)
    selectNextWorkItem
               ; case Maybe Ct
    sel of
                  Maybe Ct
    Nothing -> () -> TcS ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                  Just Ct
    ct -> do { [(String, SimplifierStage)] -> Ct -> TcS ()
    runSolverPipeline [(String, SimplifierStage)]
    thePipeline Ct
    ct
                                ; TcS ()
    solve_loop } }

    -- | Extract the (inert) givens and invoke the plugins on them.
    -- Remove solved givens from the inert set and emit insolubles, but
    -- return new work produced so that 'solveSimpleGivens' can feed it back
    -- into the main solver.
    runTcPluginsGiven :: TcS [Ct]
    runTcPluginsGiven :: TcS [Ct]
    runTcPluginsGiven
      = do { [TcPluginSolver]
    plugins <- TcS [TcPluginSolver]
    getTcPlugins
           ; if [TcPluginSolver] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [TcPluginSolver]
    plugins then [Ct] -> TcS [Ct]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [] else
        do { [Ct]
    givens <- TcS [Ct]
    getInertGivens
           ; if [Ct] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Ct]
    givens then [Ct] -> TcS [Ct]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [] else
        do { TcPluginProgress
    p <- [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress
    runTcPlugins [TcPluginSolver]
    plugins ([Ct]
    givens,[],[])
           ; let ([Ct]
    solved_givens, [Ct]
    _, [(EvTerm, Ct)]
    _) = TcPluginProgress -> ([Ct], [Ct], [(EvTerm, Ct)])
    pluginSolvedCts TcPluginProgress
    p
                 insols :: [Ct]
    insols                = TcPluginProgress -> [Ct]
    pluginBadCts TcPluginProgress
    p
           ; (InertCans -> InertCans) -> TcS ()
    updInertCans ([Ct] -> InertCans -> InertCans
    removeInertCts [Ct]
    solved_givens)
           ; (Cts -> Cts) -> TcS ()
    updInertIrreds (\Cts
    irreds -> Cts -> [Ct] -> Cts
    extendCtsList Cts
    irreds [Ct]
    insols)
           ; [Ct] -> TcS [Ct]
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TcPluginProgress -> [Ct]
    pluginNewCts TcPluginProgress
    p) } } }

    -- | Given a bag of (rewritten, zonked) wanteds, invoke the plugins on
    -- them and produce an updated bag of wanteds (possibly with some new
    -- work) and a bag of insolubles.  The boolean indicates whether
    -- 'solveSimpleWanteds' should feed the updated wanteds back into the
    -- main solver.
    runTcPluginsWanted :: WantedConstraints -> TcS (Bool, WantedConstraints)
    runTcPluginsWanted :: WantedConstraints -> TcS (Bool, WantedConstraints)
    runTcPluginsWanted wc :: WantedConstraints
    wc@(WC { wc_simple :: WantedConstraints -> Cts
    wc_simple = Cts
    simples1 })
      | Cts -> Bool
    forall a. Bag a -> Bool
    isEmptyBag Cts
    simples1
      = (Bool, WantedConstraints) -> TcS (Bool, WantedConstraints)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    False, WantedConstraints
    wc)
      | Bool
    otherwise
      = do { [TcPluginSolver]
    plugins <- TcS [TcPluginSolver]
    getTcPlugins
           ; if [TcPluginSolver] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [TcPluginSolver]
    plugins then (Bool, WantedConstraints) -> TcS (Bool, WantedConstraints)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    False, WantedConstraints
    wc) else

        do { [Ct]
    given <- TcS [Ct]
    getInertGivens
           ; Cts
    simples1 <- Cts -> TcS Cts
    zonkSimples Cts
    simples1    -- Plugin requires zonked inputs
           ; let ([Ct]
    wanted, [Ct]
    derived) = (Ct -> Bool) -> [Ct] -> ([Ct], [Ct])
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    partition Ct -> Bool
    isWantedCt (Cts -> [Ct]
    forall a. Bag a -> [a]
    bagToList Cts
    simples1)
           ; TcPluginProgress
    p <- [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress
    runTcPlugins [TcPluginSolver]
    plugins ([Ct]
    given, [Ct]
    derived, [Ct]
    wanted)
           ; let ([Ct]
    _, [Ct]
    _,                [(EvTerm, Ct)]
    solved_wanted)   = TcPluginProgress -> ([Ct], [Ct], [(EvTerm, Ct)])
    pluginSolvedCts TcPluginProgress
    p
                 ([Ct]
    _, [Ct]
    unsolved_derived, [Ct]
    unsolved_wanted) = TcPluginProgress -> SplitCts
    pluginInputCts TcPluginProgress
    p
                 new_wanted :: [Ct]
    new_wanted                             = TcPluginProgress -> [Ct]
    pluginNewCts TcPluginProgress
    p
                 insols :: [Ct]
    insols                                 = TcPluginProgress -> [Ct]
    pluginBadCts TcPluginProgress
    p

    -- SLPJ: I'm deeply suspicious of this
    --       ; updInertCans (removeInertCts $ solved_givens ++ solved_deriveds)

           ; ((EvTerm, Ct) -> TcS ()) -> [(EvTerm, Ct)] -> TcS ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (EvTerm, Ct) -> TcS ()
    setEv [(EvTerm, Ct)]
    solved_wanted
           ; (Bool, WantedConstraints) -> TcS (Bool, WantedConstraints)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ( [Ct] -> Bool
    forall (f :: * -> *) a. Foldable f => f a -> Bool
    notNull (TcPluginProgress -> [Ct]
    pluginNewCts TcPluginProgress
    p)
                    , WantedConstraints
    wc { wc_simple :: Cts
    wc_simple = [Ct] -> Cts
    forall a. [a] -> Bag a
    listToBag [Ct]
    new_wanted       Cts -> Cts -> Cts
    `andCts`
                                       [Ct] -> Cts
    forall a. [a] -> Bag a
    listToBag [Ct]
    unsolved_wanted  Cts -> Cts -> Cts
    `andCts`
                                       [Ct] -> Cts
    forall a. [a] -> Bag a
    listToBag [Ct]
    unsolved_derived Cts -> Cts -> Cts
    `andCts`
                                       [Ct] -> Cts
    forall a. [a] -> Bag a
    listToBag [Ct]
    insols } ) } }
      where
        setEv :: (EvTerm,Ct) -> TcS ()
        setEv :: (EvTerm, Ct) -> TcS ()
    setEv (EvTerm
    ev,Ct
    ct) = case Ct -> CtEvidence
    ctEvidence Ct
    ct of
          CtWanted { ctev_dest :: CtEvidence -> TcEvDest
    ctev_dest = TcEvDest
    dest } -> TcEvDest -> EvTerm -> TcS ()
    setWantedEvTerm TcEvDest
    dest EvTerm
    ev
          CtEvidence
    _ -> String -> TcS ()
    forall a. String -> a
    panic String
    "runTcPluginsWanted.setEv: attempt to solve non-wanted!"

    -- | A triple of (given, derived, wanted) constraints to pass to plugins
    type SplitCts  = ([Ct], [Ct], [Ct])

    -- | A solved triple of constraints, with evidence for wanteds
    type SolvedCts = ([Ct], [Ct], [(EvTerm,Ct)])

    -- | Represents collections of constraints generated by typechecker
    -- plugins
    data TcPluginProgress = TcPluginProgress
        { TcPluginProgress -> SplitCts
    pluginInputCts  :: SplitCts
          -- ^ Original inputs to the plugins with solved/bad constraints
          -- removed, but otherwise unmodified
        , TcPluginProgress -> ([Ct], [Ct], [(EvTerm, Ct)])
    pluginSolvedCts :: SolvedCts
          -- ^ Constraints solved by plugins
        , TcPluginProgress -> [Ct]
    pluginBadCts    :: [Ct]
          -- ^ Constraints reported as insoluble by plugins
        , TcPluginProgress -> [Ct]
    pluginNewCts    :: [Ct]
          -- ^ New constraints emitted by plugins
        }

    getTcPlugins :: TcS [TcPluginSolver]
    getTcPlugins :: TcS [TcPluginSolver]
    getTcPlugins = do { TcGblEnv
    tcg_env <- TcS TcGblEnv
    getGblEnv; [TcPluginSolver] -> TcS [TcPluginSolver]
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TcGblEnv -> [TcPluginSolver]
    tcg_tc_plugins TcGblEnv
    tcg_env) }

    -- | Starting from a triple of (given, derived, wanted) constraints,
    -- invoke each of the typechecker plugins in turn and return
    --
    --  * the remaining unmodified constraints,
    --  * constraints that have been solved,
    --  * constraints that are insoluble, and
    --  * new work.
    --
    -- Note that new work generated by one plugin will not be seen by
    -- other plugins on this pass (but the main constraint solver will be
    -- re-invoked and they will see it later).  There is no check that new
    -- work differs from the original constraints supplied to the plugin:
    -- the plugin itself should perform this check if necessary.
    runTcPlugins :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress
    runTcPlugins :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress
    runTcPlugins [TcPluginSolver]
    plugins SplitCts
    all_cts
      = (TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress)
    -> TcPluginProgress -> [TcPluginSolver] -> TcS TcPluginProgress
    forall (t :: * -> *) (m :: * -> *) b a.
    (Foldable t, Monad m) =>
    (b -> a -> m b) -> b -> t a -> m b
    foldM TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress
    do_plugin TcPluginProgress
    initialProgress [TcPluginSolver]
    plugins
      where
        do_plugin :: TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress
        do_plugin :: TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress
    do_plugin TcPluginProgress
    p TcPluginSolver
    solver = do
            TcPluginResult
    result <- TcPluginM TcPluginResult -> TcS TcPluginResult
    forall a. TcPluginM a -> TcS a
    runTcPluginTcS (TcPluginSolver -> SplitCts -> TcPluginM TcPluginResult
    forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
    uncurry3 TcPluginSolver
    solver (TcPluginProgress -> SplitCts
    pluginInputCts TcPluginProgress
    p))
            TcPluginProgress -> TcS TcPluginProgress
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TcPluginProgress -> TcS TcPluginProgress)
    -> TcPluginProgress -> TcS TcPluginProgress
    forall a b. (a -> b) -> a -> b
    $ TcPluginProgress -> TcPluginResult -> TcPluginProgress
    progress TcPluginProgress
    p TcPluginResult
    result

        progress :: TcPluginProgress -> TcPluginResult -> TcPluginProgress
        progress :: TcPluginProgress -> TcPluginResult -> TcPluginProgress
    progress TcPluginProgress
    p (TcPluginContradiction [Ct]
    bad_cts) =
           TcPluginProgress
    p { pluginInputCts :: SplitCts
    pluginInputCts = [Ct] -> SplitCts -> SplitCts
    discard [Ct]
    bad_cts (TcPluginProgress -> SplitCts
    pluginInputCts TcPluginProgress
    p)
             , pluginBadCts :: [Ct]
    pluginBadCts   = [Ct]
    bad_cts [Ct] -> [Ct] -> [Ct]
    forall a. [a] -> [a] -> [a]
    ++ TcPluginProgress -> [Ct]
    pluginBadCts TcPluginProgress
    p
             }
        progress TcPluginProgress
    p (TcPluginOk [(EvTerm, Ct)]
    solved_cts [Ct]
    new_cts) =
          TcPluginProgress
    p { pluginInputCts :: SplitCts
    pluginInputCts  = [Ct] -> SplitCts -> SplitCts
    discard (((EvTerm, Ct) -> Ct) -> [(EvTerm, Ct)] -> [Ct]
    forall a b. (a -> b) -> [a] -> [b]
    map (EvTerm, Ct) -> Ct
    forall a b. (a, b) -> b
    snd [(EvTerm, Ct)]
    solved_cts) (TcPluginProgress -> SplitCts
    pluginInputCts TcPluginProgress
    p)
            , pluginSolvedCts :: ([Ct], [Ct], [(EvTerm, Ct)])
    pluginSolvedCts = [(EvTerm, Ct)]
    -> ([Ct], [Ct], [(EvTerm, Ct)]) -> ([Ct], [Ct], [(EvTerm, Ct)])
    add [(EvTerm, Ct)]
    solved_cts (TcPluginProgress -> ([Ct], [Ct], [(EvTerm, Ct)])
    pluginSolvedCts TcPluginProgress
    p)
            , pluginNewCts :: [Ct]
    pluginNewCts    = [Ct]
    new_cts [Ct] -> [Ct] -> [Ct]
    forall a. [a] -> [a] -> [a]
    ++ TcPluginProgress -> [Ct]
    pluginNewCts TcPluginProgress
    p
            }

        initialProgress :: TcPluginProgress
    initialProgress = SplitCts
    -> ([Ct], [Ct], [(EvTerm, Ct)]) -> [Ct] -> [Ct] -> TcPluginProgress
    TcPluginProgress SplitCts
    all_cts ([], [], []) [] []

        discard :: [Ct] -> SplitCts -> SplitCts
        discard :: [Ct] -> SplitCts -> SplitCts
    discard [Ct]
    cts ([Ct]
    xs, [Ct]
    ys, [Ct]
    zs) =
            ([Ct]
    xs [Ct] -> [Ct] -> [Ct]
    `without` [Ct]
    cts, [Ct]
    ys [Ct] -> [Ct] -> [Ct]
    `without` [Ct]
    cts, [Ct]
    zs [Ct] -> [Ct] -> [Ct]
    `without` [Ct]
    cts)

        without :: [Ct] -> [Ct] -> [Ct]
        without :: [Ct] -> [Ct] -> [Ct]
    without = (Ct -> Ct -> Bool) -> [Ct] -> [Ct] -> [Ct]
    forall a. (a -> a -> Bool) -> [a] -> [a] -> [a]
    deleteFirstsBy Ct -> Ct -> Bool
    eqCt

        eqCt :: Ct -> Ct -> Bool
        eqCt :: Ct -> Ct -> Bool
    eqCt Ct
    c Ct
    c' = Ct -> CtFlavour
    ctFlavour Ct
    c CtFlavour -> CtFlavour -> Bool
    forall a. Eq a => a -> a -> Bool
    == Ct -> CtFlavour
    ctFlavour Ct
    c'
                 Bool -> Bool -> Bool
    && Ct -> TcPredType
    ctPred Ct
    c HasDebugCallStack => TcPredType -> TcPredType -> Bool
    TcPredType -> TcPredType -> Bool
    `tcEqType` Ct -> TcPredType
    ctPred Ct
    c'

        add :: [(EvTerm,Ct)] -> SolvedCts -> SolvedCts
        add :: [(EvTerm, Ct)]
    -> ([Ct], [Ct], [(EvTerm, Ct)]) -> ([Ct], [Ct], [(EvTerm, Ct)])
    add [(EvTerm, Ct)]
    xs ([Ct], [Ct], [(EvTerm, Ct)])
    scs = (([Ct], [Ct], [(EvTerm, Ct)])
     -> (EvTerm, Ct) -> ([Ct], [Ct], [(EvTerm, Ct)]))
    -> ([Ct], [Ct], [(EvTerm, Ct)])
    -> [(EvTerm, Ct)]
    -> ([Ct], [Ct], [(EvTerm, Ct)])
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' ([Ct], [Ct], [(EvTerm, Ct)])
    -> (EvTerm, Ct) -> ([Ct], [Ct], [(EvTerm, Ct)])
    addOne ([Ct], [Ct], [(EvTerm, Ct)])
    scs [(EvTerm, Ct)]
    xs

        addOne :: SolvedCts -> (EvTerm,Ct) -> SolvedCts
        addOne :: ([Ct], [Ct], [(EvTerm, Ct)])
    -> (EvTerm, Ct) -> ([Ct], [Ct], [(EvTerm, Ct)])
    addOne ([Ct]
    givens, [Ct]
    deriveds, [(EvTerm, Ct)]
    wanteds) (EvTerm
    ev,Ct
    ct) = case Ct -> CtEvidence
    ctEvidence Ct
    ct of
          CtGiven  {} -> (Ct
    ctCt -> [Ct] -> [Ct]
    forall a. a -> [a] -> [a]
    :[Ct]
    givens, [Ct]
    deriveds, [(EvTerm, Ct)]
    wanteds)
          CtDerived{} -> ([Ct]
    givens, Ct
    ctCt -> [Ct] -> [Ct]
    forall a. a -> [a] -> [a]
    :[Ct]
    deriveds, [(EvTerm, Ct)]
    wanteds)
          CtWanted {} -> ([Ct]
    givens, [Ct]
    deriveds, (EvTerm
    ev,Ct
    ct)(EvTerm, Ct) -> [(EvTerm, Ct)] -> [(EvTerm, Ct)]
    forall a. a -> [a] -> [a]
    :[(EvTerm, Ct)]
    wanteds)

    type WorkItem = Ct
    type SimplifierStage = WorkItem -> TcS (StopOrContinue Ct)

    runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline
                      -> WorkItem                   -- The work item
                      -> TcS ()
    -- Run this item down the pipeline, leaving behind new work and inerts
    runSolverPipeline :: [(String, SimplifierStage)] -> Ct -> TcS ()
    runSolverPipeline [(String, SimplifierStage)]
    pipeline Ct
    workItem
      = do { WorkList
    wl <- TcS WorkList
    getWorkList
           ; InertSet
    inerts <- TcS InertSet
    getTcSInerts
           ; TcLevel
    tclevel <- TcS TcLevel
    getTcLevel
           ; String -> SDoc -> TcS ()
    traceTcS String
    "----------------------------- " SDoc
    empty
           ; String -> SDoc -> TcS ()
    traceTcS String
    "Start solver pipeline {" (SDoc -> TcS ()) -> SDoc -> TcS ()
    forall a b. (a -> b) -> a -> b
    $
                      [SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "tclevel =" SDoc -> SDoc -> SDoc
    <+> TcLevel -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TcLevel
    tclevel
                           , String -> SDoc
    text String
    "work item =" SDoc -> SDoc -> SDoc
    <+> Ct -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Ct
    workItem
                           , String -> SDoc
    text String
    "inerts =" SDoc -> SDoc -> SDoc
    <+> InertSet -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr InertSet
    inerts
                           , String -> SDoc
    text String
    "rest of worklist =" SDoc -> SDoc -> SDoc
    <+> WorkList -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr WorkList
    wl ]

           ; TcS ()
    bumpStepCountTcS    -- One step for each constraint processed
           ; StopOrContinue Ct
    final_res  <- [(String, SimplifierStage)]
    -> StopOrContinue Ct -> TcS (StopOrContinue Ct)
    run_pipeline [(String, SimplifierStage)]
    pipeline (Ct -> StopOrContinue Ct
    forall a. a -> StopOrContinue a
    ContinueWith Ct
    workItem)

           ; case StopOrContinue Ct
    final_res of
               Stop CtEvidence
    ev SDoc
    s       -> do { CtEvidence -> SDoc -> TcS ()
    traceFireTcS CtEvidence
    ev SDoc
    s
                                     ; String -> SDoc -> TcS ()
    traceTcS String
    "End solver pipeline (discharged) }" SDoc
    empty
                                     ; () -> TcS ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return () }
               ContinueWith Ct
    ct -> do { Ct -> TcS ()
    addInertCan Ct
    ct
                                     ; CtEvidence -> SDoc -> TcS ()
    traceFireTcS (Ct -> CtEvidence
    ctEvidence Ct
    ct) (String -> SDoc
    text String
    "Kept as inert")
                                     ; String -> SDoc -> TcS ()
    traceTcS String
    "End solver pipeline (kept as inert) }" (SDoc -> TcS ()) -> SDoc -> TcS ()
    forall a b. (a -> b) -> a -> b
    $
                                                (String -> SDoc
    text String
    "final_item =" SDoc -> SDoc -> SDoc
    <+> Ct -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Ct
    ct) }
           }
      where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue Ct
                         -> TcS (StopOrContinue Ct)
            run_pipeline :: [(String, SimplifierStage)]
    -> StopOrContinue Ct -> TcS (StopOrContinue Ct)
    run_pipeline [] StopOrContinue Ct
    res        = StopOrContinue Ct -> TcS (StopOrContinue Ct)
    forall (m :: * -> *) a. Monad m => a -> m a
    return StopOrContinue Ct
    res
            run_pipeline [(String, SimplifierStage)]
    _ (Stop CtEvidence
    ev SDoc
    s) = StopOrContinue Ct -> TcS (StopOrContinue Ct)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CtEvidence -> SDoc -> StopOrContinue Ct
    forall a. CtEvidence -> SDoc -> StopOrContinue a
    Stop CtEvidence
    ev SDoc
    s)
            run_pipeline ((String
    stg_name,SimplifierStage
    stg):[(String, SimplifierStage)]
    stgs) (ContinueWith Ct
    ct)
              = do { String -> SDoc -> TcS ()
    traceTcS (String
    "runStage " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    stg_name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " {")
                              (String -> SDoc
    text String
    "workitem   = " SDoc -> SDoc -> SDoc
    <+> Ct -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Ct
    ct)
                   ; StopOrContinue Ct
    res <- SimplifierStage
    stg Ct
    ct
                   ; String -> SDoc -> TcS ()
    traceTcS (String
    "end stage " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    stg_name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " }") SDoc
    empty
                   ; [(String, SimplifierStage)]
    -> StopOrContinue Ct -> TcS (StopOrContinue Ct)
    run_pipeline [(String, SimplifierStage)]
    stgs StopOrContinue Ct
    res }

    {-
    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
    -}

    thePipeline :: [(String,SimplifierStage)]
    thePipeline :: [(String, SimplifierStage)]
    thePipeline = [ (String
    "canonicalization",        SimplifierStage
    GHC.Tc.Solver.Canonical.canonicalize)
                  , (String
    "interact with inerts",    SimplifierStage
    interactWithInertsStage)
                  , (String
    "top-level reactions",     SimplifierStage
    topReactionsStage) ]

    {-
    *********************************************************************************
    *                                                                               *
                           The interact-with-inert Stage
    *                                                                               *
    *********************************************************************************

    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 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
    -}

    -- Interaction result of  WorkItem <~> Ct

    interactWithInertsStage :: WorkItem -> TcS (StopOrContinue Ct)
    -- Precondition: if the workitem is a CEqCan then it will not be able to
    -- react with anything at this stage (except, maybe, via a type family
    -- dependency)

    interactWithInertsStage :: SimplifierStage
    interactWithInertsStage Ct
    wi
      = do { InertSet
    inerts <- TcS InertSet
    getTcSInerts
           ; let ics :: InertCans
    ics = InertSet -> InertCans
    inert_cans InertSet
    inerts
           ; case Ct
    wi of
                 CEqCan    {} -> InertCans -> SimplifierStage
    interactEq    InertCans
    ics Ct
    wi
                 CIrredCan {} -> InertCans -> SimplifierStage
    interactIrred InertCans
    ics Ct
    wi
                 CDictCan  {} -> InertCans -> SimplifierStage
    interactDict  InertCans
    ics Ct
    wi
                 Ct
    _ -> String -> SDoc -> TcS (StopOrContinue Ct)
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "interactWithInerts" (Ct -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Ct
    wi) }
                    -- CNonCanonical have been canonicalised

    data InteractResult
       = KeepInert   -- Keep the inert item, and solve the work item from it
                     -- (if the latter is Wanted; just discard it if not)
       | KeepWork    -- Keep the work item, and solve the inert item from it

       | KeepBoth    -- See Note [KeepBoth]

    instance Outputable InteractResult where
      ppr :: InteractResult -> SDoc
    ppr InteractResult
    KeepBoth  = String -> SDoc
    text String
    "keep both"
      ppr InteractResult
    KeepInert = String -> SDoc
    text String
    "keep inert"
      ppr InteractResult
    KeepWork  = String -> SDoc
    text String
    "keep work-item"

    {- Note [KeepBoth]
    ~~~~~~~~~~~~~~~~~~
    Consider
       Inert:     [WD] C ty1 ty2
       Work item: [D]  C ty1 ty2

    Here we can simply drop the work item. But what about
       Inert:     [W] C ty1 ty2
       Work item: [D] C ty1 ty2

    Here we /cannot/ drop the work item, becuase we lose the [D] form, and
    that is essential for e.g. fundeps, see isImprovable.  We could zap
    the inert item to [WD], but the simplest thing to do is simply to keep
    both. (They probably started as [WD] and got split; this is relatively
    rare and it doesn't seem worth trying to put them back together again.)
    -}

    solveOneFromTheOther :: CtEvidence  -- Inert    (Dict or Irred)
                         -> CtEvidence  -- WorkItem (same predicate as inert)
                         -> TcS InteractResult
    -- Precondition:
    -- * inert and work item represent evidence for the /same/ predicate
    -- * Both are CDictCan or CIrredCan
    --
    -- We can always solve one from the other: even if both are wanted,
    -- although we don't rewrite wanteds with wanteds, we can combine
    -- two wanteds into one by solving one from the other

    solveOneFromTheOther :: CtEvidence -> CtEvidence -> TcS InteractResult
    solveOneFromTheOther CtEvidence
    ev_i CtEvidence
    ev_w
      | CtDerived {} <- CtEvidence
    ev_w         -- Work item is Derived
      = case CtEvidence
    ev_i of
          CtWanted { ctev_nosh :: CtEvidence -> ShadowInfo
    ctev_nosh = ShadowInfo
    WOnly } -> InteractResult -> TcS InteractResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return InteractResult
    KeepBoth
          CtEvidence
    _                              -> InteractResult -> TcS InteractResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return InteractResult
    KeepInert

      | CtDerived {} <- CtEvidence
    ev_i         -- Inert item is Derived
      = case CtEvidence
    ev_w of
          CtWanted { ctev_nosh :: CtEvidence -> ShadowInfo
    ctev_nosh = ShadowInfo
    WOnly } -> InteractResult -> TcS InteractResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return InteractResult
    KeepBoth
          CtEvidence
    _                              -> InteractResult -> TcS InteractResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return InteractResult
    KeepWork
                  -- The ev_w is inert wrt earlier inert-set items,
                  -- so it's safe to continue on from this point

      -- After this, neither ev_i or ev_w are Derived
      | CtWanted { ctev_loc :: CtEvidence -> CtLoc
    ctev_loc = CtLoc
    loc_w } <- CtEvidence
    ev_w
      , CtLoc -> CtLoc -> Bool
    prohibitedSuperClassSolve (CtEvidence -> CtLoc
    ctEvLoc CtEvidence
    ev_i) CtLoc
    loc_w
      = -- inert must be Given
        do { String -> SDoc -> TcS ()
    traceTcS String
    "prohibitedClassSolve1" (CtEvidence -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CtEvidence
    ev_i SDoc -> SDoc -> SDoc
    $$ CtEvidence -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CtEvidence
    ev_w)
           ; InteractResult -> TcS InteractResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return InteractResult
    KeepWork }

      | CtWanted { ctev_nosh :: CtEvidence -> ShadowInfo
    ctev_nosh = ShadowInfo
    nosh_w } <- CtEvidence
    ev_w
           -- Inert is Given or Wanted
      = case CtEvidence
    ev_i of
          CtWanted { ctev_nosh :: CtEvidence -> ShadowInfo
    ctev_nosh = ShadowInfo
    WOnly }
              | ShadowInfo
    WDeriv <- ShadowInfo
    nosh_w           -> InteractResult -> TcS InteractResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return InteractResult
    KeepWork
          CtEvidence
    _                                -> InteractResult -> TcS InteractResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return InteractResult
    KeepInert
          -- Consider work  item [WD] C ty1 ty2
          --          inert item [W]  C ty1 ty2
          -- Then we must keep the work item.  But if the
          -- work item was       [W]  C ty1 ty2
          -- then we are free to discard the work item in favour of inert
          -- Remember, no Deriveds at this point

      -- From here on the work-item is Given

      | CtWanted { ctev_loc :: CtEvidence -> CtLoc
    ctev_loc = CtLoc
    loc_i } <- CtEvidence
    ev_i
      , CtLoc -> CtLoc -> Bool
    prohibitedSuperClassSolve CtLoc
    loc_w CtLoc
    loc_i
      = do { String -> SDoc -> TcS ()
    traceTcS String
    "prohibitedClassSolve2" (CtEvidence -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CtEvidence
    ev_i SDoc -> SDoc -> SDoc
    $$ CtEvidence -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CtEvidence
    ev_w)
           ; InteractResult -> TcS InteractResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return InteractResult
    KeepInert }      -- Just discard the un-usable Given
                                     -- This never actually happens because
                                     -- Givens get processed first

      | CtWanted {} <- CtEvidence
    ev_i
      = InteractResult -> TcS InteractResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return InteractResult
    KeepWork

      -- From here on both are Given
      -- See Note [Replacement vs keeping]

      | TcLevel
    lvl_i TcLevel -> TcLevel -> Bool
    forall a. Eq a => a -> a -> Bool
    == TcLevel
    lvl_w
      = do { EvBindsVar
    ev_binds_var <- TcS EvBindsVar
    getTcEvBindsVar
           ; EvBindMap
    binds <- EvBindsVar -> TcS EvBindMap
    getTcEvBindsMap EvBindsVar
    ev_binds_var
           ; InteractResult -> TcS InteractResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return (EvBindMap -> InteractResult
    same_level_strategy EvBindMap
    binds) }

      | Bool
    otherwise   -- Both are Given, levels differ
      = InteractResult -> TcS InteractResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return InteractResult
    different_level_strategy
      where
         pred :: TcPredType
    pred  = CtEvidence -> TcPredType
    ctEvPred CtEvidence
    ev_i
         loc_i :: CtLoc
    loc_i = CtEvidence -> CtLoc
    ctEvLoc CtEvidence
    ev_i
         loc_w :: CtLoc
    loc_w = CtEvidence -> CtLoc
    ctEvLoc CtEvidence
    ev_w
         lvl_i :: TcLevel
    lvl_i = CtLoc -> TcLevel
    ctLocLevel CtLoc
    loc_i
         lvl_w :: TcLevel
    lvl_w = CtLoc -> TcLevel
    ctLocLevel CtLoc
    loc_w
         ev_id_i :: TyVar
    ev_id_i = CtEvidence -> TyVar
    ctEvEvId CtEvidence
    ev_i
         ev_id_w :: TyVar
    ev_id_w = CtEvidence -> TyVar
    ctEvEvId CtEvidence
    ev_w

         different_level_strategy :: InteractResult
    different_level_strategy  -- Both Given
           | TcPredType -> Bool
    isIPLikePred TcPredType
    pred = if TcLevel
    lvl_w TcLevel -> TcLevel -> Bool
    forall a. Ord a => a -> a -> Bool
    > TcLevel
    lvl_i then InteractResult
    KeepWork  else InteractResult
    KeepInert
           | Bool
    otherwise         = if TcLevel
    lvl_w TcLevel -> TcLevel -> Bool
    forall a. Ord a => a -> a -> Bool
    > TcLevel
    lvl_i then InteractResult
    KeepInert else InteractResult
    KeepWork
           -- See Note [Replacement vs keeping] (the different-level bullet)
           -- For the isIPLikePred case see Note [Shadowing of Implicit Parameters]

         same_level_strategy :: EvBindMap -> InteractResult
    same_level_strategy EvBindMap
    binds -- Both Given
           | GivenOrigin (InstSC TypeSize
    s_i) <- CtLoc -> CtOrigin
    ctLocOrigin CtLoc
    loc_i
           = case CtLoc -> CtOrigin
    ctLocOrigin CtLoc
    loc_w of
                GivenOrigin (InstSC TypeSize
    s_w) | TypeSize
    s_w TypeSize -> TypeSize -> Bool
    forall a. Ord a => a -> a -> Bool
    < TypeSize
    s_i -> InteractResult
    KeepWork
                                         | Bool
    otherwise -> InteractResult
    KeepInert
                CtOrigin
    _                                    -> InteractResult
    KeepWork

           | GivenOrigin (InstSC {}) <- CtLoc -> CtOrigin
    ctLocOrigin CtLoc
    loc_w
           = InteractResult
    KeepInert

           | EvBindMap -> TyVar -> Bool
    has_binding EvBindMap
    binds TyVar
    ev_id_w
           , Bool -> Bool
    not (EvBindMap -> TyVar -> Bool
    has_binding EvBindMap
    binds TyVar
    ev_id_i)
           , Bool -> Bool
    not (TyVar
    ev_id_i TyVar -> VarSet -> Bool
    `elemVarSet` EvBindMap -> VarSet -> VarSet
    findNeededEvVars EvBindMap
    binds (TyVar -> VarSet
    unitVarSet TyVar
    ev_id_w))
           = InteractResult
    KeepWork

           | Bool
    otherwise
           = InteractResult
    KeepInert

         has_binding :: EvBindMap -> TyVar -> Bool
    has_binding EvBindMap
    binds TyVar
    ev_id = Maybe EvBind -> Bool
    forall a. Maybe a -> Bool
    isJust (EvBindMap -> TyVar -> Maybe EvBind
    lookupEvBind EvBindMap
    binds TyVar
    ev_id)

    {-
    Note [Replacement vs keeping]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    When we have two Given constraints both of type (C tys), say, which should
    we keep?  More subtle than you might think!

      * Constraints come from different levels (different_level_strategy)

          - For implicit parameters we want to keep the innermost (deepest)
            one, so that it overrides the outer one.
            See Note [Shadowing of Implicit Parameters]

          - For everything else, we want to keep the outermost one.  Reason: that
            makes it more likely that the inner one will turn out to be unused,
            and can be reported as redundant.  See Note [Tracking redundant constraints]
            in GHC.Tc.Solver.

            It transpires that using the outermost one is responsible for an
            8% performance improvement in nofib cryptarithm2, compared to
            just rolling the dice.  I didn't investigate why.

      * Constraints coming from the same level (i.e. same implication)

           (a) Always get rid of InstSC ones if possible, since they are less
               useful for solving.  If both are InstSC, choose the one with
               the smallest TypeSize
               See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance

           (b) Keep the one that has a non-trivial evidence binding.
                  Example:  f :: (Eq a, Ord a) => blah
                  then we may find [G] d3 :: Eq a
                                   [G] d2 :: Eq a
                    with bindings  d3 = sc_sel (d1::Ord a)
                We want to discard d2 in favour of the superclass selection from
                the Ord dictionary.
                Why? See Note [Tracking redundant constraints] in GHC.Tc.Solver again.

           (c) But don't do (b) if the evidence binding depends transitively on the
               one without a binding.  Example (with RecursiveSuperClasses)
                  class C a => D a
                  class D a => C a
               Inert:     d1 :: C a, d2 :: D a
               Binds:     d3 = sc_sel d2, d2 = sc_sel d1
               Work item: d3 :: C a
               Then it'd be ridiculous to replace d1 with d3 in the inert set!
               Hence the findNeedEvVars test.  See #14774.

      * Finally, when there is still a choice, use KeepInert rather than
        KeepWork, for two reasons:
          - to avoid unnecessary munging of the inert set.
          - to cut off superclass loops; see Note [Superclass loops] in GHC.Tc.Solver.Canonical

    Doing the depth-check for implicit parameters, rather than making the work item
    always override, is important.  Consider

        data T a where { T1 :: (?x::Int) => T Int; T2 :: T a }

        f :: (?x::a) => T a -> Int
        f T1 = ?x
        f T2 = 3

    We have a [G] (?x::a) in the inert set, and at the pattern match on T1 we add
    two new givens in the work-list:  [G] (?x::Int)
                                      [G] (a ~ Int)
    Now consider these steps
      - process a~Int, kicking out (?x::a)
      - process (?x::Int), the inner given, adding to inert set
      - process (?x::a), the outer given, overriding the inner given
    Wrong!  The depth-check ensures that the inner implicit parameter wins.
    (Actually I think that the order in which the work-list is processed means
    that this chain of events won't happen, but that's very fragile.)

    *********************************************************************************
    *                                                                               *
                       interactIrred
    *                                                                               *
    *********************************************************************************

    Note [Multiple matching irreds]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    You might think that it's impossible to have multiple irreds all match the
    work item; after all, interactIrred looks for matches and solves one from the
    other. However, note that interacting insoluble, non-droppable irreds does not
    do this matching. We thus might end up with several insoluble, non-droppable,
    matching irreds in the inert set. When another irred comes along that we have
    not yet labeled insoluble, we can find multiple matches. These multiple matches
    cause no harm, but it would be wrong to ASSERT that they aren't there (as we
    once had done). This problem can be tickled by typecheck/should_compile/holes.

    -}

    -- 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)
    interactIrred :: InertCans -> Ct -> TcS (StopOrContinue Ct)

    interactIrred :: InertCans -> SimplifierStage
    interactIrred InertCans
    inerts workItem :: Ct
    workItem@(CIrredCan { cc_ev :: Ct -> CtEvidence
    cc_ev = CtEvidence
    ev_w, cc_reason :: Ct -> CtIrredReason
    cc_reason = CtIrredReason
    reason })
      | CtIrredReason -> Bool
    isInsolubleReason CtIrredReason
    reason
                   -- For insolubles, don't allow the constraint to be dropped
                   -- which can happen with solveOneFromTheOther, so that
                   -- we get distinct error messages with -fdefer-type-errors
                   -- See Note [Do not add duplicate derived insolubles]
      , Bool -> Bool
    not (Ct -> Bool
    isDroppableCt Ct
    workItem)
      = SimplifierStage
    forall a. a -> TcS (StopOrContinue a)
    continueWith Ct
    workItem

      | let (Bag (Ct, SwapFlag)
    matching_irreds, Cts
    others) = Cts -> CtEvidence -> (Bag (Ct, SwapFlag), Cts)
    findMatchingIrreds (InertCans -> Cts
    inert_irreds InertCans
    inerts) CtEvidence
    ev_w
      , ((Ct
    ct_i, SwapFlag
    swap) : [(Ct, SwapFlag)]
    _rest) <- Bag (Ct, SwapFlag) -> [(Ct, SwapFlag)]
    forall a. Bag a -> [a]
    bagToList Bag (Ct, SwapFlag)
    matching_irreds
            -- See Note [Multiple matching irreds]
      , let ev_i :: CtEvidence
    ev_i = Ct -> CtEvidence
    ctEvidence Ct
    ct_i
      = do { InteractResult
    what_next <- CtEvidence -> CtEvidence -> TcS InteractResult
    solveOneFromTheOther CtEvidence
    ev_i CtEvidence
    ev_w
           ; String -> SDoc -> TcS ()
    traceTcS String
    "iteractIrred" (Ct -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Ct
    workItem SDoc -> SDoc -> SDoc
    $$ InteractResult -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr InteractResult
    what_next SDoc -> SDoc -> SDoc
    $$ Ct -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Ct
    ct_i)
           ; case InteractResult
    what_next of
                InteractResult
    KeepBoth  -> SimplifierStage
    forall a. a -> TcS (StopOrContinue a)
    continueWith Ct
    workItem
                InteractResult
    KeepInert -> do { CtEvidence -> EvTerm -> TcS ()
    setEvBindIfWanted CtEvidence
    ev_w (SwapFlag -> CtEvidence -> EvTerm
    swap_me SwapFlag
    swap CtEvidence
    ev_i)
                                ; StopOrContinue Ct -> TcS (StopOrContinue Ct)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CtEvidence -> SDoc -> StopOrContinue Ct
    forall a. CtEvidence -> SDoc -> StopOrContinue a
    Stop CtEvidence
    ev_w (String -> SDoc
    text String
    "Irred equal" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    parens (InteractResult -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr InteractResult
    what_next))) }
                InteractResult
    KeepWork ->  do { CtEvidence -> EvTerm -> TcS ()
    setEvBindIfWanted CtEvidence
    ev_i (SwapFlag -> CtEvidence -> EvTerm
    swap_me SwapFlag
    swap CtEvidence
    ev_w)
                                ; (Cts -> Cts) -> TcS ()
    updInertIrreds (\Cts
    _ -> Cts
    others)
                                ; SimplifierStage
    forall a. a -> TcS (StopOrContinue a)
    continueWith Ct
    workItem } }

      | Bool
    otherwise
      = SimplifierStage
    forall a. a -> TcS (StopOrContinue a)
    continueWith Ct
    workItem

      where
        swap_me :: SwapFlag -> CtEvidence -> EvTerm
        swap_me :: SwapFlag -> CtEvidence -> EvTerm
    swap_me SwapFlag
    swap CtEvidence
    ev
          = case SwapFlag
    swap of
               SwapFlag
    NotSwapped -> CtEvidence -> EvTerm
    ctEvTerm CtEvidence
    ev
               SwapFlag
    IsSwapped  -> TcCoercion -> EvTerm
    evCoercion (TcCoercion -> TcCoercion
    mkTcSymCo (EvTerm -> TcCoercion
    evTermCoercion (CtEvidence -> EvTerm
    ctEvTerm CtEvidence
    ev)))

    interactIrred InertCans
    _ Ct
    wi = String -> SDoc -> TcS (StopOrContinue Ct)
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "interactIrred" (Ct -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Ct
    wi)

    findMatchingIrreds :: Cts -> CtEvidence -> (Bag (Ct, SwapFlag), Bag Ct)
    findMatchingIrreds :: Cts -> CtEvidence -> (Bag (Ct, SwapFlag), Cts)
    findMatchingIrreds Cts
    irreds CtEvidence
    ev
      | EqPred EqRel
    eq_rel1 TcPredType
    lty1 TcPredType
    rty1 <- TcPredType -> Pred
    classifyPredType TcPredType
    pred
        -- See Note [Solving irreducible equalities]
      = (Ct -> Either (Ct, SwapFlag) Ct)
    -> Cts -> (Bag (Ct, SwapFlag), Cts)
    forall a b c. (a -> Either b c) -> Bag a -> (Bag b, Bag c)
    partitionBagWith (EqRel -> TcPredType -> TcPredType -> Ct -> Either (Ct, SwapFlag) Ct
    match_eq EqRel
    eq_rel1 TcPredType
    lty1 TcPredType
    rty1) Cts
    irreds
      | Bool
    otherwise
      = (Ct -> Either (Ct, SwapFlag) Ct)
    -> Cts -> (Bag (Ct, SwapFlag), Cts)
    forall a b c. (a -> Either b c) -> Bag a -> (Bag b, Bag c)
    partitionBagWith Ct -> Either (Ct, SwapFlag) Ct
    match_non_eq Cts
    irreds
      where
        pred :: TcPredType
    pred = CtEvidence -> TcPredType
    ctEvPred CtEvidence
    ev
        match_non_eq :: Ct -> Either (Ct, SwapFlag) Ct
    match_non_eq Ct
    ct
          | Ct -> TcPredType
    ctPred Ct
    ct TcPredType -> TcPredType -> Bool
    `tcEqTypeNoKindCheck` TcPredType
    pred = (Ct, SwapFlag) -> Either (Ct, SwapFlag) Ct
    forall a b. a -> Either a b
    Left (Ct
    ct, SwapFlag
    NotSwapped)
          | Bool
    otherwise                            = Ct -> Either (Ct, SwapFlag) Ct
    forall a b. b -> Either a b
    Right Ct
    ct

        match_eq :: EqRel -> TcPredType -> TcPredType -> Ct -> Either (Ct, SwapFlag) Ct
    match_eq EqRel
    eq_rel1 TcPredType
    lty1 TcPredType
    rty1 Ct
    ct
          | EqPred EqRel
    eq_rel2 TcPredType
    lty2 TcPredType
    rty2 <- TcPredType -> Pred
    classifyPredType (Ct -> TcPredType
    ctPred Ct
    ct)
          , EqRel
    eq_rel1 EqRel -> EqRel -> Bool
    forall a. Eq a => a -> a -> Bool
    == EqRel
    eq_rel2
          , Just SwapFlag
    swap <- TcPredType
    -> TcPredType -> TcPredType -> TcPredType -> Maybe SwapFlag
    match_eq_help TcPredType
    lty1 TcPredType
    rty1 TcPredType
    lty2 TcPredType
    rty2
          = (Ct, SwapFlag) -> Either (Ct, SwapFlag) Ct
    forall a b. a -> Either a b
    Left (Ct
    ct, SwapFlag
    swap)
          | Bool
    otherwise
          = Ct -> Either (Ct, SwapFlag) Ct
    forall a b. b -> Either a b
    Right Ct
    ct

        match_eq_help :: TcPredType
    -> TcPredType -> TcPredType -> TcPredType -> Maybe SwapFlag
    match_eq_help TcPredType
    lty1 TcPredType
    rty1 TcPredType
    lty2 TcPredType
    rty2
          | TcPredType
    lty1 TcPredType -> TcPredType -> Bool
    `tcEqTypeNoKindCheck` TcPredType
    lty2, TcPredType
    rty1 TcPredType -> TcPredType -> Bool
    `tcEqTypeNoKindCheck` TcPredType
    rty2
          = SwapFlag -> Maybe SwapFlag
    forall a. a -> Maybe a
    Just SwapFlag
    NotSwapped
          | TcPredType
    lty1 TcPredType -> TcPredType -> Bool
    `tcEqTypeNoKindCheck` TcPredType
    rty2, TcPredType
    rty1 TcPredType -> TcPredType -> Bool
    `tcEqTypeNoKindCheck` TcPredType
    lty2
          = SwapFlag -> Maybe SwapFlag
    forall a. a -> Maybe a
    Just SwapFlag
    IsSwapped
          | Bool
    otherwise
          = Maybe SwapFlag
    forall a. Maybe a
    Nothing

    {- Note [Solving irreducible equalities]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider (#14333)
      [G] a b ~R# c d
      [W] c d ~R# a b
    Clearly we should be able to solve this! Even though the constraints are
    not decomposable. We solve this when looking up the work-item in the
    irreducible constraints to look for an identical one.  When doing this
    lookup, findMatchingIrreds spots the equality case, and matches either
    way around. It has to return a swap-flag so we can generate evidence
    that is the right way round too.

    Note [Do not add duplicate derived insolubles]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    In general we *must* add an insoluble (Int ~ Bool) even if there is
    one such there already, because they may come from distinct call
    sites.  Not only do we want an error message for each, but with
    -fdefer-type-errors we must generate evidence for each.  But for
    *derived* insolubles, we only want to report each one once.  Why?

    (a) A constraint (C r s t) where r -> s, say, may generate the same fundep
        equality many times, as the original constraint is successively rewritten.

    (b) Ditto the successive iterations of the main solver itself, as it traverses
        the constraint tree. See example below.

    Also for *given* insolubles we may get repeated errors, as we
    repeatedly traverse the constraint tree.  These are relatively rare
    anyway, so removing duplicates seems ok.  (Alternatively we could take
    the SrcLoc into account.)

    Note that the test does not need to be particularly efficient because
    it is only used if the program has a type error anyway.

    Example of (b): assume a top-level class and instance declaration:

      class D a b | a -> b
      instance D [a] [a]

    Assume we have started with an implication:

      forall c. Eq c => { wc_simple = [W] D [c] c }

    which we have simplified to, with a Derived constraing coming from
    D's functional dependency:

      forall c. Eq c => { wc_simple = [W] D [c] c [W]
                                      [D] (c ~ [c]) }

    When iterating the solver, we might try to re-solve this
    implication. If we do not do a dropDerivedWC, then we will end up
    trying to solve the following constraints the second time:

      [W] (D [c] c)
      [D] (c ~ [c])

    which will result in two Deriveds to end up in the insoluble set:

      wc_simple = [W] D [c] c
                  [D] (c ~ [c])
                  [D] (c ~ [c])
    -}

    {-
    *********************************************************************************
    *                                                                               *
                       interactDict
    *                                                                               *
    *********************************************************************************

    Note [Shortcut solving]
    ~~~~~~~~~~~~~~~~~~~~~~~
    When we interact a [W] constraint with a [G] constraint that solves it, there is
    a possibility that we could produce better code if instead we solved from a
    top-level instance declaration (See #12791, #5835). For example:

        class M a b where m :: a -> b

        type C a b = (Num a, M a b)

        f :: C Int b => b -> Int -> Int
        f _ x = x + 1

    The body of `f` requires a [W] `Num Int` instance. We could solve this
    constraint from the givens because we have `C Int b` and that provides us a
    solution for `Num Int`. This would let us produce core like the following
    (with -O2):

        f :: forall b. C Int b => b -> Int -> Int
        f = \ (@ b) ($d(%,%) :: C Int b) _ (eta1 :: Int) ->
            + @ Int
              (GHC.Classes.$p1(%,%) @ (Num Int) @ (M Int b) $d(%,%))
              eta1
              A.f1

    This is bad! We could do /much/ better if we solved [W] `Num Int` directly
    from the instance that we have in scope:

        f :: forall b. C Int b => b -> Int -> Int
        f = \ (@ b) _ _ (x :: Int) ->
            case x of { GHC.Types.I# x1 -> GHC.Types.I# (GHC.Prim.+# x1 1#) }

    ** NB: It is important to emphasize that all this is purely an optimization:
    ** exactly the same programs should typecheck with or without this
    ** procedure.

    Solving fully
    ~~~~~~~~~~~~~
    There is a reason why the solver does not simply try to solve such
    constraints with top-level instances. If the solver finds a relevant
    instance declaration in scope, that instance may require a context
    that can't be solved for. A good example of this is:

        f :: Ord [a] => ...
        f x = ..Need Eq [a]...

    If we have instance `Eq a => Eq [a]` in scope and we tried to use it, we would
    be left with the obligation to solve the constraint Eq a, which we cannot. So we
    must be conservative in our attempt to use an instance declaration to solve the
    [W] constraint we're interested in.

    Our rule is that we try to solve all of the instance's subgoals
    recursively all at once. Precisely: We only attempt to solve
    constraints of the form `C1, ... Cm => C t1 ... t n`, where all the Ci
    are themselves class constraints of the form `C1', ... Cm' => C' t1'
    ... tn'` and we only succeed if the entire tree of constraints is
    solvable from instances.

    An example that succeeds:

        class Eq a => C a b | b -> a where
          m :: b -> a

        f :: C [Int] b => b -> Bool
        f x = m x == []

    We solve for `Eq [Int]`, which requires `Eq Int`, which we also have. This
    produces the following core:

        f :: forall b. C [Int] b => b -> Bool
        f = \ (@ b) ($dC :: C [Int] b) (x :: b) ->
            GHC.Classes.$fEq[]_$s$c==
              (m @ [Int] @ b $dC x) (GHC.Types.[] @ Int)

    An example that fails:

        class Eq a => C a b | b -> a where
          m :: b -> a

        f :: C [a] b => b -> Bool
        f x = m x == []

    Which, because solving `Eq [a]` demands `Eq a` which we cannot solve, produces:

        f :: forall a b. C [a] b => b -> Bool
        f = \ (@ a) (@ b) ($dC :: C [a] b) (eta :: b) ->
            ==
              @ [a]
              (A.$p1C @ [a] @ b $dC)
              (m @ [a] @ b $dC eta)
              (GHC.Types.[] @ a)

    Note [Shortcut solving: type families]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Suppose we have (#13943)
      class Take (n :: Nat) where ...
      instance {-# OVERLAPPING #-}                    Take 0 where ..
      instance {-# OVERLAPPABLE #-} (Take (n - 1)) => Take n where ..

    And we have [W] Take 3.  That only matches one instance so we get
    [W] Take (3-1).  Really we should now rewrite to reduce the (3-1) to 2, and
    so on -- but that is reproducing yet more of the solver.  Sigh.  For now,
    we just give up (remember all this is just an optimisation).

    But we must not just naively try to lookup (Take (3-1)) in the
    InstEnv, or it'll (wrongly) appear not to match (Take 0) and get a
    unique match on the (Take n) instance.  That leads immediately to an
    infinite loop.  Hence the check that 'preds' have no type families
    (isTyFamFree).

    Note [Shortcut solving: incoherence]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    This optimization relies on coherence of dictionaries to be correct. When we
    cannot assume coherence because of IncoherentInstances then this optimization
    can change the behavior of the user's code.

    The following four modules produce a program whose output would change depending
    on whether we apply this optimization when IncoherentInstances is in effect:

    =========
        {-# LANGUAGE MultiParamTypeClasses #-}
        module A where

        class A a where
          int :: a -> Int

        class A a => C a b where
          m :: b -> a -> a

    =========
        {-# LANGUAGE FlexibleInstances     #-}
        {-# LANGUAGE MultiParamTypeClasses #-}
        module B where

        import A

        instance A a where
          int _ = 1

        instance C a [b] where
          m _ = id

    =========
        {-# LANGUAGE FlexibleContexts      #-}
        {-# LANGUAGE FlexibleInstances     #-}
        {-# LANGUAGE IncoherentInstances   #-}
        {-# LANGUAGE MultiParamTypeClasses #-}
        module C where

        import A

        instance A Int where
          int _ = 2

        instance C Int [Int] where
          m _ = id

        intC :: C Int a => a -> Int -> Int
        intC _ x = int x

    =========
        module Main where

        import A
        import B
        import C

        main :: IO ()
        main = print (intC [] (0::Int))

    The output of `main` if we avoid the optimization under the effect of
    IncoherentInstances is `1`. If we were to do the optimization, the output of
    `main` would be `2`.

    Note [Shortcut try_solve_from_instance]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    The workhorse of the short-cut solver is
        try_solve_from_instance :: (EvBindMap, DictMap CtEvidence)
                                -> CtEvidence       -- Solve this
                                -> MaybeT TcS (EvBindMap, DictMap CtEvidence)
    Note that:

    * The CtEvidence is the goal to be solved

    * The MaybeT manages early failure if we find a subgoal that
      cannot be solved from instances.

    * The (EvBindMap, DictMap CtEvidence) is an accumulating purely-functional
      state that allows try_solve_from_instance to augmennt the evidence
      bindings and inert_solved_dicts as it goes.

      If it succeeds, we commit all these bindings and solved dicts to the
      main TcS InertSet.  If not, we abandon it all entirely.

    Passing along the solved_dicts important for two reasons:

    * We need to be able to handle recursive super classes. The
      solved_dicts state  ensures that we remember what we have already
      tried to solve to avoid looping.

    * As #15164 showed, it can be important to exploit sharing between
      goals. E.g. To solve G we may need G1 and G2. To solve G1 we may need H;
      and to solve G2 we may need H. If we don't spot this sharing we may
      solve H twice; and if this pattern repeats we may get exponentially bad
      behaviour.
    -}

    interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct)
    interactDict :: InertCans -> SimplifierStage
    interactDict InertCans
    inerts workItem :: Ct
    workItem@(CDictCan { cc_ev :: Ct -> CtEvidence
    cc_ev = CtEvidence
    ev_w, cc_class :: Ct -> Class
    cc_class = Class
    cls, cc_tyargs :: Ct -> [TcPredType]
    cc_tyargs = [TcPredType]
    tys })
      | Just Ct
    ct_i <- InertCans -> CtLoc -> Class -> [TcPredType] -> Maybe Ct
    lookupInertDict InertCans
    inerts (CtEvidence -> CtLoc
    ctEvLoc CtEvidence
    ev_w) Class
    cls [TcPredType]
    tys
      , let ev_i :: CtEvidence
    ev_i = Ct -> CtEvidence
    ctEvidence Ct
    ct_i
      = -- There is a matching dictionary in the inert set
        do { -- First to try to solve it /completely/ from top level instances
             -- See Note [Shortcut solving]
             DynFlags
    dflags <- TcS DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
           ; Bool
    short_cut_worked <- DynFlags -> CtEvidence -> CtEvidence -> TcS Bool
    shortCutSolver DynFlags
    dflags CtEvidence
    ev_w CtEvidence
    ev_i
           ; if Bool
    short_cut_worked
             then CtEvidence -> String -> TcS (StopOrContinue Ct)
    forall a. CtEvidence -> String -> TcS (StopOrContinue a)
    stopWith CtEvidence
    ev_w String
    "interactDict/solved from instance"
             else

        do { -- Ths short-cut solver didn't fire, so we
             -- solve ev_w from the matching inert ev_i we found
             InteractResult
    what_next <- CtEvidence -> CtEvidence -> TcS InteractResult
    solveOneFromTheOther CtEvidence
    ev_i CtEvidence
    ev_w
           ; String -> SDoc -> TcS ()
    traceTcS String
    "lookupInertDict" (InteractResult -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr InteractResult
    what_next)
           ; case InteractResult
    what_next of
               InteractResult
    KeepBoth  -> SimplifierStage
    forall a. a -> TcS (StopOrContinue a)
    continueWith Ct
    workItem
               InteractResult
    KeepInert -> do { CtEvidence -> EvTerm -> TcS ()
    setEvBindIfWanted CtEvidence
    ev_w (CtEvidence -> EvTerm
    ctEvTerm CtEvidence
    ev_i)
                               ; StopOrContinue Ct -> TcS (StopOrContinue Ct)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (StopOrContinue Ct -> TcS (StopOrContinue Ct))
    -> StopOrContinue Ct -> TcS (StopOrContinue Ct)
    forall a b. (a -> b) -> a -> b
    $ CtEvidence -> SDoc -> StopOrContinue Ct
    forall a. CtEvidence -> SDoc -> StopOrContinue a
    Stop CtEvidence
    ev_w (String -> SDoc
    text String
    "Dict equal" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    parens (InteractResult -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr InteractResult
    what_next)) }
               InteractResult
    KeepWork  -> do { CtEvidence -> EvTerm -> TcS ()
    setEvBindIfWanted CtEvidence
    ev_i (CtEvidence -> EvTerm
    ctEvTerm CtEvidence
    ev_w)
                               ; (DictMap Ct -> DictMap Ct) -> TcS ()
    updInertDicts ((DictMap Ct -> DictMap Ct) -> TcS ())
    -> (DictMap Ct -> DictMap Ct) -> TcS ()
    forall a b. (a -> b) -> a -> b
    $ \ DictMap Ct
    ds -> DictMap Ct -> Class -> [TcPredType] -> DictMap Ct
    forall a. DictMap a -> Class -> [TcPredType] -> DictMap a
    delDict DictMap Ct
    ds Class
    cls [TcPredType]
    tys
                               ; SimplifierStage
    forall a. a -> TcS (StopOrContinue a)
    continueWith Ct
    workItem } } }

      | Class
    cls Class -> Unique -> Bool
    forall a. Uniquable a => a -> Unique -> Bool
    `hasKey` Unique
    ipClassKey
      , CtEvidence -> Bool
    isGiven CtEvidence
    ev_w
      = InertCans -> SimplifierStage
    interactGivenIP InertCans
    inerts Ct
    workItem

      | Bool
    otherwise
      = do { InertCans -> CtEvidence -> Class -> TcS ()
    addFunDepWork InertCans
    inerts CtEvidence
    ev_w Class
    cls
           ; SimplifierStage
    forall a. a -> TcS (StopOrContinue a)
    continueWith Ct
    workItem  }

    interactDict InertCans
    _ Ct
    wi = String -> SDoc -> TcS (StopOrContinue Ct)
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "interactDict" (Ct -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Ct
    wi)

    -- See Note [Shortcut solving]
    shortCutSolver :: DynFlags
                   -> CtEvidence -- Work item
                   -> CtEvidence -- Inert we want to try to replace
                   -> TcS Bool   -- True <=> success
    shortCutSolver :: DynFlags -> CtEvidence -> CtEvidence -> TcS Bool
    shortCutSolver DynFlags
    dflags CtEvidence
    ev_w CtEvidence
    ev_i
      | CtEvidence -> Bool
    isWanted CtEvidence
    ev_w
     Bool -> Bool -> Bool
    && CtEvidence -> Bool
    isGiven CtEvidence
    ev_i
     -- We are about to solve a [W] constraint from a [G] constraint. We take
     -- a moment to see if we can get a better solution using an instance.
     -- Note that we only do this for the sake of performance. Exactly the same
     -- programs should typecheck regardless of whether we take this step or
     -- not. See Note [Shortcut solving]

     Bool -> Bool -> Bool
    && Bool -> Bool
    not (TcPredType -> Bool
    isIPLikePred (CtEvidence -> TcPredType
    ctEvPred CtEvidence
    ev_w))   -- Not for implicit parameters (#18627)

     Bool -> Bool -> Bool
    && Bool -> Bool
    not (Extension -> DynFlags -> Bool
    xopt Extension
    LangExt.IncoherentInstances DynFlags
    dflags)
     -- If IncoherentInstances is on then we cannot rely on coherence of proofs
     -- in order to justify this optimization: The proof provided by the
     -- [G] constraint's superclass may be different from the top-level proof.
     -- See Note [Shortcut solving: incoherence]

     Bool -> Bool -> Bool
    && GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_SolveConstantDicts DynFlags
    dflags
     -- Enabled by the -fsolve-constant-dicts flag

      = do { EvBindsVar
    ev_binds_var <- TcS EvBindsVar
    getTcEvBindsVar
           ; EvBindMap
    ev_binds <- ASSERT2( not (isCoEvBindsVar ev_binds_var ), ppr ev_w )
                         EvBindsVar -> TcS EvBindMap
    getTcEvBindsMap EvBindsVar
    ev_binds_var
           ; DictMap CtEvidence
    solved_dicts <- TcS (DictMap CtEvidence)
    getSolvedDicts

           ; Maybe (EvBindMap, DictMap CtEvidence)
    mb_stuff <- MaybeT TcS (EvBindMap, DictMap CtEvidence)
    -> TcS (Maybe (EvBindMap, DictMap CtEvidence))
    forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
    runMaybeT (MaybeT TcS (EvBindMap, DictMap CtEvidence)
     -> TcS (Maybe (EvBindMap, DictMap CtEvidence)))
    -> MaybeT TcS (EvBindMap, DictMap CtEvidence)
    -> TcS (Maybe (EvBindMap, DictMap CtEvidence))
    forall a b. (a -> b) -> a -> b
    $ (EvBindMap, DictMap CtEvidence)
    -> CtEvidence -> MaybeT TcS (EvBindMap, DictMap CtEvidence)
    try_solve_from_instance
                                       (EvBindMap
    ev_binds, DictMap CtEvidence
    solved_dicts) CtEvidence
    ev_w

           ; case Maybe (EvBindMap, DictMap CtEvidence)
    mb_stuff of
               Maybe (EvBindMap, DictMap CtEvidence)
    Nothing -> Bool -> TcS Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
               Just (EvBindMap
    ev_binds', DictMap CtEvidence
    solved_dicts')
                  -> do { EvBindsVar -> EvBindMap -> TcS ()
    setTcEvBindsMap EvBindsVar
    ev_binds_var EvBindMap
    ev_binds'
                        ; DictMap CtEvidence -> TcS ()
    setSolvedDicts DictMap CtEvidence
    solved_dicts'
                        ; Bool -> TcS Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True } }

      | Bool
    otherwise
      = Bool -> TcS Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
      where
        -- This `CtLoc` is used only to check the well-staged condition of any
        -- candidate DFun. Our subgoals all have the same stage as our root
        -- [W] constraint so it is safe to use this while solving them.
        loc_w :: CtLoc
    loc_w = CtEvidence -> CtLoc
    ctEvLoc CtEvidence
    ev_w

        try_solve_from_instance   -- See Note [Shortcut try_solve_from_instance]
          :: (EvBindMap, DictMap CtEvidence) -> CtEvidence
          -> MaybeT TcS (EvBindMap, DictMap CtEvidence)
        try_solve_from_instance :: (EvBindMap, DictMap CtEvidence)
    -> CtEvidence -> MaybeT TcS (EvBindMap, DictMap CtEvidence)
    try_solve_from_instance (EvBindMap
    ev_binds, DictMap CtEvidence
    solved_dicts) CtEvidence
    ev
          | let pred :: TcPredType
    pred = CtEvidence -> TcPredType
    ctEvPred CtEvidence
    ev
                loc :: CtLoc
    loc  = CtEvidence -> CtLoc
    ctEvLoc  CtEvidence
    ev
          , ClassPred Class
    cls [TcPredType]
    tys <- TcPredType -> Pred
    classifyPredType TcPredType
    pred
          = do { ClsInstResult
    inst_res <- TcS ClsInstResult -> MaybeT TcS ClsInstResult
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (TcS ClsInstResult -> MaybeT TcS ClsInstResult)
    -> TcS ClsInstResult -> MaybeT TcS ClsInstResult
    forall a b. (a -> b) -> a -> b
    $ DynFlags -> Bool -> Class -> [TcPredType] -> TcS ClsInstResult
    matchGlobalInst DynFlags
    dflags Bool
    True Class
    cls [TcPredType]
    tys
               ; case ClsInstResult
    inst_res of
                   OneInst { cir_new_theta :: ClsInstResult -> [TcPredType]
    cir_new_theta = [TcPredType]
    preds
                           , cir_mk_ev :: ClsInstResult -> [EvExpr] -> EvTerm
    cir_mk_ev     = [EvExpr] -> EvTerm
    mk_ev
                           , cir_what :: ClsInstResult -> InstanceWhat
    cir_what      = InstanceWhat
    what }
                     | InstanceWhat -> Bool
    safeOverlap InstanceWhat
    what
                     , (TcPredType -> Bool) -> [TcPredType] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all TcPredType -> Bool
    isTyFamFree [TcPredType]
    preds  -- Note [Shortcut solving: type families]
                     -> do { let solved_dicts' :: DictMap CtEvidence
    solved_dicts' = DictMap CtEvidence
    -> Class -> [TcPredType] -> CtEvidence -> DictMap CtEvidence
    forall a. DictMap a -> Class -> [TcPredType] -> a -> DictMap a
    addDict DictMap CtEvidence
    solved_dicts Class
    cls [TcPredType]
    tys CtEvidence
    ev
                                 -- solved_dicts': it is important that we add our goal
                                 -- to the cache before we solve! Otherwise we may end
                                 -- up in a loop while solving recursive dictionaries.

                           ; TcS () -> MaybeT TcS ()
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (TcS () -> MaybeT TcS ()) -> TcS () -> MaybeT TcS ()
    forall a b. (a -> b) -> a -> b
    $ String -> SDoc -> TcS ()
    traceTcS String
    "shortCutSolver: found instance" ([TcPredType] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [TcPredType]
    preds)
                           ; CtLoc
    loc' <- TcS CtLoc -> MaybeT TcS CtLoc
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (TcS CtLoc -> MaybeT TcS CtLoc) -> TcS CtLoc -> MaybeT TcS CtLoc
    forall a b. (a -> b) -> a -> b
    $ CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc
    checkInstanceOK CtLoc
    loc InstanceWhat
    what TcPredType
    pred
                           ; TcS () -> MaybeT TcS ()
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (TcS () -> MaybeT TcS ()) -> TcS () -> MaybeT TcS ()
    forall a b. (a -> b) -> a -> b
    $ CtLoc -> TcPredType -> TcS ()
    checkReductionDepth CtLoc
    loc' TcPredType
    pred

                           ; [MaybeNew]
    evc_vs <- (TcPredType -> MaybeT TcS MaybeNew)
    -> [TcPredType] -> MaybeT TcS [MaybeNew]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM (CtLoc -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew
    new_wanted_cached CtLoc
    loc' DictMap CtEvidence
    solved_dicts') [TcPredType]
    preds
                                      -- Emit work for subgoals but use our local cache
                                      -- so we can solve recursive dictionaries.

                           ; let ev_tm :: EvTerm
    ev_tm     = [EvExpr] -> EvTerm
    mk_ev ((MaybeNew -> EvExpr) -> [MaybeNew] -> [EvExpr]
    forall a b. (a -> b) -> [a] -> [b]
    map MaybeNew -> EvExpr
    getEvExpr [MaybeNew]
    evc_vs)
                                 ev_binds' :: EvBindMap
    ev_binds' = EvBindMap -> EvBind -> EvBindMap
    extendEvBinds EvBindMap
    ev_binds (EvBind -> EvBindMap) -> EvBind -> EvBindMap
    forall a b. (a -> b) -> a -> b
    $
                                             TyVar -> EvTerm -> EvBind
    mkWantedEvBind (CtEvidence -> TyVar
    ctEvEvId CtEvidence
    ev) EvTerm
    ev_tm

                           ; ((EvBindMap, DictMap CtEvidence)
     -> CtEvidence -> MaybeT TcS (EvBindMap, DictMap CtEvidence))
    -> (EvBindMap, DictMap CtEvidence)
    -> [CtEvidence]
    -> MaybeT TcS (EvBindMap, DictMap CtEvidence)
    forall (t :: * -> *) (m :: * -> *) b a.
    (Foldable t, Monad m) =>
    (b -> a -> m b) -> b -> t a -> m b
    foldlM (EvBindMap, DictMap CtEvidence)
    -> CtEvidence -> MaybeT TcS (EvBindMap, DictMap CtEvidence)
    try_solve_from_instance
                                    (EvBindMap
    ev_binds', DictMap CtEvidence
    solved_dicts')
                                    ([MaybeNew] -> [CtEvidence]
    freshGoals [MaybeNew]
    evc_vs) }

                   ClsInstResult
    _ -> MaybeT TcS (EvBindMap, DictMap CtEvidence)
    forall (m :: * -> *) a. MonadPlus m => m a
    mzero }
          | Bool
    otherwise = MaybeT TcS (EvBindMap, DictMap CtEvidence)
    forall (m :: * -> *) a. MonadPlus m => m a
    mzero

        -- Use a local cache of solved dicts while emitting EvVars for new work
        -- We bail out of the entire computation if we need to emit an EvVar for
        -- a subgoal that isn't a ClassPred.
        new_wanted_cached :: CtLoc -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew
        new_wanted_cached :: CtLoc -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew
    new_wanted_cached CtLoc
    loc DictMap CtEvidence
    cache TcPredType
    pty
          | ClassPred Class
    cls [TcPredType]
    tys <- TcPredType -> Pred
    classifyPredType TcPredType
    pty
          = TcS MaybeNew -> MaybeT TcS MaybeNew
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (TcS MaybeNew -> MaybeT TcS MaybeNew)
    -> TcS MaybeNew -> MaybeT TcS MaybeNew
    forall a b. (a -> b) -> a -> b
    $ case DictMap CtEvidence
    -> CtLoc -> Class -> [TcPredType] -> Maybe CtEvidence
    forall a. DictMap a -> CtLoc -> Class -> [TcPredType] -> Maybe a
    findDict DictMap CtEvidence
    cache CtLoc
    loc_w Class
    cls [TcPredType]
    tys of
              Just CtEvidence
    ctev -> MaybeNew -> TcS MaybeNew
    forall (m :: * -> *) a. Monad m => a -> m a
    return (MaybeNew -> TcS MaybeNew) -> MaybeNew -> TcS MaybeNew
    forall a b. (a -> b) -> a -> b
    $ EvExpr -> MaybeNew
    Cached (CtEvidence -> EvExpr
    ctEvExpr CtEvidence
    ctev)
              Maybe CtEvidence
    Nothing   -> CtEvidence -> MaybeNew
    Fresh (CtEvidence -> MaybeNew) -> TcS CtEvidence -> TcS MaybeNew
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> CtLoc -> TcPredType -> TcS CtEvidence
    newWantedNC CtLoc
    loc TcPredType
    pty
          | Bool
    otherwise = MaybeT TcS MaybeNew
    forall (m :: * -> *) a. MonadPlus m => m a
    mzero

    addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS ()
    -- Add derived constraints from type-class functional dependencies.
    addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS ()
    addFunDepWork InertCans
    inerts CtEvidence
    work_ev Class
    cls
      | CtEvidence -> Bool
    isImprovable CtEvidence
    work_ev
      = (Ct -> TcS ()) -> Cts -> TcS ()
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> Bag a -> m ()
    mapBagM_ Ct -> TcS ()
    add_fds (DictMap Ct -> Class -> Cts
    forall a. DictMap a -> Class -> Bag a
    findDictsByClass (InertCans -> DictMap Ct
    inert_dicts InertCans
    inerts) Class
    cls)
                   -- No need to check flavour; fundeps work between
                   -- any pair of constraints, regardless of flavour
                   -- Importantly we don't throw workitem back in the
                   -- worklist because this can cause loops (see #5236)
      | Bool
    otherwise
      = () -> TcS ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
      where
        work_pred :: TcPredType
    work_pred = CtEvidence -> TcPredType
    ctEvPred CtEvidence
    work_ev
        work_loc :: CtLoc
    work_loc  = CtEvidence -> CtLoc
    ctEvLoc CtEvidence
    work_ev

        add_fds :: Ct -> TcS ()
    add_fds Ct
    inert_ct
          | CtEvidence -> Bool
    isImprovable CtEvidence
    inert_ev
          = do { String -> SDoc -> TcS ()
    traceTcS String
    "addFunDepWork" ([SDoc] -> SDoc
    vcat
                    [ CtEvidence -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CtEvidence
    work_ev
                    , CtLoc -> SDoc
    pprCtLoc CtLoc
    work_loc, Bool -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (CtLoc -> Bool
    isGivenLoc CtLoc
    work_loc)
                    , CtLoc -> SDoc
    pprCtLoc CtLoc
    inert_loc, Bool -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (CtLoc -> Bool
    isGivenLoc CtLoc
    inert_loc)
                    , CtLoc -> SDoc
    pprCtLoc CtLoc
    derived_loc, Bool -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (CtLoc -> Bool
    isGivenLoc CtLoc
    derived_loc) ]) ;

            [FunDepEqn CtLoc] -> TcS ()
    emitFunDepDeriveds ([FunDepEqn CtLoc] -> TcS ()) -> [FunDepEqn CtLoc] -> TcS ()
    forall a b. (a -> b) -> a -> b
    $
            CtLoc -> TcPredType -> TcPredType -> [FunDepEqn CtLoc]
    forall loc. loc -> TcPredType -> TcPredType -> [FunDepEqn loc]
    improveFromAnother CtLoc
    derived_loc TcPredType
    inert_pred TcPredType
    work_pred
                   -- 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
            }
          | Bool
    otherwise
          = () -> TcS ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
          where
            inert_ev :: CtEvidence
    inert_ev   = Ct -> CtEvidence
    ctEvidence Ct
    inert_ct
            inert_pred :: TcPredType
    inert_pred = CtEvidence -> TcPredType
    ctEvPred CtEvidence
    inert_ev
            inert_loc :: CtLoc
    inert_loc  = CtEvidence -> CtLoc
    ctEvLoc CtEvidence
    inert_ev
            derived_loc :: CtLoc
    derived_loc = CtLoc
    work_loc { ctl_depth :: SubGoalDepth
    ctl_depth  = CtLoc -> SubGoalDepth
    ctl_depth CtLoc
    work_loc SubGoalDepth -> SubGoalDepth -> SubGoalDepth
    `maxSubGoalDepth`
                                                  CtLoc -> SubGoalDepth
    ctl_depth CtLoc
    inert_loc
                                   , ctl_origin :: CtOrigin
    ctl_origin = TcPredType
    -> CtOrigin
    -> RealSrcSpan
    -> TcPredType
    -> CtOrigin
    -> RealSrcSpan
    -> CtOrigin
    FunDepOrigin1 TcPredType
    work_pred
                                                                (CtLoc -> CtOrigin
    ctLocOrigin CtLoc
    work_loc)
                                                                (CtLoc -> RealSrcSpan
    ctLocSpan CtLoc
    work_loc)
                                                                TcPredType
    inert_pred
                                                                (CtLoc -> CtOrigin
    ctLocOrigin CtLoc
    inert_loc)
                                                                (CtLoc -> RealSrcSpan
    ctLocSpan CtLoc
    inert_loc) }

    {-
    **********************************************************************
    *                                                                    *
                       Implicit parameters
    *                                                                    *
    **********************************************************************
    -}

    interactGivenIP :: InertCans -> Ct -> TcS (StopOrContinue Ct)
    -- Work item is Given (?x:ty)
    -- See Note [Shadowing of Implicit Parameters]
    interactGivenIP :: InertCans -> SimplifierStage
    interactGivenIP InertCans
    inerts workItem :: Ct
    workItem@(CDictCan { cc_ev :: Ct -> CtEvidence
    cc_ev = CtEvidence
    ev, cc_class :: Ct -> Class
    cc_class = Class
    cls
                                              , cc_tyargs :: Ct -> [TcPredType]
    cc_tyargs = tys :: [TcPredType]
    tys@(TcPredType
    ip_str:[TcPredType]
    _) })
      = do { (InertCans -> InertCans) -> TcS ()
    updInertCans ((InertCans -> InertCans) -> TcS ())
    -> (InertCans -> InertCans) -> TcS ()
    forall a b. (a -> b) -> a -> b
    $ \InertCans
    cans -> InertCans
    cans { inert_dicts :: DictMap Ct
    inert_dicts = DictMap Ct -> Class -> [TcPredType] -> Ct -> DictMap Ct
    forall a. DictMap a -> Class -> [TcPredType] -> a -> DictMap a
    addDict DictMap Ct
    filtered_dicts Class
    cls [TcPredType]
    tys Ct
    workItem }
           ; CtEvidence -> String -> TcS (StopOrContinue Ct)
    forall a. CtEvidence -> String -> TcS (StopOrContinue a)
    stopWith CtEvidence
    ev String
    "Given IP" }
      where
        dicts :: DictMap Ct
    dicts           = InertCans -> DictMap Ct
    inert_dicts InertCans
    inerts
        ip_dicts :: Cts
    ip_dicts        = DictMap Ct -> Class -> Cts
    forall a. DictMap a -> Class -> Bag a
    findDictsByClass DictMap Ct
    dicts Class
    cls
        other_ip_dicts :: Cts
    other_ip_dicts  = (Ct -> Bool) -> Cts -> Cts
    forall a. (a -> Bool) -> Bag a -> Bag a
    filterBag (Bool -> Bool
    not (Bool -> Bool) -> (Ct -> Bool) -> Ct -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Ct -> Bool
    is_this_ip) Cts
    ip_dicts
        filtered_dicts :: DictMap Ct
    filtered_dicts  = DictMap Ct -> Class -> Cts -> DictMap Ct
    addDictsByClass DictMap Ct
    dicts Class
    cls Cts
    other_ip_dicts

        -- Pick out any Given constraints for the same implicit parameter
        is_this_ip :: Ct -> Bool
    is_this_ip (CDictCan { cc_ev :: Ct -> CtEvidence
    cc_ev = CtEvidence
    ev, cc_tyargs :: Ct -> [TcPredType]
    cc_tyargs = TcPredType
    ip_str':[TcPredType]
    _ })
           = CtEvidence -> Bool
    isGiven CtEvidence
    ev Bool -> Bool -> Bool
    && TcPredType
    ip_str HasDebugCallStack => TcPredType -> TcPredType -> Bool
    TcPredType -> TcPredType -> Bool
    `tcEqType` TcPredType
    ip_str'
        is_this_ip Ct
    _ = Bool
    False

    interactGivenIP InertCans
    _ Ct
    wi = String -> SDoc -> TcS (StopOrContinue Ct)
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "interactGivenIP" (Ct -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Ct
    wi)

    {- 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.

    Similarly, consider
       f :: (?x::a) => Bool -> a

       g v = let ?x::Int = 3
             in (f v, let ?x::Bool = True in f v)

    This should probably be well typed, with
       g :: Bool -> (Int, Bool)

    So the inner binding for ?x::Bool *overrides* the outer one.

    See ticket #17104 for a rather tricky example of this overriding
    behaviour.

    All 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 wanted constraints (?x :: Int, ?x :: Char),
    which would lead to an error.

    I can think of two ways to fix this:

      1. Simply disallow multiple constraints 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.

    **********************************************************************
    *                                                                    *
                       interactFunEq
    *                                                                    *
    **********************************************************************
    -}

    improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcType
                       -> TcS ()
    -- Generate derived improvement equalities, by comparing
    -- the current work item with inert CFunEqs
    -- E.g.   x + y ~ z,   x + y' ~ z   =>   [D] y ~ y'
    --
    -- See Note [FunDep and implicit parameter reactions]
    -- Precondition: isImprovable work_ev
    improveLocalFunEqs :: CtEvidence
    -> InertCans -> TyCon -> [TcPredType] -> TcPredType -> TcS ()
    improveLocalFunEqs CtEvidence
    work_ev InertCans
    inerts TyCon
    fam_tc [TcPredType]
    args TcPredType
    rhs
      = ASSERT( isImprovable work_ev )
        Bool -> TcS () -> TcS ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless ([FunDepEqn CtLoc] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [FunDepEqn CtLoc]
    improvement_eqns) (TcS () -> TcS ()) -> TcS () -> TcS ()
    forall a b. (a -> b) -> a -> b
    $
        do { String -> SDoc -> TcS ()
    traceTcS String
    "interactFunEq improvements: " (SDoc -> TcS ()) -> SDoc -> TcS ()
    forall a b. (a -> b) -> a -> b
    $
                       [SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "Eqns:" SDoc -> SDoc -> SDoc
    <+> [FunDepEqn CtLoc] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [FunDepEqn CtLoc]
    improvement_eqns
                            , String -> SDoc
    text String
    "Candidates:" SDoc -> SDoc -> SDoc
    <+> [Ct] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Ct]
    funeqs_for_tc
                            , String -> SDoc
    text String
    "Inert eqs:" SDoc -> SDoc -> SDoc
    <+> InertEqs -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (InertCans -> InertEqs
    inert_eqs InertCans
    inerts) ]
           ; [FunDepEqn CtLoc] -> TcS ()
    emitFunDepDeriveds [FunDepEqn CtLoc]
    improvement_eqns }
      where
        funeqs :: FunEqMap EqualCtList
    funeqs        = InertCans -> FunEqMap EqualCtList
    inert_funeqs InertCans
    inerts
        funeqs_for_tc :: [Ct]
    funeqs_for_tc = [ Ct
    funeq_ct | EqualCtList (Ct
    funeq_ct :| [Ct]
    _)
                                       <- FunEqMap EqualCtList -> TyCon -> [EqualCtList]
    forall a. FunEqMap a -> TyCon -> [a]
    findFunEqsByTyCon FunEqMap EqualCtList
    funeqs TyCon
    fam_tc
                                   , EqRel
    NomEq EqRel -> EqRel -> Bool
    forall a. Eq a => a -> a -> Bool
    == Ct -> EqRel
    ctEqRel Ct
    funeq_ct ]
                                      -- representational equalities don't interact
                                      -- with type family dependencies
        work_loc :: CtLoc
    work_loc      = CtEvidence -> CtLoc
    ctEvLoc CtEvidence
    work_ev
        work_pred :: TcPredType
    work_pred     = CtEvidence -> TcPredType
    ctEvPred CtEvidence
    work_ev
        fam_inj_info :: Injectivity
    fam_inj_info  = TyCon -> Injectivity
    tyConInjectivityInfo TyCon
    fam_tc

        --------------------
        improvement_eqns :: [FunDepEqn CtLoc]
        improvement_eqns :: [FunDepEqn CtLoc]
    improvement_eqns
          | Just BuiltInSynFamily
    ops <- TyCon -> Maybe BuiltInSynFamily
    isBuiltInSynFamTyCon_maybe TyCon
    fam_tc
          =    -- Try built-in families, notably for arithmethic
            (Ct -> [FunDepEqn CtLoc]) -> [Ct] -> [FunDepEqn CtLoc]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (BuiltInSynFamily -> TcPredType -> Ct -> [FunDepEqn CtLoc]
    do_one_built_in BuiltInSynFamily
    ops TcPredType
    rhs) [Ct]
    funeqs_for_tc

          | Injective [Bool]
    injective_args <- Injectivity
    fam_inj_info
          =    -- Try improvement from type families with injectivity annotations
            (Ct -> [FunDepEqn CtLoc]) -> [Ct] -> [FunDepEqn CtLoc]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap ([Bool] -> TcPredType -> Ct -> [FunDepEqn CtLoc]
    do_one_injective [Bool]
    injective_args TcPredType
    rhs) [Ct]
    funeqs_for_tc

          | Bool
    otherwise
          = []

        --------------------
        do_one_built_in :: BuiltInSynFamily -> TcPredType -> Ct -> [FunDepEqn CtLoc]
    do_one_built_in BuiltInSynFamily
    ops TcPredType
    rhs (CEqCan { cc_lhs :: Ct -> CanEqLHS
    cc_lhs = TyFamLHS TyCon
    _ [TcPredType]
    iargs, cc_rhs :: Ct -> TcPredType
    cc_rhs = TcPredType
    irhs, cc_ev :: Ct -> CtEvidence
    cc_ev = CtEvidence
    inert_ev })
          = CtEvidence -> [TypeEqn] -> [FunDepEqn CtLoc]
    mk_fd_eqns CtEvidence
    inert_ev (BuiltInSynFamily
    -> [TcPredType]
    -> TcPredType
    -> [TcPredType]
    -> TcPredType
    -> [TypeEqn]
    sfInteractInert BuiltInSynFamily
    ops [TcPredType]
    args TcPredType
    rhs [TcPredType]
    iargs TcPredType
    irhs)

        do_one_built_in BuiltInSynFamily
    _ TcPredType
    _ Ct
    _ = String -> SDoc -> [FunDepEqn CtLoc]
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "interactFunEq 1" (TyCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyCon
    fam_tc)

        --------------------
        -- See Note [Type inference for type families with injectivity]
        do_one_injective :: [Bool] -> TcPredType -> Ct -> [FunDepEqn CtLoc]
    do_one_injective [Bool]
    inj_args TcPredType
    rhs (CEqCan { cc_lhs :: Ct -> CanEqLHS
    cc_lhs = TyFamLHS TyCon
    _ [TcPredType]
    inert_args
                                              , cc_rhs :: Ct -> TcPredType
    cc_rhs = TcPredType
    irhs, cc_ev :: Ct -> CtEvidence
    cc_ev = CtEvidence
    inert_ev })
          | CtEvidence -> Bool
    isImprovable CtEvidence
    inert_ev
          , TcPredType
    rhs HasDebugCallStack => TcPredType -> TcPredType -> Bool
    TcPredType -> TcPredType -> Bool
    `tcEqType` TcPredType
    irhs
          = CtEvidence -> [TypeEqn] -> [FunDepEqn CtLoc]
    mk_fd_eqns CtEvidence
    inert_ev ([TypeEqn] -> [FunDepEqn CtLoc]) -> [TypeEqn] -> [FunDepEqn CtLoc]
    forall a b. (a -> b) -> a -> b
    $ [ TcPredType -> TcPredType -> TypeEqn
    forall a. a -> a -> Pair a
    Pair TcPredType
    arg TcPredType
    iarg
                                  | (TcPredType
    arg, TcPredType
    iarg, Bool
    True) <- [TcPredType]
    -> [TcPredType] -> [Bool] -> [(TcPredType, TcPredType, Bool)]
    forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
    zip3 [TcPredType]
    args [TcPredType]
    inert_args [Bool]
    inj_args ]
          | Bool
    otherwise
          = []

        do_one_injective [Bool]
    _ TcPredType
    _ Ct
    _ = String -> SDoc -> [FunDepEqn CtLoc]
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "interactFunEq 2" (TyCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyCon
    fam_tc)

        --------------------
        mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn CtLoc]
        mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn CtLoc]
    mk_fd_eqns CtEvidence
    inert_ev [TypeEqn]
    eqns
          | [TypeEqn] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [TypeEqn]
    eqns  = []
          | Bool
    otherwise  = [ FDEqn { fd_qtvs :: [TyVar]
    fd_qtvs = [], fd_eqs :: [TypeEqn]
    fd_eqs = [TypeEqn]
    eqns
                                 , fd_pred1 :: TcPredType
    fd_pred1 = TcPredType
    work_pred
                                 , fd_pred2 :: TcPredType
    fd_pred2 = CtEvidence -> TcPredType
    ctEvPred CtEvidence
    inert_ev
                                 , fd_loc :: CtLoc
    fd_loc   = CtLoc
    loc } ]
          where
            inert_loc :: CtLoc
    inert_loc = CtEvidence -> CtLoc
    ctEvLoc CtEvidence
    inert_ev
            loc :: CtLoc
    loc = CtLoc
    inert_loc { ctl_depth :: SubGoalDepth
    ctl_depth = CtLoc -> SubGoalDepth
    ctl_depth CtLoc
    inert_loc SubGoalDepth -> SubGoalDepth -> SubGoalDepth
    `maxSubGoalDepth`
                                          CtLoc -> SubGoalDepth
    ctl_depth CtLoc
    work_loc }

    {- Note [Type inference for type families with injectivity]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Suppose we have a type family with an injectivity annotation:
        type family F a b = r | r -> b

    Then if we have an equality like F s1 t1 ~ F s2 t2,
    we can use the injectivity to get a new Derived constraint on
    the injective argument
      [D] t1 ~ t2

    That in turn can help GHC solve constraints that would otherwise require
    guessing.  For example, consider the ambiguity check for
       f :: F Int b -> Int
    We get the constraint
       [W] F Int b ~ F Int beta
    where beta is a unification variable.  Injectivity lets us pick beta ~ b.

    Injectivity information is also used at the call sites. For example:
       g = f True
    gives rise to
       [W] F Int b ~ Bool
    from which we can derive b.  This requires looking at the defining equations of
    a type family, ie. finding equation with a matching RHS (Bool in this example)
    and inferring values of type variables (b in this example) from the LHS patterns
    of the matching equation.  For closed type families we have to perform
    additional apartness check for the selected equation to check that the selected
    is guaranteed to fire for given LHS arguments.

    These new constraints are simply *Derived* constraints; they have no evidence.
    We could go further and offer evidence from decomposing injective type-function
    applications, but that would require new evidence forms, and an extension to
    FC, so we don't do that right now (Dec 14).

    We generate these Deriveds in three places, depending on how we notice the
    injectivity.

    1. When we have a [W/D] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and
    described in Note [Decomposing equality] in GHC.Tc.Solver.Canonical.

    2. When we have [W] F tys1 ~ T and [W] F tys2 ~ T. Note that neither of these
    constraints rewrites the other, as they have different LHSs. This is done
    in improveLocalFunEqs, called during the interactWithInertsStage.

    3. When we have [W] F tys ~ T and an equation for F that looks like F tys' = T.
    This is done in improve_top_fun_eqs, called from the top-level reactions stage.

    See also Note [Injective type families] in GHC.Core.TyCon

    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 xCtEvidence), 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.

    **********************************************************************
    *                                                                    *
                       interactEq
    *                                                                    *
    **********************************************************************
    -}

    {- Note [Combining equalities]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Suppose we have
       Inert:     g1 :: a ~ t
       Work item: g2 :: a ~ t

    Then we can simply solve g2 from g1, thus g2 := g1.  Easy!
    But it's not so simple:

    * If t is a type variable, the equalties might be oriented differently:
          e.g. (g1 :: a~b) and (g2 :: b~a)
      So we look both ways round.  Hence the SwapFlag result to
      inertsCanDischarge.

    * We can only do g2 := g1 if g1 can discharge g2; that depends on
      (a) the role and (b) the flavour.  E.g. a representational equality
      cannot discharge a nominal one; a Wanted cannot discharge a Given.
      The predicate is eqCanDischargeFR.

    * If the inert is [W] and the work-item is [WD] we don't want to
      forget the [D] part; hence the Bool result of inertsCanDischarge.

    * Visibility. Suppose  S :: forall k. k -> Type, and consider unifying
          S @Type (a::Type)  ~   S @(Type->Type) (b::Type->Type)
      From the first argument we get (Type ~ Type->Type); from the second
      argument we get (a ~ b) which in turn gives (Type ~ Type->Type).
      See typecheck/should_fail/T16204c.

      That first argument is invisible in the source program (aside from
      visible type application), so we'd much prefer to get the error from
      the second. We track visiblity in the uo_visible field of a TypeEqOrigin.
      We use this to prioritise visible errors (see GHC.Tc.Errors.tryReporters,
      the partition on isVisibleOrigin).

      So when combining two otherwise-identical equalites, we want to
      keep the visible one, and discharge the invisible one.  Hence the
      call to strictly_more_visible.
    -}

    inertsCanDischarge :: InertCans -> Ct
                       -> Maybe ( CtEvidence  -- The evidence for the inert
                                , SwapFlag    -- Whether we need mkSymCo
                                , Bool)       -- True <=> keep a [D] version
                                              --          of the [WD] constraint
    inertsCanDischarge :: InertCans -> Ct -> Maybe (CtEvidence, SwapFlag, Bool)
    inertsCanDischarge InertCans
    inerts (CEqCan { cc_lhs :: Ct -> CanEqLHS
    cc_lhs = CanEqLHS
    lhs_w, cc_rhs :: Ct -> TcPredType
    cc_rhs = TcPredType
    rhs_w
                                      , cc_ev :: Ct -> CtEvidence
    cc_ev = CtEvidence
    ev_w, cc_eq_rel :: Ct -> EqRel
    cc_eq_rel = EqRel
    eq_rel })
      | (CtEvidence
    ev_i : [CtEvidence]
    _) <- [ CtEvidence
    ev_i | CEqCan { cc_ev :: Ct -> CtEvidence
    cc_ev = CtEvidence
    ev_i, cc_rhs :: Ct -> TcPredType
    cc_rhs = TcPredType
    rhs_i
                                      , cc_eq_rel :: Ct -> EqRel
    cc_eq_rel = EqRel
    eq_rel }
                                 <- InertCans -> CanEqLHS -> [Ct]
    findEq InertCans
    inerts CanEqLHS
    lhs_w
                             , TcPredType
    rhs_i HasDebugCallStack => TcPredType -> TcPredType -> Bool
    TcPredType -> TcPredType -> Bool
    `tcEqType` TcPredType
    rhs_w
                             , CtEvidence -> EqRel -> Bool
    inert_beats_wanted CtEvidence
    ev_i EqRel
    eq_rel ]
      =  -- Inert:     a ~ ty
         -- Work item: a ~ ty
        (CtEvidence, SwapFlag, Bool) -> Maybe (CtEvidence, SwapFlag, Bool)
    forall a. a -> Maybe a
    Just (CtEvidence
    ev_i, SwapFlag
    NotSwapped, CtEvidence -> Bool
    keep_deriv CtEvidence
    ev_i)

      | Just CanEqLHS
    rhs_lhs <- TcPredType -> Maybe CanEqLHS
    canEqLHS_maybe TcPredType
    rhs_w
      , (CtEvidence
    ev_i : [CtEvidence]
    _) <- [ CtEvidence
    ev_i | CEqCan { cc_ev :: Ct -> CtEvidence
    cc_ev = CtEvidence
    ev_i, cc_rhs :: Ct -> TcPredType
    cc_rhs = TcPredType
    rhs_i
                                      , cc_eq_rel :: Ct -> EqRel
    cc_eq_rel = EqRel
    eq_rel }
                                 <- InertCans -> CanEqLHS -> [Ct]
    findEq InertCans
    inerts CanEqLHS
    rhs_lhs
                             , TcPredType
    rhs_i HasDebugCallStack => TcPredType -> TcPredType -> Bool
    TcPredType -> TcPredType -> Bool
    `tcEqType` CanEqLHS -> TcPredType
    canEqLHSType CanEqLHS
    lhs_w
                             , CtEvidence -> EqRel -> Bool
    inert_beats_wanted CtEvidence
    ev_i EqRel
    eq_rel ]
      =  -- Inert:     a ~ b
         -- Work item: b ~ a
         (CtEvidence, SwapFlag, Bool) -> Maybe (CtEvidence, SwapFlag, Bool)
    forall a. a -> Maybe a
    Just (CtEvidence
    ev_i, SwapFlag
    IsSwapped, CtEvidence -> Bool
    keep_deriv CtEvidence
    ev_i)

      where
        loc_w :: CtLoc
    loc_w  = CtEvidence -> CtLoc
    ctEvLoc CtEvidence
    ev_w
        flav_w :: CtFlavour
    flav_w = CtEvidence -> CtFlavour
    ctEvFlavour CtEvidence
    ev_w
        fr_w :: (CtFlavour, EqRel)
    fr_w   = (CtFlavour
    flav_w, EqRel
    eq_rel)

        inert_beats_wanted :: CtEvidence -> EqRel -> Bool
    inert_beats_wanted CtEvidence
    ev_i EqRel
    eq_rel
          = -- eqCanDischargeFR:    see second bullet of Note [Combining equalities]
            -- strictly_more_visible: see last bullet of Note [Combining equalities]
            (CtFlavour, EqRel)
    fr_i(CtFlavour, EqRel) -> (CtFlavour, EqRel) -> Bool
    `eqCanDischargeFR` (CtFlavour, EqRel)
    fr_w
            Bool -> Bool -> Bool
    && Bool -> Bool
    not ((CtLoc
    loc_w CtLoc -> CtLoc -> Bool
    `strictly_more_visible` CtEvidence -> CtLoc
    ctEvLoc CtEvidence
    ev_i)
                     Bool -> Bool -> Bool
    && ((CtFlavour, EqRel)
    fr_w (CtFlavour, EqRel) -> (CtFlavour, EqRel) -> Bool
    `eqCanDischargeFR` (CtFlavour, EqRel)
    fr_i))
          where
            fr_i :: (CtFlavour, EqRel)
    fr_i = (CtEvidence -> CtFlavour
    ctEvFlavour CtEvidence
    ev_i, EqRel
    eq_rel)

        -- See Note [Combining equalities], third bullet
        keep_deriv :: CtEvidence -> Bool
    keep_deriv CtEvidence
    ev_i
          | Wanted ShadowInfo
    WOnly  <- CtEvidence -> CtFlavour
    ctEvFlavour CtEvidence
    ev_i  -- inert is [W]
          , Wanted ShadowInfo
    WDeriv <- CtFlavour
    flav_w            -- work item is [WD]
          = Bool
    True   -- Keep a derived version of the work item
          | Bool
    otherwise
          = Bool
    False  -- Work item is fully discharged

        -- See Note [Combining equalities], final bullet
        strictly_more_visible :: CtLoc -> CtLoc -> Bool
    strictly_more_visible CtLoc
    loc1 CtLoc
    loc2
           = Bool -> Bool
    not (CtOrigin -> Bool
    isVisibleOrigin (CtLoc -> CtOrigin
    ctLocOrigin CtLoc
    loc2)) Bool -> Bool -> Bool
    &&
             CtOrigin -> Bool
    isVisibleOrigin (CtLoc -> CtOrigin
    ctLocOrigin CtLoc
    loc1)

    inertsCanDischarge InertCans
    _ Ct
    _ = Maybe (CtEvidence, SwapFlag, Bool)
    forall a. Maybe a
    Nothing

    interactEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)
    interactEq :: InertCans -> SimplifierStage
    interactEq InertCans
    inerts workItem :: Ct
    workItem@(CEqCan { cc_lhs :: Ct -> CanEqLHS
    cc_lhs = CanEqLHS
    lhs
                                       , cc_rhs :: Ct -> TcPredType
    cc_rhs = TcPredType
    rhs
                                       , cc_ev :: Ct -> CtEvidence
    cc_ev = CtEvidence
    ev
                                       , cc_eq_rel :: Ct -> EqRel
    cc_eq_rel = EqRel
    eq_rel })
      | Just (CtEvidence
    ev_i, SwapFlag
    swapped, Bool
    keep_deriv) <- InertCans -> Ct -> Maybe (CtEvidence, SwapFlag, Bool)
    inertsCanDischarge InertCans
    inerts Ct
    workItem
      = do { CtEvidence -> EvTerm -> TcS ()
    setEvBindIfWanted CtEvidence
    ev (EvTerm -> TcS ()) -> EvTerm -> TcS ()
    forall a b. (a -> b) -> a -> b
    $
             TcCoercion -> EvTerm
    evCoercion (SwapFlag -> TcCoercion -> TcCoercion
    maybeTcSymCo SwapFlag
    swapped (TcCoercion -> TcCoercion) -> TcCoercion -> TcCoercion
    forall a b. (a -> b) -> a -> b
    $
                         Role -> Role -> TcCoercion -> TcCoercion
    tcDowngradeRole (EqRel -> Role
    eqRelRole EqRel
    eq_rel)
                                         (CtEvidence -> Role
    ctEvRole CtEvidence
    ev_i)
                                         (HasDebugCallStack => CtEvidence -> TcCoercion
    CtEvidence -> TcCoercion
    ctEvCoercion CtEvidence
    ev_i))

           ; let deriv_ev :: CtEvidence
    deriv_ev = CtDerived { ctev_pred :: TcPredType
    ctev_pred = CtEvidence -> TcPredType
    ctEvPred CtEvidence
    ev
                                      , ctev_loc :: CtLoc
    ctev_loc  = CtEvidence -> CtLoc
    ctEvLoc  CtEvidence
    ev }
           ; Bool -> TcS () -> TcS ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    keep_deriv (TcS () -> TcS ()) -> TcS () -> TcS ()
    forall a b. (a -> b) -> a -> b
    $
             [Ct] -> TcS ()
    emitWork [Ct
    workItem { cc_ev :: CtEvidence
    cc_ev = CtEvidence
    deriv_ev }]
             -- As a Derived it might not be fully rewritten,
             -- so we emit it as new work

           ; CtEvidence -> String -> TcS (StopOrContinue Ct)
    forall a. CtEvidence -> String -> TcS (StopOrContinue a)
    stopWith CtEvidence
    ev String
    "Solved from inert" }

      | EqRel
    ReprEq <- EqRel
    eq_rel   -- See Note [Do not unify representational equalities]
      = do { String -> SDoc -> TcS ()
    traceTcS String
    "Not unifying representational equality" (Ct -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Ct
    workItem)
           ; SimplifierStage
    forall a. a -> TcS (StopOrContinue a)
    continueWith Ct
    workItem }

      | Bool
    otherwise
      = case CanEqLHS
    lhs of
           TyVarLHS TyVar
    tv -> Ct -> CtEvidence -> TyVar -> TcPredType -> TcS (StopOrContinue Ct)
    tryToSolveByUnification Ct
    workItem CtEvidence
    ev TyVar
    tv TcPredType
    rhs

           TyFamLHS TyCon
    tc [TcPredType]
    args -> do { Bool -> TcS () -> TcS ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (CtEvidence -> Bool
    isImprovable CtEvidence
    ev) (TcS () -> TcS ()) -> TcS () -> TcS ()
    forall a b. (a -> b) -> a -> b
    $
                                     -- Try improvement, if possible
                                    CtEvidence
    -> InertCans -> TyCon -> [TcPredType] -> TcPredType -> TcS ()
    improveLocalFunEqs CtEvidence
    ev InertCans
    inerts TyCon
    tc [TcPredType]
    args TcPredType
    rhs
                                  ; SimplifierStage
    forall a. a -> TcS (StopOrContinue a)
    continueWith Ct
    workItem }

    interactEq InertCans
    _ Ct
    wi = String -> SDoc -> TcS (StopOrContinue Ct)
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "interactEq" (Ct -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Ct
    wi)

    ----------------------
    -- We have a meta-tyvar on the left, and metaTyVarUpateOK has said "yes"
    -- So try to solve by unifying.
    -- Three reasons why not:
    --    Skolem escape
    --    Given equalities (GADTs)
    --    Unifying a TyVarTv with a non-tyvar type
    tryToSolveByUnification :: Ct -> CtEvidence
                            -> TcTyVar   -- LHS tyvar
                            -> TcType    -- RHS
                            -> TcS (StopOrContinue Ct)
    tryToSolveByUnification :: Ct -> CtEvidence -> TyVar -> TcPredType -> TcS (StopOrContinue Ct)
    tryToSolveByUnification Ct
    work_item CtEvidence
    ev TyVar
    tv TcPredType
    rhs
      = do { TouchabilityTestResult
    is_touchable <- CtFlavour -> TyVar -> TcPredType -> TcS TouchabilityTestResult
    touchabilityTest (CtEvidence -> CtFlavour
    ctEvFlavour CtEvidence
    ev) TyVar
    tv TcPredType
    rhs
           ; String -> SDoc -> TcS ()
    traceTcS String
    "tryToSolveByUnification" ([SDoc] -> SDoc
    vcat [ TyVar -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyVar
    tv SDoc -> SDoc -> SDoc
    <+> Char -> SDoc
    char Char
    '~' SDoc -> SDoc -> SDoc
    <+> TcPredType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TcPredType
    rhs
                                                      , TouchabilityTestResult -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TouchabilityTestResult
    is_touchable ])

           ; case TouchabilityTestResult
    is_touchable of
               TouchabilityTestResult
    Untouchable -> SimplifierStage
    forall a. a -> TcS (StopOrContinue a)
    continueWith Ct
    work_item
               -- For the latter two cases see Note [Solve by unification]
               TouchabilityTestResult
    TouchableSameLevel -> CtEvidence -> TyVar -> TcPredType -> TcS (StopOrContinue Ct)
    solveByUnification CtEvidence
    ev TyVar
    tv TcPredType
    rhs
               TouchableOuterLevel [TyVar]
    free_metas TcLevel
    tv_lvl
                 -> do { TcM () -> TcS ()
    forall a. TcM a -> TcS a
    wrapTcS (TcM () -> TcS ()) -> TcM () -> TcS ()
    forall a b. (a -> b) -> a -> b
    $ (TyVar -> IOEnv (Env TcGblEnv TcLclEnv) Bool) -> [TyVar] -> TcM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (TcLevel -> TyVar -> IOEnv (Env TcGblEnv TcLclEnv) Bool
    promoteMetaTyVarTo TcLevel
    tv_lvl) [TyVar]
    free_metas
                       ; TcLevel -> TcS ()
    setUnificationFlag TcLevel
    tv_lvl
                       ; CtEvidence -> TyVar -> TcPredType -> TcS (StopOrContinue Ct)
    solveByUnification CtEvidence
    ev TyVar
    tv TcPredType
    rhs } }

    solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS (StopOrContinue Ct)
    -- Solve with the identity coercion
    -- Precondition: kind(xi) equals kind(tv)
    -- Precondition: CtEvidence is Wanted or Derived
    -- Precondition: CtEvidence is nominal
    -- Returns: workItem where
    --        workItem = the new Given constraint
    --
    -- NB: No need for an occurs check here, because solveByUnification always
    --     arises from a CEqCan, a *canonical* constraint.  Its invariant (TyEq:OC)
    --     says that in (a ~ xi), the type variable a does not appear in xi.
    --     See GHC.Tc.Types.Constraint.Ct invariants.
    --
    -- Post: tv is unified (by side effect) with xi;
    --       we often write tv := xi
    solveByUnification :: CtEvidence -> TyVar -> TcPredType -> TcS (StopOrContinue Ct)
    solveByUnification CtEvidence
    wd TyVar
    tv TcPredType
    xi
      = do { let tv_ty :: TcPredType
    tv_ty = TyVar -> TcPredType
    mkTyVarTy TyVar
    tv
           ; String -> SDoc -> TcS ()
    traceTcS String
    "Sneaky unification:" (SDoc -> TcS ()) -> SDoc -> TcS ()
    forall a b. (a -> b) -> a -> b
    $
                           [SDoc] -> SDoc
    vcat [String -> SDoc
    text String
    "Unifies:" SDoc -> SDoc -> SDoc
    <+> TyVar -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyVar
    tv SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    ":=" SDoc -> SDoc -> SDoc
    <+> TcPredType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TcPredType
    xi,
                                 String -> SDoc
    text String
    "Coercion:" SDoc -> SDoc -> SDoc
    <+> TcPredType -> TcPredType -> SDoc
    pprEq TcPredType
    tv_ty TcPredType
    xi,
                                 String -> SDoc
    text String
    "Left Kind is:" SDoc -> SDoc -> SDoc
    <+> TcPredType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (HasDebugCallStack => TcPredType -> TcPredType
    TcPredType -> TcPredType
    tcTypeKind TcPredType
    tv_ty),
                                 String -> SDoc
    text String
    "Right Kind is:" SDoc -> SDoc -> SDoc
    <+> TcPredType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (HasDebugCallStack => TcPredType -> TcPredType
    TcPredType -> TcPredType
    tcTypeKind TcPredType
    xi) ]
           ; TyVar -> TcPredType -> TcS ()
    unifyTyVar TyVar
    tv TcPredType
    xi
           ; CtEvidence -> EvTerm -> TcS ()
    setEvBindIfWanted CtEvidence
    wd (TcCoercion -> EvTerm
    evCoercion (TcPredType -> TcCoercion
    mkTcNomReflCo TcPredType
    xi))
           ; Int
    n_kicked <- TyVar -> TcS Int
    kickOutAfterUnification TyVar
    tv
           ; StopOrContinue Ct -> TcS (StopOrContinue Ct)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CtEvidence -> SDoc -> StopOrContinue Ct
    forall a. CtEvidence -> SDoc -> StopOrContinue a
    Stop CtEvidence
    wd (String -> SDoc
    text String
    "Solved by unification" SDoc -> SDoc -> SDoc
    <+> Int -> SDoc
    pprKicked Int
    n_kicked)) }

    {- 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 it 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 GHC.Tc.Solver.Monad; avoiding
    double unifications is the main reason we disallow touchable
    unification variables as RHS of type family equations: F xis ~ alpha.

    Note [Do not unify representational equalities]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider   [W] alpha ~R# b
    where alpha is touchable. Should we unify alpha := b?

    Certainly not!  Unifying forces alpha and be to be the same; but they
    only need to be representationally equal types.

    For example, we might have another constraint [W] alpha ~# N b
    where
      newtype N b = MkN b
    and we want to get alpha := N b.

    See also #15144, which was caused by unifying a representational
    equality.

    Note [Solve by unification]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~
    If we solve
       alpha[n] ~ ty
    by unification, there are two cases to consider

    * TouchableSameLevel: if the ambient level is 'n', then
      we can simply update alpha := ty, and do nothing else

    * TouchableOuterLevel free_metas n: if the ambient level is greater than
      'n' (the level of alpha), in addition to setting alpha := ty we must
      do two other things:

      1. Promote all the free meta-vars of 'ty' to level n.  After all,
         alpha[n] is at level n, and so if we set, say,
              alpha[n] := Maybe beta[m],
         we must ensure that when unifying beta we do skolem-escape checks
         etc relevant to level n.  Simple way to do that: promote beta to
         level n.

      2. Set the Unification Level Flag to record that a level-n unification has
         taken place. See Note [The Unification Level Flag] in GHC.Tc.Solver.Monad

    NB: TouchableSameLevel is just an optimisation for TouchableOuterLevel. Promotion
    would be a no-op, and setting the unification flag unnecessarily would just
    make the solver iterate more often.  (We don't need to iterate when unifying
    at the ambient level because of the kick-out mechanism.)

    ************************************************************************
    *                                                                      *
    *          Functional dependencies, instantiation of equations
    *                                                                      *
    ************************************************************************

    When we spot an equality arising from a functional dependency,
    we now use that equality (a "wanted") to rewrite the work-item
    constraint right away.  This avoids two dangers

     Danger 1: If we send the original constraint on down the pipeline
               it may react with an instance declaration, and in delicate
               situations (when a Given overlaps with an instance) that
               may produce new insoluble goals: see #4952

     Danger 2: If we don't rewrite the constraint, it may re-react
               with the same thing later, and produce the same equality
               again --> termination worries.

    To achieve this required some refactoring of GHC.Tc.Instance.FunDeps (nicer
    now!).

    Note [FunDep and implicit parameter reactions]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Currently, our story of interacting two dictionaries (or a dictionary
    and top-level instances) for functional dependencies, and implicit
    parameters, is that we simply produce new Derived equalities.  So for example

            class D a b | a -> b where ...
        Inert:
            d1 :g D Int Bool
        WorkItem:
            d2 :w D Int alpha

        We generate the extra work item
            cv :d alpha ~ Bool
        where 'cv' is currently unused.  However, this new item can perhaps be
        spontaneously solved to become given and react with d2,
        discharging it in favour of a new constraint d2' thus:
            d2' :w D Int Bool
            d2 := d2' |> D Int cv
        Now d2' can be discharged from d1

    We could be more aggressive and try to *immediately* solve the dictionary
    using those extra equalities, but that requires those equalities to carry
    evidence and derived do not carry evidence.

    If that were the case with the same inert set and work item we might dischard
    d2 directly:

            cv :w alpha ~ Bool
            d2 := d1 |> D Int cv

    But in general it's a bit painful to figure out the necessary coercion,
    so we just take the first approach. Here is a better example. Consider:
        class C a b c | a -> b
    And:
         [Given]  d1 : C T Int Char
         [Wanted] d2 : C T beta Int
    In this case, it's *not even possible* to solve the wanted immediately.
    So we should simply output the functional dependency and add this guy
    [but NOT its superclasses] back in the worklist. Even worse:
         [Given] d1 : C T Int beta
         [Wanted] d2: C T beta Int
    Then it is solvable, but its very hard to detect this on the spot.

    It's exactly the same with implicit parameters, except that the
    "aggressive" approach would be much easier to implement.

    Note [Weird fundeps]
    ~~~~~~~~~~~~~~~~~~~~
    Consider   class Het a b | a -> b where
                  het :: m (f c) -> a -> m b

               class GHet (a :: * -> *) (b :: * -> *) | a -> b
               instance            GHet (K a) (K [a])
               instance Het a b => GHet (K a) (K b)

    The two instances don't actually conflict on their fundeps,
    although it's pretty strange.  So they are both accepted. Now
    try   [W] GHet (K Int) (K Bool)
    This triggers fundeps from both instance decls;
          [D] K Bool ~ K [a]
          [D] K Bool ~ K beta
    And there's a risk of complaining about Bool ~ [a].  But in fact
    the Wanted matches the second instance, so we never get as far
    as the fundeps.

    #7875 is a case in point.
    -}

    emitFunDepDeriveds :: [FunDepEqn CtLoc] -> TcS ()
    -- See Note [FunDep and implicit parameter reactions]
    emitFunDepDeriveds :: [FunDepEqn CtLoc] -> TcS ()
    emitFunDepDeriveds [FunDepEqn CtLoc]
    fd_eqns
      = (FunDepEqn CtLoc -> TcS ()) -> [FunDepEqn CtLoc] -> TcS ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ FunDepEqn CtLoc -> TcS ()
    do_one_FDEqn [FunDepEqn CtLoc]
    fd_eqns
      where
        do_one_FDEqn :: FunDepEqn CtLoc -> TcS ()
    do_one_FDEqn (FDEqn { fd_qtvs :: forall loc. FunDepEqn loc -> [TyVar]
    fd_qtvs = [TyVar]
    tvs, fd_eqs :: forall loc. FunDepEqn loc -> [TypeEqn]
    fd_eqs = [TypeEqn]
    eqs, fd_loc :: forall loc. FunDepEqn loc -> loc
    fd_loc = CtLoc
    loc })
         | [TyVar] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [TyVar]
    tvs  -- Common shortcut
         = do { String -> SDoc -> TcS ()
    traceTcS String
    "emitFunDepDeriveds 1" (SubGoalDepth -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (CtLoc -> SubGoalDepth
    ctl_depth CtLoc
    loc) SDoc -> SDoc -> SDoc
    $$ [TypeEqn] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [TypeEqn]
    eqs SDoc -> SDoc -> SDoc
    $$ Bool -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (CtLoc -> Bool
    isGivenLoc CtLoc
    loc))
              ; (TypeEqn -> TcS ()) -> [TypeEqn] -> TcS ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (CtLoc -> Role -> TypeEqn -> TcS ()
    unifyDerived CtLoc
    loc Role
    Nominal) [TypeEqn]
    eqs }
         | Bool
    otherwise
         = do { String -> SDoc -> TcS ()
    traceTcS String
    "emitFunDepDeriveds 2" (SubGoalDepth -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (CtLoc -> SubGoalDepth
    ctl_depth CtLoc
    loc) SDoc -> SDoc -> SDoc
    $$ [TyVar] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [TyVar]
    tvs SDoc -> SDoc -> SDoc
    $$ [TypeEqn] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [TypeEqn]
    eqs)
              ; TCvSubst
    subst <- [TyVar] -> TcS TCvSubst
    instFlexi [TyVar]
    tvs  -- Takes account of kind substitution
              ; (TypeEqn -> TcS ()) -> [TypeEqn] -> TcS ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (CtLoc -> TCvSubst -> TypeEqn -> TcS ()
    do_one_eq CtLoc
    loc TCvSubst
    subst) [TypeEqn]
    eqs }

        do_one_eq :: CtLoc -> TCvSubst -> TypeEqn -> TcS ()
    do_one_eq CtLoc
    loc TCvSubst
    subst (Pair TcPredType
    ty1 TcPredType
    ty2)
           = CtLoc -> Role -> TypeEqn -> TcS ()
    unifyDerived CtLoc
    loc Role
    Nominal (TypeEqn -> TcS ()) -> TypeEqn -> TcS ()
    forall a b. (a -> b) -> a -> b
    $
             TcPredType -> TcPredType -> TypeEqn
    forall a. a -> a -> Pair a
    Pair (TCvSubst -> TcPredType -> TcPredType
    Type.substTyUnchecked TCvSubst
    subst TcPredType
    ty1) (TCvSubst -> TcPredType -> TcPredType
    Type.substTyUnchecked TCvSubst
    subst TcPredType
    ty2)

    {-
    **********************************************************************
    *                                                                    *
                           The top-reaction Stage
    *                                                                    *
    **********************************************************************
    -}

    topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct)
    -- The work item does not react with the inert set,
    -- so try interaction with top-level instances. Note:
    topReactionsStage :: SimplifierStage
    topReactionsStage Ct
    work_item
      = do { String -> SDoc -> TcS ()
    traceTcS String
    "doTopReact" (Ct -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Ct
    work_item)
           ; case Ct
    work_item of
               CDictCan {}  -> do { InertSet
    inerts <- TcS InertSet
    getTcSInerts
                                  ; InertSet -> SimplifierStage
    doTopReactDict InertSet
    inerts Ct
    work_item }
               CEqCan {}    -> SimplifierStage
    doTopReactEq    Ct
    work_item
               CIrredCan {} -> SimplifierStage
    doTopReactOther Ct
    work_item
               Ct
    _  -> -- Any other work item does not react with any top-level equations
                     SimplifierStage
    forall a. a -> TcS (StopOrContinue a)
    continueWith Ct
    work_item  }

    --------------------
    doTopReactOther :: Ct -> TcS (StopOrContinue Ct)
    -- Try local quantified constraints for
    --     CEqCan    e.g.  (lhs ~# ty)
    -- and CIrredCan e.g.  (c a)
    --
    -- Why equalities? See GHC.Tc.Solver.Canonical
    -- Note [Equality superclasses in quantified constraints]
    doTopReactOther :: SimplifierStage
    doTopReactOther Ct
    work_item
      | CtEvidence -> Bool
    isGiven CtEvidence
    ev
      = SimplifierStage
    forall a. a -> TcS (StopOrContinue a)
    continueWith Ct
    work_item

      | EqPred EqRel
    eq_rel TcPredType
    t1 TcPredType
    t2 <- TcPredType -> Pred
    classifyPredType TcPredType
    pred
      = Ct -> EqRel -> TcPredType -> TcPredType -> TcS (StopOrContinue Ct)
    doTopReactEqPred Ct
    work_item EqRel
    eq_rel TcPredType
    t1 TcPredType
    t2

      | Bool
    otherwise
      = do { ClsInstResult
    res <- TcPredType -> CtLoc -> TcS ClsInstResult
    matchLocalInst TcPredType
    pred CtLoc
    loc
           ; case ClsInstResult
    res of
               OneInst {} -> Ct -> ClsInstResult -> TcS (StopOrContinue Ct)
    chooseInstance Ct
    work_item ClsInstResult
    res
               ClsInstResult
    _          -> SimplifierStage
    forall a. a -> TcS (StopOrContinue a)
    continueWith Ct
    work_item }

      where
        ev :: CtEvidence
    ev   = Ct -> CtEvidence
    ctEvidence Ct
    work_item
        loc :: CtLoc
    loc  = CtEvidence -> CtLoc
    ctEvLoc CtEvidence
    ev
        pred :: TcPredType
    pred = CtEvidence -> TcPredType
    ctEvPred CtEvidence
    ev

    doTopReactEqPred :: Ct -> EqRel -> TcType -> TcType -> TcS (StopOrContinue Ct)
    doTopReactEqPred :: Ct -> EqRel -> TcPredType -> TcPredType -> TcS (StopOrContinue Ct)
    doTopReactEqPred Ct
    work_item EqRel
    eq_rel TcPredType
    t1 TcPredType
    t2
      -- See Note [Looking up primitive equalities in quantified constraints]
      | Just (Class
    cls, [TcPredType]
    tys) <- EqRel -> TcPredType -> TcPredType -> Maybe (Class, [TcPredType])
    boxEqPred EqRel
    eq_rel TcPredType
    t1 TcPredType
    t2
      = do { ClsInstResult
    res <- TcPredType -> CtLoc -> TcS ClsInstResult
    matchLocalInst (Class -> [TcPredType] -> TcPredType
    mkClassPred Class
    cls [TcPredType]
    tys) CtLoc
    loc
           ; case ClsInstResult
    res of
               OneInst { cir_mk_ev :: ClsInstResult -> [EvExpr] -> EvTerm
    cir_mk_ev = [EvExpr] -> EvTerm
    mk_ev }
                 -> Ct -> ClsInstResult -> TcS (StopOrContinue Ct)
    chooseInstance Ct
    work_item
                        (ClsInstResult
    res { cir_mk_ev :: [EvExpr] -> EvTerm
    cir_mk_ev = Class -> [TcPredType] -> ([EvExpr] -> EvTerm) -> [EvExpr] -> EvTerm
    forall {t}. Class -> [TcPredType] -> (t -> EvTerm) -> t -> EvTerm
    mk_eq_ev Class
    cls [TcPredType]
    tys [EvExpr] -> EvTerm
    mk_ev })
               ClsInstResult
    _ -> SimplifierStage
    forall a. a -> TcS (StopOrContinue a)
    continueWith Ct
    work_item }

      | Bool
    otherwise
      = SimplifierStage
    forall a. a -> TcS (StopOrContinue a)
    continueWith Ct
    work_item
      where
        ev :: CtEvidence
    ev   = Ct -> CtEvidence
    ctEvidence Ct
    work_item
        loc :: CtLoc
    loc = CtEvidence -> CtLoc
    ctEvLoc CtEvidence
    ev

        mk_eq_ev :: Class -> [TcPredType] -> (t -> EvTerm) -> t -> EvTerm
    mk_eq_ev Class
    cls [TcPredType]
    tys t -> EvTerm
    mk_ev t
    evs
          = case (t -> EvTerm
    mk_ev t
    evs) of
              EvExpr EvExpr
    e -> EvExpr -> EvTerm
    EvExpr (TyVar -> EvExpr
    forall b. TyVar -> Expr b
    Var TyVar
    sc_id EvExpr -> [TcPredType] -> EvExpr
    forall b. Expr b -> [TcPredType] -> Expr b
    `mkTyApps` [TcPredType]
    tys EvExpr -> EvExpr -> EvExpr
    forall b. Expr b -> Expr b -> Expr b
    `App` EvExpr
    e)
              EvTerm
    ev       -> String -> SDoc -> EvTerm
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "mk_eq_ev" (EvTerm -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr EvTerm
    ev)
          where
            [TyVar
    sc_id] = Class -> [TyVar]
    classSCSelIds Class
    cls

    {- Note [Looking up primitive equalities in quantified constraints]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    For equalities (a ~# b) look up (a ~ b), and then do a superclass
    selection. This avoids having to support quantified constraints whose
    kind is not Constraint, such as (forall a. F a ~# b)

    See
     * Note [Evidence for quantified constraints] in GHC.Core.Predicate
     * Note [Equality superclasses in quantified constraints]
       in GHC.Tc.Solver.Canonical
    -}

    --------------------
    doTopReactEq :: Ct -> TcS (StopOrContinue Ct)
    doTopReactEq :: SimplifierStage
    doTopReactEq work_item :: Ct
    work_item@(CEqCan { cc_ev :: Ct -> CtEvidence
    cc_ev = CtEvidence
    old_ev, cc_lhs :: Ct -> CanEqLHS
    cc_lhs = TyFamLHS TyCon
    fam_tc [TcPredType]
    args
                                   , cc_rhs :: Ct -> TcPredType
    cc_rhs = TcPredType
    rhs })
      = do { CtEvidence -> TyCon -> [TcPredType] -> TcPredType -> TcS ()
    improveTopFunEqs CtEvidence
    old_ev TyCon
    fam_tc [TcPredType]
    args TcPredType
    rhs
           ; SimplifierStage
    doTopReactOther Ct
    work_item }
    doTopReactEq Ct
    work_item = SimplifierStage
    doTopReactOther Ct
    work_item

    improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcType -> TcS ()
    -- See Note [FunDep and implicit parameter reactions]
    improveTopFunEqs :: CtEvidence -> TyCon -> [TcPredType] -> TcPredType -> TcS ()
    improveTopFunEqs CtEvidence
    ev TyCon
    fam_tc [TcPredType]
    args TcPredType
    rhs
      | Bool -> Bool
    not (CtEvidence -> Bool
    isImprovable CtEvidence
    ev)
      = () -> TcS ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

      | Bool
    otherwise
      = do { (FamInstEnv, FamInstEnv)
    fam_envs <- TcS (FamInstEnv, FamInstEnv)
    getFamInstEnvs
           ; [TypeEqn]
    eqns <- (FamInstEnv, FamInstEnv)
    -> TyCon -> [TcPredType] -> TcPredType -> TcS [TypeEqn]
    improve_top_fun_eqs (FamInstEnv, FamInstEnv)
    fam_envs TyCon
    fam_tc [TcPredType]
    args TcPredType
    rhs
           ; String -> SDoc -> TcS ()
    traceTcS String
    "improveTopFunEqs" ([SDoc] -> SDoc
    vcat [ TyCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyCon
    fam_tc SDoc -> SDoc -> SDoc
    <+> [TcPredType] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [TcPredType]
    args SDoc -> SDoc -> SDoc
    <+> TcPredType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TcPredType
    rhs
                                              , [TypeEqn] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [TypeEqn]
    eqns ])
           ; (TypeEqn -> TcS ()) -> [TypeEqn] -> TcS ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (CtLoc -> Role -> TypeEqn -> TcS ()
    unifyDerived CtLoc
    loc Role
    Nominal) [TypeEqn]
    eqns }
      where
        loc :: CtLoc
    loc = CtLoc -> CtLoc
    bumpCtLocDepth (CtEvidence -> CtLoc
    ctEvLoc CtEvidence
    ev)
            -- ToDo: this location is wrong; it should be FunDepOrigin2
            -- See #14778

    improve_top_fun_eqs :: FamInstEnvs
                        -> TyCon -> [TcType] -> TcType
                        -> TcS [TypeEqn]
    improve_top_fun_eqs :: (FamInstEnv, FamInstEnv)
    -> TyCon -> [TcPredType] -> TcPredType -> TcS [TypeEqn]
    improve_top_fun_eqs (FamInstEnv, FamInstEnv)
    fam_envs TyCon
    fam_tc [TcPredType]
    args TcPredType
    rhs_ty
      | Just BuiltInSynFamily
    ops <- TyCon -> Maybe BuiltInSynFamily
    isBuiltInSynFamTyCon_maybe TyCon
    fam_tc
      = [TypeEqn] -> TcS [TypeEqn]
    forall (m :: * -> *) a. Monad m => a -> m a
    return (BuiltInSynFamily -> [TcPredType] -> TcPredType -> [TypeEqn]
    sfInteractTop BuiltInSynFamily
    ops [TcPredType]
    args TcPredType
    rhs_ty)

      -- see Note [Type inference for type families with injectivity]
      | TyCon -> Bool
    isOpenTypeFamilyTyCon TyCon
    fam_tc
      , Injective [Bool]
    injective_args <- TyCon -> Injectivity
    tyConInjectivityInfo TyCon
    fam_tc
      , let fam_insts :: [FamInst]
    fam_insts = (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst]
    lookupFamInstEnvByTyCon (FamInstEnv, FamInstEnv)
    fam_envs TyCon
    fam_tc
      = -- it is possible to have several compatible equations in an open type
        -- family but we only want to derive equalities from one such equation.
        do { let improvs :: [([TcPredType], TCvSubst, [TyVar], Maybe CoAxBranch)]
    improvs = [FamInst]
    -> (FamInst -> [TyVar])
    -> (FamInst -> [TcPredType])
    -> (FamInst -> TcPredType)
    -> (FamInst -> Maybe CoAxBranch)
    -> [([TcPredType], TCvSubst, [TyVar], Maybe CoAxBranch)]
    forall a.
    [a]
    -> (a -> [TyVar])
    -> (a -> [TcPredType])
    -> (a -> TcPredType)
    -> (a -> Maybe CoAxBranch)
    -> [([TcPredType], TCvSubst, [TyVar], Maybe CoAxBranch)]
    buildImprovementData [FamInst]
    fam_insts
                               FamInst -> [TyVar]
    fi_tvs FamInst -> [TcPredType]
    fi_tys FamInst -> TcPredType
    fi_rhs (Maybe CoAxBranch -> FamInst -> Maybe CoAxBranch
    forall a b. a -> b -> a
    const Maybe CoAxBranch
    forall a. Maybe a
    Nothing)

           ; String -> SDoc -> TcS ()
    traceTcS String
    "improve_top_fun_eqs2" ([([TcPredType], TCvSubst, [TyVar], Maybe CoAxBranch)] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [([TcPredType], TCvSubst, [TyVar], Maybe CoAxBranch)]
    improvs)
           ; (([TcPredType], TCvSubst, [TyVar], Maybe CoAxBranch)
     -> TcS [TypeEqn])
    -> [([TcPredType], TCvSubst, [TyVar], Maybe CoAxBranch)]
    -> TcS [TypeEqn]
    forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
    concatMapM ([Bool]
    -> ([TcPredType], TCvSubst, [TyVar], Maybe CoAxBranch)
    -> TcS [TypeEqn]
    injImproveEqns [Bool]
    injective_args) ([([TcPredType], TCvSubst, [TyVar], Maybe CoAxBranch)]
     -> TcS [TypeEqn])
    -> [([TcPredType], TCvSubst, [TyVar], Maybe CoAxBranch)]
    -> TcS [TypeEqn]
    forall a b. (a -> b) -> a -> b
    $
             Int
    -> [([TcPredType], TCvSubst, [TyVar], Maybe CoAxBranch)]
    -> [([TcPredType], TCvSubst, [TyVar], Maybe CoAxBranch)]
    forall a. Int -> [a] -> [a]
    take Int
    1 [([TcPredType], TCvSubst, [TyVar], Maybe CoAxBranch)]
    improvs }

      | Just CoAxiom Branched
    ax <- TyCon -> Maybe (CoAxiom Branched)
    isClosedSynFamilyTyConWithAxiom_maybe TyCon
    fam_tc
      , Injective [Bool]
    injective_args <- TyCon -> Injectivity
    tyConInjectivityInfo TyCon
    fam_tc
      = (([TcPredType], TCvSubst, [TyVar], Maybe CoAxBranch)
     -> TcS [TypeEqn])
    -> [([TcPredType], TCvSubst, [TyVar], Maybe CoAxBranch)]
    -> TcS [TypeEqn]
    forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
    concatMapM ([Bool]
    -> ([TcPredType], TCvSubst, [TyVar], Maybe CoAxBranch)
    -> TcS [TypeEqn]
    injImproveEqns [Bool]
    injective_args) ([([TcPredType], TCvSubst, [TyVar], Maybe CoAxBranch)]
     -> TcS [TypeEqn])
    -> [([TcPredType], TCvSubst, [TyVar], Maybe CoAxBranch)]
    -> TcS [TypeEqn]
    forall a b. (a -> b) -> a -> b
    $
        [CoAxBranch]
    -> (CoAxBranch -> [TyVar])
    -> (CoAxBranch -> [TcPredType])
    -> (CoAxBranch -> TcPredType)
    -> (CoAxBranch -> Maybe CoAxBranch)
    -> [([TcPredType], TCvSubst, [TyVar], Maybe CoAxBranch)]
    forall a.
    [a]
    -> (a -> [TyVar])
    -> (a -> [TcPredType])
    -> (a -> TcPredType)
    -> (a -> Maybe CoAxBranch)
    -> [([TcPredType], TCvSubst, [TyVar], Maybe CoAxBranch)]
    buildImprovementData (Branches Branched -> [CoAxBranch]
    forall (br :: BranchFlag). Branches br -> [CoAxBranch]
    fromBranches (CoAxiom Branched -> Branches Branched
    forall (br :: BranchFlag). CoAxiom br -> Branches br
    co_ax_branches CoAxiom Branched
    ax))
                             CoAxBranch -> [TyVar]
    cab_tvs CoAxBranch -> [TcPredType]
    cab_lhs CoAxBranch -> TcPredType
    cab_rhs CoAxBranch -> Maybe CoAxBranch
    forall a. a -> Maybe a
    Just

      | Bool
    otherwise
      = [TypeEqn] -> TcS [TypeEqn]
    forall (m :: * -> *) a. Monad m => a -> m a
    return []

      where
          buildImprovementData
              :: [a]                     -- axioms for a TF (FamInst or CoAxBranch)
              -> (a -> [TyVar])          -- get bound tyvars of an axiom
              -> (a -> [Type])           -- get LHS of an axiom
              -> (a -> Type)             -- get RHS of an axiom
              -> (a -> Maybe CoAxBranch) -- Just => apartness check required
              -> [( [Type], TCvSubst, [TyVar], Maybe CoAxBranch )]
                 -- Result:
                 -- ( [arguments of a matching axiom]
                 -- , RHS-unifying substitution
                 -- , axiom variables without substitution
                 -- , Maybe matching axiom [Nothing - open TF, Just - closed TF ] )
          buildImprovementData :: forall a.
    [a]
    -> (a -> [TyVar])
    -> (a -> [TcPredType])
    -> (a -> TcPredType)
    -> (a -> Maybe CoAxBranch)
    -> [([TcPredType], TCvSubst, [TyVar], Maybe CoAxBranch)]
    buildImprovementData [a]
    axioms a -> [TyVar]
    axiomTVs a -> [TcPredType]
    axiomLHS a -> TcPredType
    axiomRHS a -> Maybe CoAxBranch
    wrap =
              [ ([TcPredType]
    ax_args, TCvSubst
    subst, [TyVar]
    unsubstTvs, a -> Maybe CoAxBranch
    wrap a
    axiom)
              | a
    axiom <- [a]
    axioms
              , let ax_args :: [TcPredType]
    ax_args = a -> [TcPredType]
    axiomLHS a
    axiom
                    ax_rhs :: TcPredType
    ax_rhs  = a -> TcPredType
    axiomRHS a
    axiom
                    ax_tvs :: [TyVar]
    ax_tvs  = a -> [TyVar]
    axiomTVs a
    axiom
              , Just TCvSubst
    subst <- [Bool -> TcPredType -> TcPredType -> Maybe TCvSubst
    tcUnifyTyWithTFs Bool
    False TcPredType
    ax_rhs TcPredType
    rhs_ty]
              , let notInSubst :: TyVar -> Bool
    notInSubst TyVar
    tv = Bool -> Bool
    not (TyVar
    tv TyVar -> VarEnv TcPredType -> Bool
    forall a. TyVar -> VarEnv a -> Bool
    `elemVarEnv` TCvSubst -> VarEnv TcPredType
    getTvSubstEnv TCvSubst
    subst)
                    unsubstTvs :: [TyVar]
    unsubstTvs    = (TyVar -> Bool) -> [TyVar] -> [TyVar]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (TyVar -> Bool
    notInSubst (TyVar -> Bool) -> (TyVar -> Bool) -> TyVar -> Bool
    forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
    <&&> TyVar -> Bool
    isTyVar) [TyVar]
    ax_tvs ]
                       -- The order of unsubstTvs is important; it must be
                       -- in telescope order e.g. (k:*) (a:k)

          injImproveEqns :: [Bool]
                         -> ([Type], TCvSubst, [TyCoVar], Maybe CoAxBranch)
                         -> TcS [TypeEqn]
          injImproveEqns :: [Bool]
    -> ([TcPredType], TCvSubst, [TyVar], Maybe CoAxBranch)
    -> TcS [TypeEqn]
    injImproveEqns [Bool]
    inj_args ([TcPredType]
    ax_args, TCvSubst
    subst, [TyVar]
    unsubstTvs, Maybe CoAxBranch
    cabr)
            = do { TCvSubst
    subst <- TCvSubst -> [TyVar] -> TcS TCvSubst
    instFlexiX TCvSubst
    subst [TyVar]
    unsubstTvs
                      -- If the current substitution bind [k -> *], and
                      -- one of the un-substituted tyvars is (a::k), we'd better
                      -- be sure to apply the current substitution to a's kind.
                      -- Hence instFlexiX.   #13135 was an example.

                 ; [TypeEqn] -> TcS [TypeEqn]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [ TcPredType -> TcPredType -> TypeEqn
    forall a. a -> a -> Pair a
    Pair (TCvSubst -> TcPredType -> TcPredType
    substTyUnchecked TCvSubst
    subst TcPredType
    ax_arg) TcPredType
    arg
                            -- NB: the ax_arg part is on the left
                            -- see Note [Improvement orientation]
                          | case Maybe CoAxBranch
    cabr of
                              Just CoAxBranch
    cabr' -> [TcPredType] -> CoAxBranch -> Bool
    apartnessCheck (HasCallStack => TCvSubst -> [TcPredType] -> [TcPredType]
    TCvSubst -> [TcPredType] -> [TcPredType]
    substTys TCvSubst
    subst [TcPredType]
    ax_args) CoAxBranch
    cabr'
                              Maybe CoAxBranch
    _          -> Bool
    True
                          , (TcPredType
    ax_arg, TcPredType
    arg, Bool
    True) <- [TcPredType]
    -> [TcPredType] -> [Bool] -> [(TcPredType, TcPredType, Bool)]
    forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
    zip3 [TcPredType]
    ax_args [TcPredType]
    args [Bool]
    inj_args ] }

    {-
    Note [MATCHING-SYNONYMS]
    ~~~~~~~~~~~~~~~~~~~~~~~~
    When trying to match a dictionary (D tau) to a top-level instance, or a
    type family equation (F taus_1 ~ tau_2) to a top-level family instance,
    we do *not* need to expand type synonyms because the matcher will do that for us.

    Note [Improvement orientation]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    A very delicate point is the orientation of derived equalities
    arising from injectivity improvement (#12522).  Suppose we have
      type family F x = t | t -> x
      type instance F (a, Int) = (Int, G a)
    where G is injective; and wanted constraints

      [W] TF (alpha, beta) ~ fuv
      [W] fuv ~ (Int, <some type>)

    The injectivity will give rise to derived constraints

      [D] gamma1 ~ alpha
      [D] Int ~ beta

    The fresh unification variable gamma1 comes from the fact that we
    can only do "partial improvement" here; see Section 5.2 of
    "Injective type families for Haskell" (HS'15).

    Now, it's very important to orient the equations this way round,
    so that the fresh unification variable will be eliminated in
    favour of alpha.  If we instead had
       [D] alpha ~ gamma1
    then we would unify alpha := gamma1; and kick out the wanted
    constraint.  But when we grough it back in, it'd look like
       [W] TF (gamma1, beta) ~ fuv
    and exactly the same thing would happen again!  Infinite loop.

    This all seems fragile, and it might seem more robust to avoid
    introducing gamma1 in the first place, in the case where the
    actual argument (alpha, beta) partly matches the improvement
    template.  But that's a bit tricky, esp when we remember that the
    kinds much match too; so it's easier to let the normal machinery
    handle it.  Instead we are careful to orient the new derived
    equality with the template on the left.  Delicate, but it works.

    -}

    {- *******************************************************************
    *                                                                    *
             Top-level reaction for class constraints (CDictCan)
    *                                                                    *
    **********************************************************************-}

    doTopReactDict :: InertSet -> Ct -> TcS (StopOrContinue Ct)
    -- Try to use type-class instance declarations to simplify the constraint
    doTopReactDict :: InertSet -> SimplifierStage
    doTopReactDict InertSet
    inerts work_item :: Ct
    work_item@(CDictCan { cc_ev :: Ct -> CtEvidence
    cc_ev = CtEvidence
    ev, cc_class :: Ct -> Class
    cc_class = Class
    cls
                                              , cc_tyargs :: Ct -> [TcPredType]
    cc_tyargs = [TcPredType]
    xis })
      | CtEvidence -> Bool
    isGiven CtEvidence
    ev   -- Never use instances for Given constraints
      = do { TcS ()
    try_fundep_improvement
           ; SimplifierStage
    forall a. a -> TcS (StopOrContinue a)
    continueWith Ct
    work_item }

      | Just CtEvidence
    solved_ev <- InertSet -> CtLoc -> Class -> [TcPredType] -> Maybe CtEvidence
    lookupSolvedDict InertSet
    inerts CtLoc
    dict_loc Class
    cls [TcPredType]
    xis   -- Cached
      = do { CtEvidence -> EvTerm -> TcS ()
    setEvBindIfWanted CtEvidence
    ev (CtEvidence -> EvTerm
    ctEvTerm CtEvidence
    solved_ev)
           ; CtEvidence -> String -> TcS (StopOrContinue Ct)
    forall a. CtEvidence -> String -> TcS (StopOrContinue a)
    stopWith CtEvidence
    ev String
    "Dict/Top (cached)" }

      | Bool
    otherwise  -- Wanted or Derived, but not cached
       = do { DynFlags
    dflags <- TcS DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
            ; ClsInstResult
    lkup_res <- DynFlags
    -> InertSet -> Class -> [TcPredType] -> CtLoc -> TcS ClsInstResult
    matchClassInst DynFlags
    dflags InertSet
    inerts Class
    cls [TcPredType]
    xis CtLoc
    dict_loc
            ; case ClsInstResult
    lkup_res of
                   OneInst { cir_what :: ClsInstResult -> InstanceWhat
    cir_what = InstanceWhat
    what }
                      -> do { InstanceWhat -> Ct -> TcS ()
    insertSafeOverlapFailureTcS InstanceWhat
    what Ct
    work_item
                            ; InstanceWhat -> CtEvidence -> Class -> [TcPredType] -> TcS ()
    addSolvedDict InstanceWhat
    what CtEvidence
    ev Class
    cls [TcPredType]
    xis
                            ; Ct -> ClsInstResult -> TcS (StopOrContinue Ct)
    chooseInstance Ct
    work_item ClsInstResult
    lkup_res }
                   ClsInstResult
    _  ->  -- NoInstance or NotSure
                         do { Bool -> TcS () -> TcS ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (CtEvidence -> Bool
    isImprovable CtEvidence
    ev) (TcS () -> TcS ()) -> TcS () -> TcS ()
    forall a b. (a -> b) -> a -> b
    $
                              TcS ()
    try_fundep_improvement
                            ; SimplifierStage
    forall a. a -> TcS (StopOrContinue a)
    continueWith Ct
    work_item } }
       where
         dict_pred :: TcPredType
    dict_pred   = Class -> [TcPredType] -> TcPredType
    mkClassPred Class
    cls [TcPredType]
    xis
         dict_loc :: CtLoc
    dict_loc    = CtEvidence -> CtLoc
    ctEvLoc CtEvidence
    ev
         dict_origin :: CtOrigin
    dict_origin = CtLoc -> CtOrigin
    ctLocOrigin CtLoc
    dict_loc

         -- We didn't solve it; so try functional dependencies with
         -- the instance environment, and return
         -- See also Note [Weird fundeps]
         try_fundep_improvement :: TcS ()
    try_fundep_improvement
            = do { String -> SDoc -> TcS ()
    traceTcS String
    "try_fundeps" (Ct -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Ct
    work_item)
                 ; InstEnvs
    instEnvs <- TcS InstEnvs
    getInstEnvs
                 ; [FunDepEqn CtLoc] -> TcS ()
    emitFunDepDeriveds ([FunDepEqn CtLoc] -> TcS ()) -> [FunDepEqn CtLoc] -> TcS ()
    forall a b. (a -> b) -> a -> b
    $
                   InstEnvs
    -> (TcPredType -> SrcSpan -> CtLoc)
    -> TcPredType
    -> [FunDepEqn CtLoc]
    forall loc.
    InstEnvs
    -> (TcPredType -> SrcSpan -> loc) -> TcPredType -> [FunDepEqn loc]
    improveFromInstEnv InstEnvs
    instEnvs TcPredType -> SrcSpan -> CtLoc
    mk_ct_loc TcPredType
    dict_pred }

         mk_ct_loc :: PredType   -- From instance decl
                   -> SrcSpan    -- also from instance deol
                   -> CtLoc
         mk_ct_loc :: TcPredType -> SrcSpan -> CtLoc
    mk_ct_loc TcPredType
    inst_pred SrcSpan
    inst_loc
           = CtLoc
    dict_loc { ctl_origin :: CtOrigin
    ctl_origin = TcPredType -> CtOrigin -> TcPredType -> SrcSpan -> CtOrigin
    FunDepOrigin2 TcPredType
    dict_pred CtOrigin
    dict_origin
                                                   TcPredType
    inst_pred SrcSpan
    inst_loc }

    doTopReactDict InertSet
    _ Ct
    w = String -> SDoc -> TcS (StopOrContinue Ct)
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "doTopReactDict" (Ct -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Ct
    w)

    chooseInstance :: Ct -> ClsInstResult -> TcS (StopOrContinue Ct)
    chooseInstance :: Ct -> ClsInstResult -> TcS (StopOrContinue Ct)
    chooseInstance Ct
    work_item
                   (OneInst { cir_new_theta :: ClsInstResult -> [TcPredType]
    cir_new_theta = [TcPredType]
    theta
                            , cir_what :: ClsInstResult -> InstanceWhat
    cir_what      = InstanceWhat
    what
                            , cir_mk_ev :: ClsInstResult -> [EvExpr] -> EvTerm
    cir_mk_ev     = [EvExpr] -> EvTerm
    mk_ev })
      = do { String -> SDoc -> TcS ()
    traceTcS String
    "doTopReact/found instance for" (SDoc -> TcS ()) -> SDoc -> TcS ()
    forall a b. (a -> b) -> a -> b
    $ CtEvidence -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CtEvidence
    ev
           ; CtLoc
    deeper_loc <- CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc
    checkInstanceOK CtLoc
    loc InstanceWhat
    what TcPredType
    pred
           ; if CtEvidence -> Bool
    isDerived CtEvidence
    ev
             then -- Use type-class instances for Deriveds, in the hope
                  -- of generating some improvements
                  -- C.f. Example 3 of Note [The improvement story]
                  -- It's easy because no evidence is involved
               do { DynFlags
    dflags <- TcS DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
                  ; Bool -> TcS () -> TcS ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (DynFlags -> SubGoalDepth -> Bool
    subGoalDepthExceeded DynFlags
    dflags (CtLoc -> SubGoalDepth
    ctLocDepth CtLoc
    deeper_loc)) (TcS () -> TcS ()) -> TcS () -> TcS ()
    forall a b. (a -> b) -> a -> b
    $
                    CtLoc -> [TcPredType] -> TcS ()
    emitNewDeriveds CtLoc
    deeper_loc [TcPredType]
    theta
                      -- If we have a runaway Derived, let's not issue a
                      -- "reduction stack overflow" error, which is not particularly
                      -- friendly. Instead, just drop the Derived.
                  ; String -> SDoc -> TcS ()
    traceTcS String
    "finish_derived" (SubGoalDepth -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (CtLoc -> SubGoalDepth
    ctl_depth CtLoc
    deeper_loc))
                  ; CtEvidence -> String -> TcS (StopOrContinue Ct)
    forall a. CtEvidence -> String -> TcS (StopOrContinue a)
    stopWith CtEvidence
    ev String
    "Dict/Top (solved derived)" }

             else -- wanted
               do { CtLoc -> TcPredType -> TcS ()
    checkReductionDepth CtLoc
    deeper_loc TcPredType
    pred
                  ; EvBindsVar
    evb <- TcS EvBindsVar
    getTcEvBindsVar
                  ; if EvBindsVar -> Bool
    isCoEvBindsVar EvBindsVar
    evb
                    then SimplifierStage
    forall a. a -> TcS (StopOrContinue a)
    continueWith Ct
    work_item
                      -- See Note [Instances in no-evidence implications]

                    else
               do { [MaybeNew]
    evc_vars <- (TcPredType -> TcS MaybeNew) -> [TcPredType] -> TcS [MaybeNew]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM (CtLoc -> TcPredType -> TcS MaybeNew
    newWanted CtLoc
    deeper_loc) [TcPredType]
    theta
                  ; CtEvidence -> EvTerm -> TcS ()
    setEvBindIfWanted CtEvidence
    ev ([EvExpr] -> EvTerm
    mk_ev ((MaybeNew -> EvExpr) -> [MaybeNew] -> [EvExpr]
    forall a b. (a -> b) -> [a] -> [b]
    map MaybeNew -> EvExpr
    getEvExpr [MaybeNew]
    evc_vars))
                  ; [CtEvidence] -> TcS ()
    emitWorkNC ([MaybeNew] -> [CtEvidence]
    freshGoals [MaybeNew]
    evc_vars)
                  ; CtEvidence -> String -> TcS (StopOrContinue Ct)
    forall a. CtEvidence -> String -> TcS (StopOrContinue a)
    stopWith CtEvidence
    ev String
    "Dict/Top (solved wanted)" }}}
      where
         ev :: CtEvidence
    ev         = Ct -> CtEvidence
    ctEvidence Ct
    work_item
         pred :: TcPredType
    pred       = CtEvidence -> TcPredType
    ctEvPred CtEvidence
    ev
         loc :: CtLoc
    loc        = CtEvidence -> CtLoc
    ctEvLoc CtEvidence
    ev

    chooseInstance Ct
    work_item ClsInstResult
    lookup_res
      = String -> SDoc -> TcS (StopOrContinue Ct)
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "chooseInstance" (Ct -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Ct
    work_item SDoc -> SDoc -> SDoc
    $$ ClsInstResult -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr ClsInstResult
    lookup_res)

    checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc
    -- Check that it's OK to use this insstance:
    --    (a) the use is well staged in the Template Haskell sense
    -- Returns the CtLoc to used for sub-goals
    -- Probably also want to call checkReductionDepth, but this function
    -- does not do so to enable special handling for Deriveds in chooseInstance
    checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc
    checkInstanceOK CtLoc
    loc InstanceWhat
    what TcPredType
    pred
      = do { CtLoc -> InstanceWhat -> TcPredType -> TcS ()
    checkWellStagedDFun CtLoc
    loc InstanceWhat
    what TcPredType
    pred
           ; CtLoc -> TcS CtLoc
    forall (m :: * -> *) a. Monad m => a -> m a
    return CtLoc
    deeper_loc }
      where
         deeper_loc :: CtLoc
    deeper_loc = CtLoc -> CtLoc
    zap_origin (CtLoc -> CtLoc
    bumpCtLocDepth CtLoc
    loc)
         origin :: CtOrigin
    origin     = CtLoc -> CtOrigin
    ctLocOrigin CtLoc
    loc

         zap_origin :: CtLoc -> CtLoc
    zap_origin CtLoc
    loc  -- After applying an instance we can set ScOrigin to
                         -- infinity, so that prohibitedSuperClassSolve never fires
           | ScOrigin {} <- CtOrigin
    origin
           = CtLoc -> CtOrigin -> CtLoc
    setCtLocOrigin CtLoc
    loc (TypeSize -> CtOrigin
    ScOrigin TypeSize
    infinity)
           | Bool
    otherwise
           = CtLoc
    loc

    {- Note [Instances in no-evidence implications]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    In #15290 we had
      [G] forall p q. Coercible p q => Coercible (m p) (m q))
      [W] forall <no-ev> a. m (Int, IntStateT m a)
                              ~R#
                            m (Int, StateT Int m a)

    The Given is an ordinary quantified constraint; the Wanted is an implication
    equality that arises from
      [W] (forall a. t1) ~R# (forall a. t2)

    But because the (t1 ~R# t2) is solved "inside a type" (under that forall a)
    we can't generate any term evidence.  So we can't actually use that
    lovely quantified constraint.  Alas!

    This test arranges to ignore the instance-based solution under these
    (rare) circumstances.   It's sad, but I  really don't see what else we can do.
    -}

    matchClassInst :: DynFlags -> InertSet
                   -> Class -> [Type]
                   -> CtLoc -> TcS ClsInstResult
    matchClassInst :: DynFlags
    -> InertSet -> Class -> [TcPredType] -> CtLoc -> TcS ClsInstResult
    matchClassInst DynFlags
    dflags InertSet
    inerts Class
    clas [TcPredType]
    tys CtLoc
    loc
    -- First check whether there is an in-scope Given that could
    -- match this constraint.  In that case, do not use any instance
    -- whether top level, or local quantified constraints.
    -- See Note [Instance and Given overlap]
      | Bool -> Bool
    not (Extension -> DynFlags -> Bool
    xopt Extension
    LangExt.IncoherentInstances DynFlags
    dflags)
      , Bool -> Bool
    not (Class -> Bool
    naturallyCoherentClass Class
    clas)
      , let matchable_givens :: Cts
    matchable_givens = CtLoc -> TcPredType -> InertSet -> Cts
    matchableGivens CtLoc
    loc TcPredType
    pred InertSet
    inerts
      , Bool -> Bool
    not (Cts -> Bool
    forall a. Bag a -> Bool
    isEmptyBag Cts
    matchable_givens)
      = do { String -> SDoc -> TcS ()
    traceTcS String
    "Delaying instance application" (SDoc -> TcS ()) -> SDoc -> TcS ()
    forall a b. (a -> b) -> a -> b
    $
               [SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "Work item=" SDoc -> SDoc -> SDoc
    <+> Class -> [TcPredType] -> SDoc
    pprClassPred Class
    clas [TcPredType]
    tys
                    , String -> SDoc
    text String
    "Potential matching givens:" SDoc -> SDoc -> SDoc
    <+> Cts -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Cts
    matchable_givens ]
           ; ClsInstResult -> TcS ClsInstResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return ClsInstResult
    NotSure }

      | Bool
    otherwise
      = do { String -> SDoc -> TcS ()
    traceTcS String
    "matchClassInst" (SDoc -> TcS ()) -> SDoc -> TcS ()
    forall a b. (a -> b) -> a -> b
    $ String -> SDoc
    text String
    "pred =" SDoc -> SDoc -> SDoc
    <+> TcPredType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TcPredType
    pred SDoc -> SDoc -> SDoc
    <+> Char -> SDoc
    char Char
    '{'
           ; ClsInstResult
    local_res <- TcPredType -> CtLoc -> TcS ClsInstResult
    matchLocalInst TcPredType
    pred CtLoc
    loc
           ; case ClsInstResult
    local_res of
               OneInst {} ->  -- See Note [Local instances and incoherence]
                    do { String -> SDoc -> TcS ()
    traceTcS String
    "} matchClassInst local match" (SDoc -> TcS ()) -> SDoc -> TcS ()
    forall a b. (a -> b) -> a -> b
    $ ClsInstResult -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr ClsInstResult
    local_res
                       ; ClsInstResult -> TcS ClsInstResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return ClsInstResult
    local_res }

               ClsInstResult
    NotSure -> -- In the NotSure case for local instances
                          -- we don't want to try global instances
                    do { String -> SDoc -> TcS ()
    traceTcS String
    "} matchClassInst local not sure" SDoc
    empty
                       ; ClsInstResult -> TcS ClsInstResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return ClsInstResult
    local_res }

               ClsInstResult
    NoInstance  -- No local instances, so try global ones
                  -> do { ClsInstResult
    global_res <- DynFlags -> Bool -> Class -> [TcPredType] -> TcS ClsInstResult
    matchGlobalInst DynFlags
    dflags Bool
    False Class
    clas [TcPredType]
    tys
                        ; String -> SDoc -> TcS ()
    traceTcS String
    "} matchClassInst global result" (SDoc -> TcS ()) -> SDoc -> TcS ()
    forall a b. (a -> b) -> a -> b
    $ ClsInstResult -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr ClsInstResult
    global_res
                        ; ClsInstResult -> TcS ClsInstResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return ClsInstResult
    global_res } }
      where
        pred :: TcPredType
    pred = Class -> [TcPredType] -> TcPredType
    mkClassPred Class
    clas [TcPredType]
    tys

    -- | If a class is "naturally coherent", then we needn't worry at all, in any
    -- way, about overlapping/incoherent instances. Just solve the thing!
    -- See Note [Naturally coherent classes]
    -- See also Note [The equality class story] in "GHC.Builtin.Types.Prim".
    naturallyCoherentClass :: Class -> Bool
    naturallyCoherentClass :: Class -> Bool
    naturallyCoherentClass Class
    cls
      = Class -> Bool
    isCTupleClass Class
    cls
        Bool -> Bool -> Bool
    || Class
    cls Class -> Unique -> Bool
    forall a. Uniquable a => a -> Unique -> Bool
    `hasKey` Unique
    heqTyConKey
        Bool -> Bool -> Bool
    || Class
    cls Class -> Unique -> Bool
    forall a. Uniquable a => a -> Unique -> Bool
    `hasKey` Unique
    eqTyConKey
        Bool -> Bool -> Bool
    || Class
    cls Class -> Unique -> Bool
    forall a. Uniquable a => a -> Unique -> Bool
    `hasKey` Unique
    coercibleTyConKey

    {- Note [Instance and Given overlap]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Example, from the OutsideIn(X) paper:
           instance P x => Q [x]
           instance (x ~ y) => R y [x]

           wob :: forall a b. (Q [b], R b a) => a -> Int

           g :: forall a. Q [a] => [a] -> Int
           g x = wob x

    From 'g' we get the implication constraint:
                forall a. Q [a] => (Q [beta], R beta [a])
    If we react (Q [beta]) with its top-level axiom, we end up with a
    (P beta), which we have no way of discharging. On the other hand,
    if we react R beta [a] with the top-level we get  (beta ~ a), which
    is solvable and can help us rewrite (Q [beta]) to (Q [a]) which is
    now solvable by the given Q [a].

    The partial solution is that:
      In matchClassInst (and thus in topReact), we return a matching
      instance only when there is no Given in the inerts which is
      unifiable to this particular dictionary.

      We treat any meta-tyvar as "unifiable" for this purpose,
      *including* untouchable ones.  But not skolems like 'a' in
      the implication constraint above.

    The end effect is that, much as we do for overlapping instances, we
    delay choosing a class instance if there is a possibility of another
    instance OR a given to match our constraint later on. This fixes
    tickets #4981 and #5002.

    Other notes:

    * The check is done *first*, so that it also covers classes
      with built-in instance solving, such as
         - constraint tuples
         - natural numbers
         - Typeable

    * See also Note [What might equal later?] in GHC.Tc.Solver.Monad.

    * The given-overlap problem is arguably not easy to appear in practice
      due to our aggressive prioritization of equality solving over other
      constraints, but it is possible. I've added a test case in
      typecheck/should-compile/GivenOverlapping.hs

    * Another "live" example is #10195; another is #10177.

    * We ignore the overlap problem if -XIncoherentInstances is in force:
      see #6002 for a worked-out example where this makes a
      difference.

    * Moreover notice that our goals here are different than the goals of
      the top-level overlapping checks. There we are interested in
      validating the following principle:

          If we inline a function f at a site where the same global
          instance environment is available as the instance environment at
          the definition site of f then we should get the same behaviour.

      But for the Given Overlap check our goal is just related to completeness of
      constraint solving.

    * The solution is only a partial one.  Consider the above example with
           g :: forall a. Q [a] => [a] -> Int
           g x = let v = wob x
                 in v
      and suppose we have -XNoMonoLocalBinds, so that we attempt to find the most
      general type for 'v'.  When generalising v's type we'll simplify its
      Q [alpha] constraint, but we don't have Q [a] in the 'givens', so we
      will use the instance declaration after all. #11948 was a case
      in point.

    All of this is disgustingly delicate, so to discourage people from writing
    simplifiable class givens, we warn about signatures that contain them;
    see GHC.Tc.Validity Note [Simplifiable given constraints].

    Note [Naturally coherent classes]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    A few built-in classes are "naturally coherent".  This term means that
    the "instance" for the class is bidirectional with its superclass(es).
    For example, consider (~~), which behaves as if it was defined like
    this:
      class a ~# b => a ~~ b
      instance a ~# b => a ~~ b
    (See Note [The equality types story] in GHC.Builtin.Types.Prim.)

    Faced with [W] t1 ~~ t2, it's always OK to reduce it to [W] t1 ~# t2,
    without worrying about Note [Instance and Given overlap].  Why?  Because
    if we had [G] s1 ~~ s2, then we'd get the superclass [G] s1 ~# s2, and
    so the reduction of the [W] constraint does not risk losing any solutions.

    On the other hand, it can be fatal to /fail/ to reduce such
    equalities, on the grounds of Note [Instance and Given overlap],
    because many good things flow from [W] t1 ~# t2.

    The same reasoning applies to

    * (~~)        heqTyCon
    * (~)         eqTyCon
    * Coercible   coercibleTyCon

    And less obviously to:

    * Tuple classes.  For reasons described in GHC.Tc.Solver.Monad
      Note [Tuples hiding implicit parameters], we may have a constraint
         [W] (?x::Int, C a)
      with an exactly-matching Given constraint.  We must decompose this
      tuple and solve the components separately, otherwise we won't solve
      it at all!  It is perfectly safe to decompose it, because again the
      superclasses invert the instance;  e.g.
          class (c1, c2) => (% c1, c2 %)
          instance (c1, c2) => (% c1, c2 %)
      Example in #14218

    Exammples: T5853, T10432, T5315, T9222, T2627b, T3028b

    PS: the term "naturally coherent" doesn't really seem helpful.
    Perhaps "invertible" or something?  I left it for now though.

    Note [Local instances and incoherence]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider
       f :: forall b c. (Eq b, forall a. Eq a => Eq (c a))
                     => c b -> Bool
       f x = x==x

    We get [W] Eq (c b), and we must use the local instance to solve it.

    BUT that wanted also unifies with the top-level Eq [a] instance,
    and Eq (Maybe a) etc.  We want the local instance to "win", otherwise
    we can't solve the wanted at all.  So we mark it as Incohherent.
    According to Note [Rules for instance lookup] in GHC.Core.InstEnv, that'll
    make it win even if there are other instances that unify.

    Moreover this is not a hack!  The evidence for this local instance
    will be constructed by GHC at a call site... from the very instances
    that unify with it here.  It is not like an incoherent user-written
    instance which might have utterly different behaviour.

    Consdider  f :: Eq a => blah.  If we have [W] Eq a, we certainly
    get it from the Eq a context, without worrying that there are
    lots of top-level instances that unify with [W] Eq a!  We'll use
    those instances to build evidence to pass to f. That's just the
    nullary case of what's happening here.
    -}

    matchLocalInst :: TcPredType -> CtLoc -> TcS ClsInstResult
    -- Look up the predicate in Given quantified constraints,
    -- which are effectively just local instance declarations.
    matchLocalInst :: TcPredType -> CtLoc -> TcS ClsInstResult
    matchLocalInst TcPredType
    pred CtLoc
    loc
      = do { inerts :: InertSet
    inerts@(IS { inert_cans :: InertSet -> InertCans
    inert_cans = InertCans
    ics }) <- TcS InertSet
    getTcSInerts
           ; case InertSet -> [QCInst] -> ([(CtEvidence, [DFunInstType])], Bool)
    match_local_inst InertSet
    inerts (InertCans -> [QCInst]
    inert_insts InertCans
    ics) of
               ([], Bool
    False) -> do { String -> SDoc -> TcS ()
    traceTcS String
    "No local instance for" (TcPredType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TcPredType
    pred)
                                 ; ClsInstResult -> TcS ClsInstResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return ClsInstResult
    NoInstance }
               ([(CtEvidence
    dfun_ev, [DFunInstType]
    inst_tys)], Bool
    unifs)
                 | Bool -> Bool
    not Bool
    unifs
                 -> do { let dfun_id :: TyVar
    dfun_id = CtEvidence -> TyVar
    ctEvEvId CtEvidence
    dfun_ev
                       ; ([TcPredType]
    tys, [TcPredType]
    theta) <- TyVar -> [DFunInstType] -> TcS ([TcPredType], [TcPredType])
    instDFunType TyVar
    dfun_id [DFunInstType]
    inst_tys
                       ; let result :: ClsInstResult
    result = OneInst { cir_new_theta :: [TcPredType]
    cir_new_theta = [TcPredType]
    theta
                                              , cir_mk_ev :: [EvExpr] -> EvTerm
    cir_mk_ev     = TyVar -> [TcPredType] -> [EvExpr] -> EvTerm
    evDFunApp TyVar
    dfun_id [TcPredType]
    tys
                                              , cir_what :: InstanceWhat
    cir_what      = InstanceWhat
    LocalInstance }
                       ; String -> SDoc -> TcS ()
    traceTcS String
    "Local inst found:" (ClsInstResult -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr ClsInstResult
    result)
                       ; ClsInstResult -> TcS ClsInstResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return ClsInstResult
    result }
               ([(CtEvidence, [DFunInstType])], Bool)
    _ -> do { String -> SDoc -> TcS ()
    traceTcS String
    "Multiple local instances for" (TcPredType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TcPredType
    pred)
                       ; ClsInstResult -> TcS ClsInstResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return ClsInstResult
    NotSure }}
      where
        pred_tv_set :: VarSet
    pred_tv_set = TcPredType -> VarSet
    tyCoVarsOfType TcPredType
    pred

        match_local_inst :: InertSet
                         -> [QCInst]
                         -> ( [(CtEvidence, [DFunInstType])]
                            , Bool )      -- True <=> Some unify but do not match
        match_local_inst :: InertSet -> [QCInst] -> ([(CtEvidence, [DFunInstType])], Bool)
    match_local_inst InertSet
    _inerts []
          = ([], Bool
    False)
        match_local_inst InertSet
    inerts (qci :: QCInst
    qci@(QCI { qci_tvs :: QCInst -> [TyVar]
    qci_tvs = [TyVar]
    qtvs, qci_pred :: QCInst -> TcPredType
    qci_pred = TcPredType
    qpred
                                   , qci_ev :: QCInst -> CtEvidence
    qci_ev = CtEvidence
    ev })
                                 : [QCInst]
    qcis)
          | let in_scope :: InScopeSet
    in_scope = VarSet -> InScopeSet
    mkInScopeSet (VarSet
    qtv_set VarSet -> VarSet -> VarSet
    `unionVarSet` VarSet
    pred_tv_set)
          , Just VarEnv TcPredType
    tv_subst <- VarSet
    -> RnEnv2
    -> VarEnv TcPredType
    -> TcPredType
    -> TcPredType
    -> Maybe (VarEnv TcPredType)
    ruleMatchTyKiX VarSet
    qtv_set (InScopeSet -> RnEnv2
    mkRnEnv2 InScopeSet
    in_scope)
                                            VarEnv TcPredType
    emptyTvSubstEnv TcPredType
    qpred TcPredType
    pred
          , let match :: (CtEvidence, [DFunInstType])
    match = (CtEvidence
    ev, (TyVar -> DFunInstType) -> [TyVar] -> [DFunInstType]
    forall a b. (a -> b) -> [a] -> [b]
    map (VarEnv TcPredType -> TyVar -> DFunInstType
    forall a. VarEnv a -> TyVar -> Maybe a
    lookupVarEnv VarEnv TcPredType
    tv_subst) [TyVar]
    qtvs)
          = ((CtEvidence, [DFunInstType])
    match(CtEvidence, [DFunInstType])
    -> [(CtEvidence, [DFunInstType])] -> [(CtEvidence, [DFunInstType])]
    forall a. a -> [a] -> [a]
    :[(CtEvidence, [DFunInstType])]
    matches, Bool
    unif)

          | Bool
    otherwise
          = ASSERT2( disjointVarSet qtv_set (tyCoVarsOfType pred)
                   , ppr qci $$ ppr pred )
                -- ASSERT: unification relies on the
                -- quantified variables being fresh
            ([(CtEvidence, [DFunInstType])]
    matches, Bool
    unif Bool -> Bool -> Bool
    || Bool
    this_unif)
          where
            qtv_set :: VarSet
    qtv_set = [TyVar] -> VarSet
    mkVarSet [TyVar]
    qtvs
            this_unif :: Bool
    this_unif = InertSet -> TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool
    mightEqualLater InertSet
    inerts TcPredType
    qpred (CtEvidence -> CtLoc
    ctEvLoc CtEvidence
    ev) TcPredType
    pred CtLoc
    loc
            ([(CtEvidence, [DFunInstType])]
    matches, Bool
    unif) = InertSet -> [QCInst] -> ([(CtEvidence, [DFunInstType])], Bool)
    match_local_inst InertSet
    inerts [QCInst]
    qcis