{-# LANGUAGE CPP #-}
module Composite.Aeson.TH
  ( makeFieldJsonWrapper, makeFieldJsonWrapperExplicit
  , makeRecordJsonWrapper, makeRecordJsonWrapperExplicit
  ) where

import Composite.Aeson.Base (JsonFormat, dimapJsonFormat, parseJsonWithFormat', toJsonWithFormat)
import Composite.Aeson.CoRecord (defaultJsonFormatField, fieldJsonFormat)
import Composite.Aeson.Formats.Default (DefaultJsonFormat, defaultJsonFormat)
import Composite.Aeson.Formats.Generic (SumStyle)
import Composite.Aeson.Record (defaultJsonFormatRecord, recordJsonFormat)
import Composite.CoRecord (Field)
import Composite.Record (Record)
import Control.Lens (_head, over)
import Data.Aeson (FromJSON(parseJSON), ToJSON(toJSON))
import Data.Char (toLower)
import Language.Haskell.TH
  ( Q, clause, cxt
  , normalB
  , recC, varBangType, bang, bangType, noSourceUnpackedness, noSourceStrictness
  , Dec, funD, instanceD, newtypeD, sigD, valD
  , Exp, conE, varE
  , Name, mkName, newName
  , varP
  , conT
  )
import Language.Haskell.TH.Syntax (lift)

-- |TH splice which makes it more convenient to define 'DefaultJsonFormat', 'ToJSON', and 'FromJSON' instances for 'Field' types.
--
-- For example:
--
-- @
--   type MyField = '[FFoo, FBar]
--   makeFieldJsonWrapper "MyFieldJson" ''MyField SumStyleFieldName
-- @
--
-- is equivalent to:
--
-- @
--   newtype MyFieldJson = MyFieldJson { unMyFieldJson :: Field MyField }
--   myFieldJsonFormat :: 'Composite.Aeson.CoRecord.JsonFormatField' Void MyFieldJson
--   myFieldJsonFormat =
--     'dimapJsonFormat' unMyFieldJson MyFieldJson $
--       'fieldJsonFormat' SumStyleFieldName defaultJsonFormatField
--   instance FromJSON MyFieldJson where
--     parseJSON = 'parseJsonWithFormat'' myFieldJsonFormat
--   instance ToJSON MyFieldJson where
--     toJSON = 'toJsonWithFormat' myFieldJsonFormat
-- @
--
-- This function uses 'defaultJsonFormatField' to derive the formatting for the field. If you want to customize that formatting, use
-- 'makeFieldJsonWrapperExplicit' instead.
makeFieldJsonWrapper :: String -> Name -> SumStyle -> Q [Dec]
makeFieldJsonWrapper :: String -> Name -> SumStyle -> Q [Dec]
makeFieldJsonWrapper String
wrapperName Name
tyName SumStyle
sumStyle =
  String -> Name -> SumStyle -> Q Exp -> Q [Dec]
makeFieldJsonWrapperExplicit String
wrapperName Name
tyName SumStyle
sumStyle [| defaultJsonFormatField |]

-- |TH splice which makes it more convenient to define 'DefaultJsonFormat', 'ToJSON', and 'FromJSON' instances for 'Field' types.
--
-- For example:
--
-- @
--   type MyField = '[FFoo, FBar]
--   makeRecJsonWrapperExplicit "MyFieldJson" ''MyField [| set (rlens fFoo_) specialFormat defaultJsonFormatRecord |]
-- @
--
-- is equivalent to:
--
-- @
--   newtype MyFieldJson = MyFieldJson { unMyFieldJson :: Record MyField }
--   myRecordJsonFormat :: 'Composite.Aeson.Record.JsonFormatRecord' Void MyFieldJson
--   myRecordJsonFormat =
--     'dimapJsonFormat' unMyFieldJson MyFieldJson $
--       'recordJsonFormat' (set (rlens fFoo_) specialFormat defaultJsonFormatRecord)
--   instance FromJSON MyFieldJson where
--     parseJSON = 'parseJsonWithFormat'' myRecordJsonFormat
--   instance ToJSON MyFieldJson where
--     toJSON = 'toJsonWithFormat' myRecordJsonFormat
-- @
makeFieldJsonWrapperExplicit :: String -> Name -> SumStyle -> Q Exp -> Q [Dec]
makeFieldJsonWrapperExplicit :: String -> Name -> SumStyle -> Q Exp -> Q [Dec]
makeFieldJsonWrapperExplicit String
wrapperNameStr Name
fieldsTyName SumStyle
sumStyle Q Exp
fieldFormatExp = do
  let wrapperName :: Name
wrapperName = String -> Name
mkName String
wrapperNameStr
      extractorName :: Name
extractorName = String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"un" forall a. Semigroup a => a -> a -> a
<> String
wrapperNameStr
      fieldTy :: Q Type
fieldTy = [t| Field $(conT fieldsTyName) |]
  Name
formatName <- forall (m :: * -> *). Quote m => String -> m Name
newName forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toLower String
wrapperNameStr forall a. Semigroup a => a -> a -> a
<> String
"Format"
  forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
    [ forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> m Con
-> [m DerivClause]
-> m Dec
newtypeD
        (forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [])
        Name
wrapperName
        [] -- TyVarBndrs
        forall a. Maybe a
Nothing -- kind
        (forall (m :: * -> *). Quote m => Name -> [m VarBangType] -> m Con
recC Name
wrapperName [forall (m :: * -> *).
Quote m =>
Name -> m BangType -> m VarBangType
varBangType Name
extractorName (forall (m :: * -> *). Quote m => m Bang -> m Type -> m BangType
bangType (forall (m :: * -> *).
Quote m =>
m SourceUnpackedness -> m SourceStrictness -> m Bang
bang forall (m :: * -> *). Quote m => m SourceUnpackedness
noSourceUnpackedness forall (m :: * -> *). Quote m => m SourceStrictness
noSourceStrictness) Q Type
fieldTy)])
#if MIN_VERSION_template_haskell(2,12,0)
        [] -- deriving context
#else
        (cxt [])
#endif
    , forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD
        Name
formatName
        [t| forall e. JsonFormat e $(conT wrapperName) |]
    , forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD
        (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
formatName)
        (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| dimapJsonFormat $(varE extractorName) $(conE wrapperName) (fieldJsonFormat $(lift sumStyle) $fieldFormatExp) |])
        []
    , forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
        (forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [])
        [t| DefaultJsonFormat $(conT wrapperName) |]
        [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
            'defaultJsonFormat
            [ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
formatName) [] ]
        ]
    , forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
        (forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [])
        [t| FromJSON $(conT wrapperName) |]
        [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
            'parseJSON
            [ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| parseJsonWithFormat' $(varE formatName) |]) [] ]
        ]
    , forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
        (forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [])
        [t| ToJSON $(conT wrapperName) |]
        [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
            'toJSON
            [ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| toJsonWithFormat $(varE formatName) |]) [] ]
        ]
    ]

-- |TH splice which makes it more convenient to define 'DefaultJsonFormat', 'ToJSON', and 'FromJSON' instances for 'Record' types.
--
-- For example:
--
-- @
--   type MyRecord = '[FFoo, FBar]
--   makeRecJsonWrapper "MyRecordJson" ''MyRecord
-- @
--
-- is equivalent to:
--
-- @
--   newtype MyRecordJson = MyRecordJson { unMyRecordJson :: Record MyRecord }
--   myRecordJsonFormat :: 'Composite.Aeson.Record.JsonFormatRecord' Void MyRecordJson
--   myRecordJsonFormat =
--     'dimapJsonFormat' unMyRecordJson MyRecordJson $
--       'recordJsonFormat' defaultJsonFormatRecord
--   instance FromJSON MyRecordJson where
--     parseJSON = 'parseJsonWithFormat'' myRecordJsonFormat
--   instance ToJSON MyRecordJson where
--     toJSON = 'toJsonWithFormat' myRecordJsonFormat
-- @
--
-- This function uses 'defaultJsonFormatRecord' to derive the formatting for the record. If you want to customize that formatting, use
-- 'makeRecJsonWrapperExplicit' instead.
makeRecordJsonWrapper :: String -> Name -> Q [Dec]
makeRecordJsonWrapper :: String -> Name -> Q [Dec]
makeRecordJsonWrapper String
wrapperName Name
tyName =
  String -> Name -> Q Exp -> Q [Dec]
makeRecordJsonWrapperExplicit String
wrapperName Name
tyName [| defaultJsonFormatRecord |]

-- |TH splice which makes it more convenient to define 'DefaultJsonFormat', 'ToJSON', and 'FromJSON' instances for 'Record' types.
--
-- For example:
--
-- @
--   type MyRecord = '[FFoo, FBar]
--   makeRecordJsonWrapperExplicit "MyRecordJson" ''MyRecord [| set (rlens fFoo_) specialFormat defaultJsonFormatRecord |]
-- @
--
-- is equivalent to:
--
-- @
--   newtype MyRecordJson = MyRecordJson { unMyRecordJson :: Record MyRecord }
--   myRecordJsonFormat :: 'Composite.Aeson.Record.JsonFormatRecord' Void MyRecordJson
--   myRecordJsonFormat =
--     'dimapJsonFormat' unMyRecordJson MyRecordJson $
--       'recordJsonFormat' (set (rlens fFoo_) specialFormat defaultJsonFormatRecord)
--   instance DefaultJsonFormat MyRecordJson where
--     defaultJsonFormat = myRecordJsonFormat
--   instance FromJSON MyRecordJson where
--     parseJSON = 'parseJsonWithFormat'' myRecordJsonFormat
--   instance ToJSON MyRecordJson where
--     toJSON = 'toJsonWithFormat' myRecordJsonFormat
-- @
makeRecordJsonWrapperExplicit :: String -> Name -> Q Exp -> Q [Dec]
makeRecordJsonWrapperExplicit :: String -> Name -> Q Exp -> Q [Dec]
makeRecordJsonWrapperExplicit String
wrapperNameStr Name
fieldsTyName Q Exp
recFormatExp = do
  let wrapperName :: Name
wrapperName = String -> Name
mkName String
wrapperNameStr
      extractorName :: Name
extractorName = String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"un" forall a. Semigroup a => a -> a -> a
<> String
wrapperNameStr
      recordTy :: Q Type
recordTy = [t| Record $(conT fieldsTyName) |]
  Name
formatName <- forall (m :: * -> *). Quote m => String -> m Name
newName forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toLower String
wrapperNameStr forall a. Semigroup a => a -> a -> a
<> String
"Format"
  forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
    [ forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> m Con
-> [m DerivClause]
-> m Dec
newtypeD
        (forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [])
        Name
wrapperName
        [] -- TyVarBndrs
        forall a. Maybe a
Nothing -- kind
        (forall (m :: * -> *). Quote m => Name -> [m VarBangType] -> m Con
recC Name
wrapperName [forall (m :: * -> *).
Quote m =>
Name -> m BangType -> m VarBangType
varBangType Name
extractorName (forall (m :: * -> *). Quote m => m Bang -> m Type -> m BangType
bangType (forall (m :: * -> *).
Quote m =>
m SourceUnpackedness -> m SourceStrictness -> m Bang
bang forall (m :: * -> *). Quote m => m SourceUnpackedness
noSourceUnpackedness forall (m :: * -> *). Quote m => m SourceStrictness
noSourceStrictness) Q Type
recordTy)])
#if MIN_VERSION_template_haskell(2,12,0)
        [] -- deriving context
#else
        (cxt [])
#endif
    , forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD
        Name
formatName
        [t| forall e. JsonFormat e $(conT wrapperName) |]
    , forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD
        (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
formatName)
        (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| dimapJsonFormat $(varE extractorName) $(conE wrapperName) (recordJsonFormat $recFormatExp) |])
        []
    , forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
        (forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [])
        [t| DefaultJsonFormat $(conT wrapperName) |]
        [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
            'defaultJsonFormat
            [ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
formatName) [] ]
        ]
    , forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
        (forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [])
        [t| FromJSON $(conT wrapperName) |]
        [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
            'parseJSON
            [ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| parseJsonWithFormat' $(varE formatName) |]) [] ]
        ]
    , forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
        (forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [])
        [t| ToJSON $(conT wrapperName) |]
        [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
            'toJSON
            [ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| toJsonWithFormat $(varE formatName) |]) [] ]
        ]
    ]