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.1.0.0 +version: 0.2.0.0 synopsis: Type-level JSON specification maintainer: rick@owensmurray.com description: = Motivation diff --git a/src/Data/JsonSpec.hs b/src/Data/JsonSpec.hs --- a/src/Data/JsonSpec.hs +++ b/src/Data/JsonSpec.hs @@ -32,7 +32,7 @@ > ())) > = > pure User { name , lastLogin } - + = Motivation The particular use cases we focus on are enabling (but not providing @@ -98,6 +98,7 @@ Tag(..), Field(..), JSONStructure, + Rec(..), ) where @@ -106,9 +107,10 @@ fromJSONStructure), StructureFromJSON(reprParseJSON)) import Data.JsonSpec.Encode (HasJsonEncodingSpec(EncodingSpec, toJSONStructure), StructureToJSON(reprToJSON)) -import Data.JsonSpec.Spec (Field(Field), Specification(JsonArray, - JsonBool, JsonDateTime, JsonEither, JsonInt, JsonNullable, JsonNum, - JsonObject, JsonString, JsonTag), Tag(Tag), JSONStructure) +import Data.JsonSpec.Spec (Field(Field), Rec(Rec, unRec), + Specification(JsonArray, JsonBool, JsonDateTime, JsonEither, JsonInt, + JsonLet, JsonNullable, JsonNum, JsonObject, JsonRef, JsonString, + JsonTag), Tag(Tag), JSONStructure) {- | 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 @@ -4,6 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {- | Decoding using specs. -} @@ -14,15 +15,18 @@ import Control.Applicative (Alternative((<|>))) -import Data.Aeson (Value(Null, Object), parseJSON, withArray, withObject, - withScientific, withText) +import Data.Aeson (FromJSON(parseJSON), Value(Null, Object), withArray, + withObject, withScientific, withText) import Data.Aeson.Types (Parser) -import Data.JsonSpec.Spec (Field(Field), Tag(Tag), JSONStructure, - Specification, sym) +import Data.JsonSpec.Spec (Field(Field), Rec(Rec), Tag(Tag), + JSONStructure, JStruct, Specification, sym) import Data.Scientific (Scientific) import Data.Text (Text) import Data.Time (UTCTime) import GHC.TypeLits (KnownSymbol) +import Prelude (Applicative(pure), Either(Left, Right), Eq((==)), + Functor(fmap), Maybe(Just, Nothing), MonadFail(fail), Semigroup((<>)), + Traversable(traverse), ($), (.), (<$>), Int) import qualified Data.Aeson.KeyMap as KM import qualified Data.Vector as Vector @@ -103,5 +107,14 @@ case val of Null -> pure Nothing _ -> Just <$> reprParseJSON val +instance + (StructureFromJSON (JStruct ('(name, Rec env name spec) : env) spec)) + => + StructureFromJSON (Rec env name spec) + where + reprParseJSON val = + Rec <$> reprParseJSON val + + 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 @@ -5,6 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Data.JsonSpec.Encode ( @@ -14,12 +15,14 @@ import Data.Aeson (ToJSON(toJSON), Value) -import Data.JsonSpec.Spec (Field(Field), JSONStructure, Specification, - Tag, sym) +import Data.JsonSpec.Spec (Field(Field), Rec(unRec), JSONStructure, + JStruct, Specification, Tag, sym) import Data.Scientific (Scientific) import Data.Text (Text) import Data.Time (UTCTime) import GHC.TypeLits (KnownSymbol) +import Prelude (Either(Left, Right), Functor(fmap), Monoid(mempty), + (.), Int, Maybe, maybe) import qualified Data.Aeson as A import qualified Data.Aeson.KeyMap as KM @@ -56,7 +59,7 @@ instance StructureToJSON Int where reprToJSON = toJSON instance (ToJSONObject (a, b)) => StructureToJSON (a, b) where - reprToJSON = A.Object . toJSONObject + reprToJSON = A.Object . toJSONObject instance (StructureToJSON left, StructureToJSON right) => StructureToJSON (Either left right) where reprToJSON = \case Left val -> reprToJSON val @@ -69,6 +72,12 @@ reprToJSON = toJSON instance (StructureToJSON a) => StructureToJSON (Maybe a) where reprToJSON = maybe A.Null reprToJSON +instance + (StructureToJSON (JStruct ('(name, Rec env name spec) : env) spec)) + => + StructureToJSON (Rec env name spec) + where + reprToJSON = reprToJSON . unRec {- | 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 @@ -4,6 +4,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Data.JsonSpec.Spec ( Specification(..), @@ -11,9 +12,12 @@ sym, Tag(..), Field(..), + Rec(..), + JStruct, ) where +import Data.Kind (Type) import Data.Proxy (Proxy(Proxy)) import Data.Scientific (Scientific) import Data.String (IsString(fromString)) @@ -101,8 +105,54 @@ corresponds to `Data.Time.UTCTime`, and in json-schema it corresponds to the "date-time" format. -} + | JsonLet [(Symbol, Specification)] Specification + {-^ + 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: + > type Triangle = + > JsonObject + > '[ '("vertex1", + > JsonObject '[('x', JsonInt), ('y', JsonInt), ('z', JsonInt)]) + > , '("vertex2", + > JsonObject '[('x', JsonInt), ('y', JsonInt), ('z', JsonInt)]) + > , '("vertex3", + > JsonObject '[('x', JsonInt), ('y', JsonInt), ('z', JsonInt)]) + > ] + + Can be written more concisely as: + > type Triangle = + > JsonLet '[("Vertex", + > JsonObject '[('x', JsonInt), ('y', JsonInt), ('z', JsonInt)]) + > ] + > (JsonObject + > '[ '("vertex1", JsonRef "Vertex") + > , '("vertex2", JsonRef "Vertex") + > , '("vertex3", JsonRef "Vertex") + > ]) + + Another use is to define recursive types: + + > type LabelledTree = + > JsonLet '[ '("LabelledTree", + > JsonObject + > '[ '("label", JsonString) + > , '("children", JsonArray (JsonRef "LabelledTree")) + > ]) + > ] + > (JsonRef "LabelledTree") + -} + | JsonRef Symbol + {-^ + A reference to a specification which has been defined in a surrounding + 'JsonLet'. + -} + + {- | @'JSONStructure' spec@ is the Haskell type used to contain the JSON data that will be encoded or decoded according to the provided @spec@. @@ -123,22 +173,107 @@ guaranteed to be compliant with the 'Specification' -} type family JSONStructure (spec :: Specification) where - JSONStructure (JsonObject '[]) = () - JSONStructure (JsonObject ( '(key, s) : more )) = - ( - Field key (JSONStructure s), - JSONStructure (JsonObject more) - ) - JSONStructure JsonString = Text - JSONStructure JsonNum = Scientific - JSONStructure JsonInt = Int - JSONStructure (JsonArray spec) = [JSONStructure spec] - JSONStructure JsonBool = Bool - JSONStructure (JsonEither left right) = - Either (JSONStructure left) (JSONStructure right) - JSONStructure (JsonTag tag) = Tag tag - JSONStructure JsonDateTime = UTCTime - JSONStructure (JsonNullable spec) = Maybe (JSONStructure spec) + JSONStructure spec = JStruct '[] spec + + +type family + Append + (defs :: [(Symbol, Specification)]) + (env :: [(Symbol, Type)]) + :: [(Symbol, Type)] + where + Append '[] env = env + Append ( '(name, spec) : defs ) env = + '( name + , JStruct + ( '(name, Rec env name spec) : env) + spec + ) + : Append defs env + + +type family + Lookup + (key :: Symbol) + (env :: [(Symbol, Type)]) + :: Type + where + Lookup key ( '(key, spec) : more ) = spec + Lookup key ( _ : more ) = Lookup key more + + +type family + JStruct + (env :: [(Symbol, Type)]) + (spec :: Specification) + :: Type + where + JStruct env (JsonObject '[]) = () + JStruct env (JsonObject ( '(key, s) : more )) = + ( + Field key (JStruct env s), + JStruct env (JsonObject more) + ) + JStruct env JsonString = Text + JStruct env JsonNum = Scientific + JStruct env JsonInt = Int + JStruct env (JsonArray spec) = [JStruct env spec] + JStruct env JsonBool = Bool + JStruct env (JsonEither left right) = + Either (JStruct env left) (JStruct env right) + JStruct env (JsonTag tag) = Tag tag + JStruct env JsonDateTime = UTCTime + JStruct env (JsonNullable spec) = Maybe (JStruct env spec) + JStruct env (JsonLet defs spec) = + JStruct (Append defs env) spec + JStruct env (JsonRef ref) = Lookup ref env + + +{-| + This allows for recursive specifications. + + Since the specification is at the + type level, and type level haskell is strict, specifying a recursive + definition the "naive" way would cause an infinitely sized type. + + For example this won't work: + + > data Foo = Foo [Foo] + > instance HasJsonEncodingSpec Foo where + > type EncodingSpec Foo = JsonArray (EncodingSpec Foo) + > toJSONStructure = ... can't be written + + Using `JsonLet` prevents the specification type from being infinitely + sized, but what about "structure" type which holds real values + corresponding to the spec? The structure type has to have some way to + reference itself or else it too would be infinitely sized. + + In order to "reference itself" the structure type has to go + through a newtype somewhere along the way, and that's what this + type is for. Whenever the structure type for your spec requires a + self-reference, it will require you to wrap the recursed upon values + in this type. + + For example: + + > data Foo = Foo [Foo] + > instance HasJsonEncodingSpec Foo where + > type EncodingSpec Foo = + > JsonLet + > '[ '("Foo", JsonArray (JsonRef "Foo")) ] + > (JsonRef "Foo") + > toJSONStructure (Foo fs) = + > [ Rec (toJSONStructure f) + > | f <- fs + > ] +-} +newtype Rec env name spec = Rec + { unRec :: + JStruct + ( '(name, Rec env name spec) : env) + spec + } + {-| Structural representation of 'JsonTag'. (I.e. a constant string value.) -} diff --git a/test/jsonspec.hs b/test/jsonspec.hs --- a/test/jsonspec.hs +++ b/test/jsonspec.hs @@ -12,17 +12,18 @@ module Main (main) where import Data.Aeson (FromJSON, ToJSON) -import Data.Aeson.Types (Parser) import Data.ByteString.Lazy (ByteString) import Data.JsonSpec (Field(Field), HasJsonDecodingSpec(DecodingSpec, fromJSONStructure), HasJsonEncodingSpec(EncodingSpec, toJSONStructure), - SpecJSON(SpecJSON), Specification(JsonDateTime, JsonEither, JsonInt, - JsonNullable, JsonNum, JsonObject, JsonString, JsonTag), Tag(Tag)) -import Data.Proxy (Proxy(Proxy)) -import Data.Scientific (Scientific, floatingOrInteger) + Rec(Rec, unRec), SpecJSON(SpecJSON), Specification(JsonArray, + JsonDateTime, JsonEither, JsonInt, JsonLet, JsonNullable, JsonNum, + JsonObject, JsonRef, JsonString, JsonTag), Tag(Tag)) +import Data.Scientific (Scientific) import Data.Text (Text) import Data.Time (UTCTime(UTCTime)) -import GHC.TypeLits (KnownSymbol, symbolVal) +import Prelude (Applicative(pure), Either(Left, Right), Enum(toEnum), + Maybe(Just, Nothing), Traversable(traverse), ($), (.), Eq, IO, Int, + Show, String, realToFrac) import Test.Hspec (describe, hspec, it, shouldBe) import qualified Data.Aeson as A @@ -95,7 +96,7 @@ actual = A.eitherDecode "{ \"name\": \"foo\", \"last-login\": \"1858-11-17T00:00:00Z\" }" - + expected :: Either String User expected = Right @@ -107,6 +108,102 @@ 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 @@ -143,12 +240,11 @@ TestObj { foo = "foo" , bar = 1 - , baz = + , baz = TestSubObj { foo2 = "foo2" , bar2 = 0 } - , qux = Just 100 } @@ -158,7 +254,7 @@ TestObj { foo = "foo" , bar = 1 - , baz = + , baz = TestSubObj { foo2 = "foo2" , bar2 = 0 @@ -180,7 +276,7 @@ (JsonObject '[ '("tag", JsonTag "a"), '("content", JsonObject [ - '("int-field", JsonNum), + '("int-field", JsonInt), '("txt-field", JsonString) ]) ]) @@ -192,7 +288,7 @@ Left (Field @"tag" (Tag @"a"), (Field @"content" - ( (Field @"int-field" (realToFrac i) + ( (Field @"int-field" i , (Field @"txt-field" t , () ) @@ -206,9 +302,15 @@ instance HasJsonDecodingSpec TestSum where type DecodingSpec TestSum = EncodingSpec TestSum fromJSONStructure = \case - Left (Field Tag, (Field (rawInt, (Field txt, ())), ())) -> do - int <- parseInt rawInt - pure (TestA int txt) + Left + (Field @"tag" Tag, + (Field @"content" + (Field @"int-field" int, + (Field @"txt-field" txt, + ())), + ())) + -> + pure (TestA int txt) Right _ -> pure TestB @@ -258,33 +360,21 @@ instance HasJsonEncodingSpec TestSubObj where type EncodingSpec TestSubObj = JsonObject - '[ - '("foo", JsonString), - '("bar", JsonNum) - ] + '[ '("foo", JsonString) + , '("bar", JsonInt) + ] toJSONStructure TestSubObj { foo2 , bar2 } = (Field @"foo" foo2, - (Field @"bar" (realToFrac bar2), + (Field @"bar" bar2, ())) instance HasJsonDecodingSpec TestSubObj where type DecodingSpec TestSubObj = EncodingSpec TestSubObj - fromJSONStructure ((Field foo2), (rawBar, ())) = do - bar2 <- parseInt rawBar - pure TestSubObj {foo2 , bar2} - - -parseInt - :: forall key. - (KnownSymbol key) - => Field key Scientific - -> Parser Int -parseInt (Field val) = - case floatingOrInteger val of - Left (_ :: Float) -> - fail $ - "Bad integer for property: " - <> symbolVal (Proxy @key) - Right i -> pure i + fromJSONStructure + (Field @"foo" foo2, + (Field @"bar" bar2, + ())) + = + pure TestSubObj {foo2 , bar2} data User = User @@ -311,5 +401,105 @@ ())) = 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 + '[ '("x", JsonInt) + , '("y", JsonInt) + , '("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 + '[ '("vertex1", JsonRef "Vertex") + , '("vertex2", JsonRef "Vertex") + , '("vertex3", JsonRef "Vertex") + ]) + toJSONStructure Triangle {vertex1, vertex2, vertex3} = + (Field @"vertex1" (toJSONStructure vertex1), + (Field @"vertex2" (toJSONStructure vertex2), + (Field @"vertex3" (toJSONStructure vertex3), + ()))) +instance HasJsonDecodingSpec Triangle where + type DecodingSpec Triangle = EncodingSpec Triangle + fromJSONStructure + (Field @"vertex1" rawVertex1, + (Field @"vertex2" rawVertex2, + (Field @"vertex3" 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 + '[ '("label", JsonString) + , '("children", JsonArray (JsonRef "LabelledTree")) + ] + ) + ] + (JsonRef "LabelledTree") + toJSONStructure LabelledTree {label , children } = + (Field @"label" label, + (Field @"children" + [ Rec (toJSONStructure child) + | child <- children + ], + ())) +instance HasJsonDecodingSpec LabelledTree where + type DecodingSpec LabelledTree = EncodingSpec LabelledTree + fromJSONStructure + (Field @"label" label, + (Field @"children" children_, + ())) + = do + children <- traverse (fromJSONStructure . unRec) children_ + pure LabelledTree { label , children }