{-# OPTIONS_GHC -ddump-splices #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Derive.TopDown.TH (deriving_th, deriving_ths, deriving_thss) where
import Data.Derive.TopDown.Lib

import Language.Haskell.TH.Lib
import Language.Haskell.TH
import Language.Haskell.TH.Syntax hiding (lift)

import Control.Monad.State
import Control.Monad.Trans
import Data.List (foldl')

genTH :: (ClassName, Name -> Q [Dec]) -> TypeName -> StateT [Type] Q [Dec]
genTH :: (ClassName, ClassName -> Q [Dec])
-> ClassName -> StateT [Type] Q [Dec]
genTH (ClassName
className,ClassName -> Q [Dec]
deriveFunction) ClassName
typeName = do
                       ([TyVarBndr]
tvbs, [Con]
cons) <- ClassName -> ClassName -> StateT [Type] Q ([TyVarBndr], [Con])
getTyVarCons ClassName
className ClassName
typeName
                       [ClassName]
compositeNames <- Q [ClassName] -> StateT [Type] Q [ClassName]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q [ClassName] -> StateT [Type] Q [ClassName])
-> Q [ClassName] -> StateT [Type] Q [ClassName]
forall a b. (a -> b) -> a -> b
$ ([[ClassName]] -> [ClassName]) -> Q [[ClassName]] -> Q [ClassName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[ClassName]] -> [ClassName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[ClassName]] -> Q [ClassName])
-> Q [[ClassName]] -> Q [ClassName]
forall a b. (a -> b) -> a -> b
$ (Con -> Q [ClassName]) -> [Con] -> Q [[ClassName]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> Q [ClassName]
getCompositeTypeNames [Con]
cons
                       let typeNames :: [ClassName]
typeNames = (TyVarBndr -> ClassName) -> [TyVarBndr] -> [ClassName]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> ClassName
getTVBName [TyVarBndr]
tvbs
                       Type
instanceType <- Q Type -> StateT [Type] Q Type
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Type -> StateT [Type] Q Type) -> Q Type -> StateT [Type] Q Type
forall a b. (a -> b) -> a -> b
$ (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Type -> Q Type -> Q Type
appT (ClassName -> Q Type
conT ClassName
typeName) ([Q Type] -> Q Type) -> [Q Type] -> Q Type
forall a b. (a -> b) -> a -> b
$ (ClassName -> Q Type) -> [ClassName] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map ClassName -> Q Type
varT [ClassName]
typeNames
                       Bool
isMember <- Q Bool -> StateT [Type] Q Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Bool -> StateT [Type] Q Bool) -> Q Bool -> StateT [Type] Q Bool
forall a b. (a -> b) -> a -> b
$ ClassName -> [Type] -> Q Bool
isInstance' ClassName
className [Type
instanceType]
                       [Type]
table <- StateT [Type] Q [Type]
forall s (m :: * -> *). MonadState s m => m s
get
                       if Bool
isMember Bool -> Bool -> Bool
|| Type -> [Type] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Type
instanceType [Type]
table
                          then [Dec] -> StateT [Type] Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                          else do
                             [Dec]
decl <- Q [Dec] -> StateT [Type] Q [Dec]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q [Dec] -> StateT [Type] Q [Dec])
-> Q [Dec] -> StateT [Type] Q [Dec]
forall a b. (a -> b) -> a -> b
$ ClassName -> Q [Dec]
deriveFunction ClassName
typeName
                             (([Type] -> [Type]) -> StateT [Type] Q ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Type
instanceType Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:))
                             [ClassName]
subTypeNames <- Q [ClassName] -> StateT [Type] Q [ClassName]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q [ClassName] -> StateT [Type] Q [ClassName])
-> Q [ClassName] -> StateT [Type] Q [ClassName]
forall a b. (a -> b) -> a -> b
$ ([[ClassName]] -> [ClassName]) -> Q [[ClassName]] -> Q [ClassName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[ClassName]] -> [ClassName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[ClassName]] -> Q [ClassName])
-> Q [[ClassName]] -> Q [ClassName]
forall a b. (a -> b) -> a -> b
$ (Con -> Q [ClassName]) -> [Con] -> Q [[ClassName]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> Q [ClassName]
getCompositeTypeNames [Con]
cons
                             [[Dec]]
decls <- (ClassName -> StateT [Type] Q [Dec])
-> [ClassName] -> StateT [Type] Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ClassName
n -> (ClassName, ClassName -> Q [Dec])
-> ClassName -> StateT [Type] Q [Dec]
genTH (ClassName
className,ClassName -> Q [Dec]
deriveFunction) ClassName
n) [ClassName]
subTypeNames
                             [Dec] -> StateT [Type] Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> StateT [Type] Q [Dec]) -> [Dec] -> StateT [Type] Q [Dec]
forall a b. (a -> b) -> a -> b
$ [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
decls [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
decl


deriving_th :: (Name, Name -> Q [Dec]) -- ^ class name and corresponding isntance generation function

           -> Name -- ^ type name

           -> Q [Dec]
deriving_th :: (ClassName, ClassName -> Q [Dec]) -> ClassName -> Q [Dec]
deriving_th (ClassName, ClassName -> Q [Dec])
cd ClassName
tname = StateT [Type] Q [Dec] -> [Type] -> Q [Dec]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ((ClassName, ClassName -> Q [Dec])
-> ClassName -> StateT [Type] Q [Dec]
genTH (ClassName, ClassName -> Q [Dec])
cd ClassName
tname) []

deriving_ths :: [(Name, Name -> Q [Dec])] -- ^ class names and corresponding instance generation functions

            -> Name -- ^ type name

            -> Q [Dec]
deriving_ths :: [(ClassName, ClassName -> Q [Dec])] -> ClassName -> Q [Dec]
deriving_ths [(ClassName, ClassName -> Q [Dec])]
cds ClassName
typeName = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (((ClassName, ClassName -> Q [Dec]) -> Q [Dec])
-> [(ClassName, ClassName -> Q [Dec])] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(ClassName, ClassName -> Q [Dec])
c -> (ClassName, ClassName -> Q [Dec]) -> ClassName -> Q [Dec]
deriving_th (ClassName, ClassName -> Q [Dec])
c ClassName
typeName) [(ClassName, ClassName -> Q [Dec])]
cds)

deriving_thss :: [(Name, Name -> Q [Dec])] -- ^ class names and corresponding instance generation functions

             -> [Name] -- ^ type names

             -> Q [Dec]
deriving_thss :: [(ClassName, ClassName -> Q [Dec])] -> [ClassName] -> Q [Dec]
deriving_thss [(ClassName, ClassName -> Q [Dec])]
cds [ClassName]
typeNames = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((ClassName -> Q [Dec]) -> [ClassName] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ClassName
t -> [(ClassName, ClassName -> Q [Dec])] -> ClassName -> Q [Dec]
deriving_ths [(ClassName, ClassName -> Q [Dec])]
cds ClassName
t) [ClassName]
typeNames)