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

-- | A marker to tell the core plugin to derive all visible class instances
--      for a given newtype.
--
--   The deriving logic is to simply re-use existing instance dictionaries
--      by type-casting.
data DeriveAll
  = DeriveAll
    -- ^ Same as @DeriveAllBut []@.
  | DeriveAllBut { DeriveAll -> [String]
_ignoreList :: [String] }
    -- ^ Specify a list of class names to ignore
  | DeriveAll' { DeriveAll -> OverlapMode
_forcedMode :: OverlapMode, _ignoreList :: [String] }
    -- ^ Specify an overlap mode and a list of class names to ignore
  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)


-- | This type family is used to impose constraints on type parameters when
--   looking up type instances for the `DeriveAll` core plugin.
--
--   `DeriveAll` uses only those instances that satisfy the specified constraint.
--   If the constraint is not specified, it is assumed to be `()`.
type family DeriveContext (t :: Data.Kind.Type) :: Data.Kind.Constraint

-- | Run `DeriveAll` plugin pass
deriveAllPass :: CorePluginEnvRef -> CoreToDo
deriveAllPass :: CorePluginEnvRef -> CoreToDo
deriveAllPass CorePluginEnvRef
eref = String -> CorePluginPass -> CoreToDo
CoreDoPluginPass String
"Data.Constraint.Deriving.DeriveAll"
  -- if a plugin pass totally fails to do anything useful,
  -- copy original ModGuts as its output, so that next passes can do their jobs.
  (\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)

{-
  Derive all specific instances of a type for its newtype wrapper.

  Steps:

  1. Lookup a type or type family instances (branches of CoAxiom)
       of referenced by the newtype decl

  2. For every type instance:

     2.1 Lookup all class instances

     2.2 For every class instance:

         * Use mkLocalInstance with parameters of found instance
             and replaced RHS types
         * Create a corresponding top-level binding (DFunId),
             add it to mg_binds of ModGuts.
         * Add new instance to (mg_insts :: [ClsInst]) of ModGuts
         * Update mg_inst_env of ModGuts accordingly.

 -}
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
    -- All exports are processed, just return 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

    -- process type definitions present in the set of annotations
    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)
      -- add new definitions and continue
      [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
        --   I decided to not modify mg_inst_env so that DeriveAll-derived instances
        --   do not refer to each other.
        --   Overwise, the result of the plugin would depend on the order of
        --   type declaration, which would be not good at all.
        -- , mg_inst_env = InstEnv.extendInstEnvList (mg_inst_env guts) newInstances
        , mg_binds :: [CoreBind]
mg_binds    = [CoreBind]
newBinds [CoreBind] -> [CoreBind] -> [CoreBind]
forall a. [a] -> [a] -> [a]
++ ModGuts -> [CoreBind]
mg_binds ModGuts
guts
        }

    -- ignore the rest of type definitions
    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]



{- |
  At this point, the plugin has found a candidate type.
  The first thing I do here is to make sure this
    is indeed a proper newtype declaration.
  Then, lookup the DeriveContext-specified constraints.
  Then, enumerate specific type instances (based on constraints
    and type families in the newtype def.)
  Then, lookup all class instances for the found type instances.
 -}
deriveAll :: DeriveAll -> TyCon -> ModGuts -> CorePluginM [(ClsInst, CoreBind)]
deriveAll :: DeriveAll -> TyCon -> ModGuts -> CorePluginM [(ClsInst, CoreBind)]
deriveAll DeriveAll
da TyCon
tyCon ModGuts
guts
-- match good newtypes only
  | 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

-- not a good newtype declaration
  | 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
    -- O(n^2) search for duplicates. Slow, but what else can I do?..
    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)


-- | Find all instance of a type family in scope by its TyCon.
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

-- | Find all possible instances of DeriveContext type family for a given TyCon
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


-- | Result of base type lookup, matching, and expanding
data MatchingType
  = MatchingType
  { MatchingType -> [(TyVar, Type)]
mtCtxEqs      :: [(TyVar, Type)]
    -- ^ Current list of constraints that I may want to process
    --   during type expansion or substitution
  , MatchingType -> [Type]
mtTheta       :: ThetaType
    -- ^ Irreducible constraints
    --      (I can prepend them in the class instance declarations)
  , MatchingType -> OverlapMode
mtOverlapMode :: OverlapMode
    -- ^ How to declare a class instance
  , MatchingType -> Type
mtBaseType    :: Type
    -- ^ The type behind the newtype wrapper
  , MatchingType -> Type
mtNewType     :: Type
    -- ^ The newtype with instantiated type arguments
  , MatchingType -> [Type]
mtIgnoreList  :: [Type]
    -- ^ A list of type families I have already attempted to expand once
    --   (e.g. wired-in type families or closed families with no equations
    --         or something recursive).
  }

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
"}"
    ]


-- | Replace TyVar in all components of a MatchingType
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

-- | try to get rid of mtCtxEqs by replacing tyvars
--       by rhs in all components of the MatchingType
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
    -- TyVar occurs once in mtCtxEqs: I can safely replace it in the type.
    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
    -- TyVar occurs more than once: it may indicate
    --       a trivial substition or contradiction
    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 -- redundant, but compiler is happy
          [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


-- | Try to strip trailing TyVars from the base and newtypes,
--   thus matching higher-kinded types.
--   This way I can also derive things like Monad & co
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
    -- No constraints or anything else involving our TyVar
  , 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]

-- | For a given type and constraints, enumerate all possible concrete types;
--   specify overlapping mode if encountered with conflicting instances of
--   closed type families.
--
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 -- TODO: improve the logic and the termination rule
        ([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
              -- mkFunTys theta $ mkTyConApp tyCon 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 ]

{-
  New plan for generating matching types


  Split ThetaType into two lists:

  [(TyVar, Type)] and the rest of ThetaType

  The rest of ThetaType is considered not useful;
  it will be just appended to a list of constraints in the result types.
  [(TyVar, Type)] is a list of equality constraints that might help the algorithm.

  I want to perform three operations related to this list:
  [1] Add new tyVar ~ TypeFamily, from type family occurrences
       in the base or newtypes
      (but also check this type family is not present in the eqs?)
  [2] Remove an item (TypeFamily) from the list by substituting
        all possible type family instances
      into the the base type, the newtype, and the list of constraints.
  [3] Remove a non-TypeFamily item (i.e. a proper data/newtype TyCon)
      by substituting TyVar with
      this type in the base type, the newtype, and the list of constraints.

  Actions [1,2] may lead to an infinite expansion (recursive families)
  so I need to bound the number of iterations. An approximate implementation plan:
  1. Apply [1] until no type families present in the basetype or the newtype
  2. Apply [2] or [3] until no esq left???

 -}


-- | Split constraints into two groups:
--   1. The ones used as substitutions
--   2. Irreducible ones w.r.t. the type expansion algorithm
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
  )

-- "worker" part of filterTheta (with a provided reference to "~")
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
          -- nominal or rep-al equality does not matter here, because
          -- I don't distinguish between those a few lines above.
        = 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
    -- first, substitute all type variables,
    -- then substitute family occurrence with RHS of the axiom (rezt)
    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 }


    -- Lookup through all components
    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
      ]


-- | Depth-first lookup of the first occurrence of any type family.
--   First argument is a list of types to ignore.
lookupFamily :: [Type] -> Type -> Maybe (FamTyConFlav, Type)
lookupFamily :: [Type] -> Type -> Maybe (FamTyConFlav, Type)
lookupFamily [Type]
ignoreLst Type
t
      -- split type constructors
    | 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)
      -- split foralls
    | (TyVar
_:[TyVar]
_, Type
t') <- Type -> ([TyVar], Type)
splitForAllTys Type
t
      = [Type] -> Type -> Maybe (FamTyConFlav, Type)
lookupFamily [Type]
ignoreLst Type
t'
      -- split arrow types
    | 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


-- | Enumerate available family instances and substitute type arguments,
--   such that original type family can be replaced with any
--     of the types in the output list.
--   It passes a TCvSubst alongside with the substituted Type.
--   The substituted Type may have TyVars from the result set of the substitution,
--   thus I must be careful with using it:
--     either somehow substitute back these tyvars from the result,
--     or substitute the whole type that contains this family occurrence.
--
--   return Nothing   means cannot expand family (shall use it as-is);
--   return (Just []) means all instances contradict family arguments.
expandFamily :: ModGuts
             -> FamTyConFlav
             -> Type
             -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
-- cannot help here
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
-- .. and here
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
-- .. closed type families with no equations cannot be helped either
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
-- For a closed type family, equations are accessible right there
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
-- For a data family or an open type family, I need to lookup instances
-- in the family instance environment.
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


-- | The same as `expandFamily`, but I know already that the family is closed.
expandClosedFamily :: [OverlapMode]
                   -> [CoAxBranch]
                   -> [Type] -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])
-- empty type family -- leave it as-is
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



-- | The same as `expandFamily`, but I know already that the family is open.
expandOpenFamily :: ModGuts
                 -> TyCon  -- ^ Type family construtor
                 -> [Type] -- ^ Type family arguments
                 -> 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 [] -- No mercy
    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


-- | The same as `expandFamily`, but I know already that this is a data family.
expandDataFamily :: ModGuts
                 -> TyCon  -- ^ Type family construtor
                 -> [Type] -- ^ Type family arguments
                 -> 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 [] -- No mercy
    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
    -- ^ Original found instance for the base type (as declared somewhere);
    --   It contains the signature and original DFunId
  , MatchingInstance -> [DFunInstType]
miInstTyVars :: [DFunInstType]
    -- ^ How TyVars of miOrigBaseClsInst should be replaced to make it as
    --   an instance for the base type;
    --   e.g. a TyVar may be instantiated with a concrete type
    --         (which may or may not contain more type variables).
  , MatchingInstance -> [(Type, MatchingPredType)]
miTheta      :: [(PredType, MatchingPredType)]
    -- ^ Original pred types and how they are going to be transformed
  }

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
    ]

{-
Resolving theta types:

1. Class constraints: every time check
   a. if there is an instance, substitute corresponding DFunIds and be happy.
   b. if there is no instance and no tyvars, then fail
   c. otherwise propagate the constraint further.

2. Equality constraints: check equality
   a. Types are equal (and tyvars inside equal as well):
      Substitute mkReflCo
   b. Types are unifiable:
      Propagate constraint further
   c. Types are non-unifiable:
      Discard the whole instance declaration.
 -}
data MatchingPredType
  = MptInstance MatchingInstance
    -- ^ Found an instance
  | MptReflexive Coercion
    -- ^ The equality become reflexive after a tyvar substitution
  | MptPropagateAs PredType
    -- ^ Could do nothing, but there is still hope due to the present tyvars

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
  | -- Most important: some part of the instance parameters must unify to arg
    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
    -- substituted type parameters of the class
  , [Type]
newTyPams <- (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (TCvSubst -> Type -> Type
substTyAddInScope TCvSubst
sub) [Type]
iTyPams
    -- This tells us how instance tyvars change after matching the type
    = 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
    -- the following line checks if constraints are solvable and fails otherwise
    [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
        -- we could not find an instance, but also there are no tyvars (and no hope)
      | [] <- [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
    )


-- | Construct a core expression and a corresponding type.
--   It does not bind arguments;
--   uses only types and vars present in MatchingInstance;
--   may create a few vars for PredTypes, they are returned in fst.
miToExpression' :: [TyExp]
                   -- ^ types and expressions of the PredTypes that are in scope
                -> MatchingInstance
                -> CorePluginM ([TyBndr], TyExp)
                   -- (what to add to lambda, and the final expression)
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
    -- this is the same length as iTyVars, needs to be applied on dFunId
    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
        )


-- | Construct an expression to put as a PredType argument.
--   It may need to produce a new type variable.
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

-- | For a given most concrete type, find all possible class instances.
--   Derive them all by creating a new CoreBind with a casted type.
--
--   Prerequisite: in the tripple (overlapmode, baseType, newType),
--   TyVars of the newType must be a superset of TyVars of the baseType.
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) -- unique per baseDFunId
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
newtypeNameS                -- unique per newType
          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
            -- in case if the instance is more specific than the MatchingType,
            -- substitute types and try again
          | 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


-- checks if none of the names in the type satisfy the predicate
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

-- | Replace all occurrences of one type in another.
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
        -- found occurrence
      | Type -> Type -> Bool
eqType Type
t Type
told
        = Type
tnew
        -- split arrow types
      | 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)
        -- split type constructors
      | 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
        -- split foralls
      | (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'
        -- could not find anything
      | Bool
otherwise
        = Type
t


-- Made this similar to tcRnGetInfo
--   and a hidden function lookupInsts used there
lookupClsInsts :: InstEnvs -> TyCon -> [ClsInst]
lookupClsInsts :: InstEnvs -> TyCon -> [ClsInst]
lookupClsInsts InstEnvs
ie TyCon
tc =
  [ ClsInst
ispec        -- Search all
  | 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
  ]

-- | Similar to Unify.tcMatchTyKis, but looks if there is a non-trivial subtype
--   in the first type that matches the second.
--   Non-trivial means not a TyVar.
recMatchTyKi :: Bool -- ^ Whether to do inverse match (instance is more conrete)
             -> 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
        -- ignore plain TyVars
      | Type -> Bool
isTyVarTy Type
t
        = Maybe TCvSubst
forall a. Maybe a
Nothing
        -- found a good substitution
      | 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
        -- split type constructors
      | 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
        -- split foralls
      | (TyVar
_:[TyVar]
_, Type
t') <- Type -> ([TyVar], Type)
splitForAllTys Type
t
        = Type -> Maybe TCvSubst
go Type
t'
        -- split arrow types
      | 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