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!
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