diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Changelog +## 1.4.0.0 + +- Add `JsonDict` for JSON objects with arbitrary string keys and values that + all conform to one known specification. + ## 1.3.0.2 - Relax upper bounds on `containers` and `time` for current Hackage diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -63,3 +63,10 @@ ``` For more examples, take a look at the test suite. + +`JsonDict` represents a JSON object whose keys are arbitrary strings and +whose values all conform to one spec: + +```haskell +type ScoresByUser = JsonDict JsonInt +``` diff --git a/json-spec.cabal b/json-spec.cabal --- a/json-spec.cabal +++ b/json-spec.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: json-spec -version: 1.3.0.2 +version: 1.4.0.0 synopsis: Type-level JSON specification maintainer: rick@owensmurray.com description: See the README at: https://github.com/owensmurray/json-spec#json-spec diff --git a/src/Data/JsonSpec.hs b/src/Data/JsonSpec.hs --- a/src/Data/JsonSpec.hs +++ b/src/Data/JsonSpec.hs @@ -111,9 +111,9 @@ import Data.JsonSpec.Spec ( Field(Field), FieldSpec(Optional, Required), Ref(Ref, unRef) , Specification - ( JsonAnnotated, JsonArray, JsonBool, JsonDateTime, JsonEither, JsonInt - , JsonLet, JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef, JsonString - , JsonTag + ( JsonAnnotated, JsonArray, JsonBool, JsonDateTime, JsonDict, JsonEither + , JsonInt, JsonLet, JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef + , JsonString, JsonTag ) , Tag(Tag), (:::), (::?), JSONStructure, unField ) diff --git a/src/Data/JsonSpec/Decode.hs b/src/Data/JsonSpec/Decode.hs --- a/src/Data/JsonSpec/Decode.hs +++ b/src/Data/JsonSpec/Decode.hs @@ -23,6 +23,7 @@ import Data.JsonSpec.Spec ( Field(Field), Ref(Ref), Tag(Tag), JSONStructure, JStruct, Specification, sym ) +import Data.Map (Map) import Data.Proxy (Proxy) import Data.Scientific (Scientific) import Data.Text (Text) @@ -33,7 +34,9 @@ , Maybe(Just, Nothing), MonadFail(fail), Semigroup((<>)) , Traversable(traverse), ($), (.), (<$>), Bool, Int, String ) +import qualified Data.Aeson.Key as AK import qualified Data.Aeson.KeyMap as KM +import qualified Data.Map as Map import qualified Data.Vector as Vector @@ -120,6 +123,17 @@ withArray "list" (fmap Vector.toList . traverse reprParseJSON) +instance (StructureFromJSON a) => StructureFromJSON (Map Text a) where + reprParseJSON = + withObject + "dict" + ( fmap Map.fromList + . traverse + ( \(key, val) -> + (\val_ -> (AK.toText key, val_)) <$> reprParseJSON val + ) + . KM.toList + ) instance StructureFromJSON UTCTime where reprParseJSON = parseJSON instance (StructureFromJSON a) => StructureFromJSON (Maybe a) where diff --git a/src/Data/JsonSpec/Encode.hs b/src/Data/JsonSpec/Encode.hs --- a/src/Data/JsonSpec/Encode.hs +++ b/src/Data/JsonSpec/Encode.hs @@ -16,6 +16,7 @@ import Data.Aeson (ToJSON(toJSON), Value) +import Data.Map (Map) import Data.JsonSpec.Spec ( Field(Field), Ref(unRef), Specification(JsonArray), JSONStructure, JStruct , Tag, sym @@ -31,7 +32,9 @@ , (.), Bool, Int, id, maybe ) import qualified Data.Aeson as A +import qualified Data.Aeson.Key as AK import qualified Data.Aeson.KeyMap as KM +import qualified Data.Map as Map import qualified Data.Set as Set @@ -83,6 +86,12 @@ reprToJSON _proxy = toJSON (sym @const @Text) instance (StructureToJSON a) => StructureToJSON [a] where reprToJSON = toJSON . fmap reprToJSON +instance (StructureToJSON a) => StructureToJSON (Map Text a) where + reprToJSON = + A.Object + . KM.fromList + . fmap (\(key, val) -> (AK.fromText key, reprToJSON val)) + . Map.toList instance StructureToJSON UTCTime where reprToJSON = toJSON instance (StructureToJSON a) => StructureToJSON (Maybe a) where diff --git a/src/Data/JsonSpec/Spec.hs b/src/Data/JsonSpec/Spec.hs --- a/src/Data/JsonSpec/Spec.hs +++ b/src/Data/JsonSpec/Spec.hs @@ -26,6 +26,7 @@ import Data.Aeson (Value) import Data.Kind (Type) +import Data.Map (Map) import Data.Proxy (Proxy(Proxy)) import Data.Scientific (Scientific) import Data.String (IsString(fromString)) @@ -61,6 +62,14 @@ {-^ A JSON integer. -} JsonArray :: Specification -> Specification {-^ A JSON array of values which conform to the given spec. -} + JsonDict :: Specification -> Specification + {-^ + A JSON object used as a dictionary: arbitrary string keys, with every + value conforming to the given specification. + + This is distinct from 'JsonObject', which represents a record with + statically known fields. + -} JsonBool :: Specification {-^ A JSON boolean value. -} JsonNullable :: Specification -> Specification @@ -257,8 +266,8 @@ when building your 'HasJsonDecodingSpec' instances. See @TestHasField@ in the tests for an example - Arrays, booleans, numbers, and strings are just Lists, 'Bool's, - 'Scientific's, and 'Text's respectively. + Arrays, dicts, booleans, numbers, and strings are just Lists, + @'Map' 'Text'@, 'Bool's, 'Scientific's, and 'Text's respectively. If the user can convert their normal business logic type to/from this tuple type, then they get a JSON encoding to/from their type that is @@ -343,6 +352,7 @@ JStruct env JsonNum = Scientific JStruct env JsonInt = Int JStruct env (JsonArray spec) = [JStruct env spec] + JStruct env (JsonDict spec) = Map Text (JStruct env spec) JStruct env JsonBool = Bool JStruct env (JsonEither specs) = EitherJStruct env specs diff --git a/test/jsonspec.hs b/test/jsonspec.hs --- a/test/jsonspec.hs +++ b/test/jsonspec.hs @@ -26,19 +26,21 @@ import Control.Monad (join) import Data.Aeson (FromJSON, ToJSON) import Data.ByteString.Lazy (ByteString) +import Data.Either (isLeft) import Data.JsonSpec ( Field(Field), FieldSpec(Optional, Required) , HasJsonDecodingSpec(DecodingSpec, fromJSONStructure) , HasJsonEncodingSpec(EncodingSpec, toJSONStructure), Ref(Ref) , SpecJSON(SpecJSON) , Specification - ( JsonAnnotated, JsonArray, JsonBool, JsonDateTime, JsonEither, JsonInt - , JsonLet, JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef, JsonString - , JsonTag + ( JsonAnnotated, JsonArray, JsonBool, JsonDateTime, JsonDict, JsonEither + , JsonInt, JsonLet, JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef + , JsonString, JsonTag ) , Tag(Tag), (:::), (::?), eitherDecode , encode, unField ) +import Data.Map (Map) import Data.Proxy (Proxy(Proxy)) import Data.Scientific (Scientific) import Data.Text (Text) @@ -49,8 +51,9 @@ , Functor(fmap), Maybe(Just, Nothing), Monad((>>=)), Num(negate) , Traversable(traverse), ($), (.), Eq, IO, Int, Show, String, realToFrac ) -import Test.Hspec (describe, hspec, it, shouldBe) +import Test.Hspec (describe, hspec, it, shouldBe, shouldSatisfy) import qualified Data.Aeson as A +import qualified Data.Map as Map main :: IO () @@ -366,6 +369,184 @@ (Field @"qoo" False, ()))))) ) + in + actual `shouldBe` expected + + describe "dict" $ do + it "encodes an empty dict" $ + let + actual :: A.Value + actual = + encode + (Proxy @(JsonDict JsonInt)) + Map.empty + + expected :: A.Value + expected = A.object [] + in + actual `shouldBe` expected + + it "round-trips a non-empty int dict" $ + let + raw :: A.Value + raw = + A.object + [ ("alpha", A.Number 1) + , ("beta", A.Number 2) + ] + + decoded :: Either String (Map Text Int) + decoded = + eitherDecode + (Proxy @(JsonDict JsonInt)) + raw + + encoded :: Either String A.Value + encoded = + fmap + (encode (Proxy @(JsonDict JsonInt))) + decoded + + expected :: Either String A.Value + expected = Right raw + in + encoded `shouldBe` expected + + it "decodes a dict of objects" $ + let + raw :: A.Value + raw = + A.object + [ ( "first" + , A.object + [ ("foo", A.String "first") + , ("bar", A.Number 1) + ] + ) + , ( "second" + , A.object + [ ("foo", A.String "second") + , ("bar", A.Number 2) + ] + ) + ] + + actual + :: Either + String + (Map Text + (Field "foo" Text, + (Field "bar" Int, + ()))) + actual = + eitherDecode + (Proxy @(JsonDict (JsonObject + '[ "foo" ::: JsonString + , "bar" ::: JsonInt + ]))) + raw + + expected + :: Either + String + (Map Text + (Field "foo" Text, + (Field "bar" Int, + ()))) + expected = + Right $ + Map.fromList + [ ( "first" + , (Field @"foo" "first", + (Field @"bar" 1, + ())) + ) + , ( "second" + , (Field @"foo" "second", + (Field @"bar" 2, + ())) + ) + ] + in + actual `shouldBe` expected + + it "decodes a dict of nullable values" $ + let + raw :: A.Value + raw = + A.object + [ ("present", A.String "value") + , ("missing", A.Null) + ] + + actual :: Either String (Map Text (Maybe Text)) + actual = + eitherDecode + (Proxy @(JsonDict (JsonNullable JsonString))) + raw + + expected :: Either String (Map Text (Maybe Text)) + expected = + Right $ + Map.fromList + [ ("missing", Nothing) + , ("present", Just "value") + ] + in + actual `shouldBe` expected + + it "rejects dict values that do not match the value spec" $ + let + actual :: Either String (Map Text Int) + actual = + eitherDecode + (Proxy @(JsonDict JsonInt)) + (A.object [("bad", A.String "not an int")]) + in + actual `shouldSatisfy` isLeft + + it "rejects non-object dict JSON" $ + let + actual :: Either String (Map Text Int) + actual = + eitherDecode + (Proxy @(JsonDict JsonInt)) + (A.String "not an object") + in + actual `shouldSatisfy` isLeft + + it "works inside an object field" $ + let + actual + :: Either + String + (Field "attrs" (Map Text Int), ()) + actual = + eitherDecode + (Proxy @(JsonObject '[ "attrs" ::: JsonDict JsonInt ])) + ( A.object + [ ( "attrs" + , A.object + [ ("alpha", A.Number 1) + , ("beta", A.Number 2) + ] + ) + ] + ) + + expected + :: Either + String + (Field "attrs" (Map Text Int), ()) + expected = + Right + ( Field @"attrs" $ + Map.fromList + [ ("alpha", 1) + , ("beta", 2) + ] + , () + ) in actual `shouldBe` expected