{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {- Because of GHC-69797, we need to disable all warnings in order to disable the very specific warning about TypeAbstractions that can't be disabled individually, but then we re-enable the specific warnings we most care about. -} {-# OPTIONS_GHC -Wwarn #-} {-# OPTIONS_GHC -Werror=missing-import-lists #-} module Main (main) where import Control.Monad (join) import Data.Aeson (FromJSON, ToJSON) import Data.ByteString.Lazy (ByteString) import Data.JsonSpec ( Field(Field), FieldSpec(Optional, Required) , HasJsonDecodingSpec(DecodingSpec, fromJSONStructure) , HasJsonEncodingSpec(EncodingSpec, toJSONStructure), Ref(Ref) , SpecJSON(SpecJSON) , Specification ( JsonArray, JsonBool, JsonDateTime, JsonEither, JsonInt, JsonLet , JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef, JsonString, JsonTag ) , Tag(Tag), (:::), (::?), eitherDecode, encode, unField ) import Data.Proxy (Proxy(Proxy)) import Data.Scientific (Scientific) import Data.Text (Text) import Data.Time (UTCTime(UTCTime)) import OM.Show (ShowJ(ShowJ)) import Prelude ( Applicative(pure), Bool(False, True), Either(Left, Right), Enum(toEnum) , Functor(fmap), Maybe(Just, Nothing), Monad((>>=)), Num(negate) , Traversable(traverse), ($), (.), Eq, IO, Int, Show, String, realToFrac ) import Test.Hspec (describe, hspec, it, shouldBe) import qualified Data.Aeson as A main :: IO () main = hspec $ do describe "json" $ do it "encodes product" $ let actual :: ByteString actual = A.encode $ sampleTestObject expected :: ByteString expected = "{\"bar\":1,\"baz\":{\"bar\":0,\"foo\":\"foo2\"},\"foo\":\"foo\",\"qoo\":true,\"qux\":100}" in actual `shouldBe` expected it "decodes product" $ let actual :: Either String TestObj actual = A.eitherDecode "{\"bar\":1,\"baz\":{\"bar\":0,\"foo\":\"foo2\"},\"foo\":\"foo\",\"qux\":100,\"qoo\":true}" expected :: Either String TestObj expected = Right sampleTestObject in actual `shouldBe` expected it "encodes sum1" $ let actual :: ByteString actual = A.encode $ TestA 0 "bar" expected :: ByteString expected = "{\"content\":{\"int-field\":0,\"txt-field\":\"bar\"},\"tag\":\"a\"}" in actual `shouldBe` expected it "encodes sum2" $ let actual :: ByteString actual = A.encode $ TestB expected :: ByteString expected = "{\"tag\":\"b\"}" in actual `shouldBe` expected it "decodes sum1" $ let actual :: Either String TestSum actual = A.eitherDecode "{\"content\":{\"int-field\":0,\"txt-field\":\"bar\"},\"tag\":\"a\"}" expected :: Either String TestSum expected = Right (TestA 0 "bar") in actual `shouldBe` expected it "decodes sum2" $ let actual :: Either String TestSum actual = A.eitherDecode "{\"tag\":\"b\"}" expected :: Either String TestSum expected = Right TestB in actual `shouldBe` expected it "decodes UTCTime" $ let actual :: Either String User actual = A.eitherDecode "{ \"name\": \"foo\", \"last-login\": \"1858-11-17T00:00:00Z\" }" expected :: Either String User expected = Right User { name = "foo" , lastLogin = UTCTime (toEnum 0) 0 } in actual `shouldBe` expected describe "optionality" $ do let obj :: TestOptionality obj = TestOptionality { toFoo = Nothing , toBar = Nothing , toBaz = Nothing , toQux = 1 } it "encodes" $ let actual :: ByteString actual = A.encode obj expected :: ByteString expected = "{\"bar\":null,\"baz\":null,\"qux\":1}" in actual `shouldBe` expected it "decodes missing fields" $ let actual :: Either String TestOptionality actual = A.eitherDecode "{\"bar\":null,\"qux\":1}" expected :: Either String TestOptionality expected = Right obj in actual `shouldBe` expected it "decodes explicit null" $ let actual :: Either String TestOptionality actual = A.eitherDecode "{\"bar\":null,\"baz\":null,\"qux\":1}" expected :: Either String TestOptionality expected = Right obj in actual `shouldBe` expected describe "let" $ do it "decodes let" $ let actual :: Either String Triangle actual = A.eitherDecode "{ \"vertex1\" : { \"x\": 1, \"y\": 2, \"z\": 3 }, \ \ \"vertex2\" : { \"x\": 4, \"y\": 5, \"z\": 6 }, \ \ \"vertex3\" : { \"x\": 7, \"y\": 8, \"z\": 9 } }" expected :: Either String Triangle expected = Right Triangle { vertex1 = Vertex 1 2 3 , vertex2 = Vertex 4 5 6 , vertex3 = Vertex 7 8 9 } in actual `shouldBe` expected it "encodes let" $ let actual :: ByteString actual = A.encode Triangle { vertex1 = Vertex 1 2 3 , vertex2 = Vertex 4 5 6 , vertex3 = Vertex 7 8 9 } expected :: ByteString expected = "{\"vertex1\":{\"x\":1,\"y\":2,\"z\":3},\"vertex2\":{\"x\":4,\"y\":5,\"z\":6},\"vertex3\":{\"x\":7,\"y\":8,\"z\":9}}" in actual `shouldBe` expected describe "recursive types" $ do it "decodes" $ let actual :: Either String LabelledTree actual = A.eitherDecode "{\"children\":[{\"children\":[{\"children\":[],\"label\":\"child1\"},{\"children\":[],\"label\":\"child2\"}],\"label\":\"parent\"}],\"label\":\"grandparent\"}" expected :: Either String LabelledTree expected = Right LabelledTree { label = "grandparent" , children = [ LabelledTree { label = "parent" , children = [ LabelledTree { label = "child1" , children = [] } , LabelledTree { label = "child2" , children = [] } ] } ] } in actual `shouldBe` expected it "decodes" $ let actual :: ByteString actual = A.encode LabelledTree { label = "grandparent" , children = [ LabelledTree { label = "parent" , children = [ LabelledTree { label = "child1" , children = [] } , LabelledTree { label = "child2" , children = [] } ] } ] } expected :: ByteString expected = "{\"children\":[{\"children\":[{\"children\":[],\"label\":\"child1\"},{\"children\":[],\"label\":\"child2\"}],\"label\":\"parent\"}],\"label\":\"grandparent\"}" in actual `shouldBe` expected describe "nullable" $ do it "encodes product" $ let actual :: ByteString actual = A.encode $ sampleTestObjectWithNull expected :: ByteString expected = "{\"bar\":1,\"baz\":{\"bar\":0,\"foo\":\"foo2\"},\"foo\":\"foo\",\"qoo\":false,\"qux\":null}" in actual `shouldBe` expected it "decodes product" $ let actual :: Either String TestObj actual = A.eitherDecode "{\"bar\":1,\"baz\":{\"bar\":0,\"foo\":\"foo2\"},\"foo\":\"foo\",\"qux\":null,\"qoo\":false}" expected :: Either String TestObj expected = Right sampleTestObjectWithNull in actual `shouldBe` expected it "Bad tag does not decode" $ let actual :: Either String TestSum actual = A.eitherDecode "{\"tag\":\"c\"}" expected :: Either String TestSum expected = Left "Error in $: unexpected constant value" in actual `shouldBe` expected describe "direct encoding/decoding" $ do it "eitherDecode" $ let actual :: Either String (Field "foo" Text, (Maybe (Field "bar" Scientific), (Field "baz" (Field "foo" Text, (Field "bar" Int, ())), (Field "qux" (Maybe Int), (Field "qoo" Bool, ()))))) actual = A.eitherDecode "{\"bar\":1,\"baz\":{\"bar\":0,\"foo\":\"foo2\"},\"foo\":\"foo\",\"qux\":null,\"qoo\":false}" >>= eitherDecode (Proxy @(EncodingSpec TestObj)) expected :: Either String (Field "foo" Text, (Maybe (Field "bar" Scientific), (Field "baz" (Field "foo" Text, (Field "bar" Int, ())), (Field "qux" (Maybe Int), (Field "qoo" Bool, ()))))) expected = Right (Field @"foo" "foo", (Just (Field @"bar" 1.0), (Field @"baz" (Field @"foo" "foo2", (Field @"bar" 0, ())), (Field @"qux" Nothing, (Field @"qoo" False, ()))))) in actual `shouldBe` expected it "encode" $ let expected :: Maybe A.Value expected = A.decode "{\"bar\":1,\"baz\":{\"bar\":0,\"foo\":\"foo2\"},\"foo\":\"foo\",\"qux\":null,\"qoo\":false}" actual :: Maybe A.Value actual = Just $ encode (Proxy @(EncodingSpec TestObj)) ( (Field @"foo" "foo", (Just (Field @"bar" 1.0), (Field @"baz" (Field @"foo" "foo2", (Field @"bar" 0, ())), (Field @"qux" Nothing, (Field @"qoo" False, ()))))) ) in actual `shouldBe` expected describe "raw values" $ do it "decodes" $ let expected :: Either String (Field "foo" A.Value, ()) expected = Right (Field @"foo" ( A.object [ ("bar", A.String "barval") , ("baz", A.toJSON [A.String "qux", A.Number 1.0, A.Bool False]) ] ) ,()) actual :: Either String (Field "foo" A.Value, ()) actual = A.eitherDecode "{ \"foo\": { \"bar\": \"barval\", \"baz\": [ \"qux\", 1, false ] } }" >>= eitherDecode (Proxy @( JsonObject '[ "foo" ::: JsonRaw ])) in actual `shouldBe` expected it "encodes" $ let expected :: Maybe A.Value expected = A.decode "{ \"foo\": { \"bar\": \"barval\", \"baz\": [ \"qux\", 1, false ] } }" actual :: Maybe A.Value actual = Just $ encode (Proxy @( JsonObject '[ Required "foo" JsonRaw ])) (Field @"foo" ( A.object [ ("bar", A.String "barval") , ("baz", A.toJSON [A.String "qux", A.Number 1.0, A.Bool False]) ] ), ()) in actual `shouldBe` expected it "HasField" $ let expected :: Maybe TestHasField expected = Just TestHasField { thfFoo = "foo" , thfBar = 10 , thfBaz = TestSubObj { foo2 = "bar" , bar2 = negate 10 } } actual :: Maybe TestHasField actual = A.decode "{\ \ \"foo\": \"foo\",\ \ \"bar\": 10,\ \ \"baz\": {\ \ \"a_string\": \"bar\",\ \ \"an_int\": -10\ \ }\ \}" in actual `shouldBe` expected describe "mutual recursion" $ do describe "style1" $ do it "encodes" $ let expected :: ByteString expected = "[[[],[]]]" actual :: ByteString actual = A.encode (MRec1 [MRec2 [MRec1 [], MRec1 []]]) in actual `shouldBe` expected it "decoces" $ let expected :: Maybe MRec1 expected = Just (MRec1 [MRec2 [MRec1 [], MRec1 []]]) actual :: Maybe MRec1 actual = A.decode "[[[],[]]]" in actual `shouldBe` expected describe "style2" $ do it "encodes" $ let expected :: ByteString expected = "{\"foo\":{\"bar\":{\"foo\":{\"bar\":{\"foo\":null}}}}}" actual = A.encode MRec3 { foo = Just MRec4 { bar = MRec3 { foo = Just MRec4 { bar = MRec3 { foo = Nothing } } } } } in actual `shouldBe` expected it "decodes" $ let expected :: Maybe MRec3 expected = Just MRec3 { foo = Just MRec4 { bar = MRec3 { foo = Just MRec4 { bar = MRec3 { foo = Nothing } } } } } actual :: Maybe MRec3 actual = A.decode "{\"foo\":{\"bar\":{\"foo\":{\"bar\":{\"foo\":null}}}}}" in actual `shouldBe` expected sampleTestObject :: TestObj sampleTestObject = TestObj { foo = "foo" , bar = Just 1 , baz = TestSubObj { foo2 = "foo2" , bar2 = 0 } , qux = Just 100 , qoo = True } sampleTestObjectWithNull:: TestObj sampleTestObjectWithNull= TestObj { foo = "foo" , bar = Just 1 , baz = TestSubObj { foo2 = "foo2" , bar2 = 0 } , qux = Nothing , qoo = False } data TestSum = TestA Int Text | TestB deriving stock (Eq, Show) deriving ToJSON via (SpecJSON TestSum) deriving FromJSON via (SpecJSON TestSum) instance HasJsonEncodingSpec TestSum where type EncodingSpec TestSum = JsonEither (JsonObject '[ Required "tag" (JsonTag "a"), Required "content" (JsonObject [ Required "int-field" JsonInt, Required "txt-field" JsonString ]) ]) (JsonObject '[ Required "tag" (JsonTag "b") ]) toJSONStructure = \case TestA i t -> Left (Field @"tag" (Tag @"a"), (Field @"content" ( (Field @"int-field" i , (Field @"txt-field" t , () ) )), ())) TestB -> Right ( Field @"tag" (Tag @"b") , () ) instance HasJsonDecodingSpec TestSum where type DecodingSpec TestSum = EncodingSpec TestSum fromJSONStructure = \case Left (Field @"tag" Tag, (Field @"content" (Field @"int-field" int, (Field @"txt-field" txt, ())), ())) -> pure (TestA int txt) Right _ -> pure TestB data TestObj = TestObj { foo :: Text , bar :: Maybe Scientific , baz :: TestSubObj , qux :: Maybe Int , qoo :: Bool } deriving stock (Show, Eq) deriving ToJSON via (SpecJSON TestObj) deriving FromJSON via (SpecJSON TestObj) instance HasJsonEncodingSpec TestObj where type EncodingSpec TestObj = JsonObject '[ Required "foo" JsonString, Optional "bar" JsonNum, Required "baz" (EncodingSpec TestSubObj), Required "qux" (JsonNullable JsonInt), Required "qoo" JsonBool ] toJSONStructure TestObj { foo , bar , baz, qux, qoo } = (Field @"foo" foo, (fmap (Field @"bar" . realToFrac) bar, (Field @"baz" (toJSONStructure baz), (Field @"qux" qux, (Field @"qoo" qoo, ()))))) instance HasJsonDecodingSpec TestObj where type DecodingSpec TestObj = EncodingSpec TestObj fromJSONStructure (Field @"foo" foo, (fmap (unField @"bar") -> bar, (Field @"baz" rawBaz, (Field @"qux" qux, (Field @"qoo" qoo, ()))))) = do baz <- fromJSONStructure rawBaz pure TestObj { foo, bar, baz, qux, qoo } data TestSubObj = TestSubObj { foo2 :: Text , bar2 :: Int } deriving stock (Show, Eq) instance HasJsonEncodingSpec TestSubObj where type EncodingSpec TestSubObj = JsonObject '[ Required "foo" JsonString , Required "bar" JsonInt ] toJSONStructure TestSubObj { foo2 , bar2 } = (Field @"foo" foo2, (Field @"bar" bar2, ())) instance HasJsonDecodingSpec TestSubObj where type DecodingSpec TestSubObj = EncodingSpec TestSubObj fromJSONStructure (Field @"foo" foo2, (Field @"bar" bar2, ())) = pure TestSubObj {foo2 , bar2} data User = User { name :: Text , lastLogin :: UTCTime } deriving stock (Show, Eq) deriving (ToJSON, FromJSON) via (SpecJSON User) instance HasJsonEncodingSpec User where type EncodingSpec User = JsonObject '[ Required "name" JsonString , Required "last-login" JsonDateTime ] toJSONStructure user = (Field @"name" (name user), (Field @"last-login" (lastLogin user), ())) instance HasJsonDecodingSpec User where type DecodingSpec User = EncodingSpec User fromJSONStructure (Field @"name" name, (Field @"last-login" lastLogin, ())) = pure User { name , lastLogin } data Vertex = Vertex { x :: Int , y :: Int , z :: Int } deriving stock (Show, Eq) deriving (ToJSON, FromJSON) via (SpecJSON Vertex) instance HasJsonEncodingSpec Vertex where type EncodingSpec Vertex = JsonObject '[ Required "x" JsonInt , Required "y" JsonInt , Required "z" JsonInt ] toJSONStructure Vertex {x, y, z} = (Field @"x" x, (Field @"y" y, (Field @"z" z, ()))) instance HasJsonDecodingSpec Vertex where type DecodingSpec Vertex = EncodingSpec Vertex fromJSONStructure (Field @"x" x, (Field @"y" y, (Field @"z" z, ()))) = pure Vertex { x, y, z } data Triangle = Triangle { vertex1 :: Vertex , vertex2 :: Vertex , vertex3 :: Vertex } deriving stock (Show, Eq) deriving (ToJSON, FromJSON) via (SpecJSON Triangle) instance HasJsonEncodingSpec Triangle where type EncodingSpec Triangle = JsonLet '[ '("Vertex", EncodingSpec Vertex) ] (JsonObject '[ Required "vertex1" (JsonRef "Vertex") , Required "vertex2" (JsonRef "Vertex") , Required "vertex3" (JsonRef "Vertex") ]) toJSONStructure Triangle {vertex1, vertex2, vertex3} = (Field @"vertex1" (Ref $ toJSONStructure vertex1), (Field @"vertex2" (Ref $ toJSONStructure vertex2), (Field @"vertex3" (Ref $ toJSONStructure vertex3), ()))) instance HasJsonDecodingSpec Triangle where type DecodingSpec Triangle = EncodingSpec Triangle fromJSONStructure (Field @"vertex1" (Ref rawVertex1), (Field @"vertex2" (Ref rawVertex2), (Field @"vertex3" (Ref rawVertex3), ()))) = do vertex1 <- fromJSONStructure rawVertex1 vertex2 <- fromJSONStructure rawVertex2 vertex3 <- fromJSONStructure rawVertex3 pure Triangle{vertex1, vertex2, vertex3} data LabelledTree = LabelledTree { label :: Text , children :: [LabelledTree] } deriving stock (Show, Eq) deriving (ToJSON, FromJSON) via (SpecJSON LabelledTree) instance HasJsonEncodingSpec LabelledTree where type EncodingSpec LabelledTree = JsonLet '[ '("LabelledTree", JsonObject '[ Required "label" JsonString , Required "children" (JsonArray (JsonRef "LabelledTree")) ] ) ] (JsonRef "LabelledTree") toJSONStructure LabelledTree {label , children } = Ref (Field @"label" label, (Field @"children" [ toJSONStructure child | child <- children ], ())) instance HasJsonDecodingSpec LabelledTree where type DecodingSpec LabelledTree = EncodingSpec LabelledTree fromJSONStructure ( Ref (Field @"label" label, (Field @"children" children_, ())) ) = do children <- traverse fromJSONStructure children_ pure LabelledTree { label , children } data TestOptionality = TestOptionality { toFoo :: Maybe Int , toBar :: Maybe Int , toBaz :: Maybe Int , toQux :: Int } deriving (ToJSON, FromJSON) via (SpecJSON TestOptionality) deriving (Show) via (ShowJ TestOptionality) deriving stock (Eq) instance HasJsonEncodingSpec TestOptionality where type EncodingSpec TestOptionality = JsonObject '[ "foo" ::? JsonInt , Required "bar" (JsonNullable JsonInt) , Optional "baz" (JsonNullable JsonInt) , Required "qux" JsonInt ] toJSONStructure TestOptionality { toFoo , toBar , toBaz , toQux } = (fmap (Field @"foo") toFoo, (Field @"bar" toBar, ((Just . Field @"baz") toBaz, -- when encoding, prefer explicit null for testing. (Field @"qux" toQux, ())))) instance HasJsonDecodingSpec TestOptionality where type DecodingSpec TestOptionality = EncodingSpec TestOptionality fromJSONStructure (fmap (unField @"foo") -> toFoo, (Field @"bar" toBar, (join . fmap (unField @"baz") -> toBaz, (Field @"qux" toQux, ())))) = pure TestOptionality { toFoo , toBar , toBaz , toQux } data TestHasField = TestHasField { thfFoo :: Text , thfBar :: Int , thfBaz :: TestSubObj } deriving stock (Show, Eq) deriving (FromJSON) via (SpecJSON TestHasField) instance HasJsonDecodingSpec TestHasField where type DecodingSpec TestHasField = JsonObject '[ "foo" ::: JsonString , "bar" ::: JsonInt , "baz" ::: JsonObject '[ "a_string" ::: JsonString , "an_int" ::: JsonInt ] ] fromJSONStructure val = pure TestHasField { thfFoo = val.foo , thfBar = val.bar , thfBaz = TestSubObj { foo2 = val.baz.a_string , bar2 = val.baz.an_int } } {- Mutually recursive test. -} {- ========================================================================== -} newtype MRec1 = MRec1 [MRec2] deriving (ToJSON, FromJSON) via (SpecJSON MRec1) deriving stock (Show, Eq) newtype MRec2 = MRec2 [MRec1] deriving stock (Show, Eq) instance HasJsonEncodingSpec MRec1 where type EncodingSpec MRec1 = JsonLet '[ '("one", JsonArray (JsonRef "two")) , '("two", JsonArray (JsonRef "one")) ] (JsonRef "one") toJSONStructure (MRec1 m2s) = Ref [ Ref (fmap toJSONStructure m1s) | MRec2 m1s <- m2s ] instance HasJsonDecodingSpec MRec1 where type DecodingSpec MRec1 = EncodingSpec MRec1 fromJSONStructure (Ref m2s_) = do m2s <- traverse (\(Ref m1s_) -> do m1s <- traverse fromJSONStructure m1s_ pure (MRec2 m1s) ) m2s_ pure (MRec1 m2s) {- Another mutually recursive test. -} {- ========================================================================== -} type SharedRecSpecs = '[ '( "three" , JsonObject '[ "foo" ::: JsonNullable (JsonRef "four") ] ) , '( "four" , JsonObject '[ "bar" ::: JsonRef "three" ] ) ] newtype MRec3 = MRec3 { foo :: Maybe MRec4 } deriving stock (Show, Eq) deriving (ToJSON, FromJSON) via (SpecJSON MRec3) instance HasJsonEncodingSpec MRec3 where type EncodingSpec MRec3 = JsonLet SharedRecSpecs (JsonRef "three") toJSONStructure MRec3 { foo } = Ref (Field @"foo" (fmap toJSONStructure foo), ()) instance HasJsonDecodingSpec MRec3 where type DecodingSpec MRec3 = EncodingSpec MRec3 fromJSONStructure ( Ref (Field @"foo" rawFoo, ())) = do foo <- traverse fromJSONStructure rawFoo pure MRec3 { foo } newtype MRec4 = MRec4 { bar :: MRec3 } deriving stock (Show, Eq) instance HasJsonEncodingSpec MRec4 where type EncodingSpec MRec4 = JsonLet SharedRecSpecs (JsonRef "four") toJSONStructure MRec4 { bar } = Ref (Field @"bar" (toJSONStructure bar), ()) instance HasJsonDecodingSpec MRec4 where type DecodingSpec MRec4 = EncodingSpec MRec4 fromJSONStructure ( Ref (Field @"bar" rawbar, ())) = do bar <- fromJSONStructure rawbar pure MRec4 { bar } {- ========================================================================== -}