Json patch

JsonPatch.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GADTs #-}

module Chaucer.UKTerrorism.JsonPatch where

import Build.Core.Prelude hiding (diff)
import Control.Lens
import Data.Aeson
import Data.Aeson.Diff hiding (Config)
import Data.Aeson.Diff.Generic
import Data.Aeson.Encode.Pretty
import qualified Data.ByteString.Lazy.Char8 as LC8

--

run :: IO ()
run = do
  let alice = MkPerson "Alice" 32 Dog []
  let bob = MkPerson "Bob" 33 Bird [alice]
  ppJson alice
  ppJson bob
  ppJson $ diff (toJSON alice) (toJSON bob)

--

data Pet
  = Bird
  | Cat
  | Dog
  deriving stock (Show, Eq, Generic)
  deriving anyclass (FromJSON, ToJSON)
  deriving anyclass (JsonPatch)

data Person
  = MkPerson
      { name :: Text,
        age :: Int,
        pet :: Pet,
        friends :: [Person]
      }
  deriving stock (Show, Eq, Generic)
  deriving anyclass (FromJSON, ToJSON)
  deriving anyclass (JsonPatch)

--

instance FieldLens Pet

instance FieldLens Person where
  fieldLens (OKey fld) p =
    case fld of
      "name" -> pure $ GetSet (p ^. field @"name") (pure . fieldLensUpd @"name" p)
      "age" -> pure $ GetSet (p ^. field @"age") (pure . fieldLensUpd @"age" p)
      "pet" -> pure $ GetSet (p ^. field @"pet") (pure . fieldLensUpd @"pet" p)
      _ -> fieldLensErr
  fieldLens _ _ = fieldLensErr

fieldLensUpd :: forall field s a. (HasField' field s a) => s -> a -> s
fieldLensUpd p v = p & field' @field .~ v

fieldLensErr :: Result a
fieldLensErr = Error "Invalid Path"

--

ppJson :: (ToJSON a) => a -> IO ()
ppJson = LC8.putStrLn . prettyLC8
  where
    prettyLC8 :: (ToJSON a) => a -> LC8.ByteString
    prettyLC8 =
      encodePretty'
        Config
          { confIndent = Spaces 2,
            confCompare = compare,
            confNumFormat = Generic,
            confTrailingNewline = False
          }

output.log

λ> run
{
  "age": 32,
  "friends": [],
  "name": "Alice",
  "pet": "Dog"
}
{
  "age": 33,
  "friends": [
    {
      "age": 32,
      "friends": [],
      "name": "Alice",
      "pet": "Dog"
    }
  ],
  "name": "Bob",
  "pet": "Bird"
}
[
  {
    "op": "replace",
    "path": "/age",
    "value": 33
  },
  {
    "op": "replace",
    "path": "/name",
    "value": "Bob"
  },
  {
    "op": "replace",
    "path": "/pet",
    "value": "Bird"
  },
  {
    "op": "add",
    "path": "/friends/0",
    "value": {
      "age": 32,
      "friends": [],
      "name": "Alice",
      "pet": "Dog"
    }
  }
]