{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StandaloneDeriving #-}
module Language.JVM.TH
( deriveBase
, deriveBases
, deriveThese
, deriveBaseWithBinary
) where
import Language.Haskell.TH
import GHC.Generics
import Control.DeepSeq
import Data.Binary
import Language.JVM.Stage
deriveThese :: Name -> [Name] -> Q [Dec]
deriveThese :: Name -> [Name] -> Q [Dec]
deriveThese Name
name [Name]
items =
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> ([[Dec]] -> [Dec]) -> [[Dec]] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> Q [Dec]) -> [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ do
Type
x <- Name -> Type
ConT (Name -> Type) -> [Name] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
items
[Dec] -> [[Dec]]
forall (m :: * -> *) a. Monad m => a -> m a
return
[ Maybe DerivStrategy -> [Type] -> Type -> Dec
StandaloneDerivD Maybe DerivStrategy
forall a. Maybe a
Nothing [] (Type -> Type -> Type
AppT Type
x (Type -> Type -> Type
AppT Type
n (Name -> Type
ConT ''High)))
, Maybe DerivStrategy -> [Type] -> Type -> Dec
StandaloneDerivD Maybe DerivStrategy
forall a. Maybe a
Nothing [] (Type -> Type -> Type
AppT Type
x (Type -> Type -> Type
AppT Type
n (Name -> Type
ConT ''Low)))
]
where n :: Type
n = Name -> Type
ConT Name
name
deriveBase :: Name -> Q [Dec]
deriveBase :: Name -> Q [Dec]
deriveBase Name
name =
[[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ [d|deriving instance Show ($n Low)|]
, [d|deriving instance Eq ($n Low)|]
, [d|deriving instance Generic ($n Low)|]
, [d|deriving instance NFData ($n Low)|]
, [d|deriving instance Ord ($n Low)|]
, [d|deriving instance Show ($n High)|]
, [d|deriving instance Eq ($n High)|]
, [d|deriving instance Generic ($n High)|]
, [d|deriving instance NFData ($n High)|]
]
where n :: TypeQ
n = Name -> TypeQ
conT Name
name
deriveBases :: [Name] -> Q [Dec]
deriveBases :: [Name] -> Q [Dec]
deriveBases [Name]
names =
[[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> Q [Dec]) -> [Name] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> Q [Dec]
deriveBase [Name]
names
deriveBaseWithBinary :: Name -> Q [Dec]
deriveBaseWithBinary :: Name -> Q [Dec]
deriveBaseWithBinary Name
name = do
[Dec]
b <- Name -> Q [Dec]
deriveBase Name
name
[Dec]
m1 <- Name -> Q [Dec]
deriveBinary Name
name
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
b [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
m1)
deriveBinary :: Name -> Q [Dec]
deriveBinary :: Name -> Q [Dec]
deriveBinary Name
name =
[d|deriving instance Binary ($n Low)|]
where
n :: TypeQ
n = Name -> TypeQ
conT Name
name