Aeson: generic parser for optional fields

Hello,

I’m trying to create a GHC.Generics based parser for JSON objects to a record. The difference between mine and genericParseJSON provided by Aeson is that I want to treat missing keys in an object different from keys that are null. That is because in my case values that are absent represent an unchanged value and null represents an optional (Maybe) value.

For example, I have these types:

data Diff a = Changed a | Unchanged
data Person = Person { id :: Int, name :: Diff Text, age :: Diff (Maybe Int) }

The Diff data type is used to represent the missing keys in the JSON object.

Reading up on GHC.Generics, and trying to decipher the code in Aeson.Types.FromJSON (especially the type classes RecordFromJSON and RecordFromJSON'), I came up with the following but it gives me a compile error (see below):

#!/usr/bin/env stack
-- stack --resolver=lts-13.19 script
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
module GenericDiff where

import qualified Data.Text as T
import GHC.Generics
import Type.Reflection
import Data.Aeson (Value, Object, Options, FromArgs(..), fieldLabelModifier, gParseJSON, withObject)
import Data.Aeson.Types
import qualified Data.HashMap.Strict as H

data Diff a = Changed a | Unchanged

genericParseDiff :: (Generic a, ParseJSONDiff (Rep a)) => Options -> Value -> Parser a
genericParseDiff opts v = to <$> withObject "Object diff" (parseJSONDiff opts) v

class ParseJSONDiff f where
  parseJSONDiff :: Options -> Object -> Parser (f a)

instance ParseJSONDiff f => ParseJSONDiff (D1 x f) where
  parseJSONDiff opts obj = M1 <$> parseJSONDiff @f opts obj

instance ParseJSONDiff f => ParseJSONDiff (C1 x f) where
  parseJSONDiff opts obj = M1 <$> parseJSONDiff @f opts obj

instance (ParseJSONDiff a, ParseJSONDiff b) => ParseJSONDiff (a :*: b) where
  parseJSONDiff opts obj =
    (:*:) <$> parseJSONDiff opts obj
          <*> parseJSONDiff opts obj

instance (Selector s, FromJSON a) => ParseJSONDiff (S1 s (K1 i a)) where
  parseJSONDiff opts obj = do
      fv <- obj .: label
      M1 . K1 <$> pure fv -- gParseJSON opts NoFromArgs fv -- <?> Key label
    where
      label = T.pack $ fieldLabelModifier opts sname
      sname = selName (undefined :: M1 _i s _f _p)

instance {-# OVERLAPPING #-} (Selector s) => ParseJSONDiff (S1 s (K1 i (Diff a))) where
  parseJSONDiff opts obj =
      case H.lookup label obj of
        Just fv -> M1 . K1 . Changed <$> gParseJSON opts NoFromArgs fv
        Nothing -> M1 . K1 <$> pure Unchanged
    where
      label = T.pack $ fieldLabelModifier opts sname
      sname = selName (undefined :: M1 _i s _f _p)

instance ParseJSONDiff U1 where
  parseJSONDiff _ _ = pure U1

GHC’s gives me:

    • Couldn't match type ‘a’ with ‘f0 a0’
      ‘a’ is a rigid type variable bound by
        the instance declaration
        at .../src/GenericDiff.hs:46:30-81
      Expected type: Parser (S1 s (K1 i (Diff a)) a1)
        Actual type: Parser (M1 S s (K1 i (Diff (f0 a0))) a1)

I believe that S1 is the same as M1 S, so the only problem is that I need to get an f a from my a. I’m not really sure how to fix this. Any help is much appreciated!

This is somewhat of an off-topic, but in general, it is a good practice, when asking questions involving type errors, to provide immediately reproducible code examples. You can either wrap the whole script as a single immediately-executable file, or you could create a GitHub repo that’s easy to build with stack build (and get an error, of course). Otherwise, making people derive the dependencies, imports, and missing code (like ParseJSONDiff type) creates needless work for every person trying to help. Thanks!

Thanks for your comment. I’ve added the Stack script lines at the top…

ParseJSONDiff is a type class, it was already included.

From just playing with types for a bit, and then seeing the genericParseJSON implementation, I’ve figured that doing fmap to (gParseJSON opts NoFromArgs fv) should work (add fmap to on top of the result from gParseJSON). Please tell if that’s what you were looking for!

Hmm, no that didn’t work… but in the meantime I’ve found the solution, it was actually simple: I just needed to apply obj .: label and add the FromJSON a constraint:

#!/usr/bin/env stack
-- stack --resolver=lts-13.19 script
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
module GenericDiff where

import Control.Exception (assert)
import qualified Data.Text as T
import GHC.Generics
import Type.Reflection
import Data.Aeson (Value(..), Object, Options, FromJSON(..), (.:), fieldLabelModifier, object, withObject, defaultOptions)
import Data.Aeson.Types (Parser, parseMaybe)
import qualified Data.HashMap.Strict as H

data Diff a = Changed a | Unchanged deriving (Eq, Show)

genericParseDiff :: (Generic a, ParseJSONDiff (Rep a)) => Options -> Value -> Parser a
genericParseDiff opts v = to <$> withObject "Object diff" (parseJSONDiff opts) v

class ParseJSONDiff f where
  parseJSONDiff :: Options -> Object -> Parser (f a)

instance ParseJSONDiff f => ParseJSONDiff (D1 x f) where
  parseJSONDiff opts obj = M1 <$> parseJSONDiff @f opts obj

instance ParseJSONDiff f => ParseJSONDiff (C1 x f) where
  parseJSONDiff opts obj = M1 <$> parseJSONDiff @f opts obj

instance (ParseJSONDiff a, ParseJSONDiff b) => ParseJSONDiff (a :*: b) where
  parseJSONDiff opts obj =
    (:*:) <$> parseJSONDiff opts obj
          <*> parseJSONDiff opts obj

instance (Selector s, FromJSON a) => ParseJSONDiff (S1 s (K1 i a)) where
  parseJSONDiff opts obj = M1 . K1 <$> obj .: label
    where
      label = T.pack $ fieldLabelModifier opts sname
      sname = selName (undefined :: M1 _i s _f _p)

instance {-# OVERLAPPING #-} (Selector s, FromJSON a) => ParseJSONDiff (S1 s (K1 i (Diff a))) where
  parseJSONDiff opts obj =
      case H.lookup label obj of
        Just fv -> M1 . K1 . Changed <$> obj .: label
        Nothing -> M1 . K1 <$> pure Unchanged
    where
      label = T.pack $ fieldLabelModifier opts sname
      sname = selName (undefined :: M1 _i s _f _p)

instance ParseJSONDiff U1 where
  parseJSONDiff _ _ = pure U1


-- Tests -----------------------------------------------------------------------

data Person = Person
  { id   :: Int
  , name :: Diff T.Text
  , age  :: Diff (Maybe Int)
  } deriving (Eq, Show, Generic)

example1 :: IO ()
example1 = do
  -- name changed, age is unchanged
  let example = object [("id", Number 5), ("name", "Matthias")]
  let x = parseMaybe (genericParseDiff defaultOptions) example
  assert (x == Just (Person 5 (Changed "Matthias") Unchanged)) (putStrLn "OK")

example2 :: IO ()
example2 = do
  -- name is unchanged, age changed
  let example = object [("id", Number 5), ("age", Number 36)]
  let x = parseMaybe (genericParseDiff defaultOptions) example
  assert (x == Just (Person 5 Unchanged (Changed (Just 36)))) (putStrLn "OK")

example3 :: IO ()
example3 = do
  -- name is unchanged, age is changed to Nothing
  let example = object [("id", Number 5), ("age", Null)]
  let x = parseMaybe (genericParseDiff defaultOptions) example
  assert (x == Just (Person 5 Unchanged (Changed Nothing))) (putStrLn "OK")

main :: IO ()
main = do
  example1
  example2
  example3

@k-bx: thank you very much for your help anyway!

1 Like

oh, ok, glad the issue is resolved!

1 Like