json-spec 0.1.0.0 → 0.2.0.0
raw patch · 6 files changed
+414/−65 lines, 6 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Data.JsonSpec: JsonLet :: [(Symbol, Specification)] -> Specification -> Specification
+ Data.JsonSpec: JsonRef :: Symbol -> Specification
+ Data.JsonSpec: Rec :: JStruct ('(name, Rec env name spec) : env) spec -> Rec env name spec
+ Data.JsonSpec: [unRec] :: Rec env name spec -> JStruct ('(name, Rec env name spec) : env) spec
+ Data.JsonSpec: newtype Rec env name spec
Files
- json-spec.cabal +1/−1
- src/Data/JsonSpec.hs +6/−4
- src/Data/JsonSpec/Decode.hs +17/−4
- src/Data/JsonSpec/Encode.hs +12/−3
- src/Data/JsonSpec/Spec.hs +151/−16
- test/jsonspec.hs +227/−37
json-spec.cabal view
@@ -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
src/Data/JsonSpec.hs view
@@ -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) {- |
src/Data/JsonSpec/Decode.hs view
@@ -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++
src/Data/JsonSpec/Encode.hs view
@@ -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 {- |
src/Data/JsonSpec/Spec.hs view
@@ -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.) -}
test/jsonspec.hs view
@@ -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 }