{-# LANGUAGE TemplateHaskell  #-}
module Data.Derive.TopDown.Standalone (
  deriving_, derivings, derivingss, deriving_with_breaks
#if __GLASGOW_HASKELL__ >= 802
  ,strategy_deriving
  ,strategy_derivings
  ,strategy_derivingss
#endif
  ) where

import Data.Derive.TopDown.Lib
import Language.Haskell.TH
import Language.Haskell.TH.Syntax hiding (lift)
import qualified GHC.Generics as G
import Control.Monad
import Control.Monad.Trans
import Control.Monad.State
import Data.List (foldl')
import Data.Primitive.Types
import Data.Typeable

#if __GLASGOW_HASKELL__ >= 802
genStandaloneDerivingDecl :: ClassName -> TypeName -> Maybe DerivStrategy -> [TypeName] -> StateT [Type] Q [Dec]
genStandaloneDerivingDecl :: ClassName
-> ClassName
-> Maybe DerivStrategy
-> [ClassName]
-> StateT [Type] Q [Dec]
genStandaloneDerivingDecl ClassName
cn ClassName
tn Maybe DerivStrategy
st [ClassName]
breaks = do
#else
genStandaloneDerivingDecl :: ClassName -> TypeName -> [TypeName] -> StateT [Type] Q [Dec]
genStandaloneDerivingDecl cn tn breaks = do
#endif
                   ([TyVarBndr]
tvbs,[Con]
cons) <- ClassName -> ClassName -> StateT [Type] Q ([TyVarBndr], [Con])
getTyVarCons ClassName
cn ClassName
tn
                   Maybe Type
classContext <- Q (Maybe Type) -> StateT [Type] Q (Maybe Type)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q (Maybe Type) -> StateT [Type] Q (Maybe Type))
-> Q (Maybe Type) -> StateT [Type] Q (Maybe Type)
forall a b. (a -> b) -> a -> b
$ ClassName -> ClassName -> Q (Maybe Type)
generateClassContext ClassName
cn ClassName
tn
                   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
tn) ([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
                    -- Stop generating further instances

                   -- 1. it is already a member of that type class

                   -- 2. we have already generated it, which is kind of same with case 1

                   -- 3. for GHC.Generic, if it is a primitive type like Int, Double

                   -- 4. It will stop on the types in breaks

                   -- 5. It will stop on primitive types and Integer when deriving Typeable

                   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
cn [Type
instanceType]              
                   Bool
isPrimitive <-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' ''Prim [Type
instanceType]
                   let isGeneric :: Bool
isGeneric = ''G.Generic ClassName -> ClassName -> Bool
forall a. Eq a => a -> a -> Bool
== ClassName
cn
                   [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 Bool -> Bool -> Bool
|| ClassName -> [ClassName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ClassName
tn [ClassName]
breaks Bool -> Bool -> Bool
||
                      (Bool
isPrimitive Bool -> Bool -> Bool
&& Bool
isGeneric) Bool -> Bool -> Bool
|| (Bool
isGeneric Bool -> Bool -> Bool
&& ClassName
tn ClassName -> ClassName -> Bool
forall a. Eq a => a -> a -> Bool
== ''Integer) Bool -> Bool -> Bool
||
                      (ClassName
cn ClassName -> ClassName -> Bool
forall a. Eq a => a -> a -> Bool
== ''Typeable Bool -> Bool -> Bool
&& Bool
isPrimitive) Bool -> Bool -> Bool
|| (ClassName
cn ClassName -> ClassName -> Bool
forall a. Eq a => a -> a -> Bool
== ''Typeable Bool -> Bool -> Bool
&& ClassName
tn ClassName -> ClassName -> Bool
forall a. Eq a => a -> a -> Bool
== ''Integer)
                     then [Dec] -> StateT [Type] Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                     else do
                       let context :: [Type]
context = case Maybe Type
classContext of
                                       Maybe Type
Nothing -> []
                                       Just Type
cc -> if Bool
isGeneric then [] else [Type
cc]
#if __GLASGOW_HASKELL__ >= 802
                       DecTyType
declareType <- Q DecTyType -> StateT [Type] Q DecTyType
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ClassName -> Q DecTyType
decType ClassName
tn)
                       let standaloneD :: Maybe DerivStrategy -> [Dec]
standaloneD = \Maybe DerivStrategy
strategy -> [Maybe DerivStrategy -> [Type] -> Type -> Dec
StandaloneDerivD Maybe DerivStrategy
strategy [Type]
context (Type -> Type -> Type
AppT (ClassName -> Type
ConT ClassName
cn) Type
instanceType)]
                       let c :: [Dec]
c = if Maybe DerivStrategy
st Maybe DerivStrategy -> Maybe DerivStrategy -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe DerivStrategy
forall a. Maybe a
Nothing
                                 then Maybe DerivStrategy -> [Dec]
standaloneD Maybe DerivStrategy
forall a. Maybe a
Nothing
                                 else case DecTyType
declareType of
                                         DecTyType
Data    -> case Maybe DerivStrategy
st of
                                               Just DerivStrategy
NewtypeStrategy -> Maybe DerivStrategy -> [Dec]
standaloneD Maybe DerivStrategy
forall a. Maybe a
Nothing
                                               Maybe DerivStrategy
_                    -> Maybe DerivStrategy -> [Dec]
standaloneD Maybe DerivStrategy
st
                                         DecTyType
_       -> Maybe DerivStrategy -> [Dec]
standaloneD Maybe DerivStrategy
st
#else
                       let c = [StandaloneDerivD context (AppT (ConT cn) instanceType)]
#endif
                       ([Type] -> [Type]) -> StateT [Type] Q ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Type
instanceTypeType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:)
                       [ClassName]
names <- 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
#if __GLASGOW_HASKELL__ >= 802
                       [[Dec]]
xs <- (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
-> Maybe DerivStrategy
-> [ClassName]
-> StateT [Type] Q [Dec]
genStandaloneDerivingDecl ClassName
cn ClassName
n Maybe DerivStrategy
st [ClassName]
breaks) [ClassName]
names
#else
                       xs <- mapM (\n -> genStandaloneDerivingDecl cn n breaks) names
#endif
                       [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]]
xs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
c


deriving_ :: Name -- ^ class name

          -> Name -- ^ type name

          -> Q [Dec]

#if __GLASGOW_HASKELL__ >= 802
deriving_ :: ClassName -> ClassName -> Q [Dec]
deriving_ ClassName
cn ClassName
tn = StateT [Type] Q [Dec] -> [Type] -> Q [Dec]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (ClassName
-> ClassName
-> Maybe DerivStrategy
-> [ClassName]
-> StateT [Type] Q [Dec]
genStandaloneDerivingDecl ClassName
cn ClassName
tn Maybe DerivStrategy
forall a. Maybe a
Nothing []) []
#else
deriving_ cn tn = evalStateT (genStandaloneDerivingDecl cn tn []) []
#endif

{- | This is particularly useful with 'Generic' class.

For the types like 'Int', 'Char','Ratio' or other types which are not 'Generic', there must be a way to stop the generation process on those types.

However, the deriving topdown function will only stop generating 'Generic' instances on primitive types and 'Integer' by default, so you do not need to break on them manually.

Another circumtances might be deriving for 'Typeable' class. Since there is a bug in GHC, isInstance function in TH library is not working on 'Typeable', you can manually give the types which are already instances of 'Typeable' to stop the generation process.

For others cases, there no need to use this function, bacause for a data type @A@ which is composited by another type, when you manually write an instance declaration for @A@, the process will stop on @A@ automatically since it is already an instance of the type class.
-}
deriving_with_breaks :: Name -- ^ class name

          -> Name -- ^ type name

          -> [Name] -- ^ type names that stop the deriving process

          -> Q [Dec]

#if __GLASGOW_HASKELL__ >= 802
deriving_with_breaks :: ClassName -> ClassName -> [ClassName] -> Q [Dec]
deriving_with_breaks ClassName
cn ClassName
tn [ClassName]
bs = StateT [Type] Q [Dec] -> [Type] -> Q [Dec]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (ClassName
-> ClassName
-> Maybe DerivStrategy
-> [ClassName]
-> StateT [Type] Q [Dec]
genStandaloneDerivingDecl ClassName
cn ClassName
tn Maybe DerivStrategy
forall a. Maybe a
Nothing [ClassName]
bs) []
#else
deriving_with_breaks cn tn bs = evalStateT (genStandaloneDerivingDecl cn tn bs) []
#endif


derivings :: [Name] -- ^ class names

          -> Name   -- ^ type name

          -> Q [Dec]
derivings :: [ClassName] -> ClassName -> Q [Dec]
derivings [ClassName]
cns ClassName
tn = ([[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
x -> ClassName -> ClassName -> Q [Dec]
deriving_ ClassName
x ClassName
tn) [ClassName]
cns)

derivingss :: [Name] -- ^ class names

           -> [Name] -- ^ type names

           -> Q [Dec]
derivingss :: [ClassName] -> [ClassName] -> Q [Dec]
derivingss [ClassName]
cns [ClassName]
tns = ([[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
x -> [ClassName] -> ClassName -> Q [Dec]
derivings [ClassName]
cns ClassName
x) [ClassName]
tns)


#if __GLASGOW_HASKELL__ >= 802
strategy_deriving :: DerivStrategy
                  -> Name
                  -> Name
                  -> Q [Dec]

strategy_deriving :: DerivStrategy -> ClassName -> ClassName -> Q [Dec]
strategy_deriving DerivStrategy
st ClassName
cn ClassName
tn = StateT [Type] Q [Dec] -> [Type] -> Q [Dec]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (ClassName
-> ClassName
-> Maybe DerivStrategy
-> [ClassName]
-> StateT [Type] Q [Dec]
genStandaloneDerivingDecl ClassName
cn ClassName
tn (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
st) []) []

strategy_derivings :: DerivStrategy
                   -> [Name]
                   -> Name
                   -> Q [Dec]

strategy_derivings :: DerivStrategy -> [ClassName] -> ClassName -> Q [Dec]
strategy_derivings DerivStrategy
st [ClassName]
cns ClassName
tn = ([[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 (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ ((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
x -> DerivStrategy -> ClassName -> ClassName -> Q [Dec]
strategy_deriving DerivStrategy
st ClassName
x ClassName
tn) [ClassName]
cns)

strategy_derivingss :: DerivStrategy
                    -> [Name]
                    -> [Name]
                    -> Q [Dec]
strategy_derivingss :: DerivStrategy -> [ClassName] -> [ClassName] -> Q [Dec]
strategy_derivingss DerivStrategy
st [ClassName]
cns [ClassName]
tns = ([[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 (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ ((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
x -> DerivStrategy -> [ClassName] -> ClassName -> Q [Dec]
strategy_derivings DerivStrategy
st [ClassName]
cns ClassName
x) [ClassName]
tns)
#endif