{-# LANGUAGE TemplateHaskell #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Derive.TopDown.TH
-- Copyright   :  (c) Song Zhang
-- License     :  BSD-style (see the LICENSE file)
-- 
-- Maintainer  :  haskell.zhang.song `at` hotmail.com
-- Stability   :  experimental
-- Portability :  non-portable
--
-----------------------------------------------------------------------------

module Data.Derive.TopDown.TH
  ( deriving_th
  , deriving_ths
  , deriving_thss
  , deriving_th_with
  ) where
import           Control.Monad.State
import           Data.Derive.TopDown.IsInstance ( isInstance' )
import           Data.Derive.TopDown.Lib
import           Data.List                      ( foldl1' )
import           Language.Haskell.TH

genTH
  :: (ClassName, Name -> Q [Dec])
  -> TypeName
  -> [TypeName]
  -> StateT [Type] Q [Dec]
genTH :: (TypeName, TypeName -> Q [Dec])
-> TypeName -> [TypeName] -> StateT [Type] Q [Dec]
genTH (TypeName
className, TypeName -> Q [Dec]
deriveFunction) TypeName
typeName [TypeName]
bs = do
  ([TyVarBndr ()]
tvbs, [Con]
cons) <- Q ([TyVarBndr ()], [Con])
-> StateT [Type] Q ([TyVarBndr ()], [Con])
forall (m :: * -> *) a. Monad m => m a -> StateT [Type] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q ([TyVarBndr ()], [Con])
 -> StateT [Type] Q ([TyVarBndr ()], [Con]))
-> Q ([TyVarBndr ()], [Con])
-> StateT [Type] Q ([TyVarBndr ()], [Con])
forall a b. (a -> b) -> a -> b
$ TypeName -> Q ([TyVarBndr ()], [Con])
getTyVarCons TypeName
typeName
  let typeNames :: [TypeName]
typeNames = (TyVarBndr () -> TypeName) -> [TyVarBndr ()] -> [TypeName]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> TypeName
forall a. TyVarBndr a -> TypeName
getTVBName [TyVarBndr ()]
tvbs
  Bool
isCnHighOrderClass <- Q Bool -> StateT [Type] Q Bool
forall (m :: * -> *) a. Monad m => m a -> StateT [Type] m a
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
$ TypeName -> Q Bool
isHigherOrderClass TypeName
className
  Type
saturatedType      <- Q Type -> StateT [Type] Q Type
forall (m :: * -> *) a. Monad m => m a -> StateT [Type] m a
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
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (TypeName -> Q Type
forall (m :: * -> *). Quote m => TypeName -> m Type
conT TypeName
typeName Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
: (TypeName -> Q Type) -> [TypeName] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map TypeName -> Q Type
forall (m :: * -> *). Quote m => TypeName -> m Type
varT [TypeName]
typeNames)
  Type
instanceType       <- if Bool
isCnHighOrderClass Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> ([TypeName] -> Bool) -> [TypeName] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [TypeName]
typeNames
    then
      let pns :: [TypeName]
pns = [TypeName] -> [TypeName]
forall a. HasCallStack => [a] -> [a]
init [TypeName]
typeNames
      in  if [TypeName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeName]
pns
            then Q Type -> StateT [Type] Q Type
forall (m :: * -> *) a. Monad m => m a -> StateT [Type] m a
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
$ TypeName -> Q Type
forall (m :: * -> *). Quote m => TypeName -> m Type
conT TypeName
typeName
            else Q Type -> StateT [Type] Q Type
forall (m :: * -> *) a. Monad m => m a -> StateT [Type] m a
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
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (TypeName -> Q Type
forall (m :: * -> *). Quote m => TypeName -> m Type
conT TypeName
typeName Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
: ((TypeName -> Q Type) -> [TypeName] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map TypeName -> Q Type
forall (m :: * -> *). Quote m => TypeName -> m Type
varT [TypeName]
pns))
    else Type -> StateT [Type] Q Type
forall a. a -> StateT [Type] Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
saturatedType
  Bool
isMember <- Q Bool -> StateT [Type] Q Bool
forall (m :: * -> *) a. Monad m => m a -> StateT [Type] m a
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
$ TypeName -> [Type] -> Q Bool
isInstance' TypeName
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 a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Type
instanceType [Type]
table Bool -> Bool -> Bool
|| TypeName -> [TypeName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem TypeName
typeName [TypeName]
bs
    then [Dec] -> StateT [Type] Q [Dec]
forall a. a -> StateT [Type] Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    else do
      [Dec]
decl <- Q [Dec] -> StateT [Type] Q [Dec]
forall (m :: * -> *) a. Monad m => m a -> StateT [Type] m a
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
$ TypeName -> Q [Dec]
deriveFunction TypeName
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]
:)
      [TypeName]
subTypeNames <- Q [TypeName] -> StateT [Type] Q [TypeName]
forall (m :: * -> *) a. Monad m => m a -> StateT [Type] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q [TypeName] -> StateT [Type] Q [TypeName])
-> Q [TypeName] -> StateT [Type] Q [TypeName]
forall a b. (a -> b) -> a -> b
$ ([[TypeName]] -> [TypeName]) -> Q [[TypeName]] -> Q [TypeName]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[TypeName]] -> [TypeName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[TypeName]] -> Q [TypeName]) -> Q [[TypeName]] -> Q [TypeName]
forall a b. (a -> b) -> a -> b
$ (Con -> Q [TypeName]) -> [Con] -> Q [[TypeName]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Con -> Q [TypeName]
getCompositeTypeNames [Con]
cons
      [[Dec]]
decls <- (TypeName -> StateT [Type] Q [Dec])
-> [TypeName] -> StateT [Type] Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\TypeName
n -> (TypeName, TypeName -> Q [Dec])
-> TypeName -> [TypeName] -> StateT [Type] Q [Dec]
genTH (TypeName
className, TypeName -> Q [Dec]
deriveFunction) TypeName
n [TypeName]
bs) [TypeName]
subTypeNames
      [Dec] -> StateT [Type] Q [Dec]
forall a. a -> StateT [Type] Q a
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 :: (TypeName, TypeName -> Q [Dec]) -> TypeName -> Q [Dec]
deriving_th (TypeName, TypeName -> Q [Dec])
cd TypeName
tname = StateT [Type] Q [Dec] -> [Type] -> Q [Dec]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ((TypeName, TypeName -> Q [Dec])
-> TypeName -> [TypeName] -> StateT [Type] Q [Dec]
genTH (TypeName, TypeName -> Q [Dec])
cd TypeName
tname []) []

deriving_ths
  :: [(Name, Name -> Q [Dec])] -- ^ class names and corresponding instance generation functions
  -> Name -- ^ type name
  -> Q [Dec]
deriving_ths :: [(TypeName, TypeName -> Q [Dec])] -> TypeName -> Q [Dec]
deriving_ths [(TypeName, TypeName -> Q [Dec])]
cds TypeName
typeName =
  ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (((TypeName, TypeName -> Q [Dec]) -> Q [Dec])
-> [(TypeName, TypeName -> Q [Dec])] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(TypeName, TypeName -> Q [Dec])
c -> (TypeName, TypeName -> Q [Dec]) -> TypeName -> Q [Dec]
deriving_th (TypeName, TypeName -> Q [Dec])
c TypeName
typeName) [(TypeName, TypeName -> Q [Dec])]
cds)

deriving_thss
  :: [(Name, Name -> Q [Dec])] -- ^ class names and corresponding instance generation functions
  -> [Name] -- ^ type names
  -> Q [Dec]
deriving_thss :: [(TypeName, TypeName -> Q [Dec])] -> [TypeName] -> Q [Dec]
deriving_thss [(TypeName, TypeName -> Q [Dec])]
cds [TypeName]
typeNames =
  ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((TypeName -> Q [Dec]) -> [TypeName] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\TypeName
t -> [(TypeName, TypeName -> Q [Dec])] -> TypeName -> Q [Dec]
deriving_ths [(TypeName, TypeName -> Q [Dec])]
cds TypeName
t) [TypeName]
typeNames)

deriving_th_with
  :: (ClassName, Name -> Q [Dec]) -- ^ class name and corresponding instance generation function
  -> TypeName    -- ^ type name
  -> [TypeName]  -- ^ type name list that breaks deriving process
  -> Q [Dec]
deriving_th_with :: (TypeName, TypeName -> Q [Dec])
-> TypeName -> [TypeName] -> Q [Dec]
deriving_th_with (TypeName, TypeName -> Q [Dec])
cd TypeName
tname [TypeName]
bs = StateT [Type] Q [Dec] -> [Type] -> Q [Dec]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ((TypeName, TypeName -> Q [Dec])
-> TypeName -> [TypeName] -> StateT [Type] Q [Dec]
genTH (TypeName, TypeName -> Q [Dec])
cd TypeName
tname [TypeName]
bs) []