from and to JSON using tagged fields

JSONUsingTaggedFields.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- this file requires aeson and generics-sop
module Main where

import Data.Aeson
import qualified Data.Aeson.Types
import Data.Functor.Compose
import Data.Proxy
import Data.String (IsString (fromString))
import Data.Tagged
import qualified GHC.Generics
import GHC.TypeLits
  ( KnownSymbol,
    symbolVal,
  )
import Generics.SOP
  ( All,
    Generic,
    I (I),
    IsProductType,
    K (K),
    NP,
    SListI,
    productTypeFrom,
    productTypeTo,
  )
import Generics.SOP.NP
  ( cliftA2_NP,
    collapse_NP,
    cpure_NP,
    liftA2_NP,
    sequence_NP,
  )

class Taggy t where
  tagVal :: String

instance KnownSymbol s => Taggy (Tagged s a) where
  tagVal = symbolVal (Proxy @s)

taggedRecordFromJSON ::
  forall r xs.
  (IsProductType r xs, All Taggy xs, All FromJSON xs) =>
  Proxy r ->
  Data.Aeson.Value ->
  Data.Aeson.Types.Parser r
taggedRecordFromJSON _ =
  let giveFieldName (K alias) (Compose f) = Compose (\o -> Data.Aeson.Types.explicitParseField f o (fromString alias))
      parsers = cpure_NP (Proxy @FromJSON) (Compose parseJSON)
      Compose parser = sequence_NP (liftA2_NP giveFieldName getAliases parsers)
   in withObject "Object" $ \o -> productTypeTo <$> parser o

taggedRecordToJSON ::
  forall r xs.
  (IsProductType r xs, All Taggy xs, All ToJSON xs) =>
  r ->
  Data.Aeson.Value
taggedRecordToJSON r =
  let giveFieldName (K alias) (I fieldValue) = K (fromString alias .= fieldValue)
      pairs =
        cliftA2_NP (Proxy @ToJSON) giveFieldName getAliases (productTypeFrom r)
   in object (collapse_NP pairs)

getAliases :: (SListI xs, All Taggy xs) => NP (K String) xs
getAliases = cpure_NP (Proxy @Taggy) getAlias
  where
    getAlias :: forall x. Taggy x => K String x
    getAlias = K (tagVal @x)

--
-- example record with base's Generic and generic-sop's Generic instances
data Refuel
  = Refuel
      { distance :: Tagged "foob" Int,
        volume :: Tagged "laaa" Bool
      }
  deriving (Show, GHC.Generics.Generic, Generic)

main :: IO ()
main = return ()