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: 0.3.0.1 +version: 0.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 @@ -77,6 +77,7 @@ JSONStructure, Rec(..), eitherDecode, + encode, StructureFromJSON, FieldSpec(..) ) where @@ -86,11 +87,12 @@ import Data.JsonSpec.Decode (HasJsonDecodingSpec(DecodingSpec, fromJSONStructure), StructureFromJSON(reprParseJSON), eitherDecode) import Data.JsonSpec.Encode (HasJsonEncodingSpec(EncodingSpec, - toJSONStructure), StructureToJSON(reprToJSON)) + toJSONStructure), StructureToJSON(reprToJSON), encode) import Data.JsonSpec.Spec (Field(Field, unField), FieldSpec(Optional, Required), Rec(Rec, unRec), Specification(JsonArray, JsonBool, JsonDateTime, JsonEither, JsonInt, JsonLet, JsonNullable, JsonNum, - JsonObject, JsonRef, JsonString, JsonTag), Tag(Tag), JSONStructure) + JsonObject, JsonRaw, JsonRef, JsonString, JsonTag), Tag(Tag), + JSONStructure) import Prelude ((.), (<$>), (=<<)) 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 @@ -69,6 +69,8 @@ -} class StructureFromJSON a where reprParseJSON :: Value -> Parser a +instance StructureFromJSON Value where + reprParseJSON = pure instance StructureFromJSON Text where reprParseJSON = withText "string" pure instance StructureFromJSON Scientific 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 @@ -11,19 +11,21 @@ module Data.JsonSpec.Encode ( HasJsonEncodingSpec(..), StructureToJSON(..), + encode, ) where import Data.Aeson (ToJSON(toJSON), Value) import Data.JsonSpec.Spec (Field(Field), Rec(unRec), Specification(JsonArray), JSONStructure, JStruct, Tag, sym) +import Data.Proxy (Proxy(Proxy)) import Data.Scientific (Scientific) import Data.Set (Set) import Data.Text (Text) import Data.Time (UTCTime) import GHC.TypeLits (KnownSymbol) import Prelude (Either(Left, Right), Functor(fmap), Maybe(Just, Nothing), - Monoid(mempty), (.), Bool, Int, maybe) + Monoid(mempty), (.), Bool, Int, id, maybe) import qualified Data.Aeson as A import qualified Data.Aeson.KeyMap as KM import qualified Data.Set as Set @@ -55,6 +57,8 @@ -} class StructureToJSON a where reprToJSON :: a -> Value +instance StructureToJSON Value where + reprToJSON = id instance StructureToJSON () where reprToJSON () = A.object [] instance StructureToJSON Bool where @@ -117,5 +121,15 @@ (sym @key) (reprToJSON val) (toJSONObject more) + + +{-| + Given a raw Haskell structure, directly encode it directly into an + aeson Value without having to go through any To/FromJSON instances. + + See also: `Data.JsonSpec.eitherDecode`. +-} +encode :: StructureToJSON (JSONStructure spec) => Proxy spec -> JSONStructure spec -> Value +encode Proxy = reprToJSON 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 @@ -19,6 +19,7 @@ ) where +import Data.Aeson (Value) import Data.Kind (Type) import Data.Proxy (Proxy(Proxy)) import Data.Scientific (Scientific) @@ -31,7 +32,7 @@ {-| Simple DSL for defining type level "specifications" for JSON data. Similar in spirit to (but not isomorphic with) JSON Schema. - + Intended to be used at the type level using @-XDataKinds@ See 'JSONStructure' for how these map into Haskell representations. @@ -111,7 +112,7 @@ {-^ A "let" expression. This is useful for giving names to types, which can then be used in the generated code. - + This is also useful to shorten repetitive type definitions. For example, this repetitive definition: @@ -133,7 +134,7 @@ > Required "z" JsonInt) > ]) > ] - + Can be written more concisely as: > type Triangle = @@ -168,8 +169,10 @@ A reference to a specification which has been defined in a surrounding 'JsonLet'. -} + | JsonRaw {-^ Some raw, uninterpreted JSON value -} + {-| Specify a field in an object. -} data FieldSpec = Required Symbol Specification {-^ The field is required -} @@ -255,6 +258,7 @@ JStruct env (JsonLet defs spec) = JStruct (Append defs env) spec JStruct env (JsonRef ref) = Lookup ref env + JStruct env JsonRaw = Value {-| @@ -290,7 +294,7 @@ > JsonLet > '[ '("Foo", JsonArray (JsonRef "Foo")) ] > (JsonRef "Foo") - > toJSONStructure (Foo fs) = + > toJSONStructure (Foo fs) = > [ Rec (toJSONStructure f) > | f <- fs > ] diff --git a/test/jsonspec.hs b/test/jsonspec.hs --- a/test/jsonspec.hs +++ b/test/jsonspec.hs @@ -17,20 +17,13 @@ import Control.Monad (join) import Data.Aeson (FromJSON, ToJSON) import Data.ByteString.Lazy (ByteString) -import Data.JsonSpec (Field(Field, unField), FieldSpec(Optional, - Required), HasJsonDecodingSpec(DecodingSpec, fromJSONStructure), - HasJsonEncodingSpec(EncodingSpec, toJSONStructure), Rec(Rec, unRec), - SpecJSON(SpecJSON), Specification(JsonArray, JsonBool, JsonDateTime, - JsonEither, JsonInt, JsonLet, JsonNullable, JsonNum, JsonObject, - JsonRef, JsonString, JsonTag), Tag(Tag), eitherDecode) +import Data.JsonSpec 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((>>=)), - Traversable(traverse), ($), (.), Eq, IO, Int, Show, String, realToFrac) +import Prelude import Test.Hspec (describe, hspec, it, shouldBe) import qualified Data.Aeson as A @@ -140,7 +133,7 @@ let actual :: Either String TestOptionality actual = A.eitherDecode "{\"bar\":null,\"qux\":1}" - + expected :: Either String TestOptionality expected = Right obj in @@ -150,7 +143,7 @@ let actual :: Either String TestOptionality actual = A.eitherDecode "{\"bar\":null,\"baz\":null,\"qux\":1}" - + expected :: Either String TestOptionality expected = Right obj in @@ -251,7 +244,6 @@ in actual `shouldBe` expected - describe "nullable" $ do it "encodes product" $ let @@ -282,10 +274,27 @@ in actual `shouldBe` expected - it "eitherDecode" $ - let - actual - :: Either + 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), @@ -296,35 +305,91 @@ (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 + 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 '[ Required "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 + sampleTestObject :: TestObj sampleTestObject =