{-# LANGUAGE DeriveDataTypeable #-}
module GHC.Core.InstEnv (
        DFunId, InstMatch, ClsInstLookupResult,
        PotentialUnifiers(..), getPotentialUnifiers, nullUnifiers,
        OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
        ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances,
        instanceHead, instanceSig, mkLocalInstance, mkImportedInstance,
        instanceDFunId, updateClsInstDFuns, updateClsInstDFun,
        fuzzyClsInstCmp, orphNamesOfClsInst,
        InstEnvs(..), VisibleOrphanModules, InstEnv,
        mkInstEnv, emptyInstEnv, unionInstEnv, extendInstEnv,
        filterInstEnv, deleteFromInstEnv, deleteDFunFromInstEnv,
        anyInstEnv,
        identicalClsInstHead,
        extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts, instEnvClasses, mapInstEnv,
        memberInstEnv,
        instIsVisible,
        classInstances, instanceBindFun,
        classNameInstances,
        instanceCantMatch, roughMatchTcs,
        isOverlappable, isOverlapping, isIncoherent
    ) where
import GHC.Prelude
import GHC.Tc.Utils.TcType 
              
import GHC.Core ( IsOrphan(..), isOrphan, chooseOrphanAnchor )
import GHC.Core.RoughMap
import GHC.Unit.Module.Env
import GHC.Unit.Types
import GHC.Core.Class
import GHC.Types.Var
import GHC.Types.Unique.DSet
import GHC.Types.Var.Set
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Core.Unify
import GHC.Types.Basic
import GHC.Types.Id
import Data.Data        ( Data )
import Data.Maybe       ( isJust )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import Data.Semigroup
data ClsInst
  = ClsInst {   
                
                
               ClsInst -> Name
is_cls_nm :: Name          
             , ClsInst -> [RoughMatchTc]
is_tcs  :: [RoughMatchTc]  
                          
                          
               
               
               
               
               
               
               
               
             , ClsInst -> Name
is_dfun_name :: Name
                
             , ClsInst -> [DFunId]
is_tvs  :: [TyVar]       
                                        
             , ClsInst -> Class
is_cls  :: Class         
             , ClsInst -> [Type]
is_tys  :: [Type]        
                
                
                
             , ClsInst -> DFunId
is_dfun :: DFunId 
             , ClsInst -> OverlapFlag
is_flag :: 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 -> Constr
ClsInst -> DataType
(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)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ClsInst -> c ClsInst
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ClsInst -> c ClsInst
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ClsInst
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ClsInst
$ctoConstr :: ClsInst -> Constr
toConstr :: ClsInst -> Constr
$cdataTypeOf :: ClsInst -> DataType
dataTypeOf :: ClsInst -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ClsInst)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ClsInst)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c ClsInst)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c ClsInst)
$cgmapT :: (forall b. Data b => b -> b) -> ClsInst -> ClsInst
gmapT :: (forall b. Data b => b -> b) -> ClsInst -> ClsInst
$cgmapQl :: 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
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ClsInst -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ClsInst -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> ClsInst -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> ClsInst -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> ClsInst -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> ClsInst -> u
$cgmapM :: forall (m :: * -> *).
Monad 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
$cgmapMp :: 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
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ClsInst -> m ClsInst
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ClsInst -> m ClsInst
Data
fuzzyClsInstCmp :: ClsInst -> ClsInst -> Ordering
fuzzyClsInstCmp :: ClsInst -> ClsInst -> Ordering
fuzzyClsInstCmp ClsInst
x ClsInst
y =
    ((RoughMatchTc, RoughMatchTc) -> Ordering)
-> [(RoughMatchTc, RoughMatchTc)] -> Ordering
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (RoughMatchTc, RoughMatchTc) -> Ordering
cmp ([RoughMatchTc] -> [RoughMatchTc] -> [(RoughMatchTc, RoughMatchTc)]
forall a b. [a] -> [b] -> [(a, b)]
zip (ClsInst -> [RoughMatchTc]
is_tcs ClsInst
x) (ClsInst -> [RoughMatchTc]
is_tcs ClsInst
y))
  where
    cmp :: (RoughMatchTc, RoughMatchTc) -> Ordering
cmp (RoughMatchTc
RM_WildCard,  RoughMatchTc
RM_WildCard)   = Ordering
EQ
    cmp (RoughMatchTc
RM_WildCard,  RM_KnownTc Name
_) = Ordering
LT
    cmp (RM_KnownTc Name
_, RoughMatchTc
RM_WildCard)   = Ordering
GT
    cmp (RM_KnownTc Name
x, RM_KnownTc 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))
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) }
updateClsInstDFuns :: (DFunId -> DFunId) -> InstEnv -> InstEnv
updateClsInstDFuns :: (DFunId -> DFunId) -> InstEnv -> InstEnv
updateClsInstDFuns DFunId -> DFunId
tidy_dfun (InstEnv RoughMap ClsInst
rm)
  = RoughMap ClsInst -> InstEnv
InstEnv (RoughMap ClsInst -> InstEnv) -> RoughMap ClsInst -> InstEnv
forall a b. (a -> b) -> a -> b
$ (ClsInst -> ClsInst) -> RoughMap ClsInst -> RoughMap ClsInst
forall a b. (a -> b) -> RoughMap a -> RoughMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((DFunId -> DFunId) -> ClsInst -> ClsInst
updateClsInstDFun DFunId -> DFunId
tidy_dfun) RoughMap ClsInst
rm
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
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 :: ClsInst -> SDoc
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])
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)
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])
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
mkLocalInstance :: DFunId -> OverlapFlag -> [DFunId] -> Class -> [Type] -> ClsInst
mkLocalInstance DFunId
dfun OverlapFlag
oflag [DFunId]
tvs Class
cls [Type]
tys
  = 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 :: [RoughMatchTc]
is_tcs = Name -> RoughMatchTc
RM_KnownTc Name
cls_name RoughMatchTc -> [RoughMatchTc] -> [RoughMatchTc]
forall a. a -> [a] -> [a]
: [Type] -> [RoughMatchTc]
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 = Bool -> Module -> Module
forall a. HasCallStack => Bool -> a -> a
assert (Name -> Bool
isExternalName Name
dfun_name) (Module -> Module) -> Module -> Module
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) => Name -> Module
Name -> Module
nameModule Name
dfun_name
    is_local :: Name -> Bool
is_local Name
name = Module -> Name -> Bool
nameIsLocalOrFrom Module
this_mod Name
name
        
    ([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]
    
    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 = Bool -> IsOrphan -> IsOrphan
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ([IsOrphan] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IsOrphan]
mb_ns)) (IsOrphan -> IsOrphan) -> IsOrphan -> IsOrphan
forall a b. (a -> b) -> a -> b
$ [IsOrphan] -> IsOrphan
forall a. HasCallStack => [a] -> a
head [IsOrphan]
mb_ns
         | Bool
otherwise           = IsOrphan
IsOrphan
    notOrphan :: IsOrphan -> Bool
notOrphan NotOrphan{} = Bool
True
    notOrphan IsOrphan
_ = Bool
False
    mb_ns :: [IsOrphan]    
                           
    mb_ns :: [IsOrphan]
mb_ns | [FunDep DFunId] -> Bool
forall a. [a] -> 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
do_one [FunDep DFunId]
fds
    do_one :: FunDep DFunId -> IsOrphan
do_one ([DFunId]
_ltvs, [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 -> [DFunId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [DFunId]
rtvs)]
    choose_one :: [NameSet] -> IsOrphan
choose_one [NameSet]
nss = NameSet -> IsOrphan
chooseOrphanAnchor ([NameSet] -> NameSet
unionNameSets [NameSet]
nss)
mkImportedInstance :: Name           
                   -> [RoughMatchTc] 
                   -> Name           
                   -> DFunId         
                   -> OverlapFlag    
                   -> IsOrphan       
                   -> ClsInst
mkImportedInstance :: Name
-> [RoughMatchTc]
-> Name
-> DFunId
-> OverlapFlag
-> IsOrphan
-> ClsInst
mkImportedInstance Name
cls_nm [RoughMatchTc]
mb_tcs Name
dfun_name DFunId
dfun OverlapFlag
oflag IsOrphan
orphan
  = 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 :: [RoughMatchTc]
is_tcs = Name -> RoughMatchTc
RM_KnownTc Name
cls_nm RoughMatchTc -> [RoughMatchTc] -> [RoughMatchTc]
forall a. a -> [a] -> [a]
: [RoughMatchTc]
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)
newtype InstEnv = InstEnv (RoughMap ClsInst)      
  
instance Outputable InstEnv where
  ppr :: InstEnv -> SDoc
ppr (InstEnv RoughMap ClsInst
rm) = [ClsInst] -> SDoc
pprInstances ([ClsInst] -> SDoc) -> [ClsInst] -> SDoc
forall a b. (a -> b) -> a -> b
$ RoughMap ClsInst -> [ClsInst]
forall a. RoughMap a -> [a]
elemsRM RoughMap ClsInst
rm
data InstEnvs = InstEnvs {
        InstEnvs -> InstEnv
ie_global  :: InstEnv,               
        InstEnvs -> InstEnv
ie_local   :: InstEnv,               
        InstEnvs -> VisibleOrphanModules
ie_visible :: VisibleOrphanModules   
                                             
                                             
    }
type VisibleOrphanModules = ModuleSet
emptyInstEnv :: InstEnv
emptyInstEnv :: InstEnv
emptyInstEnv = RoughMap ClsInst -> InstEnv
InstEnv RoughMap ClsInst
forall a. RoughMap a
emptyRM
mkInstEnv :: [ClsInst] -> InstEnv
mkInstEnv :: [ClsInst] -> InstEnv
mkInstEnv = InstEnv -> [ClsInst] -> InstEnv
extendInstEnvList InstEnv
emptyInstEnv
instEnvElts :: InstEnv -> [ClsInst]
instEnvElts :: InstEnv -> [ClsInst]
instEnvElts (InstEnv RoughMap ClsInst
rm) = RoughMap ClsInst -> [ClsInst]
forall a. RoughMap a -> [a]
elemsRM RoughMap ClsInst
rm
  
instEnvEltsForClass :: InstEnv -> Name -> [ClsInst]
instEnvEltsForClass :: InstEnv -> Name -> [ClsInst]
instEnvEltsForClass (InstEnv RoughMap ClsInst
rm) Name
cls_nm = [RoughMatchLookupTc] -> RoughMap ClsInst -> [ClsInst]
forall a. [RoughMatchLookupTc] -> RoughMap a -> [a]
lookupRM [Name -> RoughMatchLookupTc
RML_KnownTc Name
cls_nm] RoughMap ClsInst
rm
instEnvClasses :: InstEnv -> UniqDSet Class
instEnvClasses :: InstEnv -> UniqDSet Class
instEnvClasses InstEnv
ie = [Class] -> UniqDSet Class
forall a. Uniquable a => [a] -> UniqDSet a
mkUniqDSet ([Class] -> UniqDSet Class) -> [Class] -> UniqDSet Class
forall a b. (a -> b) -> a -> b
$ (ClsInst -> Class) -> [ClsInst] -> [Class]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> Class
is_cls (InstEnv -> [ClsInst]
instEnvElts InstEnv
ie)
instIsVisible :: VisibleOrphanModules -> ClsInst -> Bool
instIsVisible :: VisibleOrphanModules -> ClsInst -> Bool
instIsVisible VisibleOrphanModules
vis_mods ClsInst
ispec
  
  
  
  = 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
envs Class
cls = InstEnvs -> Name -> [ClsInst]
classNameInstances InstEnvs
envs (Class -> Name
className Class
cls)
classNameInstances :: InstEnvs -> Name -> [ClsInst]
classNameInstances :: InstEnvs -> Name -> [ClsInst]
classNameInstances (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 }) Name
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 -> [ClsInst]
get InstEnv
ie = (ClsInst -> Bool) -> [ClsInst] -> [ClsInst]
forall a. (a -> Bool) -> [a] -> [a]
filter (VisibleOrphanModules -> ClsInst -> Bool
instIsVisible VisibleOrphanModules
vis_mods) (InstEnv -> Name -> [ClsInst]
instEnvEltsForClass InstEnv
ie Name
cls)
memberInstEnv :: InstEnv -> ClsInst -> Bool
memberInstEnv :: InstEnv -> ClsInst -> Bool
memberInstEnv (InstEnv RoughMap ClsInst
rm) ins_item :: ClsInst
ins_item@(ClsInst { is_tcs :: ClsInst -> [RoughMatchTc]
is_tcs = [RoughMatchTc]
tcs } ) =
    (ClsInst -> Bool) -> Bag ClsInst -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ClsInst -> ClsInst -> Bool
identicalDFunType ClsInst
ins_item) ((Bag ClsInst, [ClsInst]) -> Bag ClsInst
forall a b. (a, b) -> a
fst ((Bag ClsInst, [ClsInst]) -> Bag ClsInst)
-> (Bag ClsInst, [ClsInst]) -> Bag ClsInst
forall a b. (a -> b) -> a -> b
$ [RoughMatchLookupTc]
-> RoughMap ClsInst -> (Bag ClsInst, [ClsInst])
forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' ((RoughMatchTc -> RoughMatchLookupTc)
-> [RoughMatchTc] -> [RoughMatchLookupTc]
forall a b. (a -> b) -> [a] -> [b]
map RoughMatchTc -> RoughMatchLookupTc
roughMatchTcToLookup [RoughMatchTc]
tcs) RoughMap ClsInst
rm)
 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))
unionInstEnv :: InstEnv -> InstEnv -> InstEnv
unionInstEnv :: InstEnv -> InstEnv -> InstEnv
unionInstEnv (InstEnv RoughMap ClsInst
a) (InstEnv RoughMap ClsInst
b) = RoughMap ClsInst -> InstEnv
InstEnv (RoughMap ClsInst
a RoughMap ClsInst -> RoughMap ClsInst -> RoughMap ClsInst
forall a. RoughMap a -> RoughMap a -> RoughMap a
`unionRM` RoughMap ClsInst
b)
extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv
extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv
extendInstEnvList InstEnv
inst_env [ClsInst]
ispecs = (InstEnv -> ClsInst -> InstEnv) -> InstEnv -> [ClsInst] -> InstEnv
forall b a. (b -> a -> b) -> b -> [a] -> b
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 RoughMap ClsInst
rm) ins_item :: ClsInst
ins_item@(ClsInst { is_tcs :: ClsInst -> [RoughMatchTc]
is_tcs = [RoughMatchTc]
tcs })
  = RoughMap ClsInst -> InstEnv
InstEnv (RoughMap ClsInst -> InstEnv) -> RoughMap ClsInst -> InstEnv
forall a b. (a -> b) -> a -> b
$ [RoughMatchTc] -> ClsInst -> RoughMap ClsInst -> RoughMap ClsInst
forall a. [RoughMatchTc] -> a -> RoughMap a -> RoughMap a
insertRM [RoughMatchTc]
tcs ClsInst
ins_item RoughMap ClsInst
rm
filterInstEnv :: (ClsInst -> Bool) -> InstEnv -> InstEnv
filterInstEnv :: (ClsInst -> Bool) -> InstEnv -> InstEnv
filterInstEnv ClsInst -> Bool
pred (InstEnv RoughMap ClsInst
rm)
  = RoughMap ClsInst -> InstEnv
InstEnv (RoughMap ClsInst -> InstEnv) -> RoughMap ClsInst -> InstEnv
forall a b. (a -> b) -> a -> b
$ (ClsInst -> Bool) -> RoughMap ClsInst -> RoughMap ClsInst
forall a. (a -> Bool) -> RoughMap a -> RoughMap a
filterRM ClsInst -> Bool
pred RoughMap ClsInst
rm
anyInstEnv :: (ClsInst -> Bool) -> InstEnv -> Bool
anyInstEnv :: (ClsInst -> Bool) -> InstEnv -> Bool
anyInstEnv ClsInst -> Bool
pred (InstEnv RoughMap ClsInst
rm)
  = (ClsInst -> Bool -> Bool) -> Bool -> RoughMap ClsInst -> Bool
forall a b. (a -> b -> b) -> b -> RoughMap a -> b
foldRM (\ClsInst
x Bool
rest -> ClsInst -> Bool
pred ClsInst
x Bool -> Bool -> Bool
|| Bool
rest) Bool
False RoughMap ClsInst
rm
mapInstEnv :: (ClsInst -> ClsInst) -> InstEnv -> InstEnv
mapInstEnv :: (ClsInst -> ClsInst) -> InstEnv -> InstEnv
mapInstEnv ClsInst -> ClsInst
f (InstEnv RoughMap ClsInst
rm) = RoughMap ClsInst -> InstEnv
InstEnv (ClsInst -> ClsInst
f (ClsInst -> ClsInst) -> RoughMap ClsInst -> RoughMap ClsInst
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RoughMap ClsInst
rm)
deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv
deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv
deleteFromInstEnv (InstEnv RoughMap ClsInst
rm) ins_item :: ClsInst
ins_item@(ClsInst { is_tcs :: ClsInst -> [RoughMatchTc]
is_tcs = [RoughMatchTc]
tcs })
  = RoughMap ClsInst -> InstEnv
InstEnv (RoughMap ClsInst -> InstEnv) -> RoughMap ClsInst -> InstEnv
forall a b. (a -> b) -> a -> b
$ (ClsInst -> Bool)
-> [RoughMatchTc] -> RoughMap ClsInst -> RoughMap ClsInst
forall a. (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
filterMatchingRM (Bool -> Bool
not (Bool -> Bool) -> (ClsInst -> Bool) -> ClsInst -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClsInst -> ClsInst -> Bool
identicalClsInstHead ClsInst
ins_item) [RoughMatchTc]
tcs RoughMap ClsInst
rm
deleteDFunFromInstEnv :: InstEnv -> DFunId -> InstEnv
deleteDFunFromInstEnv :: InstEnv -> DFunId -> InstEnv
deleteDFunFromInstEnv (InstEnv RoughMap ClsInst
rm) DFunId
dfun
  = RoughMap ClsInst -> InstEnv
InstEnv (RoughMap ClsInst -> InstEnv) -> RoughMap ClsInst -> InstEnv
forall a b. (a -> b) -> a -> b
$ (ClsInst -> Bool)
-> [RoughMatchTc] -> RoughMap ClsInst -> RoughMap ClsInst
forall a. (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a
filterMatchingRM (Bool -> Bool
not (Bool -> Bool) -> (ClsInst -> Bool) -> ClsInst -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClsInst -> Bool
same_dfun) [Name -> RoughMatchTc
RM_KnownTc (Class -> Name
className Class
cls)] RoughMap ClsInst
rm
  where
    ([DFunId]
_, [Type]
_, Class
cls, [Type]
_) = Type -> ([DFunId], [Type], Class, [Type])
tcSplitDFunTy (DFunId -> Type
idType DFunId
dfun)
    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
identicalClsInstHead :: ClsInst -> ClsInst -> Bool
identicalClsInstHead (ClsInst { is_tcs :: ClsInst -> [RoughMatchTc]
is_tcs = [RoughMatchTc]
rough1, is_tys :: ClsInst -> [Type]
is_tys = [Type]
tys1 })
                     (ClsInst { is_tcs :: ClsInst -> [RoughMatchTc]
is_tcs = [RoughMatchTc]
rough2, is_tys :: ClsInst -> [Type]
is_tys = [Type]
tys2 })
  =  Bool -> Bool
not ([RoughMatchTc] -> [RoughMatchTc] -> Bool
instanceCantMatch [RoughMatchTc]
rough1 [RoughMatchTc]
rough2)  
                                            
  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)
type DFunInstType = Maybe Type
        
        
        
type InstMatch = (ClsInst, [DFunInstType])
type ClsInstLookupResult
     = ( [InstMatch]     
       , PotentialUnifiers  
       , [InstMatch] )   
                         
                         
lookupUniqueInstEnv :: InstEnvs
                    -> Class -> [Type]
                    -> Either SDoc (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)], PotentialUnifiers
_, [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)
data PotentialUnifiers = NoUnifiers
                       | OneOrMoreUnifiers [ClsInst]
                       
                       
                       
                       
instance Outputable PotentialUnifiers where
  ppr :: PotentialUnifiers -> SDoc
ppr PotentialUnifiers
NoUnifiers = String -> SDoc
text String
"NoUnifiers"
  ppr PotentialUnifiers
xs = [ClsInst] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (PotentialUnifiers -> [ClsInst]
getPotentialUnifiers PotentialUnifiers
xs)
instance Semigroup PotentialUnifiers where
  PotentialUnifiers
NoUnifiers <> :: PotentialUnifiers -> PotentialUnifiers -> PotentialUnifiers
<> PotentialUnifiers
u = PotentialUnifiers
u
  PotentialUnifiers
u <> PotentialUnifiers
NoUnifiers = PotentialUnifiers
u
  PotentialUnifiers
u1 <> PotentialUnifiers
u2 = [ClsInst] -> PotentialUnifiers
OneOrMoreUnifiers (PotentialUnifiers -> [ClsInst]
getPotentialUnifiers PotentialUnifiers
u1 [ClsInst] -> [ClsInst] -> [ClsInst]
forall a. [a] -> [a] -> [a]
++ PotentialUnifiers -> [ClsInst]
getPotentialUnifiers PotentialUnifiers
u2)
instance Monoid PotentialUnifiers where
  mempty :: PotentialUnifiers
mempty = PotentialUnifiers
NoUnifiers
getPotentialUnifiers :: PotentialUnifiers -> [ClsInst]
getPotentialUnifiers :: PotentialUnifiers -> [ClsInst]
getPotentialUnifiers PotentialUnifiers
NoUnifiers = []
getPotentialUnifiers (OneOrMoreUnifiers [ClsInst]
cls) = [ClsInst]
cls
nullUnifiers :: PotentialUnifiers -> Bool
nullUnifiers :: PotentialUnifiers -> Bool
nullUnifiers PotentialUnifiers
NoUnifiers = Bool
True
nullUnifiers PotentialUnifiers
_ = Bool
False
lookupInstEnv' :: InstEnv          
               -> VisibleOrphanModules   
               -> Class -> [Type]  
               -> ([InstMatch],    
                   PotentialUnifiers)      
                                   
lookupInstEnv' :: InstEnv
-> VisibleOrphanModules
-> Class
-> [Type]
-> ([InstMatch], PotentialUnifiers)
lookupInstEnv' (InstEnv RoughMap ClsInst
rm) VisibleOrphanModules
vis_mods Class
cls [Type]
tys
  = ((ClsInst -> [InstMatch] -> [InstMatch])
-> [InstMatch] -> Bag ClsInst -> [InstMatch]
forall a b. (a -> b -> b) -> b -> Bag a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ClsInst -> [InstMatch] -> [InstMatch]
check_match [] Bag ClsInst
rough_matches, [ClsInst] -> PotentialUnifiers
check_unifier [ClsInst]
rough_unifiers)
  where
    (Bag ClsInst
rough_matches, [ClsInst]
rough_unifiers) = [RoughMatchLookupTc]
-> RoughMap ClsInst -> (Bag ClsInst, [ClsInst])
forall a. [RoughMatchLookupTc] -> RoughMap a -> (Bag a, [a])
lookupRM' [RoughMatchLookupTc]
rough_tcs RoughMap ClsInst
rm
    rough_tcs :: [RoughMatchLookupTc]
rough_tcs  = Name -> RoughMatchLookupTc
RML_KnownTc (Class -> Name
className Class
cls) RoughMatchLookupTc -> [RoughMatchLookupTc] -> [RoughMatchLookupTc]
forall a. a -> [a] -> [a]
: [Type] -> [RoughMatchLookupTc]
roughMatchTcsLookup [Type]
tys
    
    check_match :: ClsInst -> [InstMatch] -> [InstMatch]
    check_match :: ClsInst -> [InstMatch] -> [InstMatch]
check_match item :: ClsInst
item@(ClsInst { is_tvs :: ClsInst -> [DFunId]
is_tvs = [DFunId]
tpl_tvs, is_tys :: ClsInst -> [Type]
is_tys = [Type]
tpl_tys }) [InstMatch]
acc
      | Bool -> Bool
not (VisibleOrphanModules -> ClsInst -> Bool
instIsVisible VisibleOrphanModules
vis_mods ClsInst
item)
      = [InstMatch]
acc  
      | Just TCvSubst
subst <- [Type] -> [Type] -> Maybe TCvSubst
tcMatchTys [Type]
tpl_tys [Type]
tys
      = ((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]
acc)
      | Bool
otherwise
      = [InstMatch]
acc
    check_unifier :: [ClsInst] -> PotentialUnifiers
    check_unifier :: [ClsInst] -> PotentialUnifiers
check_unifier [] = PotentialUnifiers
NoUnifiers
    check_unifier (item :: ClsInst
item@ClsInst { is_tvs :: ClsInst -> [DFunId]
is_tvs = [DFunId]
tpl_tvs, is_tys :: ClsInst -> [Type]
is_tys = [Type]
tpl_tys }:[ClsInst]
items)
      | Bool -> Bool
not (VisibleOrphanModules -> ClsInst -> Bool
instIsVisible VisibleOrphanModules
vis_mods ClsInst
item)
      = [ClsInst] -> PotentialUnifiers
check_unifier [ClsInst]
items  
      | Just {} <- [Type] -> [Type] -> Maybe TCvSubst
tcMatchTys [Type]
tpl_tys [Type]
tys = [ClsInst] -> PotentialUnifiers
check_unifier [ClsInst]
items
        
        
        
      | ClsInst -> Bool
isIncoherent ClsInst
item
      = [ClsInst] -> PotentialUnifiers
check_unifier [ClsInst]
items
      | Bool
otherwise
      = Bool -> SDoc -> PotentialUnifiers -> PotentialUnifiers
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (TyCoVarSet
tys_tv_set TyCoVarSet -> TyCoVarSet -> Bool
`disjointVarSet` TyCoVarSet
tpl_tv_set)
                  ((Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
tys) SDoc -> SDoc -> SDoc
$$
                   ([DFunId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [DFunId]
tpl_tvs SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
tpl_tys)) (PotentialUnifiers -> PotentialUnifiers)
-> PotentialUnifiers -> PotentialUnifiers
forall a b. (a -> b) -> a -> b
$
                
                
                
        case BindFun -> [Type] -> [Type] -> UnifyResult
tcUnifyTysFG BindFun
instanceBindFun [Type]
tpl_tys [Type]
tys of
          
          
          
            UnifyResult
SurelyApart              -> [ClsInst] -> PotentialUnifiers
check_unifier [ClsInst]
items
              
            MaybeApart MaybeApartReason
MARInfinite TCvSubst
_ -> [ClsInst] -> PotentialUnifiers
check_unifier [ClsInst]
items
            UnifyResult
_                        ->
              [ClsInst] -> PotentialUnifiers
OneOrMoreUnifiers (ClsInst
itemClsInst -> [ClsInst] -> [ClsInst]
forall a. a -> [a] -> [a]
: PotentialUnifiers -> [ClsInst]
getPotentialUnifiers ([ClsInst] -> PotentialUnifiers
check_unifier [ClsInst]
items))
      where
        tpl_tv_set :: TyCoVarSet
tpl_tv_set = [DFunId] -> TyCoVarSet
mkVarSet [DFunId]
tpl_tvs
        tys_tv_set :: TyCoVarSet
tys_tv_set = [Type] -> TyCoVarSet
tyCoVarsOfTypes [Type]
tys
lookupInstEnv :: Bool              
              -> InstEnvs          
              -> Class -> [Type]   
              -> ClsInstLookupResult
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
  = ([InstMatch]
final_matches, PotentialUnifiers
final_unifs, [InstMatch]
unsafe_overlapped)
  where
    ([InstMatch]
home_matches, PotentialUnifiers
home_unifs) = InstEnv
-> VisibleOrphanModules
-> Class
-> [Type]
-> ([InstMatch], PotentialUnifiers)
lookupInstEnv' InstEnv
home_ie VisibleOrphanModules
vis_mods Class
cls [Type]
tys
    ([InstMatch]
pkg_matches,  PotentialUnifiers
pkg_unifs)  = InstEnv
-> VisibleOrphanModules
-> Class
-> [Type]
-> ([InstMatch], PotentialUnifiers)
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 :: PotentialUnifiers
all_unifs   = PotentialUnifiers
home_unifs   PotentialUnifiers -> PotentialUnifiers -> PotentialUnifiers
forall a. Monoid a => a -> a -> a
`mappend` PotentialUnifiers
pkg_unifs
    final_matches :: [InstMatch]
final_matches = [InstMatch] -> [InstMatch]
pruneOverlappedMatches [InstMatch]
all_matches
        
        
        
        
    unsafe_overlapped :: [InstMatch]
unsafe_overlapped
       = case [InstMatch]
final_matches of
           [InstMatch
match] -> InstMatch -> [InstMatch]
check_safe InstMatch
match
           [InstMatch]
_       -> []
    
    final_unifs :: PotentialUnifiers
final_unifs = case [InstMatch]
final_matches of
                    (InstMatch
m:[InstMatch]
_) | ClsInst -> Bool
isIncoherent (InstMatch -> ClsInst
forall a b. (a, b) -> a
fst InstMatch
m) -> PotentialUnifiers
NoUnifiers
                    [InstMatch]
_                            -> PotentialUnifiers
all_unifs
    
    
    
    
    
    
    
    
    
    
    check_safe :: InstMatch -> [InstMatch]
check_safe (ClsInst
inst,[DFunInstType]
_)
        = case Bool
check_overlap_safe Bool -> Bool -> Bool
&& ClsInst -> Bool
unsafeTopInstance ClsInst
inst of
                
                Bool
True -> [InstMatch] -> [InstMatch] -> [InstMatch]
go [] [InstMatch]
all_matches
                
                Bool
False -> []
        where
            go :: [InstMatch] -> [InstMatch] -> [InstMatch]
go [InstMatch]
bad [] = [InstMatch]
bad
            go [InstMatch]
bad (i :: InstMatch
i@(ClsInst
x,[DFunInstType]
_):[InstMatch]
unchecked) =
                if ClsInst -> Bool
inSameMod ClsInst
x Bool -> Bool -> Bool
|| ClsInst -> Bool
isOverlappable ClsInst
x
                    then [InstMatch] -> [InstMatch] -> [InstMatch]
go [InstMatch]
bad [InstMatch]
unchecked
                    else [InstMatch] -> [InstMatch] -> [InstMatch]
go (InstMatch
iInstMatch -> [InstMatch] -> [InstMatch]
forall a. a -> [a] -> [a]
:[InstMatch]
bad) [InstMatch]
unchecked
            inSameMod :: ClsInst -> Bool
inSameMod ClsInst
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
$ ClsInst -> Name
forall a. NamedThing a => a -> Name
getName ClsInst
b
                    lb :: Bool
lb = Name -> Bool
isInternalName Name
nb
                in (Bool
la Bool -> Bool -> Bool
&& Bool
lb) Bool -> Bool -> Bool
|| ((() :: Constraint) => Name -> Module
Name -> Module
nameModule Name
na Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== (() :: Constraint) => Name -> Module
Name -> Module
nameModule Name
nb)
    
    
    
    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)
data InstMatches
  = InstMatches
  { 
    
    InstMatches -> [InstMatch]
instMatches :: [InstMatch]
    
    
    
  , InstMatches -> [ClsInst]
instGuards  :: [ClsInst]
  }
instance Outputable InstMatches where
  ppr :: InstMatches -> SDoc
ppr (InstMatches { instMatches :: InstMatches -> [InstMatch]
instMatches = [InstMatch]
matches, instGuards :: InstMatches -> [ClsInst]
instGuards = [ClsInst]
guards })
    = String -> SDoc
text String
"InstMatches" SDoc -> SDoc -> SDoc
<+>
      SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"instMatches:" SDoc -> SDoc -> SDoc
<+> [InstMatch] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InstMatch]
matches
                   , String -> SDoc
text String
"instGuards:" SDoc -> SDoc -> SDoc
<+> [ClsInst] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ClsInst]
guards ])
noMatches :: InstMatches
noMatches :: InstMatches
noMatches = InstMatches { instMatches :: [InstMatch]
instMatches = [], instGuards :: [ClsInst]
instGuards = [] }
pruneOverlappedMatches :: [InstMatch] -> [InstMatch]
pruneOverlappedMatches :: [InstMatch] -> [InstMatch]
pruneOverlappedMatches [InstMatch]
all_matches =
  InstMatches -> [InstMatch]
instMatches (InstMatches -> [InstMatch]) -> InstMatches -> [InstMatch]
forall a b. (a -> b) -> a -> b
$ (InstMatch -> InstMatches -> InstMatches)
-> InstMatches -> [InstMatch] -> InstMatches
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr InstMatch -> InstMatches -> InstMatches
insert_overlapping InstMatches
noMatches [InstMatch]
all_matches
overrides :: ClsInst -> ClsInst -> Bool
ClsInst
new_inst overrides :: ClsInst -> ClsInst -> Bool
`overrides` ClsInst
old_inst
  =  (ClsInst
new_inst ClsInst -> ClsInst -> Bool
`more_specific_than` ClsInst
old_inst)
  Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ClsInst
old_inst ClsInst -> ClsInst -> Bool
`more_specific_than` ClsInst
new_inst)
  Bool -> Bool -> Bool
&& (ClsInst -> Bool
isOverlapping ClsInst
new_inst Bool -> Bool -> Bool
|| ClsInst -> Bool
isOverlappable ClsInst
old_inst)
       
       
       
       
       
  where
    
    
    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))
insert_overlapping :: InstMatch -> InstMatches -> InstMatches
insert_overlapping :: InstMatch -> InstMatches -> InstMatches
insert_overlapping
  new_item :: InstMatch
new_item@(ClsInst
new_inst,[DFunInstType]
_)
  old :: InstMatches
old@(InstMatches { instMatches :: InstMatches -> [InstMatch]
instMatches = [InstMatch]
old_items, instGuards :: InstMatches -> [ClsInst]
instGuards = [ClsInst]
guards })
  
  
  | (ClsInst -> Bool) -> [ClsInst] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ClsInst -> ClsInst -> Bool
`overrides` ClsInst
new_inst) [ClsInst]
guards
  = InstMatches
old
  | Bool
otherwise
  = [InstMatch] -> InstMatches
insert_overlapping_new_item [InstMatch]
old_items
  where
    insert_overlapping_new_item :: [InstMatch] -> InstMatches
    insert_overlapping_new_item :: [InstMatch] -> InstMatches
insert_overlapping_new_item []
      = InstMatches { instMatches :: [InstMatch]
instMatches = [InstMatch
new_item], instGuards :: [ClsInst]
instGuards = [ClsInst]
guards }
    insert_overlapping_new_item all_old_items :: [InstMatch]
all_old_items@(old_item :: InstMatch
old_item@(ClsInst
old_inst,[DFunInstType]
_) : [InstMatch]
old_items)
      
      
      
      | ClsInst
new_inst ClsInst -> ClsInst -> Bool
`overrides` ClsInst
old_inst
      , InstMatches { instMatches :: InstMatches -> [InstMatch]
instMatches = [InstMatch]
final_matches
                    , instGuards :: InstMatches -> [ClsInst]
instGuards  = [ClsInst]
prev_guards }
                    <- [InstMatch] -> InstMatches
insert_overlapping_new_item [InstMatch]
old_items
      = if ClsInst -> Bool
isOverlapping ClsInst
new_inst Bool -> Bool -> Bool
|| Bool -> Bool
not (ClsInst -> Bool
isOverlapping ClsInst
old_inst)
        
        
        
        
        then InstMatches { instMatches :: [InstMatch]
instMatches = [InstMatch]
final_matches
                         , instGuards :: [ClsInst]
instGuards  = [ClsInst]
prev_guards }
        else InstMatches { instMatches :: [InstMatch]
instMatches = [InstMatch]
final_matches
                         , instGuards :: [ClsInst]
instGuards  = ClsInst
old_inst ClsInst -> [ClsInst] -> [ClsInst]
forall a. a -> [a] -> [a]
: [ClsInst]
prev_guards }
        
        
      
      
      
      | ClsInst
old_inst ClsInst -> ClsInst -> Bool
`overrides` ClsInst
new_inst
      = if ClsInst -> Bool
isOverlapping ClsInst
old_inst Bool -> Bool -> Bool
|| Bool -> Bool
not (ClsInst -> Bool
isOverlapping ClsInst
new_inst)
        
        
        
        
        then InstMatches { instMatches :: [InstMatch]
instMatches = [InstMatch]
all_old_items
                         , instGuards :: [ClsInst]
instGuards  = [ClsInst]
guards }
        else InstMatches
                  
                  
                  
                { instMatches :: [InstMatch]
instMatches =
                    (InstMatch -> Bool) -> [InstMatch] -> [InstMatch]
forall a. (a -> Bool) -> [a] -> [a]
filter
                      (\(ClsInst
old_inst,[DFunInstType]
_) -> Bool -> Bool
not (ClsInst
new_inst ClsInst -> ClsInst -> Bool
`overrides` ClsInst
old_inst))
                      [InstMatch]
all_old_items
                
                , instGuards :: [ClsInst]
instGuards = ClsInst
new_inst ClsInst -> [ClsInst] -> [ClsInst]
forall a. a -> [a] -> [a]
: [ClsInst]
guards }
      
      | ClsInst -> Bool
isIncoherent ClsInst
old_inst 
      = [InstMatch] -> InstMatches
insert_overlapping_new_item [InstMatch]
old_items
      | ClsInst -> Bool
isIncoherent ClsInst
new_inst 
      = InstMatches { instMatches :: [InstMatch]
instMatches = [InstMatch]
all_old_items
                    , instGuards :: [ClsInst]
instGuards  = [ClsInst]
guards }
      
      | Bool
otherwise
      , InstMatches { instMatches :: InstMatches -> [InstMatch]
instMatches = [InstMatch]
final_matches
                    , instGuards :: InstMatches -> [ClsInst]
instGuards  = [ClsInst]
final_guards }
                    <- [InstMatch] -> InstMatches
insert_overlapping_new_item [InstMatch]
old_items
      = InstMatches { instMatches :: [InstMatch]
instMatches = InstMatch
old_item InstMatch -> [InstMatch] -> [InstMatch]
forall a. a -> [a] -> [a]
: [InstMatch]
final_matches
                    , instGuards :: [ClsInst]
instGuards  = [ClsInst]
final_guards }
instanceBindFun :: BindFun
instanceBindFun :: BindFun
instanceBindFun DFunId
tv Type
_rhs_ty | DFunId -> Bool
isOverlappableTyVar DFunId
tv = BindFlag
Apart
                           | Bool
otherwise              = BindFlag
BindMe