aeson safe field renameing.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Main where

import Data.Aeson
import Data.Type.Bool (type (||))
import Data.Type.Equality (type (==))
import GHC.Generics
import GHC.TypeLits (Symbol)
import Unsafe.Coerce (unsafeCoerce)

newtype WithRename (from :: Symbol) (to :: Symbol) a = WithRename a

type family HasField field rep where
  HasField field (D1 _ cs) = HasField field cs
  HasField field (a :+: b) = HasField field a || HasField field b
  HasField field (C1 _ ss) = HasField field ss
  HasField field (a :*: b) = HasField field a || HasField field b
  HasField field (S1 (MetaSel meta _ _ _) _) = meta == Just field

type family RenameField (from :: Symbol) (to :: Symbol) x where
  RenameField from to (D1 meta cs) = D1 meta (RenameField from to cs)
  RenameField from to (a :+: b) = RenameField from to a :+: RenameField from to b
  RenameField from to (C1 meta ss) = C1 meta (RenameField from to ss)
  RenameField from to (a :*: b) = RenameField from to a :*: RenameField from to b
  RenameField from to (S1 (MetaSel (Just from) a b c) v) = S1 (MetaSel (Just to) a b c) v
  RenameField from to other = other

instance (Generic a, HasField from (Rep a) ~ True) => Generic (WithRename from to a) where
  type Rep (WithRename from to a) = RenameField from to (Rep a)
  from (WithRename x) = unsafeCoerce (from x)
  to rep = WithRename (to (unsafeCoerce rep))

deriving instance (Generic (WithRename from to a), GFromJSON Zero (Rep (WithRename from to a))) => FromJSON (WithRename from to a)

deriving instance (Generic (WithRename from to a), GToJSON' Value Zero (Rep (WithRename from to a))) => ToJSON (WithRename from to a)

-- Example

data X = X {a :: Int, c :: Int}
  deriving stock (Generic, Show)
  deriving (FromJSON, ToJSON) via (WithRename "a" "b" (WithRename "c" "d" X))

main = do
  print (decode "{\"b\": 1, \"d\": 2}" :: Maybe X)
  print (encode (X {a = 1, c = 2}))
  pure ()

with error.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Main where

import Data.Aeson
import Data.Coerce
import Data.Kind (Constraint, Type)
import Data.Type.Bool (type (||))
import Data.Type.Equality (type (==))
import GHC.Generics
import GHC.TypeLits

newtype WithRename (from :: Symbol) (to :: Symbol) a = WithRename a

type family AssertHasFieldMatch field x b r where
  AssertHasFieldMatch field x True r = r
  AssertHasFieldMatch field x False _ =
    TypeError
      ( Text "Unknown field "
          :<>: Text field
          :<>: Text " for type "
          :<>: ShowType (UnRename x)
      )

type AssertHasField field x r =
  AssertHasFieldMatch field x (HasField field (Rep x)) r

type HasField :: Symbol -> (Type -> Type) -> Bool
type family HasField field rep where
  HasField field (D1 _ cs) = HasField field cs
  HasField field (a :+: b) = HasField field a || HasField field b
  HasField field (C1 _ ss) = HasField field ss
  HasField field (a :*: b) = HasField field a || HasField field b
  HasField field (S1 (MetaSel meta _ _ _) _) = meta == Just field

type UnRename :: Type -> Type
type family UnRename x where
  UnRename (WithRename from to a) = UnRename a
  UnRename x = x

type RenameField :: Symbol -> Symbol -> (Type -> Type) -> (Type -> Type)
type family RenameField from to rep where
  RenameField from to (D1 meta cs) = D1 meta (RenameField from to cs)
  RenameField from to (a :+: b) = RenameField from to a :+: RenameField from to b
  RenameField from to (C1 meta ss) = C1 meta (RenameField from to ss)
  RenameField from to (a :*: b) = RenameField from to a :*: RenameField from to b
  RenameField from to (S1 (MetaSel (Just from) a b c) v) = S1 (MetaSel (Just to) a b c) v
  RenameField from to other = other

instance
  (Generic a, Coercible (Rep a) (Rep (WithRename from to a))) =>
  Generic (WithRename from to a)
  where
  type Rep (WithRename from to a) = AssertHasField from a (RenameField from to (Rep a))

  from :: forall x. WithRename from to a -> Rep (WithRename from to a) x
  from (WithRename x) = coerce (from @_ @x x)

  to :: forall x. Rep (WithRename from to a) x -> WithRename from to a
  to rep = WithRename (to @_ @x (coerce rep))

instance
  (Generic a, GFromJSON Zero (Rep (WithRename from to a)), Coercible (Rep a) (Rep (WithRename from to a))) =>
  FromJSON (WithRename from to a)
  where
  parseJSON = genericParseJSON defaultOptions

instance
  (Generic a, Coercible (Rep a) (Rep (WithRename from to a)), GToJSON' Value Zero (Rep (WithRename from to a))) =>
  ToJSON (WithRename from to a)
  where
  toJSON = genericToJSON defaultOptions

type (~>) :: Symbol -> Symbol -> (Symbol, Symbol)

type (~>) = '(,)

type Rename :: [(Symbol, Symbol)] -> Type -> Type
type family Rename xs a where
  Rename '[] x = x
  Rename ((a ~> b) : xs) x = WithRename a b (Rename xs x)

data X = X {a :: Int, c :: Int}
  deriving stock (Generic, Show)
  deriving (FromJSON, ToJSON) via (Rename ["a" ~> "b", "c" ~> "d"] X)

main = do
  print (decode "{\"b\": 1, \"d\": 2}" :: Maybe X)
  print (encode (X {a = 1, c = 2}))
  pure ()