{-# LANGUAGE CPP, DeriveDataTypeable #-}
module 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 GhcPrelude
import TcType
import CoreSyn ( IsOrphan(..), isOrphan, chooseOrphanAnchor )
import Module
import Class
import Var
import VarSet
import Name
import NameSet
import Unify
import Outputable
import ErrUtils
import BasicTypes
import UniqDFM
import Util
import Id
import Data.Data ( Data )
import Data.Maybe ( isJust, isNothing )
data ClsInst
= ClsInst {
ClsInst -> Name
is_cls_nm :: Name
, ClsInst -> [Maybe Name]
is_tcs :: [Maybe Name]
, ClsInst -> Name
is_dfun_name :: Name
, ClsInst -> [TyVar]
is_tvs :: [TyVar]
, ClsInst -> Class
is_cls :: Class
, ClsInst -> [Type]
is_tys :: [Type]
, ClsInst -> TyVar
is_dfun :: DFunId
, ClsInst -> OverlapFlag
is_flag :: OverlapFlag
, ClsInst -> IsOrphan
is_orphan :: IsOrphan
}
deriving Typeable ClsInst
DataType
Constr
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 d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ClsInst -> c ClsInst
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cClsInst :: Constr
$tClsInst :: DataType
gmapMo :: (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 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 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 :: Int -> (forall d. Data d => d -> u) -> ClsInst -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> ClsInst -> u
gmapQ :: (forall d. Data d => d -> u) -> ClsInst -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> ClsInst -> [u]
gmapQr :: (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 :: (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 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 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 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 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
$cp1Data :: Typeable ClsInst
Data
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))
instanceDFunId :: ClsInst -> DFunId
instanceDFunId :: ClsInst -> TyVar
instanceDFunId = ClsInst -> TyVar
is_dfun
updateClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst
updateClsInstDFun :: (TyVar -> TyVar) -> ClsInst -> ClsInst
updateClsInstDFun TyVar -> TyVar
tidy_dfun ClsInst
ispec
= ClsInst
ispec { is_dfun :: TyVar
is_dfun = TyVar -> TyVar
tidy_dfun (ClsInst -> TyVar
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 = TyVar -> Name
forall a. NamedThing a => a -> Name
getName (ClsInst -> TyVar
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 (TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ClsInst -> TyVar
is_dfun ClsInst
ispec)) ])
pprInstanceHdr :: ClsInst -> SDoc
pprInstanceHdr :: ClsInst -> SDoc
pprInstanceHdr (ClsInst { is_flag :: ClsInst -> OverlapFlag
is_flag = OverlapFlag
flag, is_dfun :: ClsInst -> TyVar
is_dfun = TyVar
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 (TyVar -> Type
idType TyVar
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 -> ([TyVar], Class, [Type])
instanceHead (ClsInst { is_tvs :: ClsInst -> [TyVar]
is_tvs = [TyVar]
tvs, is_tys :: ClsInst -> [Type]
is_tys = [Type]
tys, is_dfun :: ClsInst -> TyVar
is_dfun = TyVar
dfun })
= ([TyVar]
tvs, Class
cls, [Type]
tys)
where
([TyVar]
_, [Type]
_, Class
cls, [Type]
_) = Type -> ([TyVar], [Type], Class, [Type])
tcSplitDFunTy (TyVar -> Type
idType TyVar
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 -> ([TyVar], [Type], Class, [Type])
instanceSig ClsInst
ispec = Type -> ([TyVar], [Type], Class, [Type])
tcSplitDFunTy (TyVar -> Type
idType (ClsInst -> TyVar
is_dfun ClsInst
ispec))
mkLocalInstance :: DFunId -> OverlapFlag
-> [TyVar] -> Class -> [Type]
-> ClsInst
mkLocalInstance :: TyVar -> OverlapFlag -> [TyVar] -> Class -> [Type] -> ClsInst
mkLocalInstance TyVar
dfun OverlapFlag
oflag [TyVar]
tvs Class
cls [Type]
tys
= ClsInst :: Name
-> [Maybe Name]
-> Name
-> [TyVar]
-> Class
-> [Type]
-> TyVar
-> OverlapFlag
-> IsOrphan
-> ClsInst
ClsInst { is_flag :: OverlapFlag
is_flag = OverlapFlag
oflag, is_dfun :: TyVar
is_dfun = TyVar
dfun
, is_tvs :: [TyVar]
is_tvs = [TyVar]
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 = TyVar -> Name
idName TyVar
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
([TyVar]
cls_tvs, [FunDep TyVar]
fds) = Class -> ([TyVar], [FunDep TyVar])
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 = 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]
mb_ns :: [IsOrphan]
mb_ns | [FunDep TyVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FunDep TyVar]
fds = [[NameSet] -> IsOrphan
choose_one [NameSet]
arg_names]
| Bool
otherwise = (FunDep TyVar -> IsOrphan) -> [FunDep TyVar] -> [IsOrphan]
forall a b. (a -> b) -> [a] -> [b]
map FunDep TyVar -> IsOrphan
forall (t :: * -> *) a. Foldable t => (a, t TyVar) -> IsOrphan
do_one [FunDep TyVar]
fds
do_one :: (a, t TyVar) -> IsOrphan
do_one (a
_ltvs, t TyVar
rtvs) = [NameSet] -> IsOrphan
choose_one [NameSet
ns | (TyVar
tv,NameSet
ns) <- [TyVar]
cls_tvs [TyVar] -> [NameSet] -> [(TyVar, NameSet)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [NameSet]
arg_names
, Bool -> Bool
not (TyVar
tv TyVar -> t TyVar -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t TyVar
rtvs)]
choose_one :: [NameSet] -> IsOrphan
choose_one [NameSet]
nss = NameSet -> IsOrphan
chooseOrphanAnchor ([NameSet] -> NameSet
unionNameSets [NameSet]
nss)
mkImportedInstance :: Name
-> [Maybe Name]
-> Name
-> DFunId
-> OverlapFlag
-> IsOrphan
-> ClsInst
mkImportedInstance :: Name
-> [Maybe Name]
-> Name
-> TyVar
-> OverlapFlag
-> IsOrphan
-> ClsInst
mkImportedInstance Name
cls_nm [Maybe Name]
mb_tcs Name
dfun_name TyVar
dfun OverlapFlag
oflag IsOrphan
orphan
= ClsInst :: Name
-> [Maybe Name]
-> Name
-> [TyVar]
-> Class
-> [Type]
-> TyVar
-> OverlapFlag
-> IsOrphan
-> ClsInst
ClsInst { is_flag :: OverlapFlag
is_flag = OverlapFlag
oflag, is_dfun :: TyVar
is_dfun = TyVar
dfun
, is_tvs :: [TyVar]
is_tvs = [TyVar]
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
([TyVar]
tvs, [Type]
_, Class
cls, [Type]
tys) = Type -> ([TyVar], [Type], Class, [Type])
tcSplitDFunTy (TyVar -> Type
idType TyVar
dfun)
type InstEnv = UniqDFM ClsInstEnv
data InstEnvs = InstEnvs {
InstEnvs -> InstEnv
ie_global :: InstEnv,
InstEnvs -> InstEnv
ie_local :: InstEnv,
InstEnvs -> VisibleOrphanModules
ie_visible :: VisibleOrphanModules
}
type VisibleOrphanModules = ModuleSet
newtype ClsInstEnv
= ClsIE [ClsInst]
instance Outputable ClsInstEnv where
ppr :: ClsInstEnv -> SDoc
ppr (ClsIE [ClsInst]
is) = [ClsInst] -> SDoc
pprInstances [ClsInst]
is
emptyInstEnv :: InstEnv
emptyInstEnv :: InstEnv
emptyInstEnv = InstEnv
forall elt. UniqDFM elt
emptyUDFM
instEnvElts :: InstEnv -> [ClsInst]
instEnvElts :: InstEnv -> [ClsInst]
instEnvElts InstEnv
ie = [ClsInst
elt | ClsIE [ClsInst]
elts <- InstEnv -> [ClsInstEnv]
forall elt. UniqDFM elt -> [elt]
eltsUDFM InstEnv
ie, ClsInst
elt <- [ClsInst]
elts]
instEnvClasses :: InstEnv -> [Class]
instEnvClasses :: InstEnv -> [Class]
instEnvClasses InstEnv
ie = [ClsInst -> Class
is_cls ClsInst
e | ClsIE (ClsInst
e : [ClsInst]
_) <- InstEnv -> [ClsInstEnv]
forall elt. UniqDFM elt -> [elt]
eltsUDFM 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 { 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 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 -> []
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 -> Name -> Maybe ClsInstEnv
forall key elt. Uniquable key => UniqDFM elt -> key -> Maybe elt
lookupUDFM InstEnv
inst_env Name
cls_nm)
where
identicalDFunType :: ClsInst -> ClsInst -> Bool
identicalDFunType ClsInst
cls1 ClsInst
cls2 =
Type -> Type -> Bool
eqType (TyVar -> Type
varType (ClsInst -> TyVar
is_dfun ClsInst
cls1)) (TyVar -> Type
varType (ClsInst -> TyVar
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 -> Name -> ClsInstEnv -> InstEnv
forall key elt.
Uniquable key =>
(elt -> elt -> elt) -> UniqDFM elt -> key -> elt -> UniqDFM elt
addToUDFM_C ClsInstEnv -> ClsInstEnv -> ClsInstEnv
forall p. ClsInstEnv -> p -> ClsInstEnv
add InstEnv
inst_env 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 -> Name -> InstEnv
forall key elt.
Uniquable key =>
(elt -> elt) -> UniqDFM elt -> key -> UniqDFM elt
adjustUDFM ClsInstEnv -> ClsInstEnv
adjust InstEnv
inst_env 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
deleteDFunFromInstEnv :: InstEnv -> TyVar -> InstEnv
deleteDFunFromInstEnv InstEnv
inst_env TyVar
dfun
= (ClsInstEnv -> ClsInstEnv) -> InstEnv -> Class -> InstEnv
forall key elt.
Uniquable key =>
(elt -> elt) -> UniqDFM elt -> key -> UniqDFM elt
adjustUDFM ClsInstEnv -> ClsInstEnv
adjust InstEnv
inst_env Class
cls
where
([TyVar]
_, [Type]
_, Class
cls, [Type]
_) = Type -> ([TyVar], [Type], Class, [Type])
tcSplitDFunTy (TyVar -> Type
idType TyVar
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 -> TyVar
is_dfun = TyVar
dfun' }) = TyVar
dfun TyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TyVar
dfun'
identicalClsInstHead :: ClsInst -> ClsInst -> Bool
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)
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]
, [ClsInst]
, [InstMatch] )
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
-> VisibleOrphanModules
-> Class -> [Type]
-> ([InstMatch],
[ClsInst])
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 elt -> key -> Maybe elt
lookupUDFM InstEnv
env Class
cls of
Maybe ClsInstEnv
Nothing -> ([],[])
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 -> [TyVar]
is_tvs = [TyVar]
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
| [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, (TyVar -> DFunInstType) -> [TyVar] -> [DFunInstType]
forall a b. (a -> b) -> [a] -> [b]
map (TCvSubst -> TyVar -> DFunInstType
lookupTyVar TCvSubst
subst) [TyVar]
tpl_tvs) InstMatch -> [InstMatch] -> [InstMatch]
forall a. a -> [a] -> [a]
: [InstMatch]
ms) [ClsInst]
us [ClsInst]
rest
| 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)
)
case (TyVar -> BindFlag) -> [Type] -> [Type] -> Maybe TCvSubst
tcUnifyTys TyVar -> 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 = [TyVar] -> TyCoVarSet
mkVarSet [TyVar]
tpl_tvs
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, [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
unsafe_overlapped :: [InstMatch]
unsafe_overlapped
= case [InstMatch]
final_matches of
[InstMatch
match] -> InstMatch -> [InstMatch]
forall b. (ClsInst, b) -> [InstMatch]
check_safe InstMatch
match
[InstMatch]
_ -> []
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
check_safe :: (ClsInst, b) -> [InstMatch]
check_safe (ClsInst
inst,b
_)
= case Bool
check_overlap_safe Bool -> Bool -> Bool
&& ClsInst -> Bool
unsafeTopInstance ClsInst
inst of
Bool
True -> [InstMatch] -> [InstMatch] -> [InstMatch]
forall b. [(ClsInst, b)] -> [(ClsInst, b)] -> [(ClsInst, b)]
go [] [InstMatch]
all_matches
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 a. NamedThing a => a -> 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 :: a -> Bool
inSameMod a
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
$ a -> Name
forall a. NamedThing a => a -> Name
getName a
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)
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]
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
, 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
, 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
| ClsInst -> Bool
isIncoherent ClsInst
old_inst
= InstMatch -> [InstMatch] -> [InstMatch]
insert_overlapping InstMatch
new_item [InstMatch]
old_items
| ClsInst -> Bool
isIncoherent ClsInst
new_inst
= InstMatch
old_item InstMatch -> [InstMatch] -> [InstMatch]
forall a. a -> [a] -> [a]
: [InstMatch]
old_items
| 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
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
instanceBindFun :: TyCoVar -> BindFlag
instanceBindFun :: TyVar -> BindFlag
instanceBindFun TyVar
tv | TyVar -> Bool
isOverlappableTyVar TyVar
tv = BindFlag
Skolem
| Bool
otherwise = BindFlag
BindMe