    {-
    (c) The University of Glasgow 2006
    (c) The GRASP/AQUA Project, Glasgow University, 2000

    -}

    {-# LANGUAGE CPP #-}

    -- | Functional dependencies
    --
    -- It's better to read it as: "if we know these, then we're going to know these"
    module GHC.Tc.Instance.FunDeps
       ( FunDepEqn(..)
       , pprEquation
       , improveFromInstEnv
       , improveFromAnother
       , checkInstCoverage
       , checkFunDeps
       , pprFundeps
       )
    where

    #include "HsVersions.h"

    import GHC.Prelude

    import GHC.Types.Name
    import GHC.Types.Var
    import GHC.Core.Class
    import GHC.Core.Predicate
    import GHC.Core.Type
    import GHC.Tc.Utils.TcType( transSuperClasses )
    import GHC.Core.Coercion.Axiom( TypeEqn )
    import GHC.Core.Unify
    import GHC.Core.InstEnv
    import GHC.Types.Var.Set
    import GHC.Types.Var.Env
    import GHC.Core.TyCo.FVs
    import GHC.Core.TyCo.Ppr( pprWithExplicitKindsWhen )
    import GHC.Utils.FV
    import GHC.Utils.Outputable
    import GHC.Utils.Error( Validity(..), allValid )
    import GHC.Types.SrcLoc
    import GHC.Utils.Misc

    import GHC.Data.Pair             ( Pair(..) )
    import Data.List        ( nubBy )
    import Data.Maybe
    import Data.Foldable    ( fold )

    {-
    ************************************************************************
    *                                                                      *
    \subsection{Generate equations from functional dependencies}
    *                                                                      *
    ************************************************************************

    Each functional dependency with one variable in the RHS is responsible
    for generating a single equality. For instance:
         class C a b | a -> b
    The constraints ([Wanted] C Int Bool) and [Wanted] C Int alpha
    will generate the following FunDepEqn
         FDEqn { fd_qtvs = []
               , fd_eqs  = [Pair Bool alpha]
               , fd_pred1 = C Int Bool
               , fd_pred2 = C Int alpha
               , fd_loc = ... }
    However notice that a functional dependency may have more than one variable
    in the RHS which will create more than one pair of types in fd_eqs. Example:
         class C a b c | a -> b c
         [Wanted] C Int alpha alpha
         [Wanted] C Int Bool beta
    Will generate:
         FDEqn { fd_qtvs = []
               , fd_eqs  = [Pair Bool alpha, Pair alpha beta]
               , fd_pred1 = C Int Bool
               , fd_pred2 = C Int alpha
               , fd_loc = ... }

    INVARIANT: Corresponding types aren't already equal
    That is, there exists at least one non-identity equality in FDEqs.

    Assume:
           class C a b c | a -> b c
           instance C Int x x
    And:   [Wanted] C Int Bool alpha
    We will /match/ the LHS of fundep equations, producing a matching substitution
    and create equations for the RHS sides. In our last example we'd have generated:
          ({x}, [fd1,fd2])
    where
           fd1 = FDEq 1 Bool x
           fd2 = FDEq 2 alpha x
    To ``execute'' the equation, make fresh type variable for each tyvar in the set,
    instantiate the two types with these fresh variables, and then unify or generate
    a new constraint. In the above example we would generate a new unification
    variable 'beta' for x and produce the following constraints:
         [Wanted] (Bool ~ beta)
         [Wanted] (alpha ~ beta)

    Notice the subtle difference between the above class declaration and:
           class C a b c | a -> b, a -> c
    where we would generate:
          ({x},[fd1]),({x},[fd2])
    This means that the template variable would be instantiated to different
    unification variables when producing the FD constraints.

    Finally, the position parameters will help us rewrite the wanted constraint ``on the spot''
    -}

    data FunDepEqn loc
      = FDEqn { forall loc. FunDepEqn loc -> [TyVar]
    fd_qtvs :: [TyVar]   -- Instantiate these type and kind vars
                                     --   to fresh unification vars,
                                     -- Non-empty only for FunDepEqns arising from instance decls

              , forall loc. FunDepEqn loc -> [TypeEqn]
    fd_eqs   :: [TypeEqn]  -- Make these pairs of types equal
              , forall loc. FunDepEqn loc -> Type
    fd_pred1 :: PredType   -- The FunDepEqn arose from
              , forall loc. FunDepEqn loc -> Type
    fd_pred2 :: PredType   --  combining these two constraints
              , forall loc. FunDepEqn loc -> loc
    fd_loc   :: loc  }

    {-
    Given a bunch of predicates that must hold, such as

            C Int t1, C Int t2, C Bool t3, ?x::t4, ?x::t5

    improve figures out what extra equations must hold.
    For example, if we have

            class C a b | a->b where ...

    then improve will return

            [(t1,t2), (t4,t5)]

    NOTA BENE:

      * improve does not iterate.  It's possible that when we make
        t1=t2, for example, that will in turn trigger a new equation.
        This would happen if we also had
            C t1 t7, C t2 t8
        If t1=t2, we also get t7=t8.

        improve does *not* do this extra step.  It relies on the caller
        doing so.

      * The equations unify types that are not already equal.  So there
        is no effect iff the result of improve is empty
    -}

    instFD :: FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type
    -- (instFD fd tvs tys) returns fd instantiated with (tvs -> tys)
    instFD :: FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type
    instFD ([TyVar]
    ls,[TyVar]
    rs) [TyVar]
    tvs [Type]
    tys
      = ((TyVar -> Type) -> [TyVar] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVar -> Type
    lookup [TyVar]
    ls, (TyVar -> Type) -> [TyVar] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVar -> Type
    lookup [TyVar]
    rs)
      where
        env :: VarEnv Type
    env       = [TyVar] -> [Type] -> VarEnv Type
    forall a. [TyVar] -> [a] -> VarEnv a
    zipVarEnv [TyVar]
    tvs [Type]
    tys
        lookup :: TyVar -> Type
    lookup TyVar
    tv = VarEnv Type -> TyVar -> Type
    forall a. VarEnv a -> TyVar -> a
    lookupVarEnv_NF VarEnv Type
    env TyVar
    tv

    zipAndComputeFDEqs :: (Type -> Type -> Bool) -- Discard this FDEq if true
                       -> [Type] -> [Type]
                       -> [TypeEqn]
    -- Create a list of (Type,Type) pairs from two lists of types,
    -- making sure that the types are not already equal
    zipAndComputeFDEqs :: (Type -> Type -> Bool) -> [Type] -> [Type] -> [TypeEqn]
    zipAndComputeFDEqs Type -> Type -> Bool
    discard (Type
    ty1:[Type]
    tys1) (Type
    ty2:[Type]
    tys2)
     | Type -> Type -> Bool
    discard Type
    ty1 Type
    ty2 = (Type -> Type -> Bool) -> [Type] -> [Type] -> [TypeEqn]
    zipAndComputeFDEqs Type -> Type -> Bool
    discard [Type]
    tys1 [Type]
    tys2
     | Bool
    otherwise       = Type -> Type -> TypeEqn
    forall a. a -> a -> Pair a
    Pair Type
    ty1 Type
    ty2 TypeEqn -> [TypeEqn] -> [TypeEqn]
    forall a. a -> [a] -> [a]
    : (Type -> Type -> Bool) -> [Type] -> [Type] -> [TypeEqn]
    zipAndComputeFDEqs Type -> Type -> Bool
    discard [Type]
    tys1 [Type]
    tys2
    zipAndComputeFDEqs Type -> Type -> Bool
    _ [Type]
    _ [Type]
    _ = []

    -- Improve a class constraint from another class constraint
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    improveFromAnother :: loc
                       -> PredType -- Template item (usually given, or inert)
                       -> PredType -- Workitem [that can be improved]
                       -> [FunDepEqn loc]
    -- Post: FDEqs always oriented from the other to the workitem
    --       Equations have empty quantified variables
    improveFromAnother :: forall loc. loc -> Type -> Type -> [FunDepEqn loc]
    improveFromAnother loc
    loc Type
    pred1 Type
    pred2
      | Just (Class
    cls1, [Type]
    tys1) <- Type -> Maybe (Class, [Type])
    getClassPredTys_maybe Type
    pred1
      , Just (Class
    cls2, [Type]
    tys2) <- Type -> Maybe (Class, [Type])
    getClassPredTys_maybe Type
    pred2
      , Class
    cls1 Class -> Class -> Bool
    forall a. Eq a => a -> a -> Bool
    == Class
    cls2
      = [ FDEqn :: forall loc.
    [TyVar] -> [TypeEqn] -> Type -> Type -> loc -> FunDepEqn loc
    FDEqn { fd_qtvs :: [TyVar]
    fd_qtvs = [], fd_eqs :: [TypeEqn]
    fd_eqs = [TypeEqn]
    eqs, fd_pred1 :: Type
    fd_pred1 = Type
    pred1, fd_pred2 :: Type
    fd_pred2 = Type
    pred2, fd_loc :: loc
    fd_loc = loc
    loc }
        | let ([TyVar]
    cls_tvs, [FunDep TyVar]
    cls_fds) = Class -> ([TyVar], [FunDep TyVar])
    classTvsFds Class
    cls1
        , FunDep TyVar
    fd <- [FunDep TyVar]
    cls_fds
        , let ([Type]
    ltys1, [Type]
    rs1) = FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type
    instFD FunDep TyVar
    fd [TyVar]
    cls_tvs [Type]
    tys1
              ([Type]
    ltys2, [Type]
    rs2) = FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type
    instFD FunDep TyVar
    fd [TyVar]
    cls_tvs [Type]
    tys2
        , [Type] -> [Type] -> Bool
    eqTypes [Type]
    ltys1 [Type]
    ltys2               -- The LHSs match
        , let eqs :: [TypeEqn]
    eqs = (Type -> Type -> Bool) -> [Type] -> [Type] -> [TypeEqn]
    zipAndComputeFDEqs Type -> Type -> Bool
    eqType [Type]
    rs1 [Type]
    rs2
        , Bool -> Bool
    not ([TypeEqn] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [TypeEqn]
    eqs) ]

    improveFromAnother loc
    _ Type
    _ Type
    _ = []

    -- Improve a class constraint from instance declarations
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    instance Outputable (FunDepEqn a) where
      ppr :: FunDepEqn a -> SDoc
    ppr = FunDepEqn a -> SDoc
    forall a. FunDepEqn a -> SDoc
    pprEquation

    pprEquation :: FunDepEqn a -> SDoc
    pprEquation :: forall a. FunDepEqn a -> SDoc
    pprEquation (FDEqn { fd_qtvs :: forall loc. FunDepEqn loc -> [TyVar]
    fd_qtvs = [TyVar]
    qtvs, fd_eqs :: forall loc. FunDepEqn loc -> [TypeEqn]
    fd_eqs = [TypeEqn]
    pairs })
      = [SDoc] -> SDoc
    vcat [String -> SDoc
    text String
    "forall" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    braces ((TyVar -> SDoc) -> [TyVar] -> SDoc
    forall a. (a -> SDoc) -> [a] -> SDoc
    pprWithCommas TyVar -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [TyVar]
    qtvs),
              Int -> SDoc -> SDoc
    nest Int
    2 ([SDoc] -> SDoc
    vcat [ Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    t1 SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "~" SDoc -> SDoc -> SDoc
    <+> Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    t2
                           | Pair Type
    t1 Type
    t2 <- [TypeEqn]
    pairs])]

    improveFromInstEnv :: InstEnvs
                       -> (PredType -> SrcSpan -> loc)
                       -> PredType
                       -> [FunDepEqn loc] -- Needs to be a FunDepEqn because
                                          -- of quantified variables
    -- Post: Equations oriented from the template (matching instance) to the workitem!
    improveFromInstEnv :: forall loc.
    InstEnvs -> (Type -> SrcSpan -> loc) -> Type -> [FunDepEqn loc]
    improveFromInstEnv InstEnvs
    inst_env Type -> SrcSpan -> loc
    mk_loc Type
    pred
      | Just (Class
    cls, [Type]
    tys) <- ASSERT2( isClassPred pred, ppr pred )
                           Type -> Maybe (Class, [Type])
    getClassPredTys_maybe Type
    pred
      , let ([TyVar]
    cls_tvs, [FunDep TyVar]
    cls_fds) = Class -> ([TyVar], [FunDep TyVar])
    classTvsFds Class
    cls
            instances :: [ClsInst]
    instances          = InstEnvs -> Class -> [ClsInst]
    classInstances InstEnvs
    inst_env Class
    cls
            rough_tcs :: [Maybe Name]
    rough_tcs          = [Type] -> [Maybe Name]
    roughMatchTcs [Type]
    tys
      = [ FDEqn :: forall loc.
    [TyVar] -> [TypeEqn] -> Type -> Type -> loc -> FunDepEqn loc
    FDEqn { fd_qtvs :: [TyVar]
    fd_qtvs = [TyVar]
    meta_tvs, fd_eqs :: [TypeEqn]
    fd_eqs = [TypeEqn]
    eqs
                , fd_pred1 :: Type
    fd_pred1 = Type
    p_inst, fd_pred2 :: Type
    fd_pred2 = Type
    pred
                , fd_loc :: loc
    fd_loc = Type -> SrcSpan -> loc
    mk_loc Type
    p_inst (TyVar -> SrcSpan
    forall a. NamedThing a => a -> SrcSpan
    getSrcSpan (ClsInst -> TyVar
    is_dfun ClsInst
    ispec)) }
        | FunDep TyVar
    fd <- [FunDep TyVar]
    cls_fds             -- Iterate through the fundeps first,
                                    -- because there often are none!
        , let trimmed_tcs :: [Maybe Name]
    trimmed_tcs = [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name]
    trimRoughMatchTcs [TyVar]
    cls_tvs FunDep TyVar
    fd [Maybe Name]
    rough_tcs
                    -- Trim the rough_tcs based on the head of the fundep.
                    -- Remember that instanceCantMatch treats both arguments
                    -- symmetrically, so it's ok to trim the rough_tcs,
                    -- rather than trimming each inst_tcs in turn
        , ClsInst
    ispec <- [ClsInst]
    instances
        , ([TyVar]
    meta_tvs, [TypeEqn]
    eqs) <- [TyVar]
    -> FunDep TyVar
    -> ClsInst
    -> [Type]
    -> [Maybe Name]
    -> [([TyVar], [TypeEqn])]
    improveClsFD [TyVar]
    cls_tvs FunDep TyVar
    fd ClsInst
    ispec
                                          [Type]
    tys [Maybe Name]
    trimmed_tcs -- NB: orientation
        , let p_inst :: Type
    p_inst = Class -> [Type] -> Type
    mkClassPred Class
    cls (ClsInst -> [Type]
    is_tys ClsInst
    ispec)
        ]
    improveFromInstEnv InstEnvs
    _ Type -> SrcSpan -> loc
    _ Type
    _ = []

    improveClsFD :: [TyVar] -> FunDep TyVar    -- One functional dependency from the class
                 -> ClsInst                    -- An instance template
                 -> [Type] -> [Maybe Name]     -- Arguments of this (C tys) predicate
                 -> [([TyCoVar], [TypeEqn])]   -- Empty or singleton

    improveClsFD :: [TyVar]
    -> FunDep TyVar
    -> ClsInst
    -> [Type]
    -> [Maybe Name]
    -> [([TyVar], [TypeEqn])]
    improveClsFD [TyVar]
    clas_tvs FunDep TyVar
    fd
                 (ClsInst { is_tvs :: ClsInst -> [TyVar]
    is_tvs = [TyVar]
    qtvs, is_tys :: ClsInst -> [Type]
    is_tys = [Type]
    tys_inst, is_tcs :: ClsInst -> [Maybe Name]
    is_tcs = [Maybe Name]
    rough_tcs_inst })
                 [Type]
    tys_actual [Maybe Name]
    rough_tcs_actual

    -- Compare instance      {a,b}    C sx sp sy sq
    --         with wanted     [W] C tx tp ty tq
    --         for fundep (x,y -> p,q)  from class  (C x p y q)
    -- If (sx,sy) unifies with (tx,ty), take the subst S

    -- 'qtvs' are the quantified type variables, the ones which can be instantiated
    -- to make the types match.  For example, given
    --      class C a b | a->b where ...
    --      instance C (Maybe x) (Tree x) where ..
    --
    -- and a wanted constraint of form (C (Maybe t1) t2),
    -- then we will call checkClsFD with
    --
    --      is_qtvs = {x}, is_tys = [Maybe x,  Tree x]
    --                     tys_actual = [Maybe t1, t2]
    --
    -- We can instantiate x to t1, and then we want to force
    --      (Tree x) [t1/x]  ~   t2

      | [Maybe Name] -> [Maybe Name] -> Bool
    instanceCantMatch [Maybe Name]
    rough_tcs_inst [Maybe Name]
    rough_tcs_actual
      = []          -- Filter out ones that can't possibly match,

      | Bool
    otherwise
      = ASSERT2( equalLength tys_inst tys_actual &&
                 equalLength tys_inst clas_tvs
                , ppr tys_inst <+> ppr tys_actual )

        case [Type] -> [Type] -> Maybe TCvSubst
    tcMatchTyKis [Type]
    ltys1 [Type]
    ltys2 of
            Maybe TCvSubst
    Nothing  -> []
            Just TCvSubst
    subst | Maybe TCvSubst -> Bool
    forall a. Maybe a -> Bool
    isJust (TCvSubst -> [Type] -> [Type] -> Maybe TCvSubst
    tcMatchTyKisX TCvSubst
    subst [Type]
    rtys1 [Type]
    rtys2)
                            -- Don't include any equations that already hold.
                            -- Reason: then we know if any actual improvement has happened,
                            --         in which case we need to iterate the solver
                            -- In making this check we must taking account of the fact that any
                            -- qtvs that aren't already instantiated can be instantiated to anything
                            -- at all
                            -- NB: We can't do this 'is-useful-equation' check element-wise
                            --     because of:
                            --           class C a b c | a -> b c
                            --           instance C Int x x
                            --           [Wanted] C Int alpha Int
                            -- We would get that  x -> alpha  (isJust) and x -> Int (isJust)
                            -- so we would produce no FDs, which is clearly wrong.
                      -> []

                      | [TypeEqn] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [TypeEqn]
    fdeqs
                      -> []

                      | Bool
    otherwise
                      -> -- pprTrace "iproveClsFD" (vcat
                         --  [ text "is_tvs =" <+> ppr qtvs
                         --  , text "tys_inst =" <+> ppr tys_inst
                         --  , text "tys_actual =" <+> ppr tys_actual
                         --  , text "ltys1 =" <+> ppr ltys1
                         --  , text "ltys2 =" <+> ppr ltys2
                         --  , text "subst =" <+> ppr subst ]) $
                         [([TyVar]
    meta_tvs, [TypeEqn]
    fdeqs)]
                            -- We could avoid this substTy stuff by producing the eqn
                            -- (qtvs, ls1++rs1, ls2++rs2)
                            -- which will re-do the ls1/ls2 unification when the equation is
                            -- executed.  What we're doing instead is recording the partial
                            -- work of the ls1/ls2 unification leaving a smaller unification problem
                      where
                        rtys1' :: [Type]
    rtys1' = (Type -> Type) -> [Type] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map (TCvSubst -> Type -> Type
    substTyUnchecked TCvSubst
    subst) [Type]
    rtys1

                        fdeqs :: [TypeEqn]
    fdeqs = (Type -> Type -> Bool) -> [Type] -> [Type] -> [TypeEqn]
    zipAndComputeFDEqs (\Type
    _ Type
    _ -> Bool
    False) [Type]
    rtys1' [Type]
    rtys2
                            -- Don't discard anything!
                            -- We could discard equal types but it's an overkill to call
                            -- eqType again, since we know for sure that /at least one/
                            -- equation in there is useful)

                        meta_tvs :: [TyVar]
    meta_tvs = [ TyVar -> Type -> TyVar
    setVarType TyVar
    tv (TCvSubst -> Type -> Type
    substTyUnchecked TCvSubst
    subst (TyVar -> Type
    varType TyVar
    tv))
                                   | TyVar
    tv <- [TyVar]
    qtvs, TyVar
    tv TyVar -> TCvSubst -> Bool
    `notElemTCvSubst` TCvSubst
    subst ]
                            -- meta_tvs are the quantified type variables
                            -- that have not been substituted out
                            --
                            -- Eg.  class C a b | a -> b
                            --      instance C Int [y]
                            -- Given constraint C Int z
                            -- we generate the equation
                            --      ({y}, [y], z)
                            --
                            -- But note (a) we get them from the dfun_id, so they are *in order*
                            --              because the kind variables may be mentioned in the
                            --              type variables' kinds
                            --          (b) we must apply 'subst' to the kinds, in case we have
                            --              matched out a kind variable, but not a type variable
                            --              whose kind mentions that kind variable!
                            --          #6015, #6068
      where
        ([Type]
    ltys1, [Type]
    rtys1) = FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type
    instFD FunDep TyVar
    fd [TyVar]
    clas_tvs [Type]
    tys_inst
        ([Type]
    ltys2, [Type]
    rtys2) = FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type
    instFD FunDep TyVar
    fd [TyVar]
    clas_tvs [Type]
    tys_actual

    {-
    %************************************************************************
    %*                                                                      *
            The Coverage condition for instance declarations
    *                                                                      *
    ************************************************************************

    Note [Coverage condition]
    ~~~~~~~~~~~~~~~~~~~~~~~~~
    Example
          class C a b | a -> b
          instance theta => C t1 t2

    For the coverage condition, we check
       (normal)    fv(t2) `subset` fv(t1)
       (liberal)   fv(t2) `subset` oclose(fv(t1), theta)

    The liberal version  ensures the self-consistency of the instance, but
    it does not guarantee termination. Example:

       class Mul a b c | a b -> c where
            (.*.) :: a -> b -> c

       instance Mul Int Int Int where (.*.) = (*)
       instance Mul Int Float Float where x .*. y = fromIntegral x * y
       instance Mul a b c => Mul a [b] [c] where x .*. v = map (x.*.) v

    In the third instance, it's not the case that fv([c]) `subset` fv(a,[b]).
    But it is the case that fv([c]) `subset` oclose( theta, fv(a,[b]) )

    But it is a mistake to accept the instance because then this defn:
            f = \ b x y -> if b then x .*. [y] else y
    makes instance inference go into a loop, because it requires the constraint
            Mul a [b] b
    -}

    checkInstCoverage :: Bool   -- Be liberal
                      -> Class -> [PredType] -> [Type]
                      -> Validity
    -- "be_liberal" flag says whether to use "liberal" coverage of
    --              See Note [Coverage Condition] below
    --
    -- Return values
    --    Nothing  => no problems
    --    Just msg => coverage problem described by msg

    checkInstCoverage :: Bool -> Class -> [Type] -> [Type] -> Validity
    checkInstCoverage Bool
    be_liberal Class
    clas [Type]
    theta [Type]
    inst_taus
      = [Validity] -> Validity
    allValid ((FunDep TyVar -> Validity) -> [FunDep TyVar] -> [Validity]
    forall a b. (a -> b) -> [a] -> [b]
    map FunDep TyVar -> Validity
    fundep_ok [FunDep TyVar]
    fds)
      where
        ([TyVar]
    tyvars, [FunDep TyVar]
    fds) = Class -> ([TyVar], [FunDep TyVar])
    classTvsFds Class
    clas
        fundep_ok :: FunDep TyVar -> Validity
    fundep_ok FunDep TyVar
    fd
           | Pair Bool -> Bool
    forall (t :: * -> *). Foldable t => t Bool -> Bool
    and (VarSet -> Bool
    isEmptyVarSet (VarSet -> Bool) -> Pair VarSet -> Pair Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Pair VarSet
    undetermined_tvs) = Validity
    IsValid
           | Bool
    otherwise                                = SDoc -> Validity
    NotValid SDoc
    msg
           where
             ([Type]
    ls,[Type]
    rs) = FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type
    instFD FunDep TyVar
    fd [TyVar]
    tyvars [Type]
    inst_taus
             ls_tvs :: VarSet
    ls_tvs = [Type] -> VarSet
    tyCoVarsOfTypes [Type]
    ls
             rs_tvs :: Pair VarSet
    rs_tvs = [Type] -> Pair VarSet
    splitVisVarsOfTypes [Type]
    rs

             undetermined_tvs :: Pair VarSet
    undetermined_tvs | Bool
    be_liberal = Pair VarSet
    liberal_undet_tvs
                              | Bool
    otherwise  = Pair VarSet
    conserv_undet_tvs

             closed_ls_tvs :: VarSet
    closed_ls_tvs = [Type] -> VarSet -> VarSet
    oclose [Type]
    theta VarSet
    ls_tvs
             liberal_undet_tvs :: Pair VarSet
    liberal_undet_tvs = (VarSet -> VarSet -> VarSet
    `minusVarSet` VarSet
    closed_ls_tvs) (VarSet -> VarSet) -> Pair VarSet -> Pair VarSet
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Pair VarSet
    rs_tvs
             conserv_undet_tvs :: Pair VarSet
    conserv_undet_tvs = (VarSet -> VarSet -> VarSet
    `minusVarSet` VarSet
    ls_tvs)        (VarSet -> VarSet) -> Pair VarSet -> Pair VarSet
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Pair VarSet
    rs_tvs

             undet_set :: VarSet
    undet_set = Pair VarSet -> VarSet
    forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
    fold Pair VarSet
    undetermined_tvs

             msg :: SDoc
    msg = Bool -> SDoc -> SDoc
    pprWithExplicitKindsWhen
                     (VarSet -> Bool
    isEmptyVarSet (VarSet -> Bool) -> VarSet -> Bool
    forall a b. (a -> b) -> a -> b
    $ Pair VarSet -> VarSet
    forall a. Pair a -> a
    pSnd Pair VarSet
    undetermined_tvs) (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $
                   [SDoc] -> SDoc
    vcat [ -- text "ls_tvs" <+> ppr ls_tvs
                          -- , text "closed ls_tvs" <+> ppr (closeOverKinds ls_tvs)
                          -- , text "theta" <+> ppr theta
                          -- , text "oclose" <+> ppr (oclose theta (closeOverKinds ls_tvs))
                          -- , text "rs_tvs" <+> ppr rs_tvs
                          [SDoc] -> SDoc
    sep [ String -> SDoc
    text String
    "The"
                                SDoc -> SDoc -> SDoc
    <+> Bool -> SDoc -> SDoc
    ppWhen Bool
    be_liberal (String -> SDoc
    text String
    "liberal")
                                SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "coverage condition fails in class"
                                SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (Class -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Class
    clas)
                              , Int -> SDoc -> SDoc
    nest Int
    2 (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $ String -> SDoc
    text String
    "for functional dependency:"
                                SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (FunDep TyVar -> SDoc
    forall a. Outputable a => FunDep a -> SDoc
    pprFunDep FunDep TyVar
    fd) ]
                        , [SDoc] -> SDoc
    sep [ String -> SDoc
    text String
    "Reason: lhs type"SDoc -> SDoc -> SDoc
    <>[Type] -> SDoc
    forall a. [a] -> SDoc
    plural [Type]
    ls SDoc -> SDoc -> SDoc
    <+> [Type] -> SDoc
    forall a. Outputable a => [a] -> SDoc
    pprQuotedList [Type]
    ls
                              , Int -> SDoc -> SDoc
    nest Int
    2 (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $
                                (if [Type] -> Bool
    forall a. [a] -> Bool
    isSingleton [Type]
    ls
                                 then String -> SDoc
    text String
    "does not"
                                 else String -> SDoc
    text String
    "do not jointly")
                                SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "determine rhs type"SDoc -> SDoc -> SDoc
    <>[Type] -> SDoc
    forall a. [a] -> SDoc
    plural [Type]
    rs
                                SDoc -> SDoc -> SDoc
    <+> [Type] -> SDoc
    forall a. Outputable a => [a] -> SDoc
    pprQuotedList [Type]
    rs ]
                        , String -> SDoc
    text String
    "Un-determined variable" SDoc -> SDoc -> SDoc
    <> VarSet -> SDoc
    pluralVarSet VarSet
    undet_set SDoc -> SDoc -> SDoc
    <> SDoc
    colon
                                SDoc -> SDoc -> SDoc
    <+> VarSet -> ([TyVar] -> SDoc) -> SDoc
    pprVarSet VarSet
    undet_set ((TyVar -> SDoc) -> [TyVar] -> SDoc
    forall a. (a -> SDoc) -> [a] -> SDoc
    pprWithCommas TyVar -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr)
                        , Bool -> SDoc -> SDoc
    ppWhen (Bool -> Bool
    not Bool
    be_liberal Bool -> Bool -> Bool
    &&
                                  Pair Bool -> Bool
    forall (t :: * -> *). Foldable t => t Bool -> Bool
    and (VarSet -> Bool
    isEmptyVarSet (VarSet -> Bool) -> Pair VarSet -> Pair Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Pair VarSet
    liberal_undet_tvs)) (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $
                          String -> SDoc
    text String
    "Using UndecidableInstances might help" ]

    {- Note [Closing over kinds in coverage]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Suppose we have a fundep  (a::k) -> b
    Then if 'a' is instantiated to (x y), where x:k2->*, y:k2,
    then fixing x really fixes k2 as well, and so k2 should be added to
    the lhs tyvars in the fundep check.

    Example (#8391), using liberal coverage
          data Foo a = ...  -- Foo :: forall k. k -> *
          class Bar a b | a -> b
          instance Bar a (Foo a)

        In the instance decl, (a:k) does fix (Foo k a), but only if we notice
        that (a:k) fixes k.  #10109 is another example.

    Here is a more subtle example, from HList-0.4.0.0 (#10564)

      class HasFieldM (l :: k) r (v :: Maybe *)
            | l r -> v where ...
      class HasFieldM1 (b :: Maybe [*]) (l :: k) r v
            | b l r -> v where ...
      class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k])
            | e1 l -> r

      data Label :: k -> *
      type family LabelsOf (a :: [*]) ::  *

      instance (HMemberM (Label {k} (l::k)) (LabelsOf xs) b,
                HasFieldM1 b l (r xs) v)
             => HasFieldM l (r xs) v where

    Is the instance OK? Does {l,r,xs} determine v?  Well:

      * From the instance constraint HMemberM (Label k l) (LabelsOf xs) b,
        plus the fundep "| el l -> r" in class HMameberM,
        we get {l,k,xs} -> b

      * Note the 'k'!! We must call closeOverKinds on the seed set
        ls_tvs = {l,r,xs}, BEFORE doing oclose, else the {l,k,xs}->b
        fundep won't fire.  This was the reason for #10564.

      * So starting from seeds {l,r,xs,k} we do oclose to get
        first {l,r,xs,k,b}, via the HMemberM constraint, and then
        {l,r,xs,k,b,v}, via the HasFieldM1 constraint.

      * And that fixes v.

    However, we must closeOverKinds whenever augmenting the seed set
    in oclose!  Consider #10109:

      data Succ a   -- Succ :: forall k. k -> *
      class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab
      instance (Add a b ab) => Add (Succ {k1} (a :: k1))
                                   b
                                   (Succ {k3} (ab :: k3})

    We start with seed set {a:k1,b:k2} and closeOverKinds to {a,k1,b,k2}.
    Now use the fundep to extend to {a,k1,b,k2,ab}.  But we need to
    closeOverKinds *again* now to {a,k1,b,k2,ab,k3}, so that we fix all
    the variables free in (Succ {k3} ab).

    Bottom line:
      * closeOverKinds on initial seeds (done automatically
        by tyCoVarsOfTypes in checkInstCoverage)
      * and closeOverKinds whenever extending those seeds (in oclose)

    Note [The liberal coverage condition]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    (oclose preds tvs) closes the set of type variables tvs,
    wrt functional dependencies in preds.  The result is a superset
    of the argument set.  For example, if we have
            class C a b | a->b where ...
    then
            oclose [C (x,y) z, C (x,p) q] {x,y} = {x,y,z}
    because if we know x and y then that fixes z.

    We also use equality predicates in the predicates; if we have an
    assumption `t1 ~ t2`, then we use the fact that if we know `t1` we
    also know `t2` and the other way.
      eg    oclose [C (x,y) z, a ~ x] {a,y} = {a,y,z,x}

    oclose is used (only) when checking the coverage condition for
    an instance declaration

    Note [Equality superclasses]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Suppose we have
      class (a ~ [b]) => C a b

    Remember from Note [The equality types story] in GHC.Builtin.Types.Prim, that
      * (a ~~ b) is a superclass of (a ~ b)
      * (a ~# b) is a superclass of (a ~~ b)

    So when oclose expands superclasses we'll get a (a ~# [b]) superclass.
    But that's an EqPred not a ClassPred, and we jolly well do want to
    account for the mutual functional dependencies implied by (t1 ~# t2).
    Hence the EqPred handling in oclose.  See #10778.

    Note [Care with type functions]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider (#12803)
      class C x y | x -> y
      type family F a b
      type family G c d = r | r -> d

    Now consider
      oclose (C (F a b) (G c d)) {a,b}

    Knowing {a,b} fixes (F a b) regardless of the injectivity of F.
    But knowing (G c d) fixes only {d}, because G is only injective
    in its second parameter.

    Hence the tyCoVarsOfTypes/injTyVarsOfTypes dance in tv_fds.
    -}

    oclose :: [PredType] -> TyCoVarSet -> TyCoVarSet
    -- See Note [The liberal coverage condition]
    oclose :: [Type] -> VarSet -> VarSet
    oclose [Type]
    preds VarSet
    fixed_tvs
      | [(VarSet, VarSet)] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [(VarSet, VarSet)]
    tv_fds = VarSet
    fixed_tvs -- Fast escape hatch for common case.
      | Bool
    otherwise   = (VarSet -> VarSet) -> VarSet -> VarSet
    fixVarSet VarSet -> VarSet
    extend VarSet
    fixed_tvs
      where
        extend :: VarSet -> VarSet
    extend VarSet
    fixed_tvs = (VarSet -> (VarSet, VarSet) -> VarSet)
    -> VarSet -> [(VarSet, VarSet)] -> VarSet
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' VarSet -> (VarSet, VarSet) -> VarSet
    add VarSet
    fixed_tvs [(VarSet, VarSet)]
    tv_fds
           where
              add :: VarSet -> (VarSet, VarSet) -> VarSet
    add VarSet
    fixed_tvs (VarSet
    ls,VarSet
    rs)
                | VarSet
    ls VarSet -> VarSet -> Bool
    `subVarSet` VarSet
    fixed_tvs = VarSet
    fixed_tvs VarSet -> VarSet -> VarSet
    `unionVarSet` VarSet -> VarSet
    closeOverKinds VarSet
    rs
                | Bool
    otherwise                = VarSet
    fixed_tvs
                -- closeOverKinds: see Note [Closing over kinds in coverage]

        tv_fds  :: [(TyCoVarSet,TyCoVarSet)]
        tv_fds :: [(VarSet, VarSet)]
    tv_fds  = [ ([Type] -> VarSet
    tyCoVarsOfTypes [Type]
    ls, FV -> VarSet
    fvVarSet (FV -> VarSet) -> FV -> VarSet
    forall a b. (a -> b) -> a -> b
    $ Bool -> [Type] -> FV
    injectiveVarsOfTypes Bool
    True [Type]
    rs)
                      -- See Note [Care with type functions]
                  | Type
    pred <- [Type]
    preds
                  , Type
    pred' <- Type
    pred Type -> [Type] -> [Type]
    forall a. a -> [a] -> [a]
    : Type -> [Type]
    transSuperClasses Type
    pred
                       -- Look for fundeps in superclasses too
                  , ([Type]
    ls, [Type]
    rs) <- Type -> [FunDep Type]
    determined Type
    pred' ]

        determined :: PredType -> [([Type],[Type])]
        determined :: Type -> [FunDep Type]
    determined Type
    pred
           = case Type -> Pred
    classifyPredType Type
    pred of
                EqPred EqRel
    NomEq Type
    t1 Type
    t2 -> [([Type
    t1],[Type
    t2]), ([Type
    t2],[Type
    t1])]
                   -- See Note [Equality superclasses]
                ClassPred Class
    cls [Type]
    tys  -> [ FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type
    instFD FunDep TyVar
    fd [TyVar]
    cls_tvs [Type]
    tys
                                      | let ([TyVar]
    cls_tvs, [FunDep TyVar]
    cls_fds) = Class -> ([TyVar], [FunDep TyVar])
    classTvsFds Class
    cls
                                      , FunDep TyVar
    fd <- [FunDep TyVar]
    cls_fds ]
                Pred
    _ -> []

    {- *********************************************************************
    *                                                                      *
            Check that a new instance decl is OK wrt fundeps
    *                                                                      *
    ************************************************************************

    Here is the bad case:
            class C a b | a->b where ...
            instance C Int Bool where ...
            instance C Int Char where ...

    The point is that a->b, so Int in the first parameter must uniquely
    determine the second.  In general, given the same class decl, and given

            instance C s1 s2 where ...
            instance C t1 t2 where ...

    Then the criterion is: if U=unify(s1,t1) then U(s2) = U(t2).

    Matters are a little more complicated if there are free variables in
    the s2/t2.

            class D a b c | a -> b
            instance D a b => D [(a,a)] [b] Int
            instance D a b => D [a]     [b] Bool

    The instance decls don't overlap, because the third parameter keeps
    them separate.  But we want to make sure that given any constraint
            D s1 s2 s3
    if s1 matches

    Note [Bogus consistency check]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    In checkFunDeps we check that a new ClsInst is consistent with all the
    ClsInsts in the environment.

    The bogus aspect is discussed in #10675. Currently it if the two
    types are *contradicatory*, using (isNothing . tcUnifyTys).  But all
    the papers say we should check if the two types are *equal* thus
       not (substTys subst rtys1 `eqTypes` substTys subst rtys2)
    For now I'm leaving the bogus form because that's the way it has
    been for years.
    -}

    checkFunDeps :: InstEnvs -> ClsInst -> [ClsInst]
    -- The Consistency Check.
    -- Check whether adding DFunId would break functional-dependency constraints
    -- Used only for instance decls defined in the module being compiled
    -- Returns a list of the ClsInst in InstEnvs that are inconsistent
    -- with the proposed new ClsInst
    checkFunDeps :: InstEnvs -> ClsInst -> [ClsInst]
    checkFunDeps InstEnvs
    inst_envs (ClsInst { is_tvs :: ClsInst -> [TyVar]
    is_tvs = [TyVar]
    qtvs1, is_cls :: ClsInst -> Class
    is_cls = Class
    cls
                                    , is_tys :: ClsInst -> [Type]
    is_tys = [Type]
    tys1, is_tcs :: ClsInst -> [Maybe Name]
    is_tcs = [Maybe Name]
    rough_tcs1 })
      | [FunDep TyVar] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [FunDep TyVar]
    fds
      = []
      | Bool
    otherwise
      = (ClsInst -> ClsInst -> Bool) -> [ClsInst] -> [ClsInst]
    forall a. (a -> a -> Bool) -> [a] -> [a]
    nubBy ClsInst -> ClsInst -> Bool
    eq_inst ([ClsInst] -> [ClsInst]) -> [ClsInst] -> [ClsInst]
    forall a b. (a -> b) -> a -> b
    $
        [ ClsInst
    ispec | ClsInst
    ispec <- [ClsInst]
    cls_insts
                , FunDep TyVar
    fd    <- [FunDep TyVar]
    fds
                , FunDep TyVar -> ClsInst -> Bool
    is_inconsistent FunDep TyVar
    fd ClsInst
    ispec ]
      where
        cls_insts :: [ClsInst]
    cls_insts      = InstEnvs -> Class -> [ClsInst]
    classInstances InstEnvs
    inst_envs Class
    cls
        ([TyVar]
    cls_tvs, [FunDep TyVar]
    fds) = Class -> ([TyVar], [FunDep TyVar])
    classTvsFds Class
    cls
        qtv_set1 :: VarSet
    qtv_set1       = [TyVar] -> VarSet
    mkVarSet [TyVar]
    qtvs1

        is_inconsistent :: FunDep TyVar -> ClsInst -> Bool
    is_inconsistent FunDep TyVar
    fd (ClsInst { is_tvs :: ClsInst -> [TyVar]
    is_tvs = [TyVar]
    qtvs2, is_tys :: ClsInst -> [Type]
    is_tys = [Type]
    tys2, is_tcs :: ClsInst -> [Maybe Name]
    is_tcs = [Maybe Name]
    rough_tcs2 })
          | [Maybe Name] -> [Maybe Name] -> Bool
    instanceCantMatch [Maybe Name]
    trimmed_tcs [Maybe Name]
    rough_tcs2
          = Bool
    False
          | Bool
    otherwise
          = case (TyVar -> BindFlag) -> [Type] -> [Type] -> Maybe TCvSubst
    tcUnifyTyKis TyVar -> BindFlag
    bind_fn [Type]
    ltys1 [Type]
    ltys2 of
              Maybe TCvSubst
    Nothing         -> Bool
    False
              Just TCvSubst
    subst
                -> Maybe TCvSubst -> Bool
    forall a. Maybe a -> Bool
    isNothing (Maybe TCvSubst -> Bool) -> Maybe TCvSubst -> Bool
    forall a b. (a -> b) -> a -> b
    $   -- Bogus legacy test (#10675)
                                 -- See Note [Bogus consistency check]
                   (TyVar -> BindFlag) -> [Type] -> [Type] -> Maybe TCvSubst
    tcUnifyTyKis TyVar -> BindFlag
    bind_fn (TCvSubst -> [Type] -> [Type]
    substTysUnchecked TCvSubst
    subst [Type]
    rtys1) (TCvSubst -> [Type] -> [Type]
    substTysUnchecked TCvSubst
    subst [Type]
    rtys2)

          where
            trimmed_tcs :: [Maybe Name]
    trimmed_tcs    = [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name]
    trimRoughMatchTcs [TyVar]
    cls_tvs FunDep TyVar
    fd [Maybe Name]
    rough_tcs1
            ([Type]
    ltys1, [Type]
    rtys1) = FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type
    instFD FunDep TyVar
    fd [TyVar]
    cls_tvs [Type]
    tys1
            ([Type]
    ltys2, [Type]
    rtys2) = FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type
    instFD FunDep TyVar
    fd [TyVar]
    cls_tvs [Type]
    tys2
            qtv_set2 :: VarSet
    qtv_set2       = [TyVar] -> VarSet
    mkVarSet [TyVar]
    qtvs2
            bind_fn :: TyVar -> BindFlag
    bind_fn TyVar
    tv | TyVar
    tv TyVar -> VarSet -> Bool
    `elemVarSet` VarSet
    qtv_set1 = BindFlag
    BindMe
                       | TyVar
    tv TyVar -> VarSet -> Bool
    `elemVarSet` VarSet
    qtv_set2 = BindFlag
    BindMe
                       | Bool
    otherwise                = BindFlag
    Skolem

        eq_inst :: ClsInst -> ClsInst -> Bool
    eq_inst ClsInst
    i1 ClsInst
    i2 = ClsInst -> TyVar
    instanceDFunId ClsInst
    i1 TyVar -> TyVar -> Bool
    forall a. Eq a => a -> a -> Bool
    == ClsInst -> TyVar
    instanceDFunId ClsInst
    i2
            -- A single instance may appear twice in the un-nubbed conflict list
            -- because it may conflict with more than one fundep.  E.g.
            --      class C a b c | a -> b, a -> c
            --      instance C Int Bool Bool
            --      instance C Int Char Char
            -- The second instance conflicts with the first by *both* fundeps

    trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name]
    -- Computing rough_tcs for a particular fundep
    --     class C a b c | a -> b where ...
    -- For each instance .... => C ta tb tc
    -- we want to match only on the type ta; so our
    -- rough-match thing must similarly be filtered.
    -- Hence, we Nothing-ise the tb and tc types right here
    --
    -- Result list is same length as input list, just with more Nothings
    trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name]
    trimRoughMatchTcs [TyVar]
    clas_tvs ([TyVar]
    ltvs, [TyVar]
    _) [Maybe Name]
    mb_tcs
      = (TyVar -> Maybe Name -> Maybe Name)
    -> [TyVar] -> [Maybe Name] -> [Maybe Name]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith TyVar -> Maybe Name -> Maybe Name
    forall {a}. TyVar -> Maybe a -> Maybe a
    select [TyVar]
    clas_tvs [Maybe Name]
    mb_tcs
      where
        select :: TyVar -> Maybe a -> Maybe a
    select TyVar
    clas_tv Maybe a
    mb_tc | TyVar
    clas_tv TyVar -> [TyVar] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [TyVar]
    ltvs = Maybe a
    mb_tc
                             | Bool
    otherwise           = Maybe a
    forall a. Maybe a
    Nothing