{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StandaloneDeriving #-}
{-|
Module      : Language.JVM.TH
Copyright   : (c) Christian Gram Kalhauge, 2018
License     : MIT
Maintainer  : kalhuage@cs.ucla.edu

This module contains some Template Haskell functions for internal use.
-}

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


-- | Derives the 'NFData', 'Show', 'Eq', and 'Generic'
-- from something that is 'Staged'
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

-- | Derives the 'NFData', 'Show', 'Eq', and 'Generic'
-- from something that is 'Staged'
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

-- | Derives the bases of a list of names
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

-- | Derives the 'NFData', 'Show', 'Eq', and 'Generic' from something that is
-- 'Staged'
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

-- -- | Derives the 'NFData', 'Show', 'Eq', and 'Generic'
-- -- from something that is 'Staged'
-- deriveBaseO :: Name -> Name -> Q [Dec]
-- deriveBaseO tp name = do
--   b <- deriveBase name
--   m1 <- [d|deriving instance Eq ($n $t)|]
--   m2 <- [d|deriving instance Ord ($n $t)|]
--   return (b ++ m1 ++ m2)
--   where
--     n = conT name
--     t = conT tp

-- -- | Derives the 'NFData', 'Show', 'Eq', and 'Generic'
-- -- from something that is 'Staged'
-- deriveBaseBO :: Name -> Name -> Q [Dec]
-- deriveBaseBO tp name = do
--   b <- deriveBaseB tp name
--   m1 <- [d|deriving instance Eq ($n $t)|]
--   m2 <- [d|deriving instance Ord ($n $t)|]
--   return (b ++ m1 ++ m2)
--   where
--     n = conT name
--     t = conT tp