{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE OverloadedStrings  #-}
module Data.Constraint.Deriving.ToInstance
  ( ToInstance (..)
  , OverlapMode (..)
  , toInstancePass
  , CorePluginEnvRef, initCorePluginEnv
  ) where

import Control.Applicative (Alternative (..))
import Control.Monad       (join, unless)
import Data.Data           (Data)
import Data.Maybe          (fromMaybe, isJust)
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 convert a top-level `Data.Constraint.Dict` binding into
     an instance declaration.

     Example:

@
type family FooFam a where
  FooFam Int = Int
  FooFam a   = Double

data FooSing a where
  FooInt   :: FooSing Int
  FooNoInt :: FooSing a

class FooClass a where
  fooSing :: FooSing a

newtype Bar a = Bar (FooFam a)

{\-\# ANN fooNum (ToInstance NoOverlap) \#-\}
fooNum :: forall a . Dict (Num (Bar a))
fooNum = mapDict (unsafeDerive Bar) $ case fooSing @a of
  FooInt   -> Dict
  FooNoInt -> Dict
@

     Note:

     * `fooNum` should be exported by the module
        (otherwise, it may be optimized-out before the core plugin pass);
     * Constraints of the function become constraints of the new instance;
     * The argument of `Dict` must be a single class (no constraint tuples or equality constraints);
     * The instance is created in a core-to-core pass, so it does not exist for the type checker in the current module.
 -}
newtype ToInstance = ToInstance { ToInstance -> OverlapMode
overlapMode :: OverlapMode }
  deriving (ToInstance -> ToInstance -> Bool
(ToInstance -> ToInstance -> Bool)
-> (ToInstance -> ToInstance -> Bool) -> Eq ToInstance
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ToInstance -> ToInstance -> Bool
$c/= :: ToInstance -> ToInstance -> Bool
== :: ToInstance -> ToInstance -> Bool
$c== :: ToInstance -> ToInstance -> Bool
Eq, Int -> ToInstance -> ShowS
[ToInstance] -> ShowS
ToInstance -> String
(Int -> ToInstance -> ShowS)
-> (ToInstance -> String)
-> ([ToInstance] -> ShowS)
-> Show ToInstance
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ToInstance] -> ShowS
$cshowList :: [ToInstance] -> ShowS
show :: ToInstance -> String
$cshow :: ToInstance -> String
showsPrec :: Int -> ToInstance -> ShowS
$cshowsPrec :: Int -> ToInstance -> ShowS
Show, ReadPrec [ToInstance]
ReadPrec ToInstance
Int -> ReadS ToInstance
ReadS [ToInstance]
(Int -> ReadS ToInstance)
-> ReadS [ToInstance]
-> ReadPrec ToInstance
-> ReadPrec [ToInstance]
-> Read ToInstance
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ToInstance]
$creadListPrec :: ReadPrec [ToInstance]
readPrec :: ReadPrec ToInstance
$creadPrec :: ReadPrec ToInstance
readList :: ReadS [ToInstance]
$creadList :: ReadS [ToInstance]
readsPrec :: Int -> ReadS ToInstance
$creadsPrec :: Int -> ReadS ToInstance
Read, Typeable ToInstance
DataType
Constr
Typeable ToInstance
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> ToInstance -> c ToInstance)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c ToInstance)
-> (ToInstance -> Constr)
-> (ToInstance -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c ToInstance))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c ToInstance))
-> ((forall b. Data b => b -> b) -> ToInstance -> ToInstance)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> ToInstance -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> ToInstance -> r)
-> (forall u. (forall d. Data d => d -> u) -> ToInstance -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> ToInstance -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> ToInstance -> m ToInstance)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> ToInstance -> m ToInstance)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> ToInstance -> m ToInstance)
-> Data ToInstance
ToInstance -> DataType
ToInstance -> Constr
(forall b. Data b => b -> b) -> ToInstance -> ToInstance
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ToInstance -> c ToInstance
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ToInstance
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) -> ToInstance -> u
forall u. (forall d. Data d => d -> u) -> ToInstance -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ToInstance -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ToInstance -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ToInstance -> m ToInstance
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ToInstance -> m ToInstance
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ToInstance
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ToInstance -> c ToInstance
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ToInstance)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c ToInstance)
$cToInstance :: Constr
$tToInstance :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> ToInstance -> m ToInstance
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ToInstance -> m ToInstance
gmapMp :: (forall d. Data d => d -> m d) -> ToInstance -> m ToInstance
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ToInstance -> m ToInstance
gmapM :: (forall d. Data d => d -> m d) -> ToInstance -> m ToInstance
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ToInstance -> m ToInstance
gmapQi :: Int -> (forall d. Data d => d -> u) -> ToInstance -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> ToInstance -> u
gmapQ :: (forall d. Data d => d -> u) -> ToInstance -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> ToInstance -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ToInstance -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ToInstance -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ToInstance -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ToInstance -> r
gmapT :: (forall b. Data b => b -> b) -> ToInstance -> ToInstance
$cgmapT :: (forall b. Data b => b -> b) -> ToInstance -> ToInstance
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c ToInstance)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c ToInstance)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c ToInstance)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ToInstance)
dataTypeOf :: ToInstance -> DataType
$cdataTypeOf :: ToInstance -> DataType
toConstr :: ToInstance -> Constr
$ctoConstr :: ToInstance -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ToInstance
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ToInstance
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ToInstance -> c ToInstance
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ToInstance -> c ToInstance
$cp1Data :: Typeable ToInstance
Data)

-- | Run `ToInstance` plugin pass
toInstancePass :: CorePluginEnvRef -> CoreToDo
toInstancePass :: CorePluginEnvRef -> CoreToDo
toInstancePass CorePluginEnvRef
eref = String -> CorePluginPass -> CoreToDo
CoreDoPluginPass String
"Data.Constraint.Deriving.ToInstance"
  -- 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
toInstancePass' ModGuts
x) CorePluginEnvRef
eref)

toInstancePass' :: ModGuts -> CorePluginM ModGuts
toInstancePass' :: ModGuts -> CorePluginM ModGuts
toInstancePass' ModGuts
gs = [CoreBind]
-> UniqMap [(Name, ToInstance)] -> ModGuts -> CorePluginM ModGuts
go ([CoreBind] -> [CoreBind]
forall a. [a] -> [a]
reverse ([CoreBind] -> [CoreBind]) -> [CoreBind] -> [CoreBind]
forall a b. (a -> b) -> a -> b
$ ModGuts -> [CoreBind]
mg_binds ModGuts
gs) UniqMap [(Name, ToInstance)]
annotateds ModGuts
gs
  where
    annotateds :: UniqMap [(Name, ToInstance)]
    annotateds :: UniqMap [(Name, ToInstance)]
annotateds = ModGuts -> UniqMap [(Name, ToInstance)]
forall a. Data a => ModGuts -> UniqMap [(Name, a)]
getModuleAnns ModGuts
gs

    go :: [CoreBind] -> UniqMap [(Name, ToInstance)] -> ModGuts -> CorePluginM ModGuts
    -- All exports are processed, just return ModGuts
    go :: [CoreBind]
-> UniqMap [(Name, ToInstance)] -> ModGuts -> CorePluginM ModGuts
go [] UniqMap [(Name, ToInstance)]
anns ModGuts
guts = do
      Bool -> CorePluginM () -> CorePluginM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (UniqMap [(Name, ToInstance)] -> Bool
forall elt. UniqFM elt -> Bool
isNullUFM UniqMap [(Name, ToInstance)]
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 ToInstance annotations are ignored:"
          SDoc -> SDoc -> SDoc
$+$ [SDoc] -> SDoc
vcat
            (((Name, ToInstance) -> SDoc) -> [(Name, ToInstance)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> SDoc
pprBulletNameLoc (Name -> SDoc)
-> ((Name, ToInstance) -> Name) -> (Name, ToInstance) -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, ToInstance) -> Name
forall a b. (a, b) -> a
fst) ([(Name, ToInstance)] -> [SDoc])
-> ([[(Name, ToInstance)]] -> [(Name, ToInstance)])
-> [[(Name, ToInstance)]]
-> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Name, ToInstance)]] -> [(Name, ToInstance)]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[(Name, ToInstance)]] -> [SDoc])
-> [[(Name, ToInstance)]] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ UniqMap [(Name, ToInstance)] -> [[(Name, ToInstance)]]
forall elt. UniqFM elt -> [elt]
eltsUFM UniqMap [(Name, ToInstance)]
anns)
          SDoc -> SDoc -> SDoc
$$ SDoc
"Note possible issues:"
          SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
pprNotes
           [ SDoc
"ToInstance is meant to be used only on bindings of type Ctx => Dict (Class t1 .. tn)."
           , SDoc
"Currently, I process non-recursive bindings only."
           , [SDoc] -> SDoc
sep
             [ SDoc
"Non-exported bindings may vanish before the plugin pass:"
             , SDoc
"make sure you export annotated definitions!"
             ]
           ]
      ModGuts -> CorePluginM ModGuts
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts

    -- process type definitions present in the set of annotations
    go (cbx :: CoreBind
cbx@(NonRec CoreBndr
x Expr CoreBndr
_):[CoreBind]
xs) UniqMap [(Name, ToInstance)]
anns ModGuts
guts
      | Just ((Name
xn, ToInstance
ti):[(Name, ToInstance)]
ds) <- UniqMap [(Name, ToInstance)]
-> Unique -> Maybe [(Name, ToInstance)]
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqMap [(Name, ToInstance)]
anns (CoreBndr -> Unique
forall a. Uniquable a => a -> Unique
getUnique CoreBndr
x) = do
      Bool -> CorePluginM () -> CorePluginM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Name, ToInstance)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, ToInstance)]
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 ToInstance annotations" SDoc -> SDoc -> SDoc
$$
          [SDoc] -> SDoc
hcat
          [ SDoc
"(the plugin needs only one annotation per binding, but got "
          , Int -> SDoc
speakN ([(Name, ToInstance)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, ToInstance)]
ds Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          , SDoc
")"
          ]
      -- add new definitions and continue
      CorePluginM (ClsInst, CoreBind)
-> CorePluginM (Maybe (ClsInst, CoreBind))
forall a. CorePluginM a -> CorePluginM (Maybe a)
try (ToInstance -> CoreBind -> CorePluginM (ClsInst, CoreBind)
toInstance ToInstance
ti CoreBind
cbx) CorePluginM (Maybe (ClsInst, CoreBind))
-> (Maybe (ClsInst, CoreBind) -> CorePluginM ModGuts)
-> CorePluginM ModGuts
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (ClsInst, CoreBind)
Nothing
          -> [CoreBind]
-> UniqMap [(Name, ToInstance)] -> ModGuts -> CorePluginM ModGuts
go [CoreBind]
xs (UniqMap [(Name, ToInstance)]
-> Unique -> UniqMap [(Name, ToInstance)]
forall key elt. Uniquable key => UniqFM elt -> key -> UniqFM elt
delFromUFM UniqMap [(Name, ToInstance)]
anns (CoreBndr -> Unique
forall a. Uniquable a => a -> Unique
getUnique CoreBndr
x)) ModGuts
guts
        Just (ClsInst
newInstance, CoreBind
newBind)
          -> [CoreBind]
-> UniqMap [(Name, ToInstance)] -> ModGuts -> CorePluginM ModGuts
go [CoreBind]
xs (UniqMap [(Name, ToInstance)]
-> Unique -> UniqMap [(Name, ToInstance)]
forall key elt. Uniquable key => UniqFM elt -> key -> UniqFM elt
delFromUFM UniqMap [(Name, ToInstance)]
anns (CoreBndr -> Unique
forall a. Uniquable a => a -> Unique
getUnique CoreBndr
x))
              (ClsInst -> CoreBind -> ModGuts -> ModGuts
replaceInstance ClsInst
newInstance CoreBind
newBind ModGuts
guts)
                { -- Remove original binding from the export list
                  --                                if it was there.
                  mg_exports :: [AvailInfo]
mg_exports  = (Name -> Bool) -> [AvailInfo] -> [AvailInfo]
filterAvails (Name
xn Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/=) ([AvailInfo] -> [AvailInfo]) -> [AvailInfo] -> [AvailInfo]
forall a b. (a -> b) -> a -> b
$ ModGuts -> [AvailInfo]
mg_exports ModGuts
guts
                }

    -- ignore the rest of bindings
    go (CoreBind
_:[CoreBind]
xs) UniqMap [(Name, ToInstance)]
anns ModGuts
guts = [CoreBind]
-> UniqMap [(Name, ToInstance)] -> ModGuts -> CorePluginM ModGuts
go [CoreBind]
xs UniqMap [(Name, ToInstance)]
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]
    pprNotes :: [SDoc] -> SDoc
pprNotes = [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SDoc -> SDoc) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\SDoc
x -> [SDoc] -> SDoc
hsep [SDoc
" ", SDoc
bullet, SDoc
x])

-- | Transform a given CoreBind into an instance.
--
--   The input core bind must have type `Ctx => Dict (Class t1 .. tn)`
--
--   The output is `instance {-# overlapMode #-} Ctx => Class t1 ... tn`
toInstance :: ToInstance -> CoreBind -> CorePluginM (ClsInst, CoreBind)

toInstance :: ToInstance -> CoreBind -> CorePluginM (ClsInst, CoreBind)
toInstance ToInstance
_ (Rec [(CoreBndr, Expr CoreBndr)]
xs) = do
    SrcSpan
loc <- CoreM SrcSpan -> CorePluginM SrcSpan
forall a. CoreM a -> CorePluginM a
liftCoreM CoreM SrcSpan
getSrcSpanM
    SrcSpan -> SDoc -> CorePluginM (ClsInst, CoreBind)
forall a. SrcSpan -> SDoc -> CorePluginM a
pluginLocatedError
        (SrcSpan -> Maybe SrcSpan -> SrcSpan
forall a. a -> Maybe a -> a
fromMaybe SrcSpan
loc (Maybe SrcSpan -> SrcSpan) -> Maybe SrcSpan -> SrcSpan
forall a b. (a -> b) -> a -> b
$ First SrcSpan -> Maybe SrcSpan
forall a. First a -> Maybe a
getFirst (First SrcSpan -> Maybe SrcSpan) -> First SrcSpan -> Maybe SrcSpan
forall a b. (a -> b) -> a -> b
$ ((CoreBndr, Expr CoreBndr) -> First SrcSpan)
-> [(CoreBndr, Expr CoreBndr)] -> First SrcSpan
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe SrcSpan -> First SrcSpan
forall a. Maybe a -> First a
First (Maybe SrcSpan -> First SrcSpan)
-> ((CoreBndr, Expr CoreBndr) -> Maybe SrcSpan)
-> (CoreBndr, Expr CoreBndr)
-> First SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Maybe SrcSpan
forall a. a -> Maybe a
Just (SrcSpan -> Maybe SrcSpan)
-> ((CoreBndr, Expr CoreBndr) -> SrcSpan)
-> (CoreBndr, Expr CoreBndr)
-> Maybe SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> SrcSpan
nameSrcSpan (Name -> SrcSpan)
-> ((CoreBndr, Expr CoreBndr) -> Name)
-> (CoreBndr, Expr CoreBndr)
-> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Name
forall a. NamedThing a => a -> Name
getName (CoreBndr -> Name)
-> ((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> (CoreBndr, Expr CoreBndr)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreBndr, Expr CoreBndr) -> CoreBndr
forall a b. (a, b) -> a
fst) [(CoreBndr, Expr CoreBndr)]
xs)
      (SDoc -> CorePluginM (ClsInst, CoreBind))
-> SDoc -> CorePluginM (ClsInst, CoreBind)
forall a b. (a -> b) -> a -> b
$ SDoc
"ToInstance plugin pass does not support recursive bindings"
      SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
hsep [SDoc
"(group:", [Name] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList (((CoreBndr, Expr CoreBndr) -> Name)
-> [(CoreBndr, Expr CoreBndr)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr -> Name
forall a. NamedThing a => a -> Name
getName (CoreBndr -> Name)
-> ((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> (CoreBndr, Expr CoreBndr)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreBndr, Expr CoreBndr) -> CoreBndr
forall a b. (a, b) -> a
fst) [(CoreBndr, Expr CoreBndr)]
xs), SDoc
")"]

toInstance (ToInstance OverlapMode
omode) (NonRec CoreBndr
bindVar Expr CoreBndr
bindExpr) = do
    -- check if all type arguments are constraint arguments
    Bool -> CorePluginM () -> CorePluginM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Type -> Bool
tcIsConstraintKind (Type -> Bool) -> (Type -> Type) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Type -> Type
Type -> Type
typeKind) [Type]
theta) (CorePluginM () -> CorePluginM ())
-> CorePluginM () -> CorePluginM ()
forall a b. (a -> b) -> a -> b
$
      SrcSpan -> SDoc -> CorePluginM ()
forall a. SrcSpan -> SDoc -> CorePluginM a
pluginLocatedError SrcSpan
loc SDoc
notGoodMsg

    -- get necessary definitions
    TyCon
tcBareConstraint <- (CorePluginEnv -> CorePluginM TyCon) -> CorePluginM TyCon
forall a. (CorePluginEnv -> CorePluginM a) -> CorePluginM a
ask CorePluginEnv -> CorePluginM TyCon
tyConBareConstraint
    TyCon
tcDict <- (CorePluginEnv -> CorePluginM TyCon) -> CorePluginM TyCon
forall a. (CorePluginEnv -> CorePluginM a) -> CorePluginM a
ask CorePluginEnv -> CorePluginM TyCon
tyConDict
    CoreBndr
fDictToBare <- (CorePluginEnv -> CorePluginM CoreBndr) -> CorePluginM CoreBndr
forall a. (CorePluginEnv -> CorePluginM a) -> CorePluginM a
ask CorePluginEnv -> CorePluginM CoreBndr
funDictToBare
    CoreBndr
varCls <- Type -> CorePluginM CoreBndr
newTyVar Type
constraintKind
    let tyMatcher :: Type
tyMatcher = TyCon -> [Type] -> Type
mkTyConApp TyCon
tcDict [CoreBndr -> Type
mkTyVarTy CoreBndr
varCls]

    -- Get instance definition
    TCvSubst
match <- case Type -> Type -> Maybe TCvSubst
tcMatchTy Type
tyMatcher Type
dictTy of
      Maybe TCvSubst
Nothing -> SrcSpan -> SDoc -> CorePluginM TCvSubst
forall a. SrcSpan -> SDoc -> CorePluginM a
pluginLocatedError SrcSpan
loc SDoc
notGoodMsg
      Just TCvSubst
ma -> TCvSubst -> CorePluginM TCvSubst
forall (f :: * -> *) a. Applicative f => a -> f a
pure TCvSubst
ma
    let matchedTy :: Type
matchedTy = TCvSubst -> CoreBndr -> Type
substTyVar TCvSubst
match CoreBndr
varCls
        instSig :: Type
instSig = [CoreBndr] -> Type -> Type
mkSpecForAllTys [CoreBndr]
bndrs (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> Type
mkInvisFunTysMany [Type]
theta Type
matchedTy
        bindBareTy :: Type
bindBareTy = [CoreBndr] -> Type -> Type
mkSpecForAllTys [CoreBndr]
bndrs (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> Type
mkInvisFunTysMany [Type]
theta (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ TyCon -> [Type] -> Type
mkTyConApp TyCon
tcBareConstraint [Type
matchedTy]

    -- check if constraint is indeed a class and get it
    Class
matchedClass <- case Type -> Maybe TyCon
tyConAppTyCon_maybe Type
matchedTy Maybe TyCon -> (TyCon -> Maybe Class) -> Maybe Class
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TyCon -> Maybe Class
tyConClass_maybe of
      Maybe Class
Nothing -> SrcSpan -> SDoc -> CorePluginM Class
forall a. SrcSpan -> SDoc -> CorePluginM a
pluginLocatedError SrcSpan
loc SDoc
notGoodMsg
      Just Class
cl -> Class -> CorePluginM Class
forall (f :: * -> *) a. Applicative f => a -> f a
pure Class
cl

    -- try to apply dictToBare to the expression of the found binding
    Maybe (Expr CoreBndr)
mnewExpr <- CorePluginM (Expr CoreBndr) -> CorePluginM (Maybe (Expr CoreBndr))
forall a. CorePluginM a -> CorePluginM (Maybe a)
try (CorePluginM (Expr CoreBndr)
 -> CorePluginM (Maybe (Expr CoreBndr)))
-> CorePluginM (Expr CoreBndr)
-> CorePluginM (Maybe (Expr CoreBndr))
forall a b. (a -> b) -> a -> b
$ Type -> CoreBndr -> Expr CoreBndr -> CorePluginM (Expr CoreBndr)
unwrapDictExpr Type
dictTy CoreBndr
fDictToBare Expr CoreBndr
bindExpr
    Expr CoreBndr
newExpr  <- case Maybe (Expr CoreBndr)
mnewExpr of
      Maybe (Expr CoreBndr)
Nothing -> SrcSpan -> SDoc -> CorePluginM (Expr CoreBndr)
forall a. SrcSpan -> SDoc -> CorePluginM a
pluginLocatedError SrcSpan
loc SDoc
notGoodMsg
      Just Expr CoreBndr
ex -> Expr CoreBndr -> CorePluginM (Expr CoreBndr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr CoreBndr -> CorePluginM (Expr CoreBndr))
-> Expr CoreBndr -> CorePluginM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ Expr CoreBndr -> CoercionR -> Expr CoreBndr
mkCast Expr CoreBndr
ex
                      (CoercionR -> Expr CoreBndr) -> CoercionR -> Expr CoreBndr
forall a b. (a -> b) -> a -> b
$ String -> Role -> Type -> Type -> CoercionR
mkPluginCo String
"(BareConstraint c ~ c)" Role
Representational Type
bindBareTy Type
instSig


    OverlapMode
-> Class
-> CoreBndr
-> Expr CoreBndr
-> CorePluginM (ClsInst, CoreBind)
mkNewInstance OverlapMode
omode Class
matchedClass CoreBndr
bindVar Expr CoreBndr
newExpr

  where
    origBindTy :: Type
origBindTy = CoreBndr -> Type
idType CoreBndr
bindVar
    ([CoreBndr]
bndrs, Type
bindTy) = Type -> ([CoreBndr], Type)
splitForAllTys Type
origBindTy
    ([Type]
theta, Type
dictTy) = Type -> ([Type], Type)
splitFunTysCompat Type
bindTy
    loc :: SrcSpan
loc = Name -> SrcSpan
nameSrcSpan (Name -> SrcSpan) -> Name -> SrcSpan
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Name
forall a. NamedThing a => a -> Name
getName CoreBndr
bindVar
    notGoodMsg :: SDoc
notGoodMsg =
         SDoc
"ToInstance plugin pass failed to process a Dict declaraion."
      SDoc -> SDoc -> SDoc
$$ SDoc
"The declaration must have form `forall a1..an . Ctx => Dict (Cls t1..tn)'"
      SDoc -> SDoc -> SDoc
$$ SDoc
"Declaration:"
      SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
hcat
         [ SDoc
"  "
         , CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
bindVar, SDoc
" :: "
         , Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
origBindTy
         ]
      SDoc -> SDoc -> SDoc
$$ SDoc
""
      SDoc -> SDoc -> SDoc
$$ SDoc
"Please check:"
      SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
vcat
       ( (SDoc -> SDoc) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\SDoc
s -> [SDoc] -> SDoc
hsep  [SDoc
" ", SDoc
bullet, SDoc
s])
         [ SDoc
"It must not have arguments (i.e. is it not a fuction, but a value);"
         , SDoc
"It must have type Dict;"
         , SDoc
"The argument of Dict must be a single class (e.g. no constraint tuples or equalities);"
         , SDoc
"It must not have implicit arguments or any other complicated things."
         ]
       )

-- This fails if the CoreExpr type is not valid instance signature.
mkNewInstance :: OverlapMode
              -> Class
              -> Id -- ^ Original core binding (with old type)
              -> CoreExpr -- ^ implementation, with a proper new type (instance signature)
              -> CorePluginM (ClsInst, CoreBind)
mkNewInstance :: OverlapMode
-> Class
-> CoreBndr
-> Expr CoreBndr
-> CorePluginM (ClsInst, CoreBind)
mkNewInstance OverlapMode
omode Class
cls CoreBndr
bindVar Expr CoreBndr
bindExpr = do
    Name
n <- NameSpace -> String -> CorePluginM Name
newName NameSpace
varName
       (String -> CorePluginM Name) -> String -> CorePluginM Name
forall a b. (a -> b) -> a -> b
$ CoreBndr -> String
forall a. NamedThing a => a -> String
getOccString CoreBndr
bindVar String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_ToInstance"
    let iDFunId :: CoreBndr
iDFunId = IdDetails -> Name -> Type -> CoreBndr
mkExportedLocalId
          (Bool -> IdDetails
DFunId (Bool -> IdDetails) -> Bool -> IdDetails
forall a b. (a -> b) -> a -> b
$ TyCon -> Bool
isNewTyCon (Class -> TyCon
classTyCon Class
cls))
          Name
n Type
itype
    (ClsInst, CoreBind) -> CorePluginM (ClsInst, CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return
      ( CoreBndr -> OverlapFlag -> [CoreBndr] -> Class -> [Type] -> ClsInst
mkLocalInstance CoreBndr
iDFunId OverlapFlag
ioflag [CoreBndr]
tvs Class
cls [Type]
tys
      , CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
iDFunId Expr CoreBndr
bindExpr
      )
  where
    ioflag :: OverlapFlag
ioflag  = OverlapMode -> OverlapFlag
toOverlapFlag OverlapMode
omode
    itype :: Type
itype   = Expr CoreBndr -> Type
exprType Expr CoreBndr
bindExpr

    ([CoreBndr]
tvs, Type
itype') = Type -> ([CoreBndr], Type)
splitForAllTys Type
itype
    ([Type]
_, Type
typeBody) = Type -> ([Type], Type)
splitFunTysCompat Type
itype'
    tys :: [Type]
tys = [Type] -> Maybe [Type] -> [Type]
forall a. a -> Maybe a -> a
fromMaybe [Type]
forall a. a
aAaaOmg (Maybe [Type] -> [Type]) -> Maybe [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ Type -> Maybe [Type]
tyConAppArgs_maybe Type
typeBody
    aAaaOmg :: a
aAaaOmg = String -> SDoc -> a
forall a. String -> SDoc -> a
panicDoc String
"ToInstance" (SDoc -> a) -> SDoc -> a
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep
      [ SDoc
"Impossible happened:"
      , SDoc
"expected a class constructor in mkNewInstance, but got"
      , Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
typeBody
      , 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
$ CoreBndr -> Name
forall a. NamedThing a => a -> Name
getName CoreBndr
bindVar
      ]


-- | Go through type applications and apply dictToBare function on `Dict c` type
unwrapDictExpr :: Type
                  -- ^ Dict c
                  --
                  --   Serves as stop test (if rhs expression matches the type)
               -> Id
                  -- ^ dictToBare :: forall (c :: Constraint) . Dict c -> BareConstraint c
               -> CoreExpr
                  -- ^ forall a1..an . (Ctx1,.. Ctxn) => Dict c
               -> CorePluginM CoreExpr
                  -- ^ forall a1..an . (Ctx1,.. Ctxn) => BareConstraint c
unwrapDictExpr :: Type -> CoreBndr -> Expr CoreBndr -> CorePluginM (Expr CoreBndr)
unwrapDictExpr Type
dictT CoreBndr
unwrapFun Expr CoreBndr
ex = case Expr CoreBndr
ex of
    Var CoreBndr
_      -> CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr)
testNWrap CorePluginM (Expr CoreBndr)
forall a. CorePluginM a
unwrapFail CorePluginM (Expr CoreBndr)
-> CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (CorePluginM (Expr CoreBndr)
mkLamApp CorePluginM (Expr CoreBndr)
-> (Expr CoreBndr -> CorePluginM (Expr CoreBndr))
-> CorePluginM (Expr CoreBndr)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Expr CoreBndr -> CorePluginM (Expr CoreBndr)
proceed)
    Lit Literal
_      -> CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr)
testNWrap CorePluginM (Expr CoreBndr)
forall a. CorePluginM a
unwrapFail
    App Expr CoreBndr
e Expr CoreBndr
a    -> CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr)
testNWrap (CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr))
-> CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ (Expr CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. Expr b -> Expr b -> Expr b
App Expr CoreBndr
e (Expr CoreBndr -> Expr CoreBndr)
-> CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr CoreBndr -> CorePluginM (Expr CoreBndr)
proceed Expr CoreBndr
a) CorePluginM (Expr CoreBndr)
-> CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Expr CoreBndr -> Expr CoreBndr -> Expr CoreBndr)
-> Expr CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Expr CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. Expr b -> Expr b -> Expr b
App Expr CoreBndr
a (Expr CoreBndr -> Expr CoreBndr)
-> CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr CoreBndr -> CorePluginM (Expr CoreBndr)
proceed Expr CoreBndr
e)
    Lam CoreBndr
b Expr CoreBndr
e    -> CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr)
testNWrap (CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr))
-> CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
b (Expr CoreBndr -> Expr CoreBndr)
-> CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr CoreBndr -> CorePluginM (Expr CoreBndr)
proceed Expr CoreBndr
e
    Let CoreBind
b Expr CoreBndr
e    -> CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr)
testNWrap (CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr))
-> CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ CoreBind -> Expr CoreBndr -> Expr CoreBndr
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
b (Expr CoreBndr -> Expr CoreBndr)
-> CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr CoreBndr -> CorePluginM (Expr CoreBndr)
proceed Expr CoreBndr
e
    Case{}     -> CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr)
testNWrap CorePluginM (Expr CoreBndr)
forall a. CorePluginM a
unwrapFail
    Cast{}     -> CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr)
testNWrap CorePluginM (Expr CoreBndr)
forall a. CorePluginM a
unwrapFail
    Tick Tickish CoreBndr
t Expr CoreBndr
e   -> CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr)
testNWrap (CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr))
-> CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ Tickish CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. Tickish CoreBndr -> Expr b -> Expr b
Tick Tickish CoreBndr
t (Expr CoreBndr -> Expr CoreBndr)
-> CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr CoreBndr -> CorePluginM (Expr CoreBndr)
proceed Expr CoreBndr
e
    Type{}     -> CorePluginM (Expr CoreBndr)
forall a. CorePluginM a
unwrapFail
    Coercion{} -> CorePluginM (Expr CoreBndr)
forall a. CorePluginM a
unwrapFail
  where
    unwrapFail :: CorePluginM a
unwrapFail = SDoc -> CorePluginM a
forall a. SDoc -> CorePluginM a
pluginError
      (SDoc -> CorePluginM a) -> SDoc -> CorePluginM a
forall a b. (a -> b) -> a -> b
$  SDoc
"Failed to match a definition signature."
      SDoc -> SDoc -> SDoc
$$ SDoc -> Int -> SDoc -> SDoc
hang SDoc
"Looking for a dictionary:" Int
2 (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
dictT)
      SDoc -> SDoc -> SDoc
$$ SDoc -> Int -> SDoc -> SDoc
hang SDoc
"Inspecting an expression:" Int
2
              ([SDoc] -> SDoc
hsep [Expr CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr Expr CoreBndr
ex, SDoc
"::", Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Type -> SDoc) -> Type -> SDoc
forall a b. (a -> b) -> a -> b
$ Expr CoreBndr -> Type
exprType Expr CoreBndr
ex])
    proceed :: Expr CoreBndr -> CorePluginM (Expr CoreBndr)
proceed = Type -> CoreBndr -> Expr CoreBndr -> CorePluginM (Expr CoreBndr)
unwrapDictExpr Type
dictT CoreBndr
unwrapFun
    testNWrap :: CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr)
testNWrap CorePluginM (Expr CoreBndr)
go = if Expr CoreBndr -> Bool
testType Expr CoreBndr
ex then Expr CoreBndr -> CorePluginM (Expr CoreBndr)
wrap Expr CoreBndr
ex else CorePluginM (Expr CoreBndr)
go
    wrap :: Expr CoreBndr -> CorePluginM (Expr CoreBndr)
wrap Expr CoreBndr
e = ((Expr CoreBndr -> Expr CoreBndr)
 -> CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr))
-> CorePluginM (Expr CoreBndr)
-> (Expr CoreBndr -> Expr CoreBndr)
-> CorePluginM (Expr CoreBndr)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Expr CoreBndr -> Expr CoreBndr)
-> CorePluginM (Expr CoreBndr) -> CorePluginM (Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Expr CoreBndr -> CorePluginM (Expr CoreBndr)
forall b. Expr CoreBndr -> CorePluginM (Expr b)
getClsT Expr CoreBndr
e) ((Expr CoreBndr -> Expr CoreBndr) -> CorePluginM (Expr CoreBndr))
-> (Expr CoreBndr -> Expr CoreBndr) -> CorePluginM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ \Expr CoreBndr
t -> CoreBndr -> Expr CoreBndr
forall b. CoreBndr -> Expr b
Var CoreBndr
unwrapFun Expr CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. Expr b -> Expr b -> Expr b
`App` Expr CoreBndr
t Expr CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. Expr b -> Expr b -> Expr b
`App` Expr CoreBndr
e
    -- type variables may differ, so I need to use tcMatchTy.
    -- I do not check if resulting substition is not trivial. Shall I?
    testType :: Expr CoreBndr -> Bool
testType = Maybe TCvSubst -> Bool
forall a. Maybe a -> Bool
isJust (Maybe TCvSubst -> Bool)
-> (Expr CoreBndr -> Maybe TCvSubst) -> Expr CoreBndr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Maybe TCvSubst
tcMatchTy Type
dictT (Type -> Maybe TCvSubst)
-> (Expr CoreBndr -> Type) -> Expr CoreBndr -> Maybe TCvSubst
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr CoreBndr -> Type
exprType
    getClsT :: Expr CoreBndr -> CorePluginM (Expr b)
getClsT Expr CoreBndr
e = case Type -> Maybe [Type]
tyConAppArgs_maybe (Type -> Maybe [Type]) -> Type -> Maybe [Type]
forall a b. (a -> b) -> a -> b
$ Expr CoreBndr -> Type
exprType Expr CoreBndr
e of
      Just [Type
t] -> Expr b -> CorePluginM (Expr b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr b -> CorePluginM (Expr b)) -> Expr b -> CorePluginM (Expr b)
forall a b. (a -> b) -> a -> b
$ Type -> Expr b
forall b. Type -> Expr b
Type Type
t
      Maybe [Type]
_        -> CorePluginM (Expr b)
forall a. CorePluginM a
unwrapFail
    mkThetaVar :: (Int, Type) -> CorePluginM CoreBndr
mkThetaVar (Int
i, Type
ty) = Type -> String -> CorePluginM CoreBndr
newLocalVar Type
ty (String
"theta" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
i :: Int))
    mkLamApp :: CorePluginM (Expr CoreBndr)
mkLamApp =
      let et0 :: Type
et0          = Expr CoreBndr -> Type
exprType Expr CoreBndr
ex
          ([CoreBndr]
bndrs, Type
et1) = Type -> ([CoreBndr], Type)
splitForAllTys Type
et0
          ([Type]
theta, Type
_  ) = Type -> ([Type], Type)
splitFunTysCompat Type
et1
      in  if [CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreBndr]
bndrs Bool -> Bool -> Bool
&& [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
theta
            then CorePluginM (Expr CoreBndr)
forall a. CorePluginM a
unwrapFail
            else do
              [CoreBndr]
thetaVars <- ((Int, Type) -> CorePluginM CoreBndr)
-> [(Int, Type)] -> CorePluginM [CoreBndr]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Int, Type) -> CorePluginM CoreBndr
mkThetaVar ([(Int, Type)] -> CorePluginM [CoreBndr])
-> [(Int, Type)] -> CorePluginM [CoreBndr]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Type] -> [(Int, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] [Type]
theta
              let allVars :: [CoreBndr]
allVars      = [CoreBndr]
bndrs [CoreBndr] -> [CoreBndr] -> [CoreBndr]
forall a. [a] -> [a] -> [a]
++ [CoreBndr]
thetaVars
                  allApps :: [Expr b]
allApps      = (CoreBndr -> Expr b) -> [CoreBndr] -> [Expr b]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Expr b
forall b. Type -> Expr b
Type (Type -> Expr b) -> (CoreBndr -> Type) -> CoreBndr -> Expr b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Type
mkTyVarTy) [CoreBndr]
bndrs [Expr b] -> [Expr b] -> [Expr b]
forall a. [a] -> [a] -> [a]
++ (CoreBndr -> Expr b) -> [CoreBndr] -> [Expr b]
forall a b. (a -> b) -> [a] -> [b]
map CoreBndr -> Expr b
forall b. CoreBndr -> Expr b
Var [CoreBndr]
thetaVars
                  fullyApplied :: Expr CoreBndr
fullyApplied = (Expr CoreBndr -> Expr CoreBndr -> Expr CoreBndr)
-> Expr CoreBndr -> [Expr CoreBndr] -> Expr CoreBndr
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Expr CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. Expr b -> Expr b -> Expr b
App Expr CoreBndr
ex [Expr CoreBndr]
forall b. [Expr b]
allApps
              Expr CoreBndr -> CorePluginM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr -> CorePluginM (Expr CoreBndr))
-> Expr CoreBndr -> CorePluginM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ (CoreBndr -> Expr CoreBndr -> Expr CoreBndr)
-> Expr CoreBndr -> [CoreBndr] -> Expr CoreBndr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. b -> Expr b -> Expr b
Lam Expr CoreBndr
fullyApplied [CoreBndr]
allVars


-- | Replace instance in ModGuts if its duplicate already exists there;
--   otherwise just add this instance.
replaceInstance :: ClsInst -> CoreBind -> ModGuts -> ModGuts
replaceInstance :: ClsInst -> CoreBind -> ModGuts -> ModGuts
replaceInstance ClsInst
newI CoreBind
newB ModGuts
guts
  | NonRec CoreBndr
_ Expr CoreBndr
newE <- CoreBind
newB
  , First (Just ClsInst
oldI) <- (ClsInst -> First ClsInst) -> [ClsInst] -> First ClsInst
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ClsInst -> First ClsInst
sameInst ([ClsInst] -> First ClsInst) -> [ClsInst] -> First ClsInst
forall a b. (a -> b) -> a -> b
$ ModGuts -> [ClsInst]
mg_insts ModGuts
guts
  , CoreBndr
newDFunId <- ClsInst -> CoreBndr
instanceDFunId ClsInst
newI
  , CoreBndr
origDFunId <- ClsInst -> CoreBndr
instanceDFunId ClsInst
oldI
  , CoreBndr
dFunId <- CoreBndr
newDFunId CoreBndr -> Name -> CoreBndr
`setVarName`   CoreBndr -> Name
idName CoreBndr
origDFunId
                        CoreBndr -> Unique -> CoreBndr
`setVarUnique` CoreBndr -> Unique
varUnique CoreBndr
origDFunId
  , CoreBind
bind   <- CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
dFunId Expr CoreBndr
newE
  , ClsInst
inst   <- CoreBndr -> ClsInst -> ClsInst
setClsInstDfunId CoreBndr
dFunId ClsInst
newI
    = ModGuts
guts
      { mg_insts :: [ClsInst]
mg_insts    = CoreBndr -> ClsInst -> [ClsInst] -> [ClsInst]
replInst CoreBndr
origDFunId ClsInst
inst ([ClsInst] -> [ClsInst]) -> [ClsInst] -> [ClsInst]
forall a b. (a -> b) -> a -> b
$ ModGuts -> [ClsInst]
mg_insts ModGuts
guts
      , mg_inst_env :: InstEnv
mg_inst_env = ModGuts -> InstEnv
mg_inst_env ModGuts
guts
           InstEnv -> ClsInst -> InstEnv
`deleteFromInstEnv` ClsInst
oldI
           InstEnv -> ClsInst -> InstEnv
`extendInstEnv` ClsInst
inst
      , mg_binds :: [CoreBind]
mg_binds    = CoreBind
bind CoreBind -> [CoreBind] -> [CoreBind]
forall a. a -> [a] -> [a]
: CoreBndr -> [CoreBind] -> [CoreBind]
forall b. Eq b => b -> [Bind b] -> [Bind b]
remBind CoreBndr
origDFunId (ModGuts -> [CoreBind]
mg_binds ModGuts
guts)
      }
  | Bool
otherwise
    = ModGuts
guts
      { mg_insts :: [ClsInst]
mg_insts    = ClsInst
newI ClsInst -> [ClsInst] -> [ClsInst]
forall a. a -> [a] -> [a]
: ModGuts -> [ClsInst]
mg_insts ModGuts
guts
      , mg_inst_env :: InstEnv
mg_inst_env = InstEnv -> ClsInst -> InstEnv
extendInstEnv (ModGuts -> InstEnv
mg_inst_env ModGuts
guts) ClsInst
newI
      , mg_binds :: [CoreBind]
mg_binds    = CoreBind
newB CoreBind -> [CoreBind] -> [CoreBind]
forall a. a -> [a] -> [a]
: ModGuts -> [CoreBind]
mg_binds ModGuts
guts
      }
  where
    remBind :: b -> [Bind b] -> [Bind b]
remBind b
_ [] = []
    remBind b
i' (b :: Bind b
b@(NonRec b
i Expr b
_):[Bind b]
bs)
      | b
i b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
i'   = b -> [Bind b] -> [Bind b]
remBind b
i' [Bind b]
bs
      | Bool
otherwise = Bind b
b  Bind b -> [Bind b] -> [Bind b]
forall a. a -> [a] -> [a]
: b -> [Bind b] -> [Bind b]
remBind b
i' [Bind b]
bs
    remBind b
i' (Rec [(b, Expr b)]
rb :[Bind b]
bs) = [(b, Expr b)] -> Bind b
forall b. [(b, Expr b)] -> Bind b
Rec (((b, Expr b) -> Bool) -> [(b, Expr b)] -> [(b, Expr b)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((b
i' b -> b -> Bool
forall a. Eq a => a -> a -> Bool
/=) (b -> Bool) -> ((b, Expr b) -> b) -> (b, Expr b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b, Expr b) -> b
forall a b. (a, b) -> a
fst) [(b, Expr b)]
rb) Bind b -> [Bind b] -> [Bind b]
forall a. a -> [a] -> [a]
: b -> [Bind b] -> [Bind b]
remBind b
i' [Bind b]
bs
    replInst :: CoreBndr -> ClsInst -> [ClsInst] -> [ClsInst]
replInst CoreBndr
_ ClsInst
_ [] = []
    replInst CoreBndr
d' ClsInst
i' (ClsInst
i:[ClsInst]
is)
      | ClsInst -> CoreBndr
instanceDFunId ClsInst
i CoreBndr -> CoreBndr -> Bool
forall a. Eq a => a -> a -> Bool
== CoreBndr
d'   = ClsInst
i' ClsInst -> [ClsInst] -> [ClsInst]
forall a. a -> [a] -> [a]
: [ClsInst]
is
      | Bool
otherwise = ClsInst
i ClsInst -> [ClsInst] -> [ClsInst]
forall a. a -> [a] -> [a]
: CoreBndr -> ClsInst -> [ClsInst] -> [ClsInst]
replInst CoreBndr
d' ClsInst
i' [ClsInst]
is
    sameInst :: ClsInst -> First ClsInst
sameInst ClsInst
i
      = Maybe ClsInst -> First ClsInst
forall a. Maybe a -> First a
First (Maybe ClsInst -> First ClsInst) -> Maybe ClsInst -> First ClsInst
forall a b. (a -> b) -> a -> b
$ if ClsInst -> ClsInst -> Bool
identicalClsInstHead ClsInst
newI ClsInst
i then ClsInst -> Maybe ClsInst
forall a. a -> Maybe a
Just ClsInst
i else Maybe ClsInst
forall a. Maybe a
Nothing