{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Constraint.Deriving.DeriveAll
( DeriveAll (..), DeriveContext
, deriveAllPass
, CorePluginEnvRef, initCorePluginEnv
) where
import Control.Applicative (Alternative (..))
import Control.Arrow (second)
import Control.Monad (join, unless)
import Data.Data (Data)
import Data.Either (partitionEithers)
import qualified Data.Kind (Constraint, Type)
import Data.List (groupBy, isPrefixOf, nubBy, sortOn)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Monoid (First (..))
import Data.Constraint.Deriving.CorePluginM
import Data.Constraint.Deriving.Import
import Data.Constraint.Deriving.OverlapMode
data DeriveAll
= DeriveAll
| DeriveAllBut { DeriveAll -> [String]
_ignoreList :: [String] }
| DeriveAll' { DeriveAll -> OverlapMode
_forcedMode :: OverlapMode, _ignoreList :: [String] }
deriving (DeriveAll -> DeriveAll -> Bool
(DeriveAll -> DeriveAll -> Bool)
-> (DeriveAll -> DeriveAll -> Bool) -> Eq DeriveAll
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DeriveAll -> DeriveAll -> Bool
$c/= :: DeriveAll -> DeriveAll -> Bool
== :: DeriveAll -> DeriveAll -> Bool
$c== :: DeriveAll -> DeriveAll -> Bool
Eq, Int -> DeriveAll -> ShowS
[DeriveAll] -> ShowS
DeriveAll -> String
(Int -> DeriveAll -> ShowS)
-> (DeriveAll -> String)
-> ([DeriveAll] -> ShowS)
-> Show DeriveAll
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DeriveAll] -> ShowS
$cshowList :: [DeriveAll] -> ShowS
show :: DeriveAll -> String
$cshow :: DeriveAll -> String
showsPrec :: Int -> DeriveAll -> ShowS
$cshowsPrec :: Int -> DeriveAll -> ShowS
Show, ReadPrec [DeriveAll]
ReadPrec DeriveAll
Int -> ReadS DeriveAll
ReadS [DeriveAll]
(Int -> ReadS DeriveAll)
-> ReadS [DeriveAll]
-> ReadPrec DeriveAll
-> ReadPrec [DeriveAll]
-> Read DeriveAll
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [DeriveAll]
$creadListPrec :: ReadPrec [DeriveAll]
readPrec :: ReadPrec DeriveAll
$creadPrec :: ReadPrec DeriveAll
readList :: ReadS [DeriveAll]
$creadList :: ReadS [DeriveAll]
readsPrec :: Int -> ReadS DeriveAll
$creadsPrec :: Int -> ReadS DeriveAll
Read, Typeable DeriveAll
DataType
Constr
Typeable DeriveAll
-> (forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DeriveAll -> c DeriveAll)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DeriveAll)
-> (DeriveAll -> Constr)
-> (DeriveAll -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DeriveAll))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DeriveAll))
-> ((forall b. Data b => b -> b) -> DeriveAll -> DeriveAll)
-> (forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DeriveAll -> r)
-> (forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DeriveAll -> r)
-> (forall u. (forall d. Data d => d -> u) -> DeriveAll -> [u])
-> (forall u.
Int -> (forall d. Data d => d -> u) -> DeriveAll -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DeriveAll -> m DeriveAll)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DeriveAll -> m DeriveAll)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DeriveAll -> m DeriveAll)
-> Data DeriveAll
DeriveAll -> DataType
DeriveAll -> Constr
(forall b. Data b => b -> b) -> DeriveAll -> DeriveAll
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DeriveAll -> c DeriveAll
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DeriveAll
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) -> DeriveAll -> u
forall u. (forall d. Data d => d -> u) -> DeriveAll -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DeriveAll -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DeriveAll -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DeriveAll -> m DeriveAll
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DeriveAll -> m DeriveAll
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DeriveAll
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DeriveAll -> c DeriveAll
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DeriveAll)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DeriveAll)
$cDeriveAll' :: Constr
$cDeriveAllBut :: Constr
$cDeriveAll :: Constr
$tDeriveAll :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> DeriveAll -> m DeriveAll
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DeriveAll -> m DeriveAll
gmapMp :: (forall d. Data d => d -> m d) -> DeriveAll -> m DeriveAll
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DeriveAll -> m DeriveAll
gmapM :: (forall d. Data d => d -> m d) -> DeriveAll -> m DeriveAll
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DeriveAll -> m DeriveAll
gmapQi :: Int -> (forall d. Data d => d -> u) -> DeriveAll -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DeriveAll -> u
gmapQ :: (forall d. Data d => d -> u) -> DeriveAll -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DeriveAll -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DeriveAll -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DeriveAll -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DeriveAll -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DeriveAll -> r
gmapT :: (forall b. Data b => b -> b) -> DeriveAll -> DeriveAll
$cgmapT :: (forall b. Data b => b -> b) -> DeriveAll -> DeriveAll
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DeriveAll)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DeriveAll)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c DeriveAll)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DeriveAll)
dataTypeOf :: DeriveAll -> DataType
$cdataTypeOf :: DeriveAll -> DataType
toConstr :: DeriveAll -> Constr
$ctoConstr :: DeriveAll -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DeriveAll
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DeriveAll
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DeriveAll -> c DeriveAll
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DeriveAll -> c DeriveAll
$cp1Data :: Typeable DeriveAll
Data)
type family DeriveContext (t :: Data.Kind.Type) :: Data.Kind.Constraint
deriveAllPass :: CorePluginEnvRef -> CoreToDo
deriveAllPass :: CorePluginEnvRef -> CoreToDo
deriveAllPass CorePluginEnvRef
eref = String -> CorePluginPass -> CoreToDo
CoreDoPluginPass String
"Data.Constraint.Deriving.DeriveAll"
(\ModGuts
x -> ModGuts -> Maybe ModGuts -> ModGuts
forall a. a -> Maybe a -> a
fromMaybe ModGuts
x (Maybe ModGuts -> ModGuts)
-> CoreM (Maybe ModGuts) -> CoreM ModGuts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CorePluginM ModGuts -> CorePluginEnvRef -> CoreM (Maybe ModGuts)
forall a. CorePluginM a -> CorePluginEnvRef -> CoreM (Maybe a)
runCorePluginM (ModGuts -> CorePluginM ModGuts
deriveAllPass' ModGuts
x) CorePluginEnvRef
eref)
deriveAllPass' :: ModGuts -> CorePluginM ModGuts
deriveAllPass' :: ModGuts -> CorePluginM ModGuts
deriveAllPass' ModGuts
gs = [TyCon]
-> UniqMap [(Name, DeriveAll)] -> ModGuts -> CorePluginM ModGuts
go (ModGuts -> [TyCon]
mg_tcs ModGuts
gs) UniqMap [(Name, DeriveAll)]
annotateds ModGuts
gs
where
annotateds :: UniqMap [(Name, DeriveAll)]
annotateds :: UniqMap [(Name, DeriveAll)]
annotateds = ModGuts -> UniqMap [(Name, DeriveAll)]
forall a. Data a => ModGuts -> UniqMap [(Name, a)]
getModuleAnns ModGuts
gs
go :: [TyCon] -> UniqMap [(Name, DeriveAll)] -> ModGuts -> CorePluginM ModGuts
go :: [TyCon]
-> UniqMap [(Name, DeriveAll)] -> ModGuts -> CorePluginM ModGuts
go [] UniqMap [(Name, DeriveAll)]
anns ModGuts
guts = do
Bool -> CorePluginM () -> CorePluginM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (UniqMap [(Name, DeriveAll)] -> Bool
forall elt. UniqFM elt -> Bool
isNullUFM UniqMap [(Name, DeriveAll)]
anns) (CorePluginM () -> CorePluginM ())
-> CorePluginM () -> CorePluginM ()
forall a b. (a -> b) -> a -> b
$
SDoc -> CorePluginM ()
pluginWarning (SDoc -> CorePluginM ()) -> SDoc -> CorePluginM ()
forall a b. (a -> b) -> a -> b
$ SDoc
"One or more DeriveAll annotations are ignored:"
SDoc -> SDoc -> SDoc
$+$ [SDoc] -> SDoc
vcat
(((Name, DeriveAll) -> SDoc) -> [(Name, DeriveAll)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> SDoc
pprBulletNameLoc (Name -> SDoc)
-> ((Name, DeriveAll) -> Name) -> (Name, DeriveAll) -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, DeriveAll) -> Name
forall a b. (a, b) -> a
fst) ([(Name, DeriveAll)] -> [SDoc])
-> ([[(Name, DeriveAll)]] -> [(Name, DeriveAll)])
-> [[(Name, DeriveAll)]]
-> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Name, DeriveAll)]] -> [(Name, DeriveAll)]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[(Name, DeriveAll)]] -> [SDoc])
-> [[(Name, DeriveAll)]] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ UniqMap [(Name, DeriveAll)] -> [[(Name, DeriveAll)]]
forall elt. UniqFM elt -> [elt]
eltsUFM UniqMap [(Name, DeriveAll)]
anns)
SDoc -> SDoc -> SDoc
$+$ SDoc
"Note, DeriveAll is meant to be used only on type declarations."
ModGuts -> CorePluginM ModGuts
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts
go (TyCon
x:[TyCon]
xs) UniqMap [(Name, DeriveAll)]
anns ModGuts
guts
| Just ((Name
xn, DeriveAll
da):[(Name, DeriveAll)]
ds) <- UniqMap [(Name, DeriveAll)] -> Unique -> Maybe [(Name, DeriveAll)]
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqMap [(Name, DeriveAll)]
anns (TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
x) = do
Bool -> CorePluginM () -> CorePluginM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Name, DeriveAll)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, DeriveAll)]
ds) (CorePluginM () -> CorePluginM ())
-> CorePluginM () -> CorePluginM ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> SDoc -> CorePluginM ()
pluginLocatedWarning (Name -> SrcSpan
nameSrcSpan Name
xn) (SDoc -> CorePluginM ()) -> SDoc -> CorePluginM ()
forall a b. (a -> b) -> a -> b
$
SDoc
"Ignoring redundant DeriveAll annotations" SDoc -> SDoc -> SDoc
$$
[SDoc] -> SDoc
hcat
[ SDoc
"(the plugin needs only one annotation per type declaration, but got "
, Int -> SDoc
speakN ([(Name, DeriveAll)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, DeriveAll)]
ds Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
, SDoc
")"
]
SDoc -> CorePluginM ()
pluginDebug (SDoc -> CorePluginM ()) -> SDoc -> CorePluginM ()
forall a b. (a -> b) -> a -> b
$ SDoc
"DeriveAll invoked on TyCon" SDoc -> SDoc -> SDoc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
x
([ClsInst]
newInstances, [CoreBind]
newBinds) <- [(ClsInst, CoreBind)] -> ([ClsInst], [CoreBind])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(ClsInst, CoreBind)] -> ([ClsInst], [CoreBind]))
-> (Maybe [(ClsInst, CoreBind)] -> [(ClsInst, CoreBind)])
-> Maybe [(ClsInst, CoreBind)]
-> ([ClsInst], [CoreBind])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ClsInst, CoreBind)]
-> Maybe [(ClsInst, CoreBind)] -> [(ClsInst, CoreBind)]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [(ClsInst, CoreBind)] -> ([ClsInst], [CoreBind]))
-> CorePluginM (Maybe [(ClsInst, CoreBind)])
-> CorePluginM ([ClsInst], [CoreBind])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CorePluginM [(ClsInst, CoreBind)]
-> CorePluginM (Maybe [(ClsInst, CoreBind)])
forall a. CorePluginM a -> CorePluginM (Maybe a)
try (DeriveAll -> TyCon -> ModGuts -> CorePluginM [(ClsInst, CoreBind)]
deriveAll DeriveAll
da TyCon
x ModGuts
guts)
[TyCon]
-> UniqMap [(Name, DeriveAll)] -> ModGuts -> CorePluginM ModGuts
go [TyCon]
xs (UniqMap [(Name, DeriveAll)]
-> Unique -> UniqMap [(Name, DeriveAll)]
forall key elt. Uniquable key => UniqFM elt -> key -> UniqFM elt
delFromUFM UniqMap [(Name, DeriveAll)]
anns (TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
x)) ModGuts
guts
{ mg_insts :: [ClsInst]
mg_insts = [ClsInst]
newInstances [ClsInst] -> [ClsInst] -> [ClsInst]
forall a. [a] -> [a] -> [a]
++ ModGuts -> [ClsInst]
mg_insts ModGuts
guts
, mg_binds :: [CoreBind]
mg_binds = [CoreBind]
newBinds [CoreBind] -> [CoreBind] -> [CoreBind]
forall a. [a] -> [a] -> [a]
++ ModGuts -> [CoreBind]
mg_binds ModGuts
guts
}
go (TyCon
_:[TyCon]
xs) UniqMap [(Name, DeriveAll)]
anns ModGuts
guts = [TyCon]
-> UniqMap [(Name, DeriveAll)] -> ModGuts -> CorePluginM ModGuts
go [TyCon]
xs UniqMap [(Name, DeriveAll)]
anns ModGuts
guts
pprBulletNameLoc :: Name -> SDoc
pprBulletNameLoc Name
n = [SDoc] -> SDoc
hsep
[SDoc
" ", SDoc
bullet, OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OccName -> SDoc) -> OccName -> SDoc
forall a b. (a -> b) -> a -> b
$ Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
n, SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SrcSpan -> SDoc) -> SrcSpan -> SDoc
forall a b. (a -> b) -> a -> b
$ Name -> SrcSpan
nameSrcSpan Name
n]
deriveAll :: DeriveAll -> TyCon -> ModGuts -> CorePluginM [(ClsInst, CoreBind)]
deriveAll :: DeriveAll -> TyCon -> ModGuts -> CorePluginM [(ClsInst, CoreBind)]
deriveAll DeriveAll
da TyCon
tyCon ModGuts
guts
| Bool
True <- TyCon -> Bool
isNewTyCon TyCon
tyCon
, Bool
False <- TyCon -> Bool
isClassTyCon TyCon
tyCon
, [DataCon
dataCon] <- TyCon -> [DataCon]
tyConDataCons TyCon
tyCon
= do
[FamInst]
dcInsts <- ModGuts -> TyCon -> CorePluginM [FamInst]
lookupDeriveContextInstances ModGuts
guts TyCon
tyCon
SDoc -> CorePluginM ()
pluginDebug
(SDoc -> CorePluginM ())
-> ([SDoc] -> SDoc) -> [SDoc] -> CorePluginM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> Int -> SDoc -> SDoc
hang SDoc
"DeriveAll (1): DeriveContext instances:" Int
2
(SDoc -> SDoc) -> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
vcat ([SDoc] -> CorePluginM ()) -> [SDoc] -> CorePluginM ()
forall a b. (a -> b) -> a -> b
$ (FamInst -> SDoc) -> [FamInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map FamInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr [FamInst]
dcInsts
[([Type], Type)]
unpackedInsts <-
if [FamInst] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FamInst]
dcInsts
then (([Type], Type) -> [([Type], Type)] -> [([Type], Type)]
forall a. a -> [a] -> [a]
:[]) (([Type], Type) -> [([Type], Type)])
-> CorePluginM ([Type], Type) -> CorePluginM [([Type], Type)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyCon -> CorePluginM ([Type], Type)
mockInstance TyCon
tyCon
else [([Type], Type)] -> CorePluginM [([Type], Type)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([([Type], Type)] -> CorePluginM [([Type], Type)])
-> [([Type], Type)] -> CorePluginM [([Type], Type)]
forall a b. (a -> b) -> a -> b
$ (FamInst -> ([Type], Type)) -> [FamInst] -> [([Type], Type)]
forall a b. (a -> b) -> [a] -> [b]
map FamInst -> ([Type], Type)
unpackInstance [FamInst]
dcInsts
SDoc -> CorePluginM ()
pluginDebug
(SDoc -> CorePluginM ())
-> ([SDoc] -> SDoc) -> [SDoc] -> CorePluginM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> Int -> SDoc -> SDoc
hang SDoc
"DeriveAll (1): DeriveContext instance parameters and RHSs:" Int
2
(SDoc -> SDoc) -> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
vcat ([SDoc] -> CorePluginM ()) -> [SDoc] -> CorePluginM ()
forall a b. (a -> b) -> a -> b
$ (([Type], Type) -> SDoc) -> [([Type], Type)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ([Type], Type) -> SDoc
forall a. Outputable a => a -> SDoc
ppr [([Type], Type)]
unpackedInsts
[MatchingType]
allMatchingTypes <- [[MatchingType]] -> [MatchingType]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[MatchingType]] -> [MatchingType])
-> CorePluginM [[MatchingType]] -> CorePluginM [MatchingType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(([Type], Type) -> CorePluginM [MatchingType])
-> [([Type], Type)] -> CorePluginM [[MatchingType]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (ModGuts
-> TyCon -> DataCon -> ([Type], Type) -> CorePluginM [MatchingType]
lookupMatchingBaseTypes ModGuts
guts TyCon
tyCon DataCon
dataCon) [([Type], Type)]
unpackedInsts
SDoc -> CorePluginM ()
pluginDebug
(SDoc -> CorePluginM ())
-> ([SDoc] -> SDoc) -> [SDoc] -> CorePluginM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> Int -> SDoc -> SDoc
hang SDoc
"DeriveAll (2): matching base types:" Int
2
(SDoc -> SDoc) -> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
vcat ([SDoc] -> CorePluginM ()) -> [SDoc] -> CorePluginM ()
forall a b. (a -> b) -> a -> b
$ (MatchingType -> SDoc) -> [MatchingType] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map MatchingType -> SDoc
forall a. Outputable a => a -> SDoc
ppr [MatchingType]
allMatchingTypes
[(ClsInst, CoreBind)]
r <- [[(ClsInst, CoreBind)]] -> [(ClsInst, CoreBind)]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[(ClsInst, CoreBind)]] -> [(ClsInst, CoreBind)])
-> CorePluginM [[(ClsInst, CoreBind)]]
-> CorePluginM [(ClsInst, CoreBind)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MatchingType -> CorePluginM [(ClsInst, CoreBind)])
-> [MatchingType] -> CorePluginM [[(ClsInst, CoreBind)]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (DeriveAll
-> ModGuts -> MatchingType -> CorePluginM [(ClsInst, CoreBind)]
lookupMatchingInstances DeriveAll
da ModGuts
guts) [MatchingType]
allMatchingTypes
SDoc -> CorePluginM ()
pluginDebug
(SDoc -> CorePluginM ())
-> ([SDoc] -> SDoc) -> [SDoc] -> CorePluginM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> Int -> SDoc -> SDoc
hang SDoc
"DeriveAll (3): matching class instances:" Int
2
(SDoc -> SDoc) -> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
vcat ([SDoc] -> CorePluginM ()) -> [SDoc] -> CorePluginM ()
forall a b. (a -> b) -> a -> b
$ ((ClsInst, CoreBind) -> SDoc) -> [(ClsInst, CoreBind)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (ClsInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ClsInst -> SDoc)
-> ((ClsInst, CoreBind) -> ClsInst) -> (ClsInst, CoreBind) -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClsInst, CoreBind) -> ClsInst
forall a b. (a, b) -> a
fst) [(ClsInst, CoreBind)]
r
[(ClsInst, CoreBind)] -> CorePluginM [(ClsInst, CoreBind)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(ClsInst, CoreBind)] -> CorePluginM [(ClsInst, CoreBind)])
-> [(ClsInst, CoreBind)] -> CorePluginM [(ClsInst, CoreBind)]
forall a b. (a -> b) -> a -> b
$ [(ClsInst, CoreBind)] -> [(ClsInst, CoreBind)]
forall b. [(ClsInst, b)] -> [(ClsInst, b)]
filterDupInsts [(ClsInst, CoreBind)]
r
| Bool
otherwise
= SrcSpan -> SDoc -> CorePluginM [(ClsInst, CoreBind)]
forall a. SrcSpan -> SDoc -> CorePluginM a
pluginLocatedError
(Name -> SrcSpan
nameSrcSpan (Name -> SrcSpan) -> Name -> SrcSpan
forall a b. (a -> b) -> a -> b
$ TyCon -> Name
tyConName TyCon
tyCon)
SDoc
"DeriveAll works only on plain newtype declarations"
where
filterDupInsts :: [(ClsInst, b)] -> [(ClsInst, b)]
filterDupInsts = ((ClsInst, b) -> (ClsInst, b) -> Bool)
-> [(ClsInst, b)] -> [(ClsInst, b)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (((ClsInst, b) -> (ClsInst, b) -> Bool)
-> [(ClsInst, b)] -> [(ClsInst, b)])
-> ((ClsInst, b) -> (ClsInst, b) -> Bool)
-> [(ClsInst, b)]
-> [(ClsInst, b)]
forall a b. (a -> b) -> a -> b
$ \(ClsInst
x,b
_) (ClsInst
y, b
_) -> ClsInst -> ClsInst -> Bool
identicalClsInstHead ClsInst
x ClsInst
y
mockInstance :: TyCon -> CorePluginM ([Type], Type)
mockInstance TyCon
tc = do
let tvs :: [TyVar]
tvs = TyCon -> [TyVar]
tyConTyVars TyCon
tc
tys :: [Type]
tys = [TyVar] -> [Type]
mkTyVarTys [TyVar]
tvs
Type
rhs <- (CorePluginEnv -> CorePluginM Type) -> CorePluginM Type
forall a. (CorePluginEnv -> CorePluginM a) -> CorePluginM a
ask CorePluginEnv -> CorePluginM Type
tyEmptyConstraint
([Type], Type) -> CorePluginM ([Type], Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
tys, Type
rhs)
unpackInstance :: FamInst -> ([Type], Type)
unpackInstance FamInst
i
= let tys :: [Type]
tys = case Type -> Maybe [Type]
tyConAppArgs_maybe (Type -> Maybe [Type]) -> [Type] -> [Maybe [Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FamInst -> [Type]
fi_tys FamInst
i of
[Just [Type]
ts] -> [Type]
ts
[Maybe [Type]]
_ -> String -> SDoc -> [Type]
forall a. String -> SDoc -> a
panicDoc String
"DeriveAll" (SDoc -> [Type]) -> SDoc -> [Type]
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
hsep
[ SDoc
"I faced an impossible type when"
SDoc -> SDoc -> SDoc
<+> SDoc
"matching an instance of type family DeriveContext:"
, FamInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr FamInst
i, SDoc
"at"
, SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SrcSpan -> SDoc) -> SrcSpan -> SDoc
forall a b. (a -> b) -> a -> b
$ Name -> SrcSpan
nameSrcSpan (Name -> SrcSpan) -> Name -> SrcSpan
forall a b. (a -> b) -> a -> b
$ FamInst -> Name
forall a. NamedThing a => a -> Name
getName FamInst
i]
rhs :: Type
rhs = FamInst -> Type
fi_rhs FamInst
i
in ([Type]
tys, Type
rhs)
lookupTyFamInstances :: ModGuts -> TyCon -> CorePluginM [FamInst]
lookupTyFamInstances :: ModGuts -> TyCon -> CorePluginM [FamInst]
lookupTyFamInstances ModGuts
guts TyCon
fTyCon = do
PackageFamInstEnv
pkgFamInstEnv <- CoreM PackageFamInstEnv -> CorePluginM PackageFamInstEnv
forall a. CoreM a -> CorePluginM a
liftCoreM CoreM PackageFamInstEnv
getPackageFamInstEnv
[FamInst] -> CorePluginM [FamInst]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FamInst] -> CorePluginM [FamInst])
-> [FamInst] -> CorePluginM [FamInst]
forall a b. (a -> b) -> a -> b
$ FamInstEnvs -> TyCon -> [FamInst]
lookupFamInstEnvByTyCon
(PackageFamInstEnv
pkgFamInstEnv, ModGuts -> PackageFamInstEnv
mg_fam_inst_env ModGuts
guts) TyCon
fTyCon
lookupDeriveContextInstances :: ModGuts -> TyCon -> CorePluginM [FamInst]
lookupDeriveContextInstances :: ModGuts -> TyCon -> CorePluginM [FamInst]
lookupDeriveContextInstances ModGuts
guts TyCon
tyCon = do
[FamInst]
allInsts <- (CorePluginEnv -> CorePluginM TyCon) -> CorePluginM TyCon
forall a. (CorePluginEnv -> CorePluginM a) -> CorePluginM a
ask CorePluginEnv -> CorePluginM TyCon
tyConDeriveContext CorePluginM TyCon
-> (TyCon -> CorePluginM [FamInst]) -> CorePluginM [FamInst]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ModGuts -> TyCon -> CorePluginM [FamInst]
lookupTyFamInstances ModGuts
guts
[FamInst] -> CorePluginM [FamInst]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FamInst] -> CorePluginM [FamInst])
-> [FamInst] -> CorePluginM [FamInst]
forall a b. (a -> b) -> a -> b
$ (FamInst -> Bool) -> [FamInst] -> [FamInst]
forall a. (a -> Bool) -> [a] -> [a]
filter FamInst -> Bool
check [FamInst]
allInsts
where
check :: FamInst -> Bool
check FamInst
fi = case Type -> Maybe TyCon
tyConAppTyCon_maybe (Type -> Maybe TyCon) -> [Type] -> [Maybe TyCon]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FamInst -> [Type]
fi_tys FamInst
fi of
Just TyCon
tc : [Maybe TyCon]
_ -> TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tyCon
[Maybe TyCon]
_ -> Bool
False
data MatchingType
= MatchingType
{ MatchingType -> [(TyVar, Type)]
mtCtxEqs :: [(TyVar, Type)]
, MatchingType -> [Type]
mtTheta :: ThetaType
, MatchingType -> OverlapMode
mtOverlapMode :: OverlapMode
, MatchingType -> Type
mtBaseType :: Type
, MatchingType -> Type
mtNewType :: Type
, MatchingType -> [Type]
mtIgnoreList :: [Type]
}
instance Outputable MatchingType where
ppr :: MatchingType -> SDoc
ppr MatchingType {[(TyVar, Type)]
[Type]
Type
OverlapMode
mtIgnoreList :: [Type]
mtNewType :: Type
mtBaseType :: Type
mtOverlapMode :: OverlapMode
mtTheta :: [Type]
mtCtxEqs :: [(TyVar, Type)]
mtIgnoreList :: MatchingType -> [Type]
mtNewType :: MatchingType -> Type
mtBaseType :: MatchingType -> Type
mtOverlapMode :: MatchingType -> OverlapMode
mtTheta :: MatchingType -> [Type]
mtCtxEqs :: MatchingType -> [(TyVar, Type)]
..} = [SDoc] -> SDoc
vcat
[ SDoc
"MatchingType"
, SDoc
"{ mtCtxEqs =" SDoc -> SDoc -> SDoc
<+> [(TyVar, Type)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(TyVar, Type)]
mtCtxEqs
, SDoc
", mtTheta =" SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
mtTheta
, SDoc
", mtOverlapMode =" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (OverlapMode -> String
forall a. Show a => a -> String
show OverlapMode
mtOverlapMode)
, SDoc
", mtBaseType =" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
mtBaseType
, SDoc
", mtNewType =" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
mtNewType
, SDoc
", mtIgnorelist =" SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
mtIgnoreList
, SDoc
"}"
]
substMatchingType :: TCvSubst -> MatchingType -> MatchingType
substMatchingType :: TCvSubst -> MatchingType -> MatchingType
substMatchingType TCvSubst
sub MatchingType {[(TyVar, Type)]
[Type]
Type
OverlapMode
mtIgnoreList :: [Type]
mtNewType :: Type
mtBaseType :: Type
mtOverlapMode :: OverlapMode
mtTheta :: [Type]
mtCtxEqs :: [(TyVar, Type)]
mtIgnoreList :: MatchingType -> [Type]
mtNewType :: MatchingType -> Type
mtBaseType :: MatchingType -> Type
mtOverlapMode :: MatchingType -> OverlapMode
mtTheta :: MatchingType -> [Type]
mtCtxEqs :: MatchingType -> [(TyVar, Type)]
..} = MatchingType :: [(TyVar, Type)]
-> [Type] -> OverlapMode -> Type -> Type -> [Type] -> MatchingType
MatchingType
{ mtCtxEqs :: [(TyVar, Type)]
mtCtxEqs = ((TyVar, Type) -> (TyVar, Type))
-> [(TyVar, Type)] -> [(TyVar, Type)]
forall a b. (a -> b) -> [a] -> [b]
map ((Type -> Type) -> (TyVar, Type) -> (TyVar, Type)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Type -> Type) -> (TyVar, Type) -> (TyVar, Type))
-> (Type -> Type) -> (TyVar, Type) -> (TyVar, Type)
forall a b. (a -> b) -> a -> b
$ TCvSubst -> Type -> Type
substTyAddInScope TCvSubst
sub) [(TyVar, Type)]
mtCtxEqs
, mtTheta :: [Type]
mtTheta = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (TCvSubst -> Type -> Type
substTyAddInScope TCvSubst
sub) [Type]
mtTheta
, mtOverlapMode :: OverlapMode
mtOverlapMode = OverlapMode
mtOverlapMode
, mtBaseType :: Type
mtBaseType = TCvSubst -> Type -> Type
substTyAddInScope TCvSubst
sub Type
mtBaseType
, mtNewType :: Type
mtNewType = TCvSubst -> Type -> Type
substTyAddInScope TCvSubst
sub Type
mtNewType
, mtIgnoreList :: [Type]
mtIgnoreList = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (TCvSubst -> Type -> Type
substTyAddInScope TCvSubst
sub) [Type]
mtIgnoreList
}
replaceTyMatchingType :: Type -> Type -> MatchingType -> MatchingType
replaceTyMatchingType :: Type -> Type -> MatchingType -> MatchingType
replaceTyMatchingType Type
oldt Type
newt MatchingType {[(TyVar, Type)]
[Type]
Type
OverlapMode
mtIgnoreList :: [Type]
mtNewType :: Type
mtBaseType :: Type
mtOverlapMode :: OverlapMode
mtTheta :: [Type]
mtCtxEqs :: [(TyVar, Type)]
mtIgnoreList :: MatchingType -> [Type]
mtNewType :: MatchingType -> Type
mtBaseType :: MatchingType -> Type
mtOverlapMode :: MatchingType -> OverlapMode
mtTheta :: MatchingType -> [Type]
mtCtxEqs :: MatchingType -> [(TyVar, Type)]
..} = MatchingType :: [(TyVar, Type)]
-> [Type] -> OverlapMode -> Type -> Type -> [Type] -> MatchingType
MatchingType
{ mtCtxEqs :: [(TyVar, Type)]
mtCtxEqs = ((TyVar, Type) -> (TyVar, Type))
-> [(TyVar, Type)] -> [(TyVar, Type)]
forall a b. (a -> b) -> [a] -> [b]
map ((Type -> Type) -> (TyVar, Type) -> (TyVar, Type)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Type -> Type
rep) [(TyVar, Type)]
mtCtxEqs
, mtTheta :: [Type]
mtTheta = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
rep [Type]
mtTheta
, mtOverlapMode :: OverlapMode
mtOverlapMode = OverlapMode
mtOverlapMode
, mtBaseType :: Type
mtBaseType = Type -> Type
rep Type
mtBaseType
, mtNewType :: Type
mtNewType = Type -> Type
rep Type
mtNewType
, mtIgnoreList :: [Type]
mtIgnoreList = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
rep [Type]
mtIgnoreList
}
where
rep :: Type -> Type
rep = Type -> Type -> Type -> Type
replaceTypeOccurrences Type
oldt Type
newt
cleanupMatchingType :: MatchingType -> MatchingType
cleanupMatchingType :: MatchingType -> MatchingType
cleanupMatchingType MatchingType
mt0 = [(TyVar, [Type])] -> MatchingType -> MatchingType
go ([(TyVar, Type)] -> [(TyVar, [Type])]
forall b. [(TyVar, b)] -> [(TyVar, [b])]
groupLists ([(TyVar, Type)] -> [(TyVar, [Type])])
-> [(TyVar, Type)] -> [(TyVar, [Type])]
forall a b. (a -> b) -> a -> b
$ MatchingType -> [(TyVar, Type)]
mtCtxEqs MatchingType
mt0) MatchingType
mt0 { mtCtxEqs :: [(TyVar, Type)]
mtCtxEqs = []}
where
groupOn :: (t -> a) -> [t] -> [[t]]
groupOn t -> a
f = (t -> t -> Bool) -> [t] -> [[t]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\t
x t
y -> t -> a
f t
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== t -> a
f t
y)
flattenSnd :: [[(a, b)]] -> [(a, [b])]
flattenSnd [] = []
flattenSnd ([]:[[(a, b)]]
xs) = [[(a, b)]] -> [(a, [b])]
flattenSnd [[(a, b)]]
xs
flattenSnd (ts :: [(a, b)]
ts@((a
tv,b
_):[(a, b)]
_):[[(a, b)]]
xs) = (a
tv, ((a, b) -> b) -> [(a, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> b
forall a b. (a, b) -> b
snd [(a, b)]
ts)(a, [b]) -> [(a, [b])] -> [(a, [b])]
forall a. a -> [a] -> [a]
: [[(a, b)]] -> [(a, [b])]
flattenSnd [[(a, b)]]
xs
groupLists :: [(TyVar, b)] -> [(TyVar, [b])]
groupLists = [[(TyVar, b)]] -> [(TyVar, [b])]
forall a b. [[(a, b)]] -> [(a, [b])]
flattenSnd ([[(TyVar, b)]] -> [(TyVar, [b])])
-> ([(TyVar, b)] -> [[(TyVar, b)]])
-> [(TyVar, b)]
-> [(TyVar, [b])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TyVar, b) -> TyVar) -> [(TyVar, b)] -> [[(TyVar, b)]]
forall a t. Eq a => (t -> a) -> [t] -> [[t]]
groupOn (TyVar, b) -> TyVar
forall a b. (a, b) -> a
fst ([(TyVar, b)] -> [[(TyVar, b)]])
-> ([(TyVar, b)] -> [(TyVar, b)]) -> [(TyVar, b)] -> [[(TyVar, b)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TyVar, b) -> TyVar) -> [(TyVar, b)] -> [(TyVar, b)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (TyVar, b) -> TyVar
forall a b. (a, b) -> a
fst
go :: [(TyVar, [Type])] -> MatchingType -> MatchingType
go :: [(TyVar, [Type])] -> MatchingType -> MatchingType
go [] MatchingType
mt = MatchingType
mt
go ((TyVar
_, []):[(TyVar, [Type])]
xs) MatchingType
mt = [(TyVar, [Type])] -> MatchingType -> MatchingType
go [(TyVar, [Type])]
xs MatchingType
mt
go ((TyVar
tv,[Type
ty]):[(TyVar, [Type])]
xs) MatchingType
mt
= let sub :: TCvSubst
sub = TCvSubst -> TyVar -> Type -> TCvSubst
extendTCvSubst TCvSubst
emptyTCvSubst TyVar
tv Type
ty
in [(TyVar, [Type])] -> MatchingType -> MatchingType
go (((TyVar, [Type]) -> (TyVar, [Type]))
-> [(TyVar, [Type])] -> [(TyVar, [Type])]
forall a b. (a -> b) -> [a] -> [b]
map (([Type] -> [Type]) -> (TyVar, [Type]) -> (TyVar, [Type])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ((Type -> Type) -> [Type] -> [Type])
-> (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ TCvSubst -> Type -> Type
substTyAddInScope TCvSubst
sub)) [(TyVar, [Type])]
xs)
(MatchingType -> MatchingType) -> MatchingType -> MatchingType
forall a b. (a -> b) -> a -> b
$ TCvSubst -> MatchingType -> MatchingType
substMatchingType TCvSubst
sub MatchingType
mt
go ((TyVar
tv, [Type]
tys):[(TyVar, [Type])]
xs) MatchingType
mt
= case [Type] -> [Type]
removeEqualTypes [Type]
tys of
[] -> [(TyVar, [Type])] -> MatchingType -> MatchingType
go [(TyVar, [Type])]
xs MatchingType
mt
[Type
t] -> [(TyVar, [Type])] -> MatchingType -> MatchingType
go ((TyVar
tv, [Type
t])(TyVar, [Type]) -> [(TyVar, [Type])] -> [(TyVar, [Type])]
forall a. a -> [a] -> [a]
:[(TyVar, [Type])]
xs) MatchingType
mt
[Type]
ts -> [(TyVar, [Type])] -> MatchingType -> MatchingType
go [(TyVar, [Type])]
xs MatchingType
mt { mtCtxEqs :: [(TyVar, Type)]
mtCtxEqs = MatchingType -> [(TyVar, Type)]
mtCtxEqs MatchingType
mt [(TyVar, Type)] -> [(TyVar, Type)] -> [(TyVar, Type)]
forall a. [a] -> [a] -> [a]
++ (Type -> (TyVar, Type)) -> [Type] -> [(TyVar, Type)]
forall a b. (a -> b) -> [a] -> [b]
map ((,) TyVar
tv) [Type]
ts }
removeEqualTypes :: [Type] -> [Type]
removeEqualTypes [] = []
removeEqualTypes [Type
t] = [Type
t]
removeEqualTypes (Type
t:[Type]
ts)
| (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> Type -> Bool
eqType Type
t) [Type]
ts = [Type] -> [Type]
removeEqualTypes [Type]
ts
| Bool
otherwise = Type
t Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type] -> [Type]
removeEqualTypes [Type]
ts
tryHigherRanks :: MatchingType -> [MatchingType]
tryHigherRanks :: MatchingType -> [MatchingType]
tryHigherRanks mt :: MatchingType
mt@MatchingType {[(TyVar, Type)]
[Type]
Type
OverlapMode
mtIgnoreList :: [Type]
mtNewType :: Type
mtBaseType :: Type
mtOverlapMode :: OverlapMode
mtTheta :: [Type]
mtCtxEqs :: [(TyVar, Type)]
mtIgnoreList :: MatchingType -> [Type]
mtNewType :: MatchingType -> Type
mtBaseType :: MatchingType -> Type
mtOverlapMode :: MatchingType -> OverlapMode
mtTheta :: MatchingType -> [Type]
mtCtxEqs :: MatchingType -> [(TyVar, Type)]
..}
| Just (Type
mtBaseType', Type
bt) <- Type -> Maybe (Type, Type)
splitAppTy_maybe Type
mtBaseType
, Just (Type
mtNewType' , Type
nt) <- Type -> Maybe (Type, Type)
splitAppTy_maybe Type
mtNewType
, Just TyVar
btv <- Type -> Maybe TyVar
getTyVar_maybe Type
bt
, Just TyVar
ntv <- Type -> Maybe TyVar
getTyVar_maybe Type
nt
, TyVar
btv TyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TyVar
ntv
, TyVar -> [TyVar] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem TyVar
btv
([TyVar] -> Bool) -> ([Type] -> [TyVar]) -> [Type] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((TyVar, Type) -> TyVar) -> [(TyVar, Type)] -> [TyVar]
forall a b. (a -> b) -> [a] -> [b]
map (TyVar, Type) -> TyVar
forall a b. (a, b) -> a
fst [(TyVar, Type)]
mtCtxEqs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++)
([TyVar] -> [TyVar]) -> ([Type] -> [TyVar]) -> [Type] -> [TyVar]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type] -> [TyVar]
tyCoVarsOfTypesWellScoped
([Type] -> Bool) -> [Type] -> Bool
forall a b. (a -> b) -> a -> b
$ [Type
mtBaseType', Type
mtNewType']
[Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ ((TyVar, Type) -> Type) -> [(TyVar, Type)] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (TyVar, Type) -> Type
forall a b. (a, b) -> b
snd [(TyVar, Type)]
mtCtxEqs
[Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
mtTheta
[Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
mtIgnoreList
= let mt' :: MatchingType
mt' = MatchingType
mt
{ mtBaseType :: Type
mtBaseType = Type
mtBaseType'
, mtNewType :: Type
mtNewType = Type
mtNewType'
}
in MatchingType
mt MatchingType -> [MatchingType] -> [MatchingType]
forall a. a -> [a] -> [a]
: MatchingType -> [MatchingType]
tryHigherRanks MatchingType
mt'
tryHigherRanks MatchingType
mt = [MatchingType
mt]
lookupMatchingBaseTypes :: ModGuts
-> TyCon
-> DataCon
-> ([Type], Type)
-> CorePluginM [MatchingType]
lookupMatchingBaseTypes :: ModGuts
-> TyCon -> DataCon -> ([Type], Type) -> CorePluginM [MatchingType]
lookupMatchingBaseTypes ModGuts
guts TyCon
tyCon DataCon
dataCon ([Type]
tys, Type
constraints) = do
([(TyVar, Type)], [Type])
ftheta <- [Type] -> CorePluginM ([(TyVar, Type)], [Type])
filterTheta [Type]
theta
let initMt :: MatchingType
initMt = MatchingType :: [(TyVar, Type)]
-> [Type] -> OverlapMode -> Type -> Type -> [Type] -> MatchingType
MatchingType
{ mtCtxEqs :: [(TyVar, Type)]
mtCtxEqs = ([(TyVar, Type)], [Type]) -> [(TyVar, Type)]
forall a b. (a, b) -> a
fst ([(TyVar, Type)], [Type])
ftheta
, mtTheta :: [Type]
mtTheta = ([(TyVar, Type)], [Type]) -> [Type]
forall a b. (a, b) -> b
snd ([(TyVar, Type)], [Type])
ftheta
, mtOverlapMode :: OverlapMode
mtOverlapMode = OverlapMode
NoOverlap
, mtBaseType :: Type
mtBaseType = Type
baseType
, mtNewType :: Type
mtNewType = Type
newType
, mtIgnoreList :: [Type]
mtIgnoreList = []
}
([MatchingType]
-> (MatchingType -> [MatchingType]) -> [MatchingType]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MatchingType -> [MatchingType]
tryHigherRanks (MatchingType -> [MatchingType])
-> (MatchingType -> MatchingType) -> MatchingType -> [MatchingType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MatchingType -> MatchingType
cleanupMatchingType)
([MatchingType] -> [MatchingType])
-> ([MatchingType] -> [MatchingType])
-> [MatchingType]
-> [MatchingType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [MatchingType] -> [MatchingType]
forall a. Int -> [a] -> [a]
take Int
1000
([MatchingType] -> [MatchingType])
-> CorePluginM [MatchingType] -> CorePluginM [MatchingType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MatchingType -> CorePluginM [MatchingType]
go (MatchingType -> MatchingType
cleanupMatchingType MatchingType
initMt)
where
go :: MatchingType -> CorePluginM [MatchingType]
go :: MatchingType -> CorePluginM [MatchingType]
go MatchingType
mt = ModGuts -> MatchingType -> CorePluginM (Maybe [MatchingType])
expandOneFamily ModGuts
guts MatchingType
mt CorePluginM (Maybe [MatchingType])
-> (Maybe [MatchingType] -> CorePluginM [MatchingType])
-> CorePluginM [MatchingType]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe [MatchingType]
Nothing -> [MatchingType] -> CorePluginM [MatchingType]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [MatchingType
mt]
Just [MatchingType]
mts -> [[MatchingType]] -> [MatchingType]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[MatchingType]] -> [MatchingType])
-> CorePluginM [[MatchingType]] -> CorePluginM [MatchingType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MatchingType -> CorePluginM [MatchingType])
-> [MatchingType] -> CorePluginM [[MatchingType]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse MatchingType -> CorePluginM [MatchingType]
go [MatchingType]
mts
newType :: Type
newType = TyCon -> [Type] -> Type
mkTyConApp TyCon
tyCon [Type]
tys
theta :: [Type]
theta = Type -> [Type]
splitCts Type
constraints [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
dataConstraints
splitCts :: Type -> [Type]
splitCts Type
c = case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
c of
Maybe (TyCon, [Type])
Nothing -> [Type
c]
Just (TyCon
tc, [Type]
ts) ->
if Name -> Bool
isCTupleTyConName (Name -> Bool) -> Name -> Bool
forall a b. (a -> b) -> a -> b
$ TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc
then (Type -> [Type]) -> [Type] -> [Type]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Type -> [Type]
splitCts [Type]
ts
else [Type
c]
([Type]
dataConstraints, Type
baseType) = case DataCon -> [Type] -> ([TyVar], [Type], [Type])
dataConInstSig DataCon
dataCon [Type]
tys of
([], [Type]
cts, [Type
bt]) -> ([Type]
cts, Type
bt)
([TyVar], [Type], [Type])
_ -> String -> SDoc -> ([Type], Type)
forall a. String -> SDoc -> a
panicDoc String
"DeriveAll" (SDoc -> ([Type], Type)) -> SDoc -> ([Type], Type)
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep
[ SDoc
"Impossible happened:"
, SDoc
"expected a newtype constructor"
, SDoc
"with no existential tyvars and a single type argument,"
, SDoc
"but got", DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dataCon
, SDoc
"at", SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SrcSpan -> SDoc) -> SrcSpan -> SDoc
forall a b. (a -> b) -> a -> b
$ Name -> SrcSpan
nameSrcSpan (Name -> SrcSpan) -> Name -> SrcSpan
forall a b. (a -> b) -> a -> b
$ DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
dataCon ]
filterTheta :: ThetaType -> CorePluginM ([(TyVar, Type)], ThetaType)
filterTheta :: [Type] -> CorePluginM ([(TyVar, Type)], [Type])
filterTheta = ([[Either (TyVar, Type) Type]] -> ([(TyVar, Type)], [Type]))
-> CorePluginM [[Either (TyVar, Type) Type]]
-> CorePluginM ([(TyVar, Type)], [Type])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Either (TyVar, Type) Type] -> ([(TyVar, Type)], [Type])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either (TyVar, Type) Type] -> ([(TyVar, Type)], [Type]))
-> ([[Either (TyVar, Type) Type]] -> [Either (TyVar, Type) Type])
-> [[Either (TyVar, Type) Type]]
-> ([(TyVar, Type)], [Type])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Either (TyVar, Type) Type]] -> [Either (TyVar, Type) Type]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join) (CorePluginM [[Either (TyVar, Type) Type]]
-> CorePluginM ([(TyVar, Type)], [Type]))
-> ([Type] -> CorePluginM [[Either (TyVar, Type) Type]])
-> [Type]
-> CorePluginM ([(TyVar, Type)], [Type])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> CorePluginM [Either (TyVar, Type) Type])
-> [Type] -> CorePluginM [[Either (TyVar, Type) Type]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
(\Type
t -> do
Class
teqClass <- (CorePluginEnv -> CorePluginM Class) -> CorePluginM Class
forall a. (CorePluginEnv -> CorePluginM a) -> CorePluginM a
ask CorePluginEnv -> CorePluginM Class
classTypeEq
Class -> Type -> CorePluginM [Either (TyVar, Type) Type]
filterTheta' Class
teqClass Type
t
)
filterTheta' :: Class -> Type -> CorePluginM [Either (TyVar, Type) PredType]
filterTheta' :: Class -> Type -> CorePluginM [Either (TyVar, Type) Type]
filterTheta' Class
teqClass Type
t = Pred -> CorePluginM [Either (TyVar, Type) Type]
go (Type -> Pred
classifyPredType Type
t)
where
go :: Pred -> CorePluginM [Either (TyVar, Type) Type]
go (EqPred EqRel
_ Type
t1 Type
t2)
| Just TyVar
tv <- Type -> Maybe TyVar
getTyVar_maybe Type
t1
= [Either (TyVar, Type) Type]
-> CorePluginM [Either (TyVar, Type) Type]
forall (m :: * -> *) a. Monad m => a -> m a
return [(TyVar, Type) -> Either (TyVar, Type) Type
forall a b. a -> Either a b
Left (TyVar
tv, Type
t2)]
| Just TyVar
tv <- Type -> Maybe TyVar
getTyVar_maybe Type
t2
= [Either (TyVar, Type) Type]
-> CorePluginM [Either (TyVar, Type) Type]
forall (m :: * -> *) a. Monad m => a -> m a
return [(TyVar, Type) -> Either (TyVar, Type) Type
forall a b. a -> Either a b
Left (TyVar
tv, Type
t1)]
| Bool
otherwise
= do
TyVar
tv <- Type -> CorePluginM TyVar
newTyVar (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
t1)
[Either (TyVar, Type) Type]
-> CorePluginM [Either (TyVar, Type) Type]
forall (m :: * -> *) a. Monad m => a -> m a
return [(TyVar, Type) -> Either (TyVar, Type) Type
forall a b. a -> Either a b
Left (TyVar
tv, Type
t1), (TyVar, Type) -> Either (TyVar, Type) Type
forall a b. a -> Either a b
Left (TyVar
tv, Type
t2)]
go (ClassPred Class
c [Type]
ts)
| Class
c Class -> Class -> Bool
forall a. Eq a => a -> a -> Bool
== Class
heqClass
, [Type
_, Type
_, Type
t1, Type
t2] <- [Type]
ts
= Pred -> CorePluginM [Either (TyVar, Type) Type]
go (EqRel -> Type -> Type -> Pred
EqPred EqRel
ReprEq Type
t1 Type
t2)
| Class
c Class -> Class -> Bool
forall a. Eq a => a -> a -> Bool
== Class
teqClass
, [Type
_, Type
t1, Type
t2] <- [Type]
ts
= Pred -> CorePluginM [Either (TyVar, Type) Type]
go (EqRel -> Type -> Type -> Pred
EqPred EqRel
ReprEq Type
t1 Type
t2)
| Bool
otherwise
= [Either (TyVar, Type) Type]
-> CorePluginM [Either (TyVar, Type) Type]
forall (m :: * -> *) a. Monad m => a -> m a
return [Type -> Either (TyVar, Type) Type
forall a b. b -> Either a b
Right Type
t]
go Pred
_ = [Either (TyVar, Type) Type]
-> CorePluginM [Either (TyVar, Type) Type]
forall (m :: * -> *) a. Monad m => a -> m a
return [Type -> Either (TyVar, Type) Type
forall a b. b -> Either a b
Right Type
t]
expandOneFamily :: ModGuts -> MatchingType -> CorePluginM (Maybe [MatchingType])
expandOneFamily :: ModGuts -> MatchingType -> CorePluginM (Maybe [MatchingType])
expandOneFamily ModGuts
guts mt :: MatchingType
mt@MatchingType{[(TyVar, Type)]
[Type]
Type
OverlapMode
mtIgnoreList :: [Type]
mtNewType :: Type
mtBaseType :: Type
mtOverlapMode :: OverlapMode
mtTheta :: [Type]
mtCtxEqs :: [(TyVar, Type)]
mtIgnoreList :: MatchingType -> [Type]
mtNewType :: MatchingType -> Type
mtBaseType :: MatchingType -> Type
mtOverlapMode :: MatchingType -> OverlapMode
mtTheta :: MatchingType -> [Type]
mtCtxEqs :: MatchingType -> [(TyVar, Type)]
..} = case Maybe (FamTyConFlav, Type)
mfam of
Maybe (FamTyConFlav, Type)
Nothing -> Maybe [MatchingType] -> CorePluginM (Maybe [MatchingType])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [MatchingType]
forall a. Maybe a
Nothing
Just (FamTyConFlav
ff, Type
t) -> ModGuts
-> FamTyConFlav
-> Type
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
expandFamily ModGuts
guts FamTyConFlav
ff Type
t CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
-> (Maybe [(OverlapMode, Type, TCvSubst)]
-> CorePluginM (Maybe [MatchingType]))
-> CorePluginM (Maybe [MatchingType])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe [(OverlapMode, Type, TCvSubst)]
Nothing -> Maybe [MatchingType] -> CorePluginM (Maybe [MatchingType])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [MatchingType] -> CorePluginM (Maybe [MatchingType]))
-> Maybe [MatchingType] -> CorePluginM (Maybe [MatchingType])
forall a b. (a -> b) -> a -> b
$ [MatchingType] -> Maybe [MatchingType]
forall a. a -> Maybe a
Just [MatchingType
mt { mtIgnoreList :: [Type]
mtIgnoreList = Type
t Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
mtIgnoreList }]
Just [(OverlapMode, Type, TCvSubst)]
es -> Maybe [MatchingType] -> CorePluginM (Maybe [MatchingType])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [MatchingType] -> CorePluginM (Maybe [MatchingType]))
-> Maybe [MatchingType] -> CorePluginM (Maybe [MatchingType])
forall a b. (a -> b) -> a -> b
$ [MatchingType] -> Maybe [MatchingType]
forall a. a -> Maybe a
Just ([MatchingType] -> Maybe [MatchingType])
-> [MatchingType] -> Maybe [MatchingType]
forall a b. (a -> b) -> a -> b
$ ((OverlapMode, Type, TCvSubst) -> MatchingType)
-> [(OverlapMode, Type, TCvSubst)] -> [MatchingType]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> (OverlapMode, Type, TCvSubst) -> MatchingType
toMT Type
t) [(OverlapMode, Type, TCvSubst)]
es
where
toMT :: Type -> (OverlapMode, Type, TCvSubst) -> MatchingType
toMT Type
ft (OverlapMode
omode, Type
rezt, TCvSubst
subst)
= let famOcc :: Type
famOcc = TCvSubst -> Type -> Type
substTyAddInScope TCvSubst
subst Type
ft
newMt :: MatchingType
newMt = TCvSubst -> MatchingType -> MatchingType
substMatchingType TCvSubst
subst MatchingType
mt
in if Type -> Type -> Bool
eqType Type
ft Type
rezt
then MatchingType
mt { mtIgnoreList :: [Type]
mtIgnoreList = Type
ft Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
mtIgnoreList }
else Type -> Type -> MatchingType -> MatchingType
replaceTyMatchingType Type
famOcc Type
rezt MatchingType
newMt
{ mtOverlapMode :: OverlapMode
mtOverlapMode = OverlapMode
omode }
look :: Type -> First (FamTyConFlav, Type)
look = Maybe (FamTyConFlav, Type) -> First (FamTyConFlav, Type)
forall a. Maybe a -> First a
First (Maybe (FamTyConFlav, Type) -> First (FamTyConFlav, Type))
-> (Type -> Maybe (FamTyConFlav, Type))
-> Type
-> First (FamTyConFlav, Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type] -> Type -> Maybe (FamTyConFlav, Type)
lookupFamily [Type]
mtIgnoreList
First Maybe (FamTyConFlav, Type)
mfam = [First (FamTyConFlav, Type)] -> First (FamTyConFlav, Type)
forall a. Monoid a => [a] -> a
mconcat
[ ((TyVar, Type) -> First (FamTyConFlav, Type))
-> [(TyVar, Type)] -> First (FamTyConFlav, Type)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Type -> First (FamTyConFlav, Type)
look (Type -> First (FamTyConFlav, Type))
-> ((TyVar, Type) -> Type)
-> (TyVar, Type)
-> First (FamTyConFlav, Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyVar, Type) -> Type
forall a b. (a, b) -> b
snd) [(TyVar, Type)]
mtCtxEqs
, (Type -> First (FamTyConFlav, Type))
-> [Type] -> First (FamTyConFlav, Type)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Type -> First (FamTyConFlav, Type)
look [Type]
mtTheta
, Type -> First (FamTyConFlav, Type)
look Type
mtBaseType
, Type -> First (FamTyConFlav, Type)
look Type
mtNewType
]
lookupFamily :: [Type] -> Type -> Maybe (FamTyConFlav, Type)
lookupFamily :: [Type] -> Type -> Maybe (FamTyConFlav, Type)
lookupFamily [Type]
ignoreLst Type
t
| Just (TyCon
tyCon, [Type]
tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
t
= case (Type -> First (FamTyConFlav, Type))
-> [Type] -> First (FamTyConFlav, Type)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe (FamTyConFlav, Type) -> First (FamTyConFlav, Type)
forall a. Maybe a -> First a
First (Maybe (FamTyConFlav, Type) -> First (FamTyConFlav, Type))
-> (Type -> Maybe (FamTyConFlav, Type))
-> Type
-> First (FamTyConFlav, Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type] -> Type -> Maybe (FamTyConFlav, Type)
lookupFamily [Type]
ignoreLst) [Type]
tys of
First (Just (FamTyConFlav, Type)
r) -> (FamTyConFlav, Type) -> Maybe (FamTyConFlav, Type)
forall a. a -> Maybe a
Just (FamTyConFlav, Type)
r
First Maybe (FamTyConFlav, Type)
Nothing -> TyCon -> Maybe FamTyConFlav
famTyConFlav_maybe TyCon
tyCon Maybe FamTyConFlav
-> (FamTyConFlav -> Maybe (FamTyConFlav, Type))
-> Maybe (FamTyConFlav, Type)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \FamTyConFlav
ff ->
if (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> Type -> Bool
eqType Type
t) [Type]
ignoreLst
then Maybe (FamTyConFlav, Type)
forall a. Maybe a
Nothing
else (FamTyConFlav, Type) -> Maybe (FamTyConFlav, Type)
forall a. a -> Maybe a
Just (FamTyConFlav
ff, Type
t)
| (TyVar
_:[TyVar]
_, Type
t') <- Type -> ([TyVar], Type)
splitForAllTys Type
t
= [Type] -> Type -> Maybe (FamTyConFlav, Type)
lookupFamily [Type]
ignoreLst Type
t'
| Just (AnonArgFlag
_, Mult
_, Type
at, Type
rt) <- Type -> Maybe (AnonArgFlag, Mult, Type, Type)
splitFunTyCompat Type
t
= [Type] -> Type -> Maybe (FamTyConFlav, Type)
lookupFamily [Type]
ignoreLst Type
at Maybe (FamTyConFlav, Type)
-> Maybe (FamTyConFlav, Type) -> Maybe (FamTyConFlav, Type)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Type] -> Type -> Maybe (FamTyConFlav, Type)
lookupFamily [Type]
ignoreLst Type
rt
| Bool
otherwise
= Maybe (FamTyConFlav, Type)
forall a. Maybe a
Nothing
expandFamily :: ModGuts
-> FamTyConFlav
-> Type
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
expandFamily :: ModGuts
-> FamTyConFlav
-> Type
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
expandFamily ModGuts
_ AbstractClosedSynFamilyTyCon{} Type
_ = Maybe [(OverlapMode, Type, TCvSubst)]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [(OverlapMode, Type, TCvSubst)]
forall a. Maybe a
Nothing
expandFamily ModGuts
_ BuiltInSynFamTyCon{} Type
_ = Maybe [(OverlapMode, Type, TCvSubst)]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [(OverlapMode, Type, TCvSubst)]
forall a. Maybe a
Nothing
expandFamily ModGuts
_ (ClosedSynFamilyTyCon Maybe (CoAxiom Branched)
Nothing) Type
_ = Maybe [(OverlapMode, Type, TCvSubst)]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [(OverlapMode, Type, TCvSubst)]
forall a. Maybe a
Nothing
expandFamily ModGuts
_ (ClosedSynFamilyTyCon (Just CoAxiom Branched
coax)) Type
ft
= Type
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
-> (TyCon
-> [Type] -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)]))
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
forall a. Type -> a -> (TyCon -> [Type] -> a) -> a
withFamily Type
ft (Maybe [(OverlapMode, Type, TCvSubst)]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [(OverlapMode, Type, TCvSubst)]
forall a. Maybe a
Nothing) ((TyCon
-> [Type] -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)]))
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)]))
-> (TyCon
-> [Type] -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)]))
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
forall a b. (a -> b) -> a -> b
$ ([Type] -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)]))
-> TyCon
-> [Type]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
forall a b. a -> b -> a
const (([Type] -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)]))
-> TyCon
-> [Type]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)]))
-> ([Type] -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)]))
-> TyCon
-> [Type]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
forall a b. (a -> b) -> a -> b
$ [OverlapMode]
-> [CoAxBranch]
-> [Type]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
expandClosedFamily [OverlapMode]
os [CoAxBranch]
bcs
where
bcs :: [CoAxBranch]
bcs = Branches Branched -> [CoAxBranch]
forall (br :: BranchFlag). Branches br -> [CoAxBranch]
fromBranches (Branches Branched -> [CoAxBranch])
-> Branches Branched -> [CoAxBranch]
forall a b. (a -> b) -> a -> b
$ CoAxiom Branched -> Branches Branched
forall (br :: BranchFlag). CoAxiom br -> Branches br
coAxiomBranches CoAxiom Branched
coax
os :: [OverlapMode]
os = if (CoAxBranch -> Bool) -> [CoAxBranch] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([CoAxBranch] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([CoAxBranch] -> Bool)
-> (CoAxBranch -> [CoAxBranch]) -> CoAxBranch -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoAxBranch -> [CoAxBranch]
coAxBranchIncomps) [CoAxBranch]
bcs
then OverlapMode -> [OverlapMode]
forall a. a -> [a]
repeat OverlapMode
NoOverlap else (CoAxBranch -> OverlapMode) -> [CoAxBranch] -> [OverlapMode]
forall a b. (a -> b) -> [a] -> [b]
map CoAxBranch -> OverlapMode
overlap [CoAxBranch]
bcs
overlap :: CoAxBranch -> OverlapMode
overlap CoAxBranch
cb = if [CoAxBranch] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([CoAxBranch] -> Bool) -> [CoAxBranch] -> Bool
forall a b. (a -> b) -> a -> b
$ CoAxBranch -> [CoAxBranch]
coAxBranchIncomps CoAxBranch
cb
then OverlapMode
Overlapping
else OverlapMode
Incoherent
expandFamily ModGuts
guts DataFamilyTyCon{} Type
ft
= Type
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
-> (TyCon
-> [Type] -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)]))
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
forall a. Type -> a -> (TyCon -> [Type] -> a) -> a
withFamily Type
ft (Maybe [(OverlapMode, Type, TCvSubst)]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [(OverlapMode, Type, TCvSubst)]
forall a. Maybe a
Nothing) ((TyCon
-> [Type] -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)]))
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)]))
-> (TyCon
-> [Type] -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)]))
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
forall a b. (a -> b) -> a -> b
$ ModGuts
-> TyCon
-> [Type]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
expandDataFamily ModGuts
guts
expandFamily ModGuts
guts FamTyConFlav
OpenSynFamilyTyCon Type
ft
= Type
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
-> (TyCon
-> [Type] -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)]))
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
forall a. Type -> a -> (TyCon -> [Type] -> a) -> a
withFamily Type
ft (Maybe [(OverlapMode, Type, TCvSubst)]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [(OverlapMode, Type, TCvSubst)]
forall a. Maybe a
Nothing) ((TyCon
-> [Type] -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)]))
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)]))
-> (TyCon
-> [Type] -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)]))
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
forall a b. (a -> b) -> a -> b
$ ModGuts
-> TyCon
-> [Type]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
expandOpenFamily ModGuts
guts
withFamily :: Type -> a -> (TyCon -> [Type] -> a) -> a
withFamily :: Type -> a -> (TyCon -> [Type] -> a) -> a
withFamily Type
ft a
def TyCon -> [Type] -> a
f = case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ft of
Maybe (TyCon, [Type])
Nothing -> a
def
Just (TyCon
tc, [Type]
ts) -> TyCon -> [Type] -> a
f TyCon
tc [Type]
ts
expandClosedFamily :: [OverlapMode]
-> [CoAxBranch]
-> [Type] -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
expandClosedFamily :: [OverlapMode]
-> [CoAxBranch]
-> [Type]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
expandClosedFamily [OverlapMode]
_ [] [Type]
_ = Maybe [(OverlapMode, Type, TCvSubst)]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [(OverlapMode, Type, TCvSubst)]
forall a. Maybe a
Nothing
expandClosedFamily [OverlapMode]
os [CoAxBranch]
bs [Type]
fTyArgs = ([Maybe (OverlapMode, Type, TCvSubst)]
-> Maybe [(OverlapMode, Type, TCvSubst)])
-> CorePluginM [Maybe (OverlapMode, Type, TCvSubst)]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(OverlapMode, Type, TCvSubst)]
-> Maybe [(OverlapMode, Type, TCvSubst)]
forall a. a -> Maybe a
Just ([(OverlapMode, Type, TCvSubst)]
-> Maybe [(OverlapMode, Type, TCvSubst)])
-> ([Maybe (OverlapMode, Type, TCvSubst)]
-> [(OverlapMode, Type, TCvSubst)])
-> [Maybe (OverlapMode, Type, TCvSubst)]
-> Maybe [(OverlapMode, Type, TCvSubst)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (OverlapMode, Type, TCvSubst)]
-> [(OverlapMode, Type, TCvSubst)]
forall a. [Maybe a] -> [a]
catMaybes) (CorePluginM [Maybe (OverlapMode, Type, TCvSubst)]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)]))
-> CorePluginM [Maybe (OverlapMode, Type, TCvSubst)]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
forall a b. (a -> b) -> a -> b
$ ((OverlapMode, CoAxBranch)
-> CorePluginM (Maybe (OverlapMode, Type, TCvSubst)))
-> [(OverlapMode, CoAxBranch)]
-> CorePluginM [Maybe (OverlapMode, Type, TCvSubst)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (OverlapMode, CoAxBranch)
-> CorePluginM (Maybe (OverlapMode, Type, TCvSubst))
go ([(OverlapMode, CoAxBranch)]
-> CorePluginM [Maybe (OverlapMode, Type, TCvSubst)])
-> [(OverlapMode, CoAxBranch)]
-> CorePluginM [Maybe (OverlapMode, Type, TCvSubst)]
forall a b. (a -> b) -> a -> b
$ [OverlapMode] -> [CoAxBranch] -> [(OverlapMode, CoAxBranch)]
forall a b. [a] -> [b] -> [(a, b)]
zip [OverlapMode]
os [CoAxBranch]
bs
where
go :: (OverlapMode, CoAxBranch)
-> CorePluginM (Maybe (OverlapMode, Type, TCvSubst))
go (OverlapMode
om, CoAxBranch
cb) = do
let flhs' :: [Type]
flhs' = CoAxBranch -> [Type]
coAxBranchLHS CoAxBranch
cb
n :: Int
n = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
flhs'
tvs' :: [TyVar]
tvs' = [Type] -> [TyVar]
tyCoVarsOfTypesWellScoped [Type]
flhs'
[TyVar]
tvs <- (TyVar -> CorePluginM TyVar) -> [TyVar] -> CorePluginM [TyVar]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TyVar -> CorePluginM TyVar
freshenTyVar [TyVar]
tvs'
let freshenSub :: TCvSubst
freshenSub = [TyVar] -> [Type] -> TCvSubst
HasDebugCallStack => [TyVar] -> [Type] -> TCvSubst
zipTvSubst [TyVar]
tvs' ([Type] -> TCvSubst) -> [Type] -> TCvSubst
forall a b. (a -> b) -> a -> b
$ (TyVar -> Type) -> [TyVar] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Type
mkTyVarTy [TyVar]
tvs
flhs :: [Type]
flhs = HasCallStack => TCvSubst -> [Type] -> [Type]
TCvSubst -> [Type] -> [Type]
substTys TCvSubst
freshenSub [Type]
flhs'
frhs :: Type
frhs = TCvSubst -> Type -> Type
substTyAddInScope TCvSubst
freshenSub (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ CoAxBranch -> Type
coAxBranchRHS CoAxBranch
cb
t :: Type
t = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
mkAppTy Type
frhs ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
drop Int
n [Type]
fTyArgs
msub :: Maybe TCvSubst
msub = [Type] -> [Type] -> Maybe TCvSubst
tcMatchTys (Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
take Int
n [Type]
fTyArgs) [Type]
flhs
Maybe (OverlapMode, Type, TCvSubst)
-> CorePluginM (Maybe (OverlapMode, Type, TCvSubst))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (OverlapMode, Type, TCvSubst)
-> CorePluginM (Maybe (OverlapMode, Type, TCvSubst)))
-> Maybe (OverlapMode, Type, TCvSubst)
-> CorePluginM (Maybe (OverlapMode, Type, TCvSubst))
forall a b. (a -> b) -> a -> b
$ (,,) OverlapMode
om Type
t (TCvSubst -> (OverlapMode, Type, TCvSubst))
-> Maybe TCvSubst -> Maybe (OverlapMode, Type, TCvSubst)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TCvSubst
msub
expandOpenFamily :: ModGuts
-> TyCon
-> [Type]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
expandOpenFamily :: ModGuts
-> TyCon
-> [Type]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
expandOpenFamily ModGuts
guts TyCon
fTyCon [Type]
fTyArgs = do
[FamInst]
tfInsts <- ModGuts -> TyCon -> CorePluginM [FamInst]
lookupTyFamInstances ModGuts
guts TyCon
fTyCon
if [FamInst] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FamInst]
tfInsts
then Maybe [(OverlapMode, Type, TCvSubst)]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [(OverlapMode, Type, TCvSubst)]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)]))
-> Maybe [(OverlapMode, Type, TCvSubst)]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
forall a b. (a -> b) -> a -> b
$ [(OverlapMode, Type, TCvSubst)]
-> Maybe [(OverlapMode, Type, TCvSubst)]
forall a. a -> Maybe a
Just []
else [OverlapMode]
-> [CoAxBranch]
-> [Type]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
expandClosedFamily
(OverlapMode -> [OverlapMode]
forall a. a -> [a]
repeat OverlapMode
NoOverlap)
(CoAxiom Unbranched -> CoAxBranch
coAxiomSingleBranch (CoAxiom Unbranched -> CoAxBranch)
-> (FamInst -> CoAxiom Unbranched) -> FamInst -> CoAxBranch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FamInst -> CoAxiom Unbranched
famInstAxiom (FamInst -> CoAxBranch) -> [FamInst] -> [CoAxBranch]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FamInst]
tfInsts)
[Type]
fTyArgs
expandDataFamily :: ModGuts
-> TyCon
-> [Type]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
expandDataFamily :: ModGuts
-> TyCon
-> [Type]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
expandDataFamily ModGuts
guts TyCon
fTyCon [Type]
fTyArgs = do
[FamInst]
tfInsts <- ModGuts -> TyCon -> CorePluginM [FamInst]
lookupTyFamInstances ModGuts
guts TyCon
fTyCon
if [FamInst] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FamInst]
tfInsts
then Maybe [(OverlapMode, Type, TCvSubst)]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [(OverlapMode, Type, TCvSubst)]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)]))
-> Maybe [(OverlapMode, Type, TCvSubst)]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
forall a b. (a -> b) -> a -> b
$ [(OverlapMode, Type, TCvSubst)]
-> Maybe [(OverlapMode, Type, TCvSubst)]
forall a. a -> Maybe a
Just []
else [Maybe (OverlapMode, Type, TCvSubst)]
-> Maybe [(OverlapMode, Type, TCvSubst)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Maybe (OverlapMode, Type, TCvSubst)]
-> Maybe [(OverlapMode, Type, TCvSubst)])
-> CorePluginM [Maybe (OverlapMode, Type, TCvSubst)]
-> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FamInst -> CorePluginM (Maybe (OverlapMode, Type, TCvSubst)))
-> [FamInst] -> CorePluginM [Maybe (OverlapMode, Type, TCvSubst)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FamInst -> CorePluginM (Maybe (OverlapMode, Type, TCvSubst))
expandDInstance [FamInst]
tfInsts
where
expandDInstance :: FamInst -> CorePluginM (Maybe (OverlapMode, Type, TCvSubst))
expandDInstance FamInst
inst
| [TyVar]
fitvs <- FamInst -> [TyVar]
fi_tvs FamInst
inst
= do
[TyVar]
tvs <- (TyVar -> CorePluginM TyVar) -> [TyVar] -> CorePluginM [TyVar]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TyVar -> CorePluginM TyVar
freshenTyVar [TyVar]
fitvs
let freshenSub :: TCvSubst
freshenSub = [TyVar] -> [Type] -> TCvSubst
HasDebugCallStack => [TyVar] -> [Type] -> TCvSubst
zipTvSubst [TyVar]
fitvs ([Type] -> TCvSubst) -> [Type] -> TCvSubst
forall a b. (a -> b) -> a -> b
$ (TyVar -> Type) -> [TyVar] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Type
mkTyVarTy [TyVar]
tvs
fitys :: [Type]
fitys = HasCallStack => TCvSubst -> [Type] -> [Type]
TCvSubst -> [Type] -> [Type]
substTys TCvSubst
freshenSub ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ FamInst -> [Type]
fi_tys FamInst
inst
instTyArgs :: [Type]
instTyArgs = [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
align [Type]
fTyArgs [Type]
fitys
Maybe (OverlapMode, Type, TCvSubst)
-> CorePluginM (Maybe (OverlapMode, Type, TCvSubst))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (OverlapMode, Type, TCvSubst)
-> CorePluginM (Maybe (OverlapMode, Type, TCvSubst)))
-> Maybe (OverlapMode, Type, TCvSubst)
-> CorePluginM (Maybe (OverlapMode, Type, TCvSubst))
forall a b. (a -> b) -> a -> b
$ (,,) OverlapMode
NoOverlap (TyCon -> [Type] -> Type
mkTyConApp TyCon
fTyCon [Type]
instTyArgs)
(TCvSubst -> (OverlapMode, Type, TCvSubst))
-> Maybe TCvSubst -> Maybe (OverlapMode, Type, TCvSubst)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type] -> [Type] -> Maybe TCvSubst
tcMatchTys [Type]
fTyArgs [Type]
instTyArgs
align :: [a] -> [a] -> [a]
align [] [a]
_ = []
align [a]
xs [] = [a]
xs
align (a
_:[a]
xs) (a
y:[a]
ys) = a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
align [a]
xs [a]
ys
data MatchingInstance = MatchingInstance
{ MatchingInstance -> ClsInst
miInst :: ClsInst
, MatchingInstance -> [DFunInstType]
miInstTyVars :: [DFunInstType]
, MatchingInstance -> [(Type, MatchingPredType)]
miTheta :: [(PredType, MatchingPredType)]
}
instance Outputable MatchingInstance where
ppr :: MatchingInstance -> SDoc
ppr MatchingInstance {[DFunInstType]
[(Type, MatchingPredType)]
ClsInst
miTheta :: [(Type, MatchingPredType)]
miInstTyVars :: [DFunInstType]
miInst :: ClsInst
miTheta :: MatchingInstance -> [(Type, MatchingPredType)]
miInstTyVars :: MatchingInstance -> [DFunInstType]
miInst :: MatchingInstance -> ClsInst
..} = SDoc -> Int -> SDoc -> SDoc
hang SDoc
"MatchingInstance" Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ SDoc
"{ miInst =" SDoc -> SDoc -> SDoc
<+> ClsInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr ClsInst
miInst
, SDoc
", miInstTyVars =" SDoc -> SDoc -> SDoc
<+> [DFunInstType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [DFunInstType]
miInstTyVars
, SDoc
", miTheta =" SDoc -> SDoc -> SDoc
<+> [(Type, MatchingPredType)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Type, MatchingPredType)]
miTheta
]
data MatchingPredType
= MptInstance MatchingInstance
| MptReflexive Coercion
| MptPropagateAs PredType
instance Outputable MatchingPredType where
ppr :: MatchingPredType -> SDoc
ppr (MptInstance MatchingInstance
x) = SDoc
"MptInstance" SDoc -> SDoc -> SDoc
<+> MatchingInstance -> SDoc
forall a. Outputable a => a -> SDoc
ppr MatchingInstance
x
ppr (MptReflexive Coercion
x) = SDoc
"MptReflexive" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
x
ppr (MptPropagateAs Type
x) = SDoc
"MptPropagateAs" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
x
findInstance :: InstEnvs
-> Type
-> ClsInst
-> Maybe MatchingInstance
findInstance :: InstEnvs -> Type -> ClsInst -> Maybe MatchingInstance
findInstance InstEnvs
ie Type
t ClsInst
i
|
Just TCvSubst
sub <- First TCvSubst -> Maybe TCvSubst
forall a. First a -> Maybe a
getFirst (First TCvSubst -> Maybe TCvSubst)
-> First TCvSubst -> Maybe TCvSubst
forall a b. (a -> b) -> a -> b
$ (Type -> First TCvSubst) -> [Type] -> First TCvSubst
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe TCvSubst -> First TCvSubst
forall a. Maybe a -> First a
First (Maybe TCvSubst -> First TCvSubst)
-> (Type -> Maybe TCvSubst) -> Type -> First TCvSubst
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Type -> Maybe TCvSubst) -> Type -> Type -> Maybe TCvSubst
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Bool -> Type -> Type -> Maybe TCvSubst
recMatchTyKi Bool
False) Type
t) [Type]
iTyPams
, [Type]
newTyPams <- (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (TCvSubst -> Type -> Type
substTyAddInScope TCvSubst
sub) [Type]
iTyPams
= InstEnvs -> Class -> [Type] -> Maybe MatchingInstance
matchInstance InstEnvs
ie Class
iClass [Type]
newTyPams
| Bool
otherwise
= Maybe MatchingInstance
forall a. Maybe a
Nothing
where
([TyVar]
_, [Type]
_, Class
iClass, [Type]
iTyPams) = ClsInst -> ([TyVar], [Type], Class, [Type])
instanceSig ClsInst
i
matchInstance :: InstEnvs
-> Class
-> [Type]
-> Maybe MatchingInstance
matchInstance :: InstEnvs -> Class -> [Type] -> Maybe MatchingInstance
matchInstance InstEnvs
ie Class
cls [Type]
ts
| ([(ClsInst
i, [DFunInstType]
tyVarSubs)], [ClsInst]
_notMatchButUnify, [InstMatch]
_safeHaskellStuff)
<- Bool
-> InstEnvs
-> Class
-> [Type]
-> ([InstMatch], [ClsInst], [InstMatch])
lookupInstEnv Bool
False InstEnvs
ie Class
cls [Type]
ts
, ([TyVar]
iTyVars, [Type]
iTheta, Class
_, [Type]
_) <- ClsInst -> ([TyVar], [Type], Class, [Type])
instanceSig ClsInst
i
, TCvSubst
sub <- [(TyVar, Type)] -> TCvSubst
mkTvSubstPrs
([(TyVar, Type)] -> TCvSubst)
-> ([Maybe (TyVar, Type)] -> [(TyVar, Type)])
-> [Maybe (TyVar, Type)]
-> TCvSubst
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (TyVar, Type)] -> [(TyVar, Type)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (TyVar, Type)] -> TCvSubst)
-> [Maybe (TyVar, Type)] -> TCvSubst
forall a b. (a -> b) -> a -> b
$ (TyVar -> DFunInstType -> Maybe (TyVar, Type))
-> [TyVar] -> [DFunInstType] -> [Maybe (TyVar, Type)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((Type -> (TyVar, Type)) -> DFunInstType -> Maybe (TyVar, Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Type -> (TyVar, Type)) -> DFunInstType -> Maybe (TyVar, Type))
-> (TyVar -> Type -> (TyVar, Type))
-> TyVar
-> DFunInstType
-> Maybe (TyVar, Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,)) [TyVar]
iTyVars [DFunInstType]
tyVarSubs
= do
[MatchingPredType]
mpts <- (Type -> Maybe MatchingPredType)
-> [Type] -> Maybe [MatchingPredType]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (InstEnvs -> Type -> Maybe MatchingPredType
matchPredType InstEnvs
ie (Type -> Maybe MatchingPredType)
-> (Type -> Type) -> Type -> Maybe MatchingPredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TCvSubst -> Type -> Type
substTyAddInScope TCvSubst
sub) [Type]
iTheta
MatchingInstance -> Maybe MatchingInstance
forall (m :: * -> *) a. Monad m => a -> m a
return MatchingInstance :: ClsInst
-> [DFunInstType] -> [(Type, MatchingPredType)] -> MatchingInstance
MatchingInstance
{ miInst :: ClsInst
miInst = ClsInst
i
, miInstTyVars :: [DFunInstType]
miInstTyVars = [DFunInstType]
tyVarSubs
, miTheta :: [(Type, MatchingPredType)]
miTheta = [Type] -> [MatchingPredType] -> [(Type, MatchingPredType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
iTheta [MatchingPredType]
mpts
}
| Bool
otherwise
= Maybe MatchingInstance
forall a. Maybe a
Nothing
matchPredType :: InstEnvs
-> PredType
-> Maybe MatchingPredType
matchPredType :: InstEnvs -> Type -> Maybe MatchingPredType
matchPredType InstEnvs
ie Type
pt = Pred -> Maybe MatchingPredType
go (Pred -> Maybe MatchingPredType) -> Pred -> Maybe MatchingPredType
forall a b. (a -> b) -> a -> b
$ Type -> Pred
classifyPredType Type
pt
where
go :: Pred -> Maybe MatchingPredType
go (ClassPred Class
cls [Type]
ts)
| Just MatchingInstance
mi <- InstEnvs -> Class -> [Type] -> Maybe MatchingInstance
matchInstance InstEnvs
ie Class
cls [Type]
ts
= MatchingPredType -> Maybe MatchingPredType
forall a. a -> Maybe a
Just (MatchingPredType -> Maybe MatchingPredType)
-> MatchingPredType -> Maybe MatchingPredType
forall a b. (a -> b) -> a -> b
$ MatchingInstance -> MatchingPredType
MptInstance MatchingInstance
mi
| [] <- [Type] -> [TyVar]
tyCoVarsOfTypesWellScoped [Type]
ts
= Maybe MatchingPredType
forall a. Maybe a
Nothing
| Bool
otherwise = MatchingPredType -> Maybe MatchingPredType
forall a. a -> Maybe a
Just (MatchingPredType -> Maybe MatchingPredType)
-> MatchingPredType -> Maybe MatchingPredType
forall a b. (a -> b) -> a -> b
$ Type -> MatchingPredType
MptPropagateAs Type
pt
go (EqPred EqRel
rel Type
t1 Type
t2)
| Type -> Type -> Bool
eqType Type
t1 Type
t2 = MatchingPredType -> Maybe MatchingPredType
forall a. a -> Maybe a
Just (MatchingPredType -> Maybe MatchingPredType)
-> (Coercion -> MatchingPredType)
-> Coercion
-> Maybe MatchingPredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coercion -> MatchingPredType
MptReflexive (Coercion -> Maybe MatchingPredType)
-> Coercion -> Maybe MatchingPredType
forall a b. (a -> b) -> a -> b
$ case EqRel
rel of
EqRel
NomEq -> Role -> Type -> Coercion
mkReflCo Role
Nominal Type
t1
EqRel
ReprEq -> Role -> Type -> Coercion
mkReflCo Role
Representational Type
t1
| [(Type, Type)] -> Bool
typesCantMatch [(Type
t1,Type
t2)]
= Maybe MatchingPredType
forall a. Maybe a
Nothing
| Bool
otherwise = MatchingPredType -> Maybe MatchingPredType
forall a. a -> Maybe a
Just (MatchingPredType -> Maybe MatchingPredType)
-> MatchingPredType -> Maybe MatchingPredType
forall a b. (a -> b) -> a -> b
$ Type -> MatchingPredType
MptPropagateAs Type
pt
go Pred
_ = MatchingPredType -> Maybe MatchingPredType
forall a. a -> Maybe a
Just (MatchingPredType -> Maybe MatchingPredType)
-> MatchingPredType -> Maybe MatchingPredType
forall a b. (a -> b) -> a -> b
$ Type -> MatchingPredType
MptPropagateAs Type
pt
type TyExp = (Type, CoreExpr)
type TyBndr = (Type, CoreBndr)
mtmiToExpression :: MatchingType
-> MatchingInstance
-> CorePluginM TyExp
mtmiToExpression :: MatchingType -> MatchingInstance -> CorePluginM TyExp
mtmiToExpression MatchingType {[(TyVar, Type)]
[Type]
Type
OverlapMode
mtIgnoreList :: [Type]
mtNewType :: Type
mtBaseType :: Type
mtOverlapMode :: OverlapMode
mtTheta :: [Type]
mtCtxEqs :: [(TyVar, Type)]
mtIgnoreList :: MatchingType -> [Type]
mtNewType :: MatchingType -> Type
mtBaseType :: MatchingType -> Type
mtOverlapMode :: MatchingType -> OverlapMode
mtTheta :: MatchingType -> [Type]
mtCtxEqs :: MatchingType -> [(TyVar, Type)]
..} MatchingInstance
mi = do
([TyBndr]
bndrs, (Type
tOrig, CoreExpr
e)) <- [TyExp] -> MatchingInstance -> CorePluginM ([TyBndr], TyExp)
miToExpression' [] MatchingInstance
mi
let extraTheta :: [Type]
extraTheta
= (Type -> Bool) -> [Type] -> [Type]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Type
t -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (TyBndr -> Bool) -> [TyBndr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> Type -> Bool
eqType Type
t (Type -> Bool) -> (TyBndr -> Type) -> TyBndr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyBndr -> Type
forall a b. (a, b) -> a
fst) [TyBndr]
bndrs) [Type]
mtTheta
tRepl :: Type
tRepl = Type -> Type -> Type -> Type
replaceTypeOccurrences Type
mtBaseType Type
mtNewType Type
tOrig
tFun :: Type
tFun = [Type] -> Type -> Type
mkInvisFunTysMany ([Type]
extraTheta [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ (TyBndr -> Type) -> [TyBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyBndr -> Type
forall a b. (a, b) -> a
fst [TyBndr]
bndrs) Type
tRepl
tvs :: [TyVar]
tvs = Type -> [TyVar]
tyCoVarsOfTypeWellScoped Type
tFun
TyExp -> CorePluginM TyExp
forall (m :: * -> *) a. Monad m => a -> m a
return
( [TyVar] -> Type -> Type
mkSpecForAllTys [TyVar]
tvs Type
tFun
, [TyVar] -> CoreExpr -> CoreExpr
mkCoreLams ([TyVar]
tvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ (Type -> TyVar) -> [Type] -> [TyVar]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TyVar
mkWildValBinderCompat [Type]
extraTheta [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ (TyBndr -> TyVar) -> [TyBndr] -> [TyVar]
forall a b. (a -> b) -> [a] -> [b]
map TyBndr -> TyVar
forall a b. (a, b) -> b
snd [TyBndr]
bndrs)
(CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
e
(Coercion -> CoreExpr) -> Coercion -> CoreExpr
forall a b. (a -> b) -> a -> b
$ String -> Role -> Type -> Type -> Coercion
mkPluginCo String
"ignore newtype" Role
Representational Type
tOrig Type
tRepl
)
miToExpression' :: [TyExp]
-> MatchingInstance
-> CorePluginM ([TyBndr], TyExp)
miToExpression' :: [TyExp] -> MatchingInstance -> CorePluginM ([TyBndr], TyExp)
miToExpression' [TyExp]
availPTs MatchingInstance {[DFunInstType]
[(Type, MatchingPredType)]
ClsInst
miTheta :: [(Type, MatchingPredType)]
miInstTyVars :: [DFunInstType]
miInst :: ClsInst
miTheta :: MatchingInstance -> [(Type, MatchingPredType)]
miInstTyVars :: MatchingInstance -> [DFunInstType]
miInst :: MatchingInstance -> ClsInst
..} = do
([TyBndr]
bndrs, [CoreExpr]
eArgs) <- [TyExp] -> [MatchingPredType] -> CorePluginM ([TyBndr], [CoreExpr])
addArgs [TyExp]
availPTs ([MatchingPredType] -> CorePluginM ([TyBndr], [CoreExpr]))
-> [MatchingPredType] -> CorePluginM ([TyBndr], [CoreExpr])
forall a b. (a -> b) -> a -> b
$ ((Type, MatchingPredType) -> MatchingPredType)
-> [(Type, MatchingPredType)] -> [MatchingPredType]
forall a b. (a -> b) -> [a] -> [b]
map (Type, MatchingPredType) -> MatchingPredType
forall a b. (a, b) -> b
snd [(Type, MatchingPredType)]
miTheta
([TyBndr], TyExp) -> CorePluginM ([TyBndr], TyExp)
forall (m :: * -> *) a. Monad m => a -> m a
return
( [TyBndr]
bndrs
, ( Type
newIHead
, CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps CoreExpr
eDFunWithTyPams [CoreExpr]
eArgs
)
)
where
([TyVar]
iTyVars, [Type]
_, Class
iClass, [Type]
iTyPams) = ClsInst -> ([TyVar], [Type], Class, [Type])
instanceSig ClsInst
miInst
tyVarVals :: [Type]
tyVarVals = (TyVar -> DFunInstType -> Type)
-> [TyVar] -> [DFunInstType] -> [Type]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Type -> DFunInstType -> Type
forall a. a -> Maybe a -> a
fromMaybe (Type -> DFunInstType -> Type)
-> (TyVar -> Type) -> TyVar -> DFunInstType -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Type
mkTyVarTy) [TyVar]
iTyVars [DFunInstType]
miInstTyVars
sub :: TCvSubst
sub = [(TyVar, Type)] -> TCvSubst
mkTvSubstPrs ([(TyVar, Type)] -> TCvSubst)
-> ([Maybe (TyVar, Type)] -> [(TyVar, Type)])
-> [Maybe (TyVar, Type)]
-> TCvSubst
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (TyVar, Type)] -> [(TyVar, Type)]
forall a. [Maybe a] -> [a]
catMaybes
([Maybe (TyVar, Type)] -> TCvSubst)
-> [Maybe (TyVar, Type)] -> TCvSubst
forall a b. (a -> b) -> a -> b
$ (TyVar -> DFunInstType -> Maybe (TyVar, Type))
-> [TyVar] -> [DFunInstType] -> [Maybe (TyVar, Type)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((Type -> (TyVar, Type)) -> DFunInstType -> Maybe (TyVar, Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Type -> (TyVar, Type)) -> DFunInstType -> Maybe (TyVar, Type))
-> (TyVar -> Type -> (TyVar, Type))
-> TyVar
-> DFunInstType
-> Maybe (TyVar, Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,)) [TyVar]
iTyVars [DFunInstType]
miInstTyVars
newTyPams :: [Type]
newTyPams = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (TCvSubst -> Type -> Type
substTyAddInScope TCvSubst
sub) [Type]
iTyPams
newIHead :: Type
newIHead = TyCon -> [Type] -> Type
mkTyConApp (Class -> TyCon
classTyCon Class
iClass) [Type]
newTyPams
eDFun :: CoreExpr
eDFun = TyVar -> CoreExpr
forall b. TyVar -> Expr b
Var (TyVar -> CoreExpr) -> TyVar -> CoreExpr
forall a b. (a -> b) -> a -> b
$ ClsInst -> TyVar
instanceDFunId ClsInst
miInst
eDFunWithTyPams :: CoreExpr
eDFunWithTyPams = CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
mkTyApps CoreExpr
eDFun [Type]
tyVarVals
addArgs :: [TyExp]
-> [MatchingPredType]
-> CorePluginM ([TyBndr], [CoreExpr])
addArgs :: [TyExp] -> [MatchingPredType] -> CorePluginM ([TyBndr], [CoreExpr])
addArgs [TyExp]
_ [] = ([TyBndr], [CoreExpr]) -> CorePluginM ([TyBndr], [CoreExpr])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [])
addArgs [TyExp]
ps (MatchingPredType
x:[MatchingPredType]
xs) = do
([TyBndr]
tbdrs, CoreExpr
e) <- [TyExp] -> MatchingPredType -> CorePluginM ([TyBndr], CoreExpr)
mptToExpression [TyExp]
ps MatchingPredType
x
let ps' :: [TyExp]
ps' = [TyExp]
ps [TyExp] -> [TyExp] -> [TyExp]
forall a. [a] -> [a] -> [a]
++ (TyBndr -> TyExp) -> [TyBndr] -> [TyExp]
forall a b. (a -> b) -> [a] -> [b]
map (TyVar -> CoreExpr
forall b. TyVar -> Expr b
Var (TyVar -> CoreExpr) -> TyBndr -> TyExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) [TyBndr]
tbdrs
([TyBndr]
tbdrs', [CoreExpr]
es) <- [TyExp] -> [MatchingPredType] -> CorePluginM ([TyBndr], [CoreExpr])
addArgs [TyExp]
ps' [MatchingPredType]
xs
([TyBndr], [CoreExpr]) -> CorePluginM ([TyBndr], [CoreExpr])
forall (m :: * -> *) a. Monad m => a -> m a
return
( [TyBndr]
tbdrs [TyBndr] -> [TyBndr] -> [TyBndr]
forall a. [a] -> [a] -> [a]
++ [TyBndr]
tbdrs'
, CoreExpr
eCoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
:[CoreExpr]
es
)
mptToExpression :: [TyExp]
-> MatchingPredType
-> CorePluginM ([TyBndr], CoreExpr)
mptToExpression :: [TyExp] -> MatchingPredType -> CorePluginM ([TyBndr], CoreExpr)
mptToExpression [TyExp]
ps (MptInstance MatchingInstance
mi)
= (TyExp -> CoreExpr) -> ([TyBndr], TyExp) -> ([TyBndr], CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyExp -> CoreExpr
forall a b. (a, b) -> b
snd (([TyBndr], TyExp) -> ([TyBndr], CoreExpr))
-> CorePluginM ([TyBndr], TyExp)
-> CorePluginM ([TyBndr], CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyExp] -> MatchingInstance -> CorePluginM ([TyBndr], TyExp)
miToExpression' [TyExp]
ps MatchingInstance
mi
mptToExpression [TyExp]
_ (MptReflexive Coercion
c)
= ([TyBndr], CoreExpr) -> CorePluginM ([TyBndr], CoreExpr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Coercion -> CoreExpr
forall b. Coercion -> Expr b
Coercion Coercion
c)
mptToExpression [TyExp]
ps (MptPropagateAs Type
pt)
= case Maybe CoreExpr
mte of
Just CoreExpr
e -> ([TyBndr], CoreExpr) -> CorePluginM ([TyBndr], CoreExpr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], CoreExpr
e)
Maybe CoreExpr
Nothing -> do
SrcSpan
loc <- CoreM SrcSpan -> CorePluginM SrcSpan
forall a. CoreM a -> CorePluginM a
liftCoreM CoreM SrcSpan
getSrcSpanM
Unique
u <- CorePluginM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
let n :: Name
n = Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
u
(NameSpace -> String -> OccName
mkOccName NameSpace
varName (String -> OccName) -> String -> OccName
forall a b. (a -> b) -> a -> b
$ String
"dFunArg_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Unique -> String
forall a. Show a => a -> String
show Unique
u) SrcSpan
loc
v :: TyVar
v = Name -> Mult -> Type -> TyVar
mkLocalIdOrCoVarCompat Name
n Mult
Many Type
pt
([TyBndr], CoreExpr) -> CorePluginM ([TyBndr], CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Type
pt,TyVar
v)], TyVar -> CoreExpr
forall b. TyVar -> Expr b
Var TyVar
v)
where
mte :: Maybe CoreExpr
mte = First CoreExpr -> Maybe CoreExpr
forall a. First a -> Maybe a
getFirst (First CoreExpr -> Maybe CoreExpr)
-> First CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ (TyExp -> First CoreExpr) -> [TyExp] -> First CoreExpr
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TyExp -> First CoreExpr
getSamePT [TyExp]
ps
getSamePT :: TyExp -> First CoreExpr
getSamePT (Type
t, CoreExpr
e)
| Type -> Type -> Bool
eqType Type
t Type
pt = Maybe CoreExpr -> First CoreExpr
forall a. Maybe a -> First a
First (Maybe CoreExpr -> First CoreExpr)
-> Maybe CoreExpr -> First CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
e
| Bool
otherwise = Maybe CoreExpr -> First CoreExpr
forall a. Maybe a -> First a
First Maybe CoreExpr
forall a. Maybe a
Nothing
lookupMatchingInstances :: DeriveAll
-> ModGuts
-> MatchingType
-> CorePluginM [(ClsInst, CoreBind)]
lookupMatchingInstances :: DeriveAll
-> ModGuts -> MatchingType -> CorePluginM [(ClsInst, CoreBind)]
lookupMatchingInstances DeriveAll
da ModGuts
guts MatchingType
mt
| Just TyCon
bTyCon <- Type -> Maybe TyCon
tyConAppTyCon_maybe (Type -> Maybe TyCon) -> Type -> Maybe TyCon
forall a b. (a -> b) -> a -> b
$ MatchingType -> Type
mtBaseType MatchingType
mt = do
InstEnvs
ie <- ModGuts -> CorePluginM InstEnvs
getInstEnvs ModGuts
guts
let clsInsts :: [ClsInst]
clsInsts = InstEnvs -> TyCon -> [ClsInst]
lookupClsInsts InstEnvs
ie TyCon
bTyCon
SDoc -> CorePluginM ()
pluginDebug (SDoc -> CorePluginM ()) -> SDoc -> CorePluginM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> Int -> SDoc -> SDoc
hang SDoc
"lookupMatchingInstances candidate instances:" Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (ClsInst -> SDoc) -> [ClsInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ClsInst]
clsInsts
[Maybe (ClsInst, CoreBind)] -> [(ClsInst, CoreBind)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (ClsInst, CoreBind)] -> [(ClsInst, CoreBind)])
-> CorePluginM [Maybe (ClsInst, CoreBind)]
-> CorePluginM [(ClsInst, CoreBind)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ClsInst -> CorePluginM (Maybe (ClsInst, CoreBind)))
-> [ClsInst] -> CorePluginM [Maybe (ClsInst, CoreBind)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (DeriveAll
-> InstEnvs
-> MatchingType
-> ClsInst
-> CorePluginM (Maybe (ClsInst, CoreBind))
lookupMatchingInstance DeriveAll
da InstEnvs
ie MatchingType
mt) [ClsInst]
clsInsts
| Bool
otherwise = (() -> [(ClsInst, CoreBind)])
-> CorePluginM () -> CorePluginM [(ClsInst, CoreBind)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(ClsInst, CoreBind)] -> () -> [(ClsInst, CoreBind)]
forall a b. a -> b -> a
const []) (CorePluginM () -> CorePluginM [(ClsInst, CoreBind)])
-> (SDoc -> CorePluginM ())
-> SDoc
-> CorePluginM [(ClsInst, CoreBind)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> CorePluginM ()
pluginDebug (SDoc -> CorePluginM [(ClsInst, CoreBind)])
-> SDoc -> CorePluginM [(ClsInst, CoreBind)]
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hcat
[ String -> SDoc
text String
"DeriveAll.lookupMatchingInstances found no class instances for "
, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (MatchingType -> Type
mtBaseType MatchingType
mt)
, String -> SDoc
text String
", because it could not get the type constructor."
]
lookupMatchingInstance :: DeriveAll
-> InstEnvs
-> MatchingType
-> ClsInst
-> CorePluginM (Maybe (ClsInst, CoreBind))
lookupMatchingInstance :: DeriveAll
-> InstEnvs
-> MatchingType
-> ClsInst
-> CorePluginM (Maybe (ClsInst, CoreBind))
lookupMatchingInstance DeriveAll
da InstEnvs
ie mt :: MatchingType
mt@MatchingType {[(TyVar, Type)]
[Type]
Type
OverlapMode
mtIgnoreList :: [Type]
mtNewType :: Type
mtBaseType :: Type
mtOverlapMode :: OverlapMode
mtTheta :: [Type]
mtCtxEqs :: [(TyVar, Type)]
mtIgnoreList :: MatchingType -> [Type]
mtNewType :: MatchingType -> Type
mtBaseType :: MatchingType -> Type
mtOverlapMode :: MatchingType -> OverlapMode
mtTheta :: MatchingType -> [Type]
mtCtxEqs :: MatchingType -> [(TyVar, Type)]
..} ClsInst
baseInst
| Bool -> Bool
not (Bool -> Bool) -> (Name -> Bool) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeriveAll -> Name -> Bool
unwantedName DeriveAll
da (Name -> Bool) -> Name -> Bool
forall a b. (a -> b) -> a -> b
$ Class -> Name
forall a. NamedThing a => a -> Name
getName Class
iClass
, (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Name -> Bool) -> Type -> Bool
noneTy (DeriveAll -> Name -> Bool
unwantedName DeriveAll
DeriveAll)) [Type]
iTyPams
= case InstEnvs -> Type -> ClsInst -> Maybe MatchingInstance
findInstance InstEnvs
ie Type
mtBaseType ClsInst
baseInst of
Just MatchingInstance
mi -> do
(Type
t, CoreExpr
e) <- MatchingType -> MatchingInstance -> CorePluginM TyExp
mtmiToExpression MatchingType
mt MatchingInstance
mi
Name
newN <- NameSpace -> String -> CorePluginM Name
newName (OccName -> NameSpace
occNameSpace OccName
baseDFunName)
(String -> CorePluginM Name) -> String -> CorePluginM Name
forall a b. (a -> b) -> a -> b
$ OccName -> String
occNameString OccName
baseDFunName
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Unique -> String
forall a. Show a => a -> String
show (TyVar -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyVar
baseDFunId)
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
newtypeNameS
let ([TyVar]
newTyVars, [Type]
_, Class
_, [Type]
newTyPams) = Type -> ([TyVar], [Type], Class, [Type])
tcSplitDFunTy Type
t
newDFunId :: TyVar
newDFunId = IdDetails -> Name -> Type -> TyVar
mkExportedLocalId
(Bool -> IdDetails
DFunId Bool
isNewType) Name
newN Type
t
Maybe (ClsInst, CoreBind)
-> CorePluginM (Maybe (ClsInst, CoreBind))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ClsInst, CoreBind)
-> CorePluginM (Maybe (ClsInst, CoreBind)))
-> Maybe (ClsInst, CoreBind)
-> CorePluginM (Maybe (ClsInst, CoreBind))
forall a b. (a -> b) -> a -> b
$ (ClsInst, CoreBind) -> Maybe (ClsInst, CoreBind)
forall a. a -> Maybe a
Just
( TyVar -> OverlapFlag -> [TyVar] -> Class -> [Type] -> ClsInst
mkLocalInstance
TyVar
newDFunId
( DeriveAll -> OverlapMode -> OverlapFlag
deriveAllMode DeriveAll
da (OverlapMode -> OverlapFlag) -> OverlapMode -> OverlapFlag
forall a b. (a -> b) -> a -> b
$ OverlapMode -> OverlapMode -> OverlapMode
forall a. Monoid a => a -> a -> a
mappend OverlapMode
mtOverlapMode OverlapMode
baseOM )
[TyVar]
newTyVars Class
iClass [Type]
newTyPams
, TyVar -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec TyVar
newDFunId CoreExpr
e
)
Maybe MatchingInstance
Nothing
| Just TCvSubst
sub <- First TCvSubst -> Maybe TCvSubst
forall a. First a -> Maybe a
getFirst
(First TCvSubst -> Maybe TCvSubst)
-> First TCvSubst -> Maybe TCvSubst
forall a b. (a -> b) -> a -> b
$ (Type -> First TCvSubst) -> [Type] -> First TCvSubst
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe TCvSubst -> First TCvSubst
forall a. Maybe a -> First a
First (Maybe TCvSubst -> First TCvSubst)
-> (Type -> Maybe TCvSubst) -> Type -> First TCvSubst
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Type -> Maybe TCvSubst) -> Type -> Type -> Maybe TCvSubst
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Bool -> Type -> Type -> Maybe TCvSubst
recMatchTyKi Bool
True) Type
mtBaseType) [Type]
iTyPams
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ TCvSubst -> Bool
isEmptyTCvSubst TCvSubst
sub
-> do
SDoc -> CorePluginM ()
pluginDebug (SDoc -> CorePluginM ()) -> SDoc -> CorePluginM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> Int -> SDoc -> SDoc
hang SDoc
"Could not find an instance, trying again:" Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"Base type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
mtBaseType
, String -> SDoc
text String
"Instance:" SDoc -> SDoc -> SDoc
<+> ClsInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr ClsInst
baseInst
, String -> SDoc
text String
"Substitution:" SDoc -> SDoc -> SDoc
<+> TCvSubst -> SDoc
forall a. Outputable a => a -> SDoc
ppr TCvSubst
sub
]
DeriveAll
-> InstEnvs
-> MatchingType
-> ClsInst
-> CorePluginM (Maybe (ClsInst, CoreBind))
lookupMatchingInstance DeriveAll
da InstEnvs
ie (TCvSubst -> MatchingType -> MatchingType
substMatchingType TCvSubst
sub MatchingType
mt) ClsInst
baseInst
| Bool
otherwise
-> do
SDoc -> CorePluginM ()
pluginDebug (SDoc -> CorePluginM ()) -> SDoc -> CorePluginM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> Int -> SDoc -> SDoc
hang SDoc
"Ignored instance" Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"Base type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
mtBaseType
, String -> SDoc
text String
"Instance:" SDoc -> SDoc -> SDoc
<+> ClsInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr ClsInst
baseInst
]
Maybe (ClsInst, CoreBind)
-> CorePluginM (Maybe (ClsInst, CoreBind))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ClsInst, CoreBind)
forall a. Maybe a
Nothing
| Bool
otherwise
= Maybe (ClsInst, CoreBind)
-> CorePluginM (Maybe (ClsInst, CoreBind))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ClsInst, CoreBind)
forall a. Maybe a
Nothing
where
deriveAllMode :: DeriveAll -> OverlapMode -> OverlapFlag
deriveAllMode (DeriveAll' OverlapMode
m [String]
_) OverlapMode
_ = OverlapMode -> OverlapFlag
toOverlapFlag OverlapMode
m
deriveAllMode DeriveAll
_ OverlapMode
m = OverlapMode -> OverlapFlag
toOverlapFlag OverlapMode
m
baseOM :: OverlapMode
baseOM = ClsInst -> OverlapMode
instanceOverlapMode ClsInst
baseInst
baseDFunId :: TyVar
baseDFunId = ClsInst -> TyVar
instanceDFunId ClsInst
baseInst
([TyVar]
_, [Type]
_, Class
iClass, [Type]
iTyPams) = ClsInst -> ([TyVar], [Type], Class, [Type])
instanceSig ClsInst
baseInst
isNewType :: Bool
isNewType = TyCon -> Bool
isNewTyCon (Class -> TyCon
classTyCon Class
iClass)
baseDFunName :: OccName
baseDFunName = Name -> OccName
forall name. HasOccName name => name -> OccName
occName (Name -> OccName) -> (TyVar -> Name) -> TyVar -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Name
idName (TyVar -> OccName) -> TyVar -> OccName
forall a b. (a -> b) -> a -> b
$ TyVar
baseDFunId
newtypeNameS :: String
newtypeNameS = case Type -> Maybe TyCon
tyConAppTyCon_maybe Type
mtNewType of
Maybe TyCon
Nothing -> String
"DeriveAll-generated"
Just TyCon
tc -> OccName -> String
occNameString (OccName -> String) -> OccName -> String
forall a b. (a -> b) -> a -> b
$ Name -> OccName
forall name. HasOccName name => name -> OccName
occName (Name -> OccName) -> Name -> OccName
forall a b. (a -> b) -> a -> b
$ TyCon -> Name
tyConName TyCon
tc
noneTy :: (Name -> Bool) -> Type -> Bool
noneTy :: (Name -> Bool) -> Type -> Bool
noneTy Name -> Bool
f = Bool -> Bool
not (Bool -> Bool) -> (Type -> Bool) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Bool) -> UniqSet Name -> Bool
forall a. (a -> Bool) -> UniqSet a -> Bool
uniqSetAny Name -> Bool
f (UniqSet Name -> Bool) -> (Type -> UniqSet Name) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> UniqSet Name
orphNamesOfType
unwantedName :: DeriveAll -> Name -> Bool
unwantedName :: DeriveAll -> Name -> Bool
unwantedName DeriveAll
da Name
n
| String
modName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"GHC.Generics" = Bool
True
| String
modName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Data.Typeable" = Bool
True
| String
modName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Data.Data" = Bool
True
| String
"Language.Haskell.TH"
String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
modName = Bool
True
| String
valName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Coercible" = Bool
True
| DeriveAllBut [String]
xs <- DeriveAll
da
, String
valName String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
xs = Bool
True
| DeriveAll' OverlapMode
_ [String]
xs <- DeriveAll
da
, String
valName String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
xs = Bool
True
| Bool
otherwise = Bool
False
where
modName :: String
modName = ModuleName -> String
moduleNameString (ModuleName -> String)
-> (Module -> ModuleName) -> Module -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
moduleName (Module -> String) -> Module -> String
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
n
valName :: String
valName = OccName -> String
occNameString (OccName -> String) -> OccName -> String
forall a b. (a -> b) -> a -> b
$ Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
n
replaceTypeOccurrences :: Type -> Type -> Type -> Type
replaceTypeOccurrences :: Type -> Type -> Type -> Type
replaceTypeOccurrences Type
told Type
tnew = Type -> Type
replace
where
replace :: Type -> Type
replace :: Type -> Type
replace Type
t
| Type -> Type -> Bool
eqType Type
t Type
told
= Type
tnew
| Just (AnonArgFlag
vis, Mult
mu, Type
at, Type
rt) <- Type -> Maybe (AnonArgFlag, Mult, Type, Type)
splitFunTyCompat Type
t
= AnonArgFlag -> Mult -> Type -> Type -> Type
mkFunTyCompat AnonArgFlag
vis Mult
mu (Type -> Type
replace Type
at) (Type -> Type
replace Type
rt)
| Just (TyCon
tyCon, [Type]
tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
t
= TyCon -> [Type] -> Type
mkTyConApp TyCon
tyCon ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
replace [Type]
tys
| (bndrs :: [TyVar]
bndrs@(TyVar
_:[TyVar]
_), Type
t') <- Type -> ([TyVar], Type)
splitForAllTys Type
t
= [TyVar] -> Type -> Type
mkSpecForAllTys [TyVar]
bndrs (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
replace Type
t'
| Bool
otherwise
= Type
t
lookupClsInsts :: InstEnvs -> TyCon -> [ClsInst]
lookupClsInsts :: InstEnvs -> TyCon -> [ClsInst]
lookupClsInsts InstEnvs
ie TyCon
tc =
[ ClsInst
ispec
| ClsInst
ispec <- InstEnv -> [ClsInst]
instEnvElts (InstEnvs -> InstEnv
ie_local InstEnvs
ie)
[ClsInst] -> [ClsInst] -> [ClsInst]
forall a. [a] -> [a] -> [a]
++ InstEnv -> [ClsInst]
instEnvElts (InstEnvs -> InstEnv
ie_global InstEnvs
ie)
, VisibleOrphanModules -> ClsInst -> Bool
instIsVisible (InstEnvs -> VisibleOrphanModules
ie_visible InstEnvs
ie) ClsInst
ispec
, TyCon -> Name
tyConName TyCon
tc Name -> UniqSet Name -> Bool
`elemNameSet` ClsInst -> UniqSet Name
orphNamesOfClsInst ClsInst
ispec
]
recMatchTyKi :: Bool
-> Type -> Type -> Maybe TCvSubst
recMatchTyKi :: Bool -> Type -> Type -> Maybe TCvSubst
recMatchTyKi Bool
inverse Type
tsearched Type
ttemp = Type -> Maybe TCvSubst
go Type
tsearched
where
go :: Type -> Maybe TCvSubst
go :: Type -> Maybe TCvSubst
go Type
t
| Type -> Bool
isTyVarTy Type
t
= Maybe TCvSubst
forall a. Maybe a
Nothing
| Just TCvSubst
sub <- if Bool
inverse
then Type -> Type -> Maybe TCvSubst
tcMatchTyKi Type
ttemp Type
t
else Type -> Type -> Maybe TCvSubst
tcMatchTyKi Type
t Type
ttemp
= TCvSubst -> Maybe TCvSubst
forall a. a -> Maybe a
Just TCvSubst
sub
| Just (TyCon
_, [Type]
tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
t
= First TCvSubst -> Maybe TCvSubst
forall a. First a -> Maybe a
getFirst (First TCvSubst -> Maybe TCvSubst)
-> First TCvSubst -> Maybe TCvSubst
forall a b. (a -> b) -> a -> b
$ (Type -> First TCvSubst) -> [Type] -> First TCvSubst
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe TCvSubst -> First TCvSubst
forall a. Maybe a -> First a
First (Maybe TCvSubst -> First TCvSubst)
-> (Type -> Maybe TCvSubst) -> Type -> First TCvSubst
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe TCvSubst
go) [Type]
tys
| (TyVar
_:[TyVar]
_, Type
t') <- Type -> ([TyVar], Type)
splitForAllTys Type
t
= Type -> Maybe TCvSubst
go Type
t'
| Just (AnonArgFlag
_, Mult
_, Type
at, Type
rt) <- Type -> Maybe (AnonArgFlag, Mult, Type, Type)
splitFunTyCompat Type
t
= Type -> Maybe TCvSubst
go Type
at Maybe TCvSubst -> Maybe TCvSubst -> Maybe TCvSubst
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Type -> Maybe TCvSubst
go Type
rt
| Bool
otherwise
= Maybe TCvSubst
forall a. Maybe a
Nothing