records-edsl-deriving-aeson-0.1.0: Records/EDSL/Deriving/JSON.hs

module Records.EDSL.Deriving.JSON (deriveJSON, deriveToJSON, deriveFromJSON) where

import Data.Aeson qualified as JSON
import Data.Aeson.Encoding qualified as JE
import Data.Aeson.Key qualified as JSONKey
import Data.Maybe
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Syntax qualified as TH
import Records.EDSL.Deriving.Type
import Records.EDSL.Description
import Relude hiding (lines)

deriveJSON, deriveToJSON, deriveFromJSON :: Deriver
deriveJSON = deriveToJSON <> deriveFromJSON
deriveToJSON = deriver #aeson_toJSON \RecordDesc {typeName, fields} ->
  [d|
    instance JSON.ToJSON $(TH.conT typeName) where
      toJSON = $(qToJSON fields)
      {-# INLINE toEncoding #-}
      toEncoding = $(qToEncoding fields)
    |]
deriveFromJSON = deriver #aeson_fromJSON \RecordDesc {typeName, constrName, fields} ->
  [d|
    instance JSON.FromJSON $(TH.conT typeName) where
      parseJSON = $(qParseJSON constrName fields)
    |]

qToJSON :: [FieldDesc TH.Name] -> TH.ExpQ
qToJSON fields =
  [|
    \object ->
      JSON.Object . fromList . dropNulls $
        $( TH.listE
             [ [|
                 ( JSONKey.fromText $(TH.lift nameText)
                 , JSON.toJSON ($(qFieldToExternalFormat type_) ($(TH.varE name) object))
                 , isOptional
                 )
                 |]
             | FieldDesc
                 { name
                 , nameText
                 , type_
                 , isOptional
                 } <-
                 fields
             ]
         )
    |]

dropNulls :: [(JSON.Key, JSON.Value, Bool)] -> [(JSON.Key, JSON.Value)]
dropNulls = mapMaybe \case
  (key, val, isOptional)
    | isOptional, JSON.Null <- val -> Nothing
    | otherwise -> Just (key, val)

qToEncoding :: [FieldDesc TH.Name] -> TH.ExpQ
qToEncoding fields =
  [|
    \object ->
      JSON.pairs
        $( foldr
             (\a b -> [|$a <> $b|])
             [|mempty :: JSON.Series|]
             [ if isOptional
                 then
                   [|
                     case $(qFieldToExternalFormat type_) ($(TH.varE name) object) of
                       Just value ->
                         JE.pair
                           (JSONKey.fromText $(TH.lift nameText))
                           (JSON.toEncoding value)
                       Nothing -> mempty
                     |]
                 else
                   [|
                     JE.pair
                       (JSONKey.fromText $(TH.lift nameText))
                       (JSON.toEncoding ($(qFieldToExternalFormat type_) ($(TH.varE name) object)))
                     |]
             | FieldDesc {name, nameText, type_, isOptional} <- fields
             ]
         )
    |]

qParseJSON :: TH.Name -> [FieldDesc TH.Name] -> TH.ExpQ
qParseJSON conName fields =
  [|
    JSON.withObject $(TH.lift (show conName :: String)) \obj ->
      $( do
           flds :: [(FieldDesc TH.Name, TH.Name)] <- forM fields \fld -> do
             name <- TH.newName ("parsed_" ++ toString fld.nameText)
             pure (fld, name)

           let
             qParseField :: (FieldDesc TH.Name, TH.Name) -> TH.StmtQ
             qParseField (fld, pname) =
               TH.bindS
                 (TH.varP pname)
                 [|
                   $(qGetField (fld, pname))
                     >>= $(qFieldFromExternalFormat fld.type_)
                   |]

             qGetField :: (FieldDesc TH.Name, TH.Name) -> TH.ExpQ
             qGetField (FieldDesc {nameText, isOptional}, _)
               | isOptional = [|obj JSON..:? JSONKey.fromText $(TH.lift nameText)|]
               | otherwise = [|obj JSON..: JSONKey.fromText $(TH.lift nameText)|]

             qMkRec :: TH.ExpQ
             qMkRec =
               [|pure|]
                 `TH.appE` TH.recConE
                   conName
                   [ (name,) <$> TH.varE parsedName
                   | (FieldDesc {name}, parsedName) <- flds
                   ]

           TH.doE (map qParseField flds ++ [TH.noBindS qMkRec])
       )
    |]