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