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

\section[InstEnv]{Utilities for typechecking instance declarations}

The bits common to GHC.Tc.TyCl.Instance and GHC.Tc.Deriv.
-}

{-# LANGUAGE CPP, DeriveDataTypeable #-}

module GHC.Core.InstEnv (
        DFunId, InstMatch, ClsInstLookupResult,
        OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
        ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances,
        instanceHead, instanceSig, mkLocalInstance, mkImportedInstance,
        instanceDFunId, updateClsInstDFun, instanceRoughTcs,
        fuzzyClsInstCmp, orphNamesOfClsInst,

        InstEnvs(..), VisibleOrphanModules, InstEnv,
        emptyInstEnv, extendInstEnv,
        deleteFromInstEnv, deleteDFunFromInstEnv,
        identicalClsInstHead,
        extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts, instEnvClasses,
        memberInstEnv,
        instIsVisible,
        classInstances, instanceBindFun,
        instanceCantMatch, roughMatchTcs,
        isOverlappable, isOverlapping, isIncoherent
    ) where

#include "HsVersions.h"

import GHC.Prelude

import GHC.Tc.Utils.TcType -- InstEnv is really part of the type checker,
              -- and depends on TcType in many ways
import GHC.Core ( IsOrphan(..), isOrphan, chooseOrphanAnchor )
import GHC.Unit
import GHC.Core.Class
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Unique (getUnique)
import GHC.Core.Unify
import GHC.Utils.Outputable
import GHC.Utils.Error
import GHC.Types.Basic
import GHC.Types.Unique.DFM
import GHC.Utils.Misc
import GHC.Types.Id
import Data.Data        ( Data )
import Data.Maybe       ( isJust, isNothing )

{-
************************************************************************
*                                                                      *
           ClsInst: the data type for type-class instances
*                                                                      *
************************************************************************
-}

-- | A type-class instance. Note that there is some tricky laziness at work
-- here. See Note [ClsInst laziness and the rough-match fields] for more
-- details.
data ClsInst
  = ClsInst {   -- Used for "rough matching"; see
                -- Note [ClsInst laziness and the rough-match fields]
                -- INVARIANT: is_tcs = roughMatchTcs is_tys
               ClsInst -> Name
is_cls_nm :: Name        -- ^ Class name
             , ClsInst -> [Maybe Name]
is_tcs  :: [Maybe Name]  -- ^ Top of type args

               -- | @is_dfun_name = idName . is_dfun@.
               --
               -- We use 'is_dfun_name' for the visibility check,
               -- 'instIsVisible', which needs to know the 'Module' which the
               -- dictionary is defined in. However, we cannot use the 'Module'
               -- attached to 'is_dfun' since doing so would mean we would
               -- potentially pull in an entire interface file unnecessarily.
               -- This was the cause of #12367.
             , ClsInst -> Name
is_dfun_name :: Name

                -- Used for "proper matching"; see Note [Proper-match fields]
             , ClsInst -> [DFunId]
is_tvs  :: [TyVar]       -- Fresh template tyvars for full match
                                        -- See Note [Template tyvars are fresh]
             , ClsInst -> Class
is_cls  :: Class         -- The real class
             , ClsInst -> [Type]
is_tys  :: [Type]        -- Full arg types (mentioning is_tvs)
                -- INVARIANT: is_dfun Id has type
                --      forall is_tvs. (...) => is_cls is_tys
                -- (modulo alpha conversion)

             , ClsInst -> DFunId
is_dfun :: DFunId -- See Note [Haddock assumptions]

             , ClsInst -> OverlapFlag
is_flag :: OverlapFlag   -- See detailed comments with
                                        -- the decl of BasicTypes.OverlapFlag
             , ClsInst -> IsOrphan
is_orphan :: IsOrphan
    }
  deriving Typeable ClsInst
Typeable ClsInst
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> ClsInst -> c ClsInst)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c ClsInst)
-> (ClsInst -> Constr)
-> (ClsInst -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c ClsInst))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c ClsInst))
-> ((forall b. Data b => b -> b) -> ClsInst -> ClsInst)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> ClsInst -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> ClsInst -> r)
-> (forall u. (forall d. Data d => d -> u) -> ClsInst -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> ClsInst -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> ClsInst -> m ClsInst)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> ClsInst -> m ClsInst)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> ClsInst -> m ClsInst)
-> Data ClsInst
ClsInst -> DataType
ClsInst -> Constr
(forall b. Data b => b -> b) -> ClsInst -> ClsInst
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> ClsInst -> u
forall u. (forall d. Data d => d -> u) -> ClsInst -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ClsInst -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ClsInst -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ClsInst -> m ClsInst
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ClsInst -> m ClsInst
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ClsInst
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ClsInst -> c ClsInst
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ClsInst)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c ClsInst)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ClsInst -> m ClsInst
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ClsInst -> m ClsInst
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ClsInst -> m ClsInst
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ClsInst -> m ClsInst
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ClsInst -> m ClsInst
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ClsInst -> m ClsInst
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> ClsInst -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> ClsInst -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> ClsInst -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> ClsInst -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ClsInst -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ClsInst -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ClsInst -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ClsInst -> r
gmapT :: (forall b. Data b => b -> b) -> ClsInst -> ClsInst
$cgmapT :: (forall b. Data b => b -> b) -> ClsInst -> ClsInst
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c ClsInst)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c ClsInst)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ClsInst)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ClsInst)
dataTypeOf :: ClsInst -> DataType
$cdataTypeOf :: ClsInst -> DataType
toConstr :: ClsInst -> Constr
$ctoConstr :: ClsInst -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ClsInst
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ClsInst
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ClsInst -> c ClsInst
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ClsInst -> c ClsInst
Data

-- | A fuzzy comparison function for class instances, intended for sorting
-- instances before displaying them to the user.
fuzzyClsInstCmp :: ClsInst -> ClsInst -> Ordering
fuzzyClsInstCmp :: ClsInst -> ClsInst -> Ordering
fuzzyClsInstCmp ClsInst
x ClsInst
y =
    Name -> Name -> Ordering
stableNameCmp (ClsInst -> Name
is_cls_nm ClsInst
x) (ClsInst -> Name
is_cls_nm ClsInst
y) Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend`
    [Ordering] -> Ordering
forall a. Monoid a => [a] -> a
mconcat (((Maybe Name, Maybe Name) -> Ordering)
-> [(Maybe Name, Maybe Name)] -> [Ordering]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Name, Maybe Name) -> Ordering
cmp ([Maybe Name] -> [Maybe Name] -> [(Maybe Name, Maybe Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip (ClsInst -> [Maybe Name]
is_tcs ClsInst
x) (ClsInst -> [Maybe Name]
is_tcs ClsInst
y)))
  where
    cmp :: (Maybe Name, Maybe Name) -> Ordering
cmp (Maybe Name
Nothing, Maybe Name
Nothing) = Ordering
EQ
    cmp (Maybe Name
Nothing, Just Name
_) = Ordering
LT
    cmp (Just Name
_, Maybe Name
Nothing) = Ordering
GT
    cmp (Just Name
x, Just Name
y) = Name -> Name -> Ordering
stableNameCmp Name
x Name
y

isOverlappable, isOverlapping, isIncoherent :: ClsInst -> Bool
isOverlappable :: ClsInst -> Bool
isOverlappable ClsInst
i = OverlapMode -> Bool
hasOverlappableFlag (OverlapFlag -> OverlapMode
overlapMode (ClsInst -> OverlapFlag
is_flag ClsInst
i))
isOverlapping :: ClsInst -> Bool
isOverlapping  ClsInst
i = OverlapMode -> Bool
hasOverlappingFlag  (OverlapFlag -> OverlapMode
overlapMode (ClsInst -> OverlapFlag
is_flag ClsInst
i))
isIncoherent :: ClsInst -> Bool
isIncoherent   ClsInst
i = OverlapMode -> Bool
hasIncoherentFlag   (OverlapFlag -> OverlapMode
overlapMode (ClsInst -> OverlapFlag
is_flag ClsInst
i))

{-
Note [ClsInst laziness and the rough-match fields]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we load 'instance A.C B.T' from A.hi, but suppose that the type B.T is
otherwise unused in the program. Then it's stupid to load B.hi, the data type
declaration for B.T -- and perhaps further instance declarations!

We avoid this as follows:

* is_cls_nm, is_tcs, is_dfun_name are all Names. We can poke them to our heart's
  content.

* Proper-match fields. is_dfun, and its related fields is_tvs, is_cls, is_tys
  contain TyVars, Class, Type, Class etc, and so are all lazy thunks. When we
  poke any of these fields we'll typecheck the DFunId declaration, and hence
  pull in interfaces that it refers to. See Note [Proper-match fields].

* Rough-match fields. During instance lookup, we use the is_cls_nm :: Name and
  is_tcs :: [Maybe Name] fields to perform a "rough match", *without* poking
  inside the DFunId. The rough-match fields allow us to say "definitely does not
  match", based only on Names.

  This laziness is very important; see #12367. Try hard to avoid pulling on
  the structured fields unless you really need the instance.

* Another place to watch is InstEnv.instIsVisible, which needs the module to
  which the ClsInst belongs. We can get this from is_dfun_name.

* In is_tcs,
    Nothing  means that this type arg is a type variable

    (Just n) means that this type arg is a
                TyConApp with a type constructor of n.
                This is always a real tycon, never a synonym!
                (Two different synonyms might match, but two
                different real tycons can't.)
                NB: newtypes are not transparent, though!
-}

{-
Note [Template tyvars are fresh]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The is_tvs field of a ClsInst has *completely fresh* tyvars.
That is, they are
  * distinct from any other ClsInst
  * distinct from any tyvars free in predicates that may
    be looked up in the class instance environment
Reason for freshness: we use unification when checking for overlap
etc, and that requires the tyvars to be distinct.

The invariant is checked by the ASSERT in lookupInstEnv'.

Note [Proper-match fields]
~~~~~~~~~~~~~~~~~~~~~~~~~
The is_tvs, is_cls, is_tys fields are simply cached values, pulled
out (lazily) from the dfun id. They are cached here simply so
that we don't need to decompose the DFunId each time we want
to match it.  The hope is that the rough-match fields mean
that we often never poke the proper-match fields.

However, note that:
 * is_tvs must be a superset of the free vars of is_tys

 * is_tvs, is_tys may be alpha-renamed compared to the ones in
   the dfun Id

Note [Haddock assumptions]
~~~~~~~~~~~~~~~~~~~~~~~~~~
For normal user-written instances, Haddock relies on

 * the SrcSpan of
 * the Name of
 * the is_dfun of
 * an Instance

being equal to

  * the SrcSpan of
  * the instance head type of
  * the InstDecl used to construct the Instance.
-}

instanceDFunId :: ClsInst -> DFunId
instanceDFunId :: ClsInst -> DFunId
instanceDFunId = ClsInst -> DFunId
is_dfun

updateClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst
updateClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst
updateClsInstDFun DFunId -> DFunId
tidy_dfun ClsInst
ispec
  = ClsInst
ispec { is_dfun :: DFunId
is_dfun = DFunId -> DFunId
tidy_dfun (ClsInst -> DFunId
is_dfun ClsInst
ispec) }

instanceRoughTcs :: ClsInst -> [Maybe Name]
instanceRoughTcs :: ClsInst -> [Maybe Name]
instanceRoughTcs = ClsInst -> [Maybe Name]
is_tcs


instance NamedThing ClsInst where
   getName :: ClsInst -> Name
getName ClsInst
ispec = DFunId -> Name
forall a. NamedThing a => a -> Name
getName (ClsInst -> DFunId
is_dfun ClsInst
ispec)

instance Outputable ClsInst where
   ppr :: ClsInst -> SDoc
ppr = ClsInst -> SDoc
pprInstance

pprInstance :: ClsInst -> SDoc
-- Prints the ClsInst as an instance declaration
pprInstance :: ClsInst -> SDoc
pprInstance ClsInst
ispec
  = SDoc -> Int -> SDoc -> SDoc
hang (ClsInst -> SDoc
pprInstanceHdr ClsInst
ispec)
       Int
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"--" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
pprDefinedAt (ClsInst -> Name
forall a. NamedThing a => a -> Name
getName ClsInst
ispec)
               , SDoc -> SDoc
whenPprDebug (DFunId -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ClsInst -> DFunId
is_dfun ClsInst
ispec)) ])

-- * pprInstanceHdr is used in VStudio to populate the ClassView tree
pprInstanceHdr :: ClsInst -> SDoc
-- Prints the ClsInst as an instance declaration
pprInstanceHdr :: ClsInst -> SDoc
pprInstanceHdr (ClsInst { is_flag :: ClsInst -> OverlapFlag
is_flag = OverlapFlag
flag, is_dfun :: ClsInst -> DFunId
is_dfun = DFunId
dfun })
  = String -> SDoc
text String
"instance" SDoc -> SDoc -> SDoc
<+> OverlapFlag -> SDoc
forall a. Outputable a => a -> SDoc
ppr OverlapFlag
flag SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprSigmaType (DFunId -> Type
idType DFunId
dfun)

pprInstances :: [ClsInst] -> SDoc
pprInstances :: [ClsInst] -> SDoc
pprInstances [ClsInst]
ispecs = [SDoc] -> SDoc
vcat ((ClsInst -> SDoc) -> [ClsInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> SDoc
pprInstance [ClsInst]
ispecs)

instanceHead :: ClsInst -> ([TyVar], Class, [Type])
-- Returns the head, using the fresh tyavs from the ClsInst
instanceHead :: ClsInst -> ([DFunId], Class, [Type])
instanceHead (ClsInst { is_tvs :: ClsInst -> [DFunId]
is_tvs = [DFunId]
tvs, is_tys :: ClsInst -> [Type]
is_tys = [Type]
tys, is_dfun :: ClsInst -> DFunId
is_dfun = DFunId
dfun })
   = ([DFunId]
tvs, Class
cls, [Type]
tys)
   where
     ([DFunId]
_, [Type]
_, Class
cls, [Type]
_) = Type -> ([DFunId], [Type], Class, [Type])
tcSplitDFunTy (DFunId -> Type
idType DFunId
dfun)

-- | Collects the names of concrete types and type constructors that make
-- up the head of a class instance. For instance, given `class Foo a b`:
--
-- `instance Foo (Either (Maybe Int) a) Bool` would yield
--      [Either, Maybe, Int, Bool]
--
-- Used in the implementation of ":info" in GHCi.
--
-- The 'tcSplitSigmaTy' is because of
--      instance Foo a => Baz T where ...
-- The decl is an orphan if Baz and T are both not locally defined,
--      even if Foo *is* locally defined
orphNamesOfClsInst :: ClsInst -> NameSet
orphNamesOfClsInst :: ClsInst -> NameSet
orphNamesOfClsInst (ClsInst { is_cls_nm :: ClsInst -> Name
is_cls_nm = Name
cls_nm, is_tys :: ClsInst -> [Type]
is_tys = [Type]
tys })
  = [Type] -> NameSet
orphNamesOfTypes [Type]
tys NameSet -> NameSet -> NameSet
`unionNameSet` Name -> NameSet
unitNameSet Name
cls_nm

instanceSig :: ClsInst -> ([TyVar], [Type], Class, [Type])
-- Decomposes the DFunId
instanceSig :: ClsInst -> ([DFunId], [Type], Class, [Type])
instanceSig ClsInst
ispec = Type -> ([DFunId], [Type], Class, [Type])
tcSplitDFunTy (DFunId -> Type
idType (ClsInst -> DFunId
is_dfun ClsInst
ispec))

mkLocalInstance :: DFunId -> OverlapFlag
                -> [TyVar] -> Class -> [Type]
                -> ClsInst
-- Used for local instances, where we can safely pull on the DFunId.
-- Consider using newClsInst instead; this will also warn if
-- the instance is an orphan.
mkLocalInstance :: DFunId -> OverlapFlag -> [DFunId] -> Class -> [Type] -> ClsInst
mkLocalInstance DFunId
dfun OverlapFlag
oflag [DFunId]
tvs Class
cls [Type]
tys
  = ClsInst :: Name
-> [Maybe Name]
-> Name
-> [DFunId]
-> Class
-> [Type]
-> DFunId
-> OverlapFlag
-> IsOrphan
-> ClsInst
ClsInst { is_flag :: OverlapFlag
is_flag = OverlapFlag
oflag, is_dfun :: DFunId
is_dfun = DFunId
dfun
            , is_tvs :: [DFunId]
is_tvs = [DFunId]
tvs
            , is_dfun_name :: Name
is_dfun_name = Name
dfun_name
            , is_cls :: Class
is_cls = Class
cls, is_cls_nm :: Name
is_cls_nm = Name
cls_name
            , is_tys :: [Type]
is_tys = [Type]
tys, is_tcs :: [Maybe Name]
is_tcs = [Type] -> [Maybe Name]
roughMatchTcs [Type]
tys
            , is_orphan :: IsOrphan
is_orphan = IsOrphan
orph
            }
  where
    cls_name :: Name
cls_name = Class -> Name
className Class
cls
    dfun_name :: Name
dfun_name = DFunId -> Name
idName DFunId
dfun
    this_mod :: Module
this_mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name
    is_local :: Name -> Bool
is_local Name
name = Module -> Name -> Bool
nameIsLocalOrFrom Module
this_mod Name
name

        -- Compute orphanhood.  See Note [Orphans] in GHC.Core.InstEnv
    ([DFunId]
cls_tvs, [FunDep DFunId]
fds) = Class -> ([DFunId], [FunDep DFunId])
classTvsFds Class
cls
    arg_names :: [NameSet]
arg_names = [(Name -> Bool) -> NameSet -> NameSet
filterNameSet Name -> Bool
is_local (Type -> NameSet
orphNamesOfType Type
ty) | Type
ty <- [Type]
tys]

    -- See Note [When exactly is an instance decl an orphan?]
    orph :: IsOrphan
orph | Name -> Bool
is_local Name
cls_name = OccName -> IsOrphan
NotOrphan (Name -> OccName
nameOccName Name
cls_name)
         | (IsOrphan -> Bool) -> [IsOrphan] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all IsOrphan -> Bool
notOrphan [IsOrphan]
mb_ns  = ASSERT( not (null mb_ns) ) head mb_ns
         | Bool
otherwise         = IsOrphan
IsOrphan

    notOrphan :: IsOrphan -> Bool
notOrphan NotOrphan{} = Bool
True
    notOrphan IsOrphan
_ = Bool
False

    mb_ns :: [IsOrphan]    -- One for each fundep; a locally-defined name
                           -- that is not in the "determined" arguments
    mb_ns :: [IsOrphan]
mb_ns | [FunDep DFunId] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FunDep DFunId]
fds   = [[NameSet] -> IsOrphan
choose_one [NameSet]
arg_names]
          | Bool
otherwise  = (FunDep DFunId -> IsOrphan) -> [FunDep DFunId] -> [IsOrphan]
forall a b. (a -> b) -> [a] -> [b]
map FunDep DFunId -> IsOrphan
forall {t :: * -> *} {a}. Foldable t => (a, t DFunId) -> IsOrphan
do_one [FunDep DFunId]
fds
    do_one :: (a, t DFunId) -> IsOrphan
do_one (a
_ltvs, t DFunId
rtvs) = [NameSet] -> IsOrphan
choose_one [NameSet
ns | (DFunId
tv,NameSet
ns) <- [DFunId]
cls_tvs [DFunId] -> [NameSet] -> [(DFunId, NameSet)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [NameSet]
arg_names
                                            , Bool -> Bool
not (DFunId
tv DFunId -> t DFunId -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t DFunId
rtvs)]

    choose_one :: [NameSet] -> IsOrphan
choose_one [NameSet]
nss = NameSet -> IsOrphan
chooseOrphanAnchor ([NameSet] -> NameSet
unionNameSets [NameSet]
nss)

mkImportedInstance :: Name         -- ^ the name of the class
                   -> [Maybe Name] -- ^ the types which the class was applied to
                   -> Name         -- ^ the 'Name' of the dictionary binding
                   -> DFunId       -- ^ the 'Id' of the dictionary.
                   -> OverlapFlag  -- ^ may this instance overlap?
                   -> IsOrphan     -- ^ is this instance an orphan?
                   -> ClsInst
-- Used for imported instances, where we get the rough-match stuff
-- from the interface file
-- The bound tyvars of the dfun are guaranteed fresh, because
-- the dfun has been typechecked out of the same interface file
mkImportedInstance :: Name
-> [Maybe Name]
-> Name
-> DFunId
-> OverlapFlag
-> IsOrphan
-> ClsInst
mkImportedInstance Name
cls_nm [Maybe Name]
mb_tcs Name
dfun_name DFunId
dfun OverlapFlag
oflag IsOrphan
orphan
  = ClsInst :: Name
-> [Maybe Name]
-> Name
-> [DFunId]
-> Class
-> [Type]
-> DFunId
-> OverlapFlag
-> IsOrphan
-> ClsInst
ClsInst { is_flag :: OverlapFlag
is_flag = OverlapFlag
oflag, is_dfun :: DFunId
is_dfun = DFunId
dfun
            , is_tvs :: [DFunId]
is_tvs = [DFunId]
tvs, is_tys :: [Type]
is_tys = [Type]
tys
            , is_dfun_name :: Name
is_dfun_name = Name
dfun_name
            , is_cls_nm :: Name
is_cls_nm = Name
cls_nm, is_cls :: Class
is_cls = Class
cls, is_tcs :: [Maybe Name]
is_tcs = [Maybe Name]
mb_tcs
            , is_orphan :: IsOrphan
is_orphan = IsOrphan
orphan }
  where
    ([DFunId]
tvs, [Type]
_, Class
cls, [Type]
tys) = Type -> ([DFunId], [Type], Class, [Type])
tcSplitDFunTy (DFunId -> Type
idType DFunId
dfun)

{-
Note [When exactly is an instance decl an orphan?]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  (see GHC.Iface.Make.instanceToIfaceInst, which implements this)
Roughly speaking, an instance is an orphan if its head (after the =>)
mentions nothing defined in this module.

Functional dependencies complicate the situation though. Consider

  module M where { class C a b | a -> b }

and suppose we are compiling module X:

  module X where
        import M
        data T = ...
        instance C Int T where ...

This instance is an orphan, because when compiling a third module Y we
might get a constraint (C Int v), and we'd want to improve v to T.  So
we must make sure X's instances are loaded, even if we do not directly
use anything from X.

More precisely, an instance is an orphan iff

  If there are no fundeps, then at least of the names in
  the instance head is locally defined.

  If there are fundeps, then for every fundep, at least one of the
  names free in a *non-determined* part of the instance head is
  defined in this module.

(Note that these conditions hold trivially if the class is locally
defined.)


************************************************************************
*                                                                      *
                InstEnv, ClsInstEnv
*                                                                      *
************************************************************************

A @ClsInstEnv@ all the instances of that class.  The @Id@ inside a
ClsInstEnv mapping is the dfun for that instance.

If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then

        forall a b, C t1 t2 t3  can be constructed by dfun

or, to put it another way, we have

        instance (...) => C t1 t2 t3,  witnessed by dfun
-}

---------------------------------------------------
{-
Note [InstEnv determinism]
~~~~~~~~~~~~~~~~~~~~~~~~~~
We turn InstEnvs into a list in some places that don't directly affect
the ABI. That happens when we create output for `:info`.
Unfortunately that nondeterminism is nonlocal and it's hard to tell what it
affects without following a chain of functions. It's also easy to accidentally
make that nondeterminism affect the ABI. Furthermore the envs should be
relatively small, so it should be free to use deterministic maps here.
Testing with nofib and validate detected no difference between UniqFM and
UniqDFM. See also Note [Deterministic UniqFM]
-}

-- Internally it's safe to indexable this map by
-- by @Class@, the classes @Name@, the classes @TyCon@
-- or it's @Unique@.
-- This is since:
-- getUnique cls == getUnique (className cls) == getUnique (classTyCon cls)
--
-- We still use Class as key type as it's both the common case
-- and conveys the meaning better. But the implementation of
--InstEnv is a bit more lax internally.
type InstEnv = UniqDFM Class ClsInstEnv      -- Maps Class to instances for that class
  -- See Note [InstEnv determinism]

-- | 'InstEnvs' represents the combination of the global type class instance
-- environment, the local type class instance environment, and the set of
-- transitively reachable orphan modules (according to what modules have been
-- directly imported) used to test orphan instance visibility.
data InstEnvs = InstEnvs {
        InstEnvs -> InstEnv
ie_global  :: InstEnv,               -- External-package instances
        InstEnvs -> InstEnv
ie_local   :: InstEnv,               -- Home-package instances
        InstEnvs -> VisibleOrphanModules
ie_visible :: VisibleOrphanModules   -- Set of all orphan modules transitively
                                             -- reachable from the module being compiled
                                             -- See Note [Instance lookup and orphan instances]
    }

-- | Set of visible orphan modules, according to what modules have been directly
-- imported.  This is based off of the dep_orphs field, which records
-- transitively reachable orphan modules (modules that define orphan instances).
type VisibleOrphanModules = ModuleSet

newtype ClsInstEnv
  = ClsIE [ClsInst]    -- The instances for a particular class, in any order

instance Outputable ClsInstEnv where
  ppr :: ClsInstEnv -> SDoc
ppr (ClsIE [ClsInst]
is) = [ClsInst] -> SDoc
pprInstances [ClsInst]
is

-- INVARIANTS:
--  * The is_tvs are distinct in each ClsInst
--      of a ClsInstEnv (so we can safely unify them)

-- Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry:
--      [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
-- The "a" in the pattern must be one of the forall'd variables in
-- the dfun type.

emptyInstEnv :: InstEnv
emptyInstEnv :: InstEnv
emptyInstEnv = InstEnv
forall key elt. UniqDFM key elt
emptyUDFM

instEnvElts :: InstEnv -> [ClsInst]
instEnvElts :: InstEnv -> [ClsInst]
instEnvElts InstEnv
ie = [ClsInst
elt | ClsIE [ClsInst]
elts <- InstEnv -> [ClsInstEnv]
forall key elt. UniqDFM key elt -> [elt]
eltsUDFM InstEnv
ie, ClsInst
elt <- [ClsInst]
elts]
  -- See Note [InstEnv determinism]

instEnvClasses :: InstEnv -> [Class]
instEnvClasses :: InstEnv -> [Class]
instEnvClasses InstEnv
ie = [ClsInst -> Class
is_cls ClsInst
e | ClsIE (ClsInst
e : [ClsInst]
_) <- InstEnv -> [ClsInstEnv]
forall key elt. UniqDFM key elt -> [elt]
eltsUDFM InstEnv
ie]

-- | Test if an instance is visible, by checking that its origin module
-- is in 'VisibleOrphanModules'.
-- See Note [Instance lookup and orphan instances]
instIsVisible :: VisibleOrphanModules -> ClsInst -> Bool
instIsVisible :: VisibleOrphanModules -> ClsInst -> Bool
instIsVisible VisibleOrphanModules
vis_mods ClsInst
ispec
  -- NB: Instances from the interactive package always are visible. We can't
  -- add interactive modules to the set since we keep creating new ones
  -- as a GHCi session progresses.
  = case Name -> Maybe Module
nameModule_maybe (ClsInst -> Name
is_dfun_name ClsInst
ispec) of
      Maybe Module
Nothing -> Bool
True
      Just Module
mod | Module -> Bool
isInteractiveModule Module
mod     -> Bool
True
               | IsOrphan
IsOrphan <- ClsInst -> IsOrphan
is_orphan ClsInst
ispec -> Module
mod Module -> VisibleOrphanModules -> Bool
`elemModuleSet` VisibleOrphanModules
vis_mods
               | Bool
otherwise                   -> Bool
True

classInstances :: InstEnvs -> Class -> [ClsInst]
classInstances :: InstEnvs -> Class -> [ClsInst]
classInstances (InstEnvs { ie_global :: InstEnvs -> InstEnv
ie_global = InstEnv
pkg_ie, ie_local :: InstEnvs -> InstEnv
ie_local = InstEnv
home_ie, ie_visible :: InstEnvs -> VisibleOrphanModules
ie_visible = VisibleOrphanModules
vis_mods }) Class
cls
  = InstEnv -> [ClsInst]
get InstEnv
home_ie [ClsInst] -> [ClsInst] -> [ClsInst]
forall a. [a] -> [a] -> [a]
++ InstEnv -> [ClsInst]
get InstEnv
pkg_ie
  where
    get :: InstEnv -> [ClsInst]
get InstEnv
env = case InstEnv -> Class -> Maybe ClsInstEnv
forall key elt.
Uniquable key =>
UniqDFM key elt -> key -> Maybe elt
lookupUDFM InstEnv
env Class
cls of
                Just (ClsIE [ClsInst]
insts) -> (ClsInst -> Bool) -> [ClsInst] -> [ClsInst]
forall a. (a -> Bool) -> [a] -> [a]
filter (VisibleOrphanModules -> ClsInst -> Bool
instIsVisible VisibleOrphanModules
vis_mods) [ClsInst]
insts
                Maybe ClsInstEnv
Nothing            -> []

-- | Checks for an exact match of ClsInst in the instance environment.
-- We use this when we do signature checking in "GHC.Tc.Module"
memberInstEnv :: InstEnv -> ClsInst -> Bool
memberInstEnv :: InstEnv -> ClsInst -> Bool
memberInstEnv InstEnv
inst_env ins_item :: ClsInst
ins_item@(ClsInst { is_cls_nm :: ClsInst -> Name
is_cls_nm = Name
cls_nm } ) =
    Bool -> (ClsInstEnv -> Bool) -> Maybe ClsInstEnv -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\(ClsIE [ClsInst]
items) -> (ClsInst -> Bool) -> [ClsInst] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ClsInst -> ClsInst -> Bool
identicalDFunType ClsInst
ins_item) [ClsInst]
items)
          (InstEnv -> Unique -> Maybe ClsInstEnv
forall key elt. UniqDFM key elt -> Unique -> Maybe elt
lookupUDFM_Directly InstEnv
inst_env (Name -> Unique
forall a. Uniquable a => a -> Unique
getUnique Name
cls_nm))
 where
  identicalDFunType :: ClsInst -> ClsInst -> Bool
identicalDFunType ClsInst
cls1 ClsInst
cls2 =
    Type -> Type -> Bool
eqType (DFunId -> Type
varType (ClsInst -> DFunId
is_dfun ClsInst
cls1)) (DFunId -> Type
varType (ClsInst -> DFunId
is_dfun ClsInst
cls2))

extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv
extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv
extendInstEnvList InstEnv
inst_env [ClsInst]
ispecs = (InstEnv -> ClsInst -> InstEnv) -> InstEnv -> [ClsInst] -> InstEnv
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' InstEnv -> ClsInst -> InstEnv
extendInstEnv InstEnv
inst_env [ClsInst]
ispecs

extendInstEnv :: InstEnv -> ClsInst -> InstEnv
extendInstEnv :: InstEnv -> ClsInst -> InstEnv
extendInstEnv InstEnv
inst_env ins_item :: ClsInst
ins_item@(ClsInst { is_cls_nm :: ClsInst -> Name
is_cls_nm = Name
cls_nm })
  = (ClsInstEnv -> ClsInstEnv -> ClsInstEnv)
-> InstEnv -> Unique -> ClsInstEnv -> InstEnv
forall elt key.
(elt -> elt -> elt)
-> UniqDFM key elt -> Unique -> elt -> UniqDFM key elt
addToUDFM_C_Directly ClsInstEnv -> ClsInstEnv -> ClsInstEnv
forall {p}. ClsInstEnv -> p -> ClsInstEnv
add InstEnv
inst_env (Name -> Unique
forall a. Uniquable a => a -> Unique
getUnique Name
cls_nm) ([ClsInst] -> ClsInstEnv
ClsIE [ClsInst
ins_item])
  where
    add :: ClsInstEnv -> p -> ClsInstEnv
add (ClsIE [ClsInst]
cur_insts) p
_ = [ClsInst] -> ClsInstEnv
ClsIE (ClsInst
ins_item ClsInst -> [ClsInst] -> [ClsInst]
forall a. a -> [a] -> [a]
: [ClsInst]
cur_insts)

deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv
deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv
deleteFromInstEnv InstEnv
inst_env ins_item :: ClsInst
ins_item@(ClsInst { is_cls_nm :: ClsInst -> Name
is_cls_nm = Name
cls_nm })
  = (ClsInstEnv -> ClsInstEnv) -> InstEnv -> Unique -> InstEnv
forall elt key.
(elt -> elt) -> UniqDFM key elt -> Unique -> UniqDFM key elt
adjustUDFM_Directly ClsInstEnv -> ClsInstEnv
adjust InstEnv
inst_env (Name -> Unique
forall a. Uniquable a => a -> Unique
getUnique Name
cls_nm)
  where
    adjust :: ClsInstEnv -> ClsInstEnv
adjust (ClsIE [ClsInst]
items) = [ClsInst] -> ClsInstEnv
ClsIE ((ClsInst -> Bool) -> [ClsInst] -> [ClsInst]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (ClsInst -> ClsInst -> Bool
identicalClsInstHead ClsInst
ins_item) [ClsInst]
items)

deleteDFunFromInstEnv :: InstEnv -> DFunId -> InstEnv
-- Delete a specific instance fron an InstEnv
deleteDFunFromInstEnv :: InstEnv -> DFunId -> InstEnv
deleteDFunFromInstEnv InstEnv
inst_env DFunId
dfun
  = (ClsInstEnv -> ClsInstEnv) -> InstEnv -> Class -> InstEnv
forall key elt.
Uniquable key =>
(elt -> elt) -> UniqDFM key elt -> key -> UniqDFM key elt
adjustUDFM ClsInstEnv -> ClsInstEnv
adjust InstEnv
inst_env Class
cls
  where
    ([DFunId]
_, [Type]
_, Class
cls, [Type]
_) = Type -> ([DFunId], [Type], Class, [Type])
tcSplitDFunTy (DFunId -> Type
idType DFunId
dfun)
    adjust :: ClsInstEnv -> ClsInstEnv
adjust (ClsIE [ClsInst]
items) = [ClsInst] -> ClsInstEnv
ClsIE ((ClsInst -> Bool) -> [ClsInst] -> [ClsInst]
forall a. (a -> Bool) -> [a] -> [a]
filterOut ClsInst -> Bool
same_dfun [ClsInst]
items)
    same_dfun :: ClsInst -> Bool
same_dfun (ClsInst { is_dfun :: ClsInst -> DFunId
is_dfun = DFunId
dfun' }) = DFunId
dfun DFunId -> DFunId -> Bool
forall a. Eq a => a -> a -> Bool
== DFunId
dfun'

identicalClsInstHead :: ClsInst -> ClsInst -> Bool
-- ^ True when when the instance heads are the same
-- e.g.  both are   Eq [(a,b)]
-- Used for overriding in GHCi
-- Obviously should be insensitive to alpha-renaming
identicalClsInstHead :: ClsInst -> ClsInst -> Bool
identicalClsInstHead (ClsInst { is_cls_nm :: ClsInst -> Name
is_cls_nm = Name
cls_nm1, is_tcs :: ClsInst -> [Maybe Name]
is_tcs = [Maybe Name]
rough1, is_tys :: ClsInst -> [Type]
is_tys = [Type]
tys1 })
                     (ClsInst { is_cls_nm :: ClsInst -> Name
is_cls_nm = Name
cls_nm2, is_tcs :: ClsInst -> [Maybe Name]
is_tcs = [Maybe Name]
rough2, is_tys :: ClsInst -> [Type]
is_tys = [Type]
tys2 })
  =  Name
cls_nm1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
cls_nm2
  Bool -> Bool -> Bool
&& Bool -> Bool
not ([Maybe Name] -> [Maybe Name] -> Bool
instanceCantMatch [Maybe Name]
rough1 [Maybe Name]
rough2)  -- Fast check for no match, uses the "rough match" fields
  Bool -> Bool -> Bool
&& Maybe TCvSubst -> Bool
forall a. Maybe a -> Bool
isJust ([Type] -> [Type] -> Maybe TCvSubst
tcMatchTys [Type]
tys1 [Type]
tys2)
  Bool -> Bool -> Bool
&& Maybe TCvSubst -> Bool
forall a. Maybe a -> Bool
isJust ([Type] -> [Type] -> Maybe TCvSubst
tcMatchTys [Type]
tys2 [Type]
tys1)

{-
************************************************************************
*                                                                      *
        Looking up an instance
*                                                                      *
************************************************************************

@lookupInstEnv@ looks up in a @InstEnv@, using a one-way match.  Since
the env is kept ordered, the first match must be the only one.  The
thing we are looking up can have an arbitrary "flexi" part.

Note [Instance lookup and orphan instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we are compiling a module M, and we have a zillion packages
loaded, and we are looking up an instance for C (T W).  If we find a
match in module 'X' from package 'p', should be "in scope"; that is,

  is p:X in the transitive closure of modules imported from M?

The difficulty is that the "zillion packages" might include ones loaded
through earlier invocations of the GHC API, or earlier module loads in GHCi.
They might not be in the dependencies of M itself; and if not, the instances
in them should not be visible.  #2182, #8427.

There are two cases:
  * If the instance is *not an orphan*, then module X defines C, T, or W.
    And in order for those types to be involved in typechecking M, it
    must be that X is in the transitive closure of M's imports.  So we
    can use the instance.

  * If the instance *is an orphan*, the above reasoning does not apply.
    So we keep track of the set of orphan modules transitively below M;
    this is the ie_visible field of InstEnvs, of type VisibleOrphanModules.

    If module p:X is in this set, then we can use the instance, otherwise
    we can't.

Note [Rules for instance lookup]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
These functions implement the carefully-written rules in the user
manual section on "overlapping instances". At risk of duplication,
here are the rules.  If the rules change, change this text and the
user manual simultaneously.  The link may be this:
http://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#instance-overlap

The willingness to be overlapped or incoherent is a property of the
instance declaration itself, controlled as follows:

 * An instance is "incoherent"
   if it has an INCOHERENT pragma, or
   if it appears in a module compiled with -XIncoherentInstances.

 * An instance is "overlappable"
   if it has an OVERLAPPABLE or OVERLAPS pragma, or
   if it appears in a module compiled with -XOverlappingInstances, or
   if the instance is incoherent.

 * An instance is "overlapping"
   if it has an OVERLAPPING or OVERLAPS pragma, or
   if it appears in a module compiled with -XOverlappingInstances, or
   if the instance is incoherent.
     compiled with -XOverlappingInstances.

Now suppose that, in some client module, we are searching for an instance
of the target constraint (C ty1 .. tyn). The search works like this.

*  Find all instances `I` that *match* the target constraint; that is, the
   target constraint is a substitution instance of `I`. These instance
   declarations are the *candidates*.

*  Eliminate any candidate `IX` for which both of the following hold:

   -  There is another candidate `IY` that is strictly more specific; that
      is, `IY` is a substitution instance of `IX` but not vice versa.

   -  Either `IX` is *overlappable*, or `IY` is *overlapping*. (This
      "either/or" design, rather than a "both/and" design, allow a
      client to deliberately override an instance from a library,
      without requiring a change to the library.)

-  If exactly one non-incoherent candidate remains, select it. If all
   remaining candidates are incoherent, select an arbitrary one.
   Otherwise the search fails (i.e. when more than one surviving
   candidate is not incoherent).

-  If the selected candidate (from the previous step) is incoherent, the
   search succeeds, returning that candidate.

-  If not, find all instances that *unify* with the target constraint,
   but do not *match* it. Such non-candidate instances might match when
   the target constraint is further instantiated. If all of them are
   incoherent, the search succeeds, returning the selected candidate; if
   not, the search fails.

Notice that these rules are not influenced by flag settings in the
client module, where the instances are *used*. These rules make it
possible for a library author to design a library that relies on
overlapping instances without the client having to know.

Note [Overlapping instances]   (NB: these notes are quite old)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Overlap is permitted, but only in such a way that one can make
a unique choice when looking up.  That is, overlap is only permitted if
one template matches the other, or vice versa.  So this is ok:

  [a]  [Int]

but this is not

  (Int,a)  (b,Int)

If overlap is permitted, the list is kept most specific first, so that
the first lookup is the right choice.


For now we just use association lists.

\subsection{Avoiding a problem with overlapping}

Consider this little program:

\begin{pseudocode}
     class C a        where c :: a
     class C a => D a where d :: a

     instance C Int where c = 17
     instance D Int where d = 13

     instance C a => C [a] where c = [c]
     instance ({- C [a], -} D a) => D [a] where d = c

     instance C [Int] where c = [37]

     main = print (d :: [Int])
\end{pseudocode}

What do you think `main' prints  (assuming we have overlapping instances, and
all that turned on)?  Well, the instance for `D' at type `[a]' is defined to
be `c' at the same type, and we've got an instance of `C' at `[Int]', so the
answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because
the `C [Int]' instance is more specific).

Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong.  That
was easy ;-)  Let's just consult hugs for good measure.  Wait - if I use old
hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it
doesn't even compile!  What's going on!?

What hugs complains about is the `D [a]' instance decl.

\begin{pseudocode}
     ERROR "mj.hs" (line 10): Cannot build superclass instance
     *** Instance            : D [a]
     *** Context supplied    : D a
     *** Required superclass : C [a]
\end{pseudocode}

You might wonder what hugs is complaining about.  It's saying that you
need to add `C [a]' to the context of the `D [a]' instance (as appears
in comments).  But there's that `C [a]' instance decl one line above
that says that I can reduce the need for a `C [a]' instance to the
need for a `C a' instance, and in this case, I already have the
necessary `C a' instance (since we have `D a' explicitly in the
context, and `C' is a superclass of `D').

Unfortunately, the above reasoning indicates a premature commitment to the
generic `C [a]' instance.  I.e., it prematurely rules out the more specific
instance `C [Int]'.  This is the mistake that ghc-4.06 makes.  The fix is to
add the context that hugs suggests (uncomment the `C [a]'), effectively
deferring the decision about which instance to use.

Now, interestingly enough, 4.04 has this same bug, but it's covered up
in this case by a little known `optimization' that was disabled in
4.06.  Ghc-4.04 silently inserts any missing superclass context into
an instance declaration.  In this case, it silently inserts the `C
[a]', and everything happens to work out.

(See `GHC.Types.Id.Make.mkDictFunId' for the code in question.  Search for
`Mark Jones', although Mark claims no credit for the `optimization' in
question, and would rather it stopped being called the `Mark Jones
optimization' ;-)

So, what's the fix?  I think hugs has it right.  Here's why.  Let's try
something else out with ghc-4.04.  Let's add the following line:

    d' :: D a => [a]
    d' = c

Everyone raise their hand who thinks that `d :: [Int]' should give a
different answer from `d' :: [Int]'.  Well, in ghc-4.04, it does.  The
`optimization' only applies to instance decls, not to regular
bindings, giving inconsistent behavior.

Old hugs had this same bug.  Here's how we fixed it: like GHC, the
list of instances for a given class is ordered, so that more specific
instances come before more generic ones.  For example, the instance
list for C might contain:
    ..., C Int, ..., C a, ...
When we go to look for a `C Int' instance we'll get that one first.
But what if we go looking for a `C b' (`b' is unconstrained)?  We'll
pass the `C Int' instance, and keep going.  But if `b' is
unconstrained, then we don't know yet if the more specific instance
will eventually apply.  GHC keeps going, and matches on the generic `C
a'.  The fix is to, at each step, check to see if there's a reverse
match, and if so, abort the search.  This prevents hugs from
prematurely choosing a generic instance when a more specific one
exists.

--Jeff

BUT NOTE [Nov 2001]: we must actually *unify* not reverse-match in
this test.  Suppose the instance envt had
    ..., forall a b. C a a b, ..., forall a b c. C a b c, ...
(still most specific first)
Now suppose we are looking for (C x y Int), where x and y are unconstrained.
        C x y Int  doesn't match the template {a,b} C a a b
but neither does
        C a a b  match the template {x,y} C x y Int
But still x and y might subsequently be unified so they *do* match.

Simple story: unify, don't match.
-}

type DFunInstType = Maybe Type
        -- Just ty   => Instantiate with this type
        -- Nothing   => Instantiate with any type of this tyvar's kind
        -- See Note [DFunInstType: instantiating types]

type InstMatch = (ClsInst, [DFunInstType])

type ClsInstLookupResult
     = ( [InstMatch]     -- Successful matches
       , [ClsInst]       -- These don't match but do unify
       , [InstMatch] )   -- Unsafe overlapped instances under Safe Haskell
                         -- (see Note [Safe Haskell Overlapping Instances] in
                         -- GHC.Tc.Solver).

{-
Note [DFunInstType: instantiating types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A successful match is a ClsInst, together with the types at which
        the dfun_id in the ClsInst should be instantiated
The instantiating types are (Either TyVar Type)s because the dfun
might have some tyvars that *only* appear in arguments
        dfun :: forall a b. C a b, Ord b => D [a]
When we match this against D [ty], we return the instantiating types
        [Just ty, Nothing]
where the 'Nothing' indicates that 'b' can be freely instantiated.
(The caller instantiates it to a flexi type variable, which will
 presumably later become fixed via functional dependencies.)
-}

-- |Look up an instance in the given instance environment. The given class application must match exactly
-- one instance and the match may not contain any flexi type variables.  If the lookup is unsuccessful,
-- yield 'Left errorMessage'.
lookupUniqueInstEnv :: InstEnvs
                    -> Class -> [Type]
                    -> Either MsgDoc (ClsInst, [Type])
lookupUniqueInstEnv :: InstEnvs -> Class -> [Type] -> Either SDoc (ClsInst, [Type])
lookupUniqueInstEnv InstEnvs
instEnv Class
cls [Type]
tys
  = case Bool -> InstEnvs -> Class -> [Type] -> ClsInstLookupResult
lookupInstEnv Bool
False InstEnvs
instEnv Class
cls [Type]
tys of
      ([(ClsInst
inst, [DFunInstType]
inst_tys)], [ClsInst]
_, [InstMatch]
_)
             | Bool
noFlexiVar -> (ClsInst, [Type]) -> Either SDoc (ClsInst, [Type])
forall a b. b -> Either a b
Right (ClsInst
inst, [Type]
inst_tys')
             | Bool
otherwise  -> SDoc -> Either SDoc (ClsInst, [Type])
forall a b. a -> Either a b
Left (SDoc -> Either SDoc (ClsInst, [Type]))
-> SDoc -> Either SDoc (ClsInst, [Type])
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"flexible type variable:" SDoc -> SDoc -> SDoc
<+>
                                    (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Type -> SDoc) -> Type -> SDoc
forall a b. (a -> b) -> a -> b
$ TyCon -> [Type] -> Type
mkTyConApp (Class -> TyCon
classTyCon Class
cls) [Type]
tys)
             where
               inst_tys' :: [Type]
inst_tys'  = [Type
ty | Just Type
ty <- [DFunInstType]
inst_tys]
               noFlexiVar :: Bool
noFlexiVar = (DFunInstType -> Bool) -> [DFunInstType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all DFunInstType -> Bool
forall a. Maybe a -> Bool
isJust [DFunInstType]
inst_tys
      ClsInstLookupResult
_other -> SDoc -> Either SDoc (ClsInst, [Type])
forall a b. a -> Either a b
Left (SDoc -> Either SDoc (ClsInst, [Type]))
-> SDoc -> Either SDoc (ClsInst, [Type])
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"instance not found" SDoc -> SDoc -> SDoc
<+>
                       (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Type -> SDoc) -> Type -> SDoc
forall a b. (a -> b) -> a -> b
$ TyCon -> [Type] -> Type
mkTyConApp (Class -> TyCon
classTyCon Class
cls) [Type]
tys)

lookupInstEnv' :: InstEnv          -- InstEnv to look in
               -> VisibleOrphanModules   -- But filter against this
               -> Class -> [Type]  -- What we are looking for
               -> ([InstMatch],    -- Successful matches
                   [ClsInst])      -- These don't match but do unify
                                   -- (no incoherent ones in here)
-- The second component of the result pair happens when we look up
--      Foo [a]
-- in an InstEnv that has entries for
--      Foo [Int]
--      Foo [b]
-- Then which we choose would depend on the way in which 'a'
-- is instantiated.  So we report that Foo [b] is a match (mapping b->a)
-- but Foo [Int] is a unifier.  This gives the caller a better chance of
-- giving a suitable error message

lookupInstEnv' :: InstEnv
-> VisibleOrphanModules
-> Class
-> [Type]
-> ([InstMatch], [ClsInst])
lookupInstEnv' InstEnv
ie VisibleOrphanModules
vis_mods Class
cls [Type]
tys
  = InstEnv -> ([InstMatch], [ClsInst])
lookup InstEnv
ie
  where
    rough_tcs :: [Maybe Name]
rough_tcs  = [Type] -> [Maybe Name]
roughMatchTcs [Type]
tys
    all_tvs :: Bool
all_tvs    = (Maybe Name -> Bool) -> [Maybe Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Maybe Name -> Bool
forall a. Maybe a -> Bool
isNothing [Maybe Name]
rough_tcs

    --------------
    lookup :: InstEnv -> ([InstMatch], [ClsInst])
lookup InstEnv
env = case InstEnv -> Class -> Maybe ClsInstEnv
forall key elt.
Uniquable key =>
UniqDFM key elt -> key -> Maybe elt
lookupUDFM InstEnv
env Class
cls of
                   Maybe ClsInstEnv
Nothing -> ([],[])   -- No instances for this class
                   Just (ClsIE [ClsInst]
insts) -> [InstMatch] -> [ClsInst] -> [ClsInst] -> ([InstMatch], [ClsInst])
find [] [] [ClsInst]
insts

    --------------
    find :: [InstMatch] -> [ClsInst] -> [ClsInst] -> ([InstMatch], [ClsInst])
find [InstMatch]
ms [ClsInst]
us [] = ([InstMatch]
ms, [ClsInst]
us)
    find [InstMatch]
ms [ClsInst]
us (item :: ClsInst
item@(ClsInst { is_tcs :: ClsInst -> [Maybe Name]
is_tcs = [Maybe Name]
mb_tcs, is_tvs :: ClsInst -> [DFunId]
is_tvs = [DFunId]
tpl_tvs
                              , is_tys :: ClsInst -> [Type]
is_tys = [Type]
tpl_tys }) : [ClsInst]
rest)
      | Bool -> Bool
not (VisibleOrphanModules -> ClsInst -> Bool
instIsVisible VisibleOrphanModules
vis_mods ClsInst
item)
      = [InstMatch] -> [ClsInst] -> [ClsInst] -> ([InstMatch], [ClsInst])
find [InstMatch]
ms [ClsInst]
us [ClsInst]
rest  -- See Note [Instance lookup and orphan instances]

        -- Fast check for no match, uses the "rough match" fields
      | [Maybe Name] -> [Maybe Name] -> Bool
instanceCantMatch [Maybe Name]
rough_tcs [Maybe Name]
mb_tcs
      = [InstMatch] -> [ClsInst] -> [ClsInst] -> ([InstMatch], [ClsInst])
find [InstMatch]
ms [ClsInst]
us [ClsInst]
rest

      | Just TCvSubst
subst <- [Type] -> [Type] -> Maybe TCvSubst
tcMatchTys [Type]
tpl_tys [Type]
tys
      = [InstMatch] -> [ClsInst] -> [ClsInst] -> ([InstMatch], [ClsInst])
find ((ClsInst
item, (DFunId -> DFunInstType) -> [DFunId] -> [DFunInstType]
forall a b. (a -> b) -> [a] -> [b]
map (TCvSubst -> DFunId -> DFunInstType
lookupTyVar TCvSubst
subst) [DFunId]
tpl_tvs) InstMatch -> [InstMatch] -> [InstMatch]
forall a. a -> [a] -> [a]
: [InstMatch]
ms) [ClsInst]
us [ClsInst]
rest

        -- Does not match, so next check whether the things unify
        -- See Note [Overlapping instances]
        -- Ignore ones that are incoherent: Note [Incoherent instances]
      | ClsInst -> Bool
isIncoherent ClsInst
item
      = [InstMatch] -> [ClsInst] -> [ClsInst] -> ([InstMatch], [ClsInst])
find [InstMatch]
ms [ClsInst]
us [ClsInst]
rest

      | Bool
otherwise
      = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tv_set,
                 (ppr cls <+> ppr tys <+> ppr all_tvs) $$
                 (ppr tpl_tvs <+> ppr tpl_tys)
                )
                -- Unification will break badly if the variables overlap
                -- They shouldn't because we allocate separate uniques for them
                -- See Note [Template tyvars are fresh]
        case (DFunId -> BindFlag) -> [Type] -> [Type] -> Maybe TCvSubst
tcUnifyTys DFunId -> BindFlag
instanceBindFun [Type]
tpl_tys [Type]
tys of
            Just TCvSubst
_   -> [InstMatch] -> [ClsInst] -> [ClsInst] -> ([InstMatch], [ClsInst])
find [InstMatch]
ms (ClsInst
itemClsInst -> [ClsInst] -> [ClsInst]
forall a. a -> [a] -> [a]
:[ClsInst]
us) [ClsInst]
rest
            Maybe TCvSubst
Nothing  -> [InstMatch] -> [ClsInst] -> [ClsInst] -> ([InstMatch], [ClsInst])
find [InstMatch]
ms [ClsInst]
us        [ClsInst]
rest
      where
        tpl_tv_set :: TyCoVarSet
tpl_tv_set = [DFunId] -> TyCoVarSet
mkVarSet [DFunId]
tpl_tvs

---------------
-- This is the common way to call this function.
lookupInstEnv :: Bool              -- Check Safe Haskell overlap restrictions
              -> InstEnvs          -- External and home package inst-env
              -> Class -> [Type]   -- What we are looking for
              -> ClsInstLookupResult
-- ^ See Note [Rules for instance lookup]
-- ^ See Note [Safe Haskell Overlapping Instances] in "GHC.Tc.Solver"
-- ^ See Note [Safe Haskell Overlapping Instances Implementation] in "GHC.Tc.Solver"
lookupInstEnv :: Bool -> InstEnvs -> Class -> [Type] -> ClsInstLookupResult
lookupInstEnv Bool
check_overlap_safe
              (InstEnvs { ie_global :: InstEnvs -> InstEnv
ie_global = InstEnv
pkg_ie
                        , ie_local :: InstEnvs -> InstEnv
ie_local = InstEnv
home_ie
                        , ie_visible :: InstEnvs -> VisibleOrphanModules
ie_visible = VisibleOrphanModules
vis_mods })
              Class
cls
              [Type]
tys
  = -- pprTrace "lookupInstEnv" (ppr cls <+> ppr tys $$ ppr home_ie) $
    ([InstMatch]
final_matches, [ClsInst]
final_unifs, [InstMatch]
unsafe_overlapped)
  where
    ([InstMatch]
home_matches, [ClsInst]
home_unifs) = InstEnv
-> VisibleOrphanModules
-> Class
-> [Type]
-> ([InstMatch], [ClsInst])
lookupInstEnv' InstEnv
home_ie VisibleOrphanModules
vis_mods Class
cls [Type]
tys
    ([InstMatch]
pkg_matches,  [ClsInst]
pkg_unifs)  = InstEnv
-> VisibleOrphanModules
-> Class
-> [Type]
-> ([InstMatch], [ClsInst])
lookupInstEnv' InstEnv
pkg_ie  VisibleOrphanModules
vis_mods Class
cls [Type]
tys
    all_matches :: [InstMatch]
all_matches = [InstMatch]
home_matches [InstMatch] -> [InstMatch] -> [InstMatch]
forall a. [a] -> [a] -> [a]
++ [InstMatch]
pkg_matches
    all_unifs :: [ClsInst]
all_unifs   = [ClsInst]
home_unifs   [ClsInst] -> [ClsInst] -> [ClsInst]
forall a. [a] -> [a] -> [a]
++ [ClsInst]
pkg_unifs
    final_matches :: [InstMatch]
final_matches = (InstMatch -> [InstMatch] -> [InstMatch])
-> [InstMatch] -> [InstMatch] -> [InstMatch]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr InstMatch -> [InstMatch] -> [InstMatch]
insert_overlapping [] [InstMatch]
all_matches
        -- Even if the unifs is non-empty (an error situation)
        -- we still prune the matches, so that the error message isn't
        -- misleading (complaining of multiple matches when some should be
        -- overlapped away)

    unsafe_overlapped :: [InstMatch]
unsafe_overlapped
       = case [InstMatch]
final_matches of
           [InstMatch
match] -> InstMatch -> [InstMatch]
forall {b}. (ClsInst, b) -> [InstMatch]
check_safe InstMatch
match
           [InstMatch]
_       -> []

    -- If the selected match is incoherent, discard all unifiers
    final_unifs :: [ClsInst]
final_unifs = case [InstMatch]
final_matches of
                    (InstMatch
m:[InstMatch]
_) | ClsInst -> Bool
isIncoherent (InstMatch -> ClsInst
forall a b. (a, b) -> a
fst InstMatch
m) -> []
                    [InstMatch]
_                            -> [ClsInst]
all_unifs

    -- NOTE [Safe Haskell isSafeOverlap]
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    -- We restrict code compiled in 'Safe' mode from overriding code
    -- compiled in any other mode. The rationale is that code compiled
    -- in 'Safe' mode is code that is untrusted by the ghc user. So
    -- we shouldn't let that code change the behaviour of code the
    -- user didn't compile in 'Safe' mode since that's the code they
    -- trust. So 'Safe' instances can only overlap instances from the
    -- same module. A same instance origin policy for safe compiled
    -- instances.
    check_safe :: (ClsInst, b) -> [InstMatch]
check_safe (ClsInst
inst,b
_)
        = case Bool
check_overlap_safe Bool -> Bool -> Bool
&& ClsInst -> Bool
unsafeTopInstance ClsInst
inst of
                -- make sure it only overlaps instances from the same module
                Bool
True -> [InstMatch] -> [InstMatch] -> [InstMatch]
forall {b}. [(ClsInst, b)] -> [(ClsInst, b)] -> [(ClsInst, b)]
go [] [InstMatch]
all_matches
                -- most specific is from a trusted location.
                Bool
False -> []
        where
            go :: [(ClsInst, b)] -> [(ClsInst, b)] -> [(ClsInst, b)]
go [(ClsInst, b)]
bad [] = [(ClsInst, b)]
bad
            go [(ClsInst, b)]
bad (i :: (ClsInst, b)
i@(ClsInst
x,b
_):[(ClsInst, b)]
unchecked) =
                if ClsInst -> Bool
forall {p}. NamedThing p => p -> Bool
inSameMod ClsInst
x Bool -> Bool -> Bool
|| ClsInst -> Bool
isOverlappable ClsInst
x
                    then [(ClsInst, b)] -> [(ClsInst, b)] -> [(ClsInst, b)]
go [(ClsInst, b)]
bad [(ClsInst, b)]
unchecked
                    else [(ClsInst, b)] -> [(ClsInst, b)] -> [(ClsInst, b)]
go ((ClsInst, b)
i(ClsInst, b) -> [(ClsInst, b)] -> [(ClsInst, b)]
forall a. a -> [a] -> [a]
:[(ClsInst, b)]
bad) [(ClsInst, b)]
unchecked

            inSameMod :: p -> Bool
inSameMod p
b =
                let na :: Name
na = Name -> Name
forall a. NamedThing a => a -> Name
getName (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ ClsInst -> Name
forall a. NamedThing a => a -> Name
getName ClsInst
inst
                    la :: Bool
la = Name -> Bool
isInternalName Name
na
                    nb :: Name
nb = Name -> Name
forall a. NamedThing a => a -> Name
getName (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ p -> Name
forall a. NamedThing a => a -> Name
getName p
b
                    lb :: Bool
lb = Name -> Bool
isInternalName Name
nb
                in (Bool
la Bool -> Bool -> Bool
&& Bool
lb) Bool -> Bool -> Bool
|| (HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
na Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
nb)

    -- We consider the most specific instance unsafe when it both:
    --   (1) Comes from a module compiled as `Safe`
    --   (2) Is an orphan instance, OR, an instance for a MPTC
    unsafeTopInstance :: ClsInst -> Bool
unsafeTopInstance ClsInst
inst = OverlapFlag -> Bool
isSafeOverlap (ClsInst -> OverlapFlag
is_flag ClsInst
inst) Bool -> Bool -> Bool
&&
        (IsOrphan -> Bool
isOrphan (ClsInst -> IsOrphan
is_orphan ClsInst
inst) Bool -> Bool -> Bool
|| Class -> Int
classArity (ClsInst -> Class
is_cls ClsInst
inst) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1)

---------------
insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch]
-- ^ Add a new solution, knocking out strictly less specific ones
-- See Note [Rules for instance lookup]
insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch]
insert_overlapping InstMatch
new_item [] = [InstMatch
new_item]
insert_overlapping new_item :: InstMatch
new_item@(ClsInst
new_inst,[DFunInstType]
_) (old_item :: InstMatch
old_item@(ClsInst
old_inst,[DFunInstType]
_) : [InstMatch]
old_items)
  | Bool
new_beats_old        -- New strictly overrides old
  , Bool -> Bool
not Bool
old_beats_new
  , ClsInst
new_inst ClsInst -> ClsInst -> Bool
`can_override` ClsInst
old_inst
  = InstMatch -> [InstMatch] -> [InstMatch]
insert_overlapping InstMatch
new_item [InstMatch]
old_items

  | Bool
old_beats_new        -- Old strictly overrides new
  , Bool -> Bool
not Bool
new_beats_old
  , ClsInst
old_inst ClsInst -> ClsInst -> Bool
`can_override` ClsInst
new_inst
  = InstMatch
old_item InstMatch -> [InstMatch] -> [InstMatch]
forall a. a -> [a] -> [a]
: [InstMatch]
old_items

  -- Discard incoherent instances; see Note [Incoherent instances]
  | ClsInst -> Bool
isIncoherent ClsInst
old_inst      -- Old is incoherent; discard it
  = InstMatch -> [InstMatch] -> [InstMatch]
insert_overlapping InstMatch
new_item [InstMatch]
old_items
  | ClsInst -> Bool
isIncoherent ClsInst
new_inst      -- New is incoherent; discard it
  = InstMatch
old_item InstMatch -> [InstMatch] -> [InstMatch]
forall a. a -> [a] -> [a]
: [InstMatch]
old_items

  -- Equal or incomparable, and neither is incoherent; keep both
  | Bool
otherwise
  = InstMatch
old_item InstMatch -> [InstMatch] -> [InstMatch]
forall a. a -> [a] -> [a]
: InstMatch -> [InstMatch] -> [InstMatch]
insert_overlapping InstMatch
new_item [InstMatch]
old_items
  where

    new_beats_old :: Bool
new_beats_old = ClsInst
new_inst ClsInst -> ClsInst -> Bool
`more_specific_than` ClsInst
old_inst
    old_beats_new :: Bool
old_beats_new = ClsInst
old_inst ClsInst -> ClsInst -> Bool
`more_specific_than` ClsInst
new_inst

    -- `instB` can be instantiated to match `instA`
    -- or the two are equal
    ClsInst
instA more_specific_than :: ClsInst -> ClsInst -> Bool
`more_specific_than` ClsInst
instB
      = Maybe TCvSubst -> Bool
forall a. Maybe a -> Bool
isJust ([Type] -> [Type] -> Maybe TCvSubst
tcMatchTys (ClsInst -> [Type]
is_tys ClsInst
instB) (ClsInst -> [Type]
is_tys ClsInst
instA))

    ClsInst
instA can_override :: ClsInst -> ClsInst -> Bool
`can_override` ClsInst
instB
       = ClsInst -> Bool
isOverlapping ClsInst
instA Bool -> Bool -> Bool
|| ClsInst -> Bool
isOverlappable ClsInst
instB
       -- Overlap permitted if either the more specific instance
       -- is marked as overlapping, or the more general one is
       -- marked as overlappable.
       -- Latest change described in: #9242.
       -- Previous change: #3877, Dec 10.

{-
Note [Incoherent instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
For some classes, the choice of a particular instance does not matter, any one
is good. E.g. consider

        class D a b where { opD :: a -> b -> String }
        instance D Int b where ...
        instance D a Int where ...

        g (x::Int) = opD x x  -- Wanted: D Int Int

For such classes this should work (without having to add an "instance D Int
Int", and using -XOverlappingInstances, which would then work). This is what
-XIncoherentInstances is for: Telling GHC "I don't care which instance you use;
if you can use one, use it."

Should this logic only work when *all* candidates have the incoherent flag, or
even when all but one have it? The right choice is the latter, which can be
justified by comparing the behaviour with how -XIncoherentInstances worked when
it was only about the unify-check (note [Overlapping instances]):

Example:
        class C a b c where foo :: (a,b,c)
        instance C [a] b Int
        instance [incoherent] [Int] b c
        instance [incoherent] C a Int c
Thanks to the incoherent flags,
        [Wanted]  C [a] b Int
works: Only instance one matches, the others just unify, but are marked
incoherent.

So I can write
        (foo :: ([a],b,Int)) :: ([Int], Int, Int).
but if that works then I really want to be able to write
        foo :: ([Int], Int, Int)
as well. Now all three instances from above match. None is more specific than
another, so none is ruled out by the normal overlapping rules. One of them is
not incoherent, but we still want this to compile. Hence the
"all-but-one-logic".

The implementation is in insert_overlapping, where we remove matching
incoherent instances as long as there are others.



************************************************************************
*                                                                      *
        Binding decisions
*                                                                      *
************************************************************************
-}

instanceBindFun :: TyCoVar -> BindFlag
instanceBindFun :: DFunId -> BindFlag
instanceBindFun DFunId
tv | DFunId -> Bool
isOverlappableTyVar DFunId
tv = BindFlag
Skolem
                   | Bool
otherwise              = BindFlag
BindMe
   -- Note [Binding when looking up instances]

{-
Note [Binding when looking up instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When looking up in the instance environment, or family-instance environment,
we are careful about multiple matches, as described above in
Note [Overlapping instances]

The key_tys can contain skolem constants, and we can guarantee that those
are never going to be instantiated to anything, so we should not involve
them in the unification test.  Example:
        class Foo a where { op :: a -> Int }
        instance Foo a => Foo [a]       -- NB overlap
        instance Foo [Int]              -- NB overlap
        data T = forall a. Foo a => MkT a
        f :: T -> Int
        f (MkT x) = op [x,x]
The op [x,x] means we need (Foo [a]).  Without the filterVarSet we'd
complain, saying that the choice of instance depended on the instantiation
of 'a'; but of course it isn't *going* to be instantiated.

We do this only for isOverlappableTyVar skolems.  For example we reject
        g :: forall a => [a] -> Int
        g x = op x
on the grounds that the correct instance depends on the instantiation of 'a'
-}