{-# LANGUAGE TemplateHaskellQuotes #-}

-- | Copyright: (c) 2021 The closed eye of love
-- SPDX-License-Identifier: BSD-3-Clause
-- Maintainer: Poscat <poscat@mail.poscat.moe>, berberman <berberman@yandex.com>
-- Stability: alpha
-- Portability: portable
-- This module provides some TH functions to create instances
-- of 'FromJSON', 'ToJSON', and 'ToHttpApiData'.
-- You can find usages in "Web.Pixiv.Types" and "Web.Pixiv.Auth".
module Web.Pixiv.TH
  ( derivePixivJSON,
    derivePixivJSON',
    deriveEnumJSON,
    deriveEnumJSON',
    deriveEnumToHttpApiData,
    deriveEnumToHttpApiData',
    ToHttpApiData (..),
    FromJSON (..),
    ToJSON (..),
  )
where

import Data.Aeson (FromJSON (..), ToJSON (..), camelTo2)
import Data.Aeson.TH
import Data.List (stripPrefix)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Language.Haskell.TH
import Servant.API (ToHttpApiData (..))

-----------------------------------------------------------------------------

-- | Creates instances of 'FromJSON' and 'ToJSON',
-- stripping @_@ and @prefix@ from field labels (making sure result is non-empty),
-- then converting into snake case.
derivePixivJSON :: String -> Name -> DecsQ
derivePixivJSON :: String -> Name -> DecsQ
derivePixivJSON String
prefix =
  Options -> Name -> DecsQ
deriveJSON
    Options
defaultOptions
      { fieldLabelModifier :: String -> String
fieldLabelModifier = String -> String -> String
modifyFieldName String
prefix
      }

-- | Like 'derivePixivJSON' but does not strip prefix.
derivePixivJSON' :: Name -> DecsQ
derivePixivJSON' :: Name -> DecsQ
derivePixivJSON' = String -> Name -> DecsQ
derivePixivJSON String
""

-----------------------------------------------------------------------------

-- | Creates instances of 'FromJSON' and 'ToJSON',
-- stripping @prefix@ from constructor tags then converting
-- into snake case.
deriveEnumJSON :: String -> Name -> DecsQ
deriveEnumJSON :: String -> Name -> DecsQ
deriveEnumJSON String
prefix =
  Options -> Name -> DecsQ
deriveJSON
    Options
defaultOptions
      { constructorTagModifier :: String -> String
constructorTagModifier = String -> String -> String
modifyConsturctorName String
prefix
      }

-- | Like 'deriveEnumJSON' but does not strip prefix.
deriveEnumJSON' :: Name -> DecsQ
deriveEnumJSON' :: Name -> DecsQ
deriveEnumJSON' = String -> Name -> DecsQ
deriveEnumJSON String
""

-----------------------------------------------------------------------------

-- | Creates instance of 'ToHttpApiData' for a enum-like data type
-- which contains only plain normal constructors.
--
-- Constructor tags will be stripped @prefix@, then converted into snake case.
deriveEnumToHttpApiData :: String -> Name -> DecsQ
deriveEnumToHttpApiData :: String -> Name -> DecsQ
deriveEnumToHttpApiData String
prefix Name
name =
  Name -> Q Info
reify Name
name Q Info -> (Info -> DecsQ) -> DecsQ
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    TyConI Dec
dec -> case Dec
dec of
      (DataD Cxt
_ Name
_dataName [] Maybe Kind
_ [Con]
cons [DerivClause]
_) -> do
        let conNames :: [Name]
conNames = [Name
n | (NormalC Name
n []) <- [Con]
cons]
        if [Con] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Con]
cons Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Name] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Name]
conNames
          then String -> DecsQ
forall a. HasCallStack => String -> a
error String
"Data type is not simply an enum"
          else do
            let clauses :: [ClauseQ]
clauses =
                  [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
                      [Name -> [PatQ] -> PatQ
conP Name
n []]
                      (ExpQ -> BodyQ
normalB [|T.pack $ modifyConsturctorName prefix n'|])
                      []
                    | Name
n <- [Name]
conNames,
                      let n' :: String
n' = Name -> String
nameBase Name
n
                  ]
            Dec
func <- Name -> [ClauseQ] -> DecQ
funD (String -> Name
mkName String
"toQueryParam") [ClauseQ]
clauses
            [Dec] -> DecsQ
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [Maybe Overlap -> Cxt -> Kind -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] (Name -> Kind
ConT ''ToHttpApiData Kind -> Kind -> Kind
`AppT` Name -> Kind
ConT Name
name) [Dec
func]]
      Dec
_ -> String -> DecsQ
forall a. HasCallStack => String -> a
error String
"Unsupported data declaration"
    Info
_ -> String -> DecsQ
forall a. HasCallStack => String -> a
error String
"Not a plain type constructor"

-- | Like 'deriveEnumToHttpApiData' but does not strip prefix.
deriveEnumToHttpApiData' :: Name -> DecsQ
deriveEnumToHttpApiData' :: Name -> DecsQ
deriveEnumToHttpApiData' = String -> Name -> DecsQ
deriveEnumToHttpApiData String
""

-----------------------------------------------------------------------------

camel2Snake :: String -> String
camel2Snake :: String -> String
camel2Snake = Char -> String -> String
camelTo2 Char
'_'

modifyFieldName :: String -> String -> String
modifyFieldName :: String -> String -> String
modifyFieldName String
prefix String
s = String -> String
camel2Snake (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ case String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
prefix String
s' of
  Maybe String
Nothing -> String
s'
  Just String
"" -> String
s'
  Just String
x -> String
x
  where
    s' :: String
s' = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
s (String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"_" String
s)

modifyConsturctorName :: String -> String -> String
modifyConsturctorName :: String -> String -> String
modifyConsturctorName String
prefix = String -> String
camel2Snake (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (String -> Maybe String -> String)
-> (String -> Maybe String) -> String -> String
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
prefix)