json-spec 0.5.0.1 → 1.0.0.0

raw patch · 6 files changed

+302/−102 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• json-spec.cabal +1/−1
• src/Data/JsonSpec.hs +17/−10
• src/Data/JsonSpec/Decode.hs +15/−10
• src/Data/JsonSpec/Encode.hs +11/−7
• src/Data/JsonSpec/Spec.hs +39/−45
• test/jsonspec.hs +219/−29

@@ -1,6 +1,6 @@ cabal-version:       3.0 name:                json-spec-version:             0.5.0.1+version:             1.0.0.0 synopsis:            Type-level JSON specification maintainer:          rick@owensmurray.com description:         See the README at: https://github.com/owensmurray/json-spec#json-spec

@@ -76,7 +76,7 @@   Field(..),   unField,   JSONStructure,-  Rec(..),+  Ref(..),   eitherDecode,   encode,   StructureFromJSON,@@ -87,15 +87,22 @@   import Data.Aeson (FromJSON(parseJSON), ToJSON(toJSON))-import Data.JsonSpec.Decode (HasJsonDecodingSpec(DecodingSpec,-  fromJSONStructure), StructureFromJSON(reprParseJSON), eitherDecode)-import Data.JsonSpec.Encode (HasJsonEncodingSpec(EncodingSpec,-  toJSONStructure), StructureToJSON(reprToJSON), encode)-import Data.JsonSpec.Spec (Field(Field), FieldSpec(Optional, Required),-  Rec(Rec, unRec), Specification(JsonArray, JsonBool, JsonDateTime,-  JsonEither, JsonInt, JsonLet, JsonNullable, JsonNum, JsonObject,-  JsonRaw, JsonRef, JsonString, JsonTag), Tag(Tag), (:::), (::?),-  JSONStructure, unField)+import Data.JsonSpec.Decode+  ( HasJsonDecodingSpec(DecodingSpec, fromJSONStructure)+  , StructureFromJSON(reprParseJSON), eitherDecode+  )+import Data.JsonSpec.Encode+  ( HasJsonEncodingSpec(EncodingSpec, toJSONStructure)+  , StructureToJSON(reprToJSON), encode+  )+import Data.JsonSpec.Spec+  ( Field(Field), FieldSpec(Optional, Required), Ref(Ref, unRef)+  , Specification+    ( JsonArray, JsonBool, JsonDateTime, JsonEither, JsonInt, JsonLet+    , JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef, JsonString, JsonTag+    )+  , Tag(Tag), (:::), (::?), JSONStructure, unField+  ) import Prelude ((.), (<$>), (=<<))  

@@ -16,18 +16,23 @@   import Control.Applicative (Alternative((<|>)))-import Data.Aeson.Types (FromJSON(parseJSON), Value(Null, Object),-  Parser, parseEither, withArray, withObject, withScientific, withText)-import Data.JsonSpec.Spec (Field(Field), Rec(Rec), Tag(Tag),-  JSONStructure, JStruct, Specification, sym)+import Data.Aeson.Types+  ( FromJSON(parseJSON), Value(Null, Object), Parser, parseEither, withArray+  , withObject, withScientific, withText+  )+import Data.JsonSpec.Spec+  ( Field(Field), Ref(Ref), Tag(Tag), JSONStructure, JStruct, Specification, sym+  ) import Data.Proxy (Proxy) 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), ($), (.), (<$>), Bool, Int, String)+import Prelude+  ( Applicative(pure), Either(Left, Right), Eq((==)), Functor(fmap)+  , Maybe(Just, Nothing), MonadFail(fail), Semigroup((<>))+  , Traversable(traverse), ($), (.), (<$>), Bool, Int, String+  ) import qualified Data.Aeson.KeyMap as KM import qualified Data.Vector as Vector @@ -123,12 +128,12 @@       Null -> pure Nothing       _ -> Just <$> reprParseJSON val instance-    (StructureFromJSON (JStruct ('(name, Rec env name spec) : env) spec))+    (StructureFromJSON (JStruct env spec))   =>-    StructureFromJSON (Rec env name spec)+    StructureFromJSON (Ref env spec)   where   reprParseJSON val =-    Rec <$> reprParseJSON val+    Ref <$> reprParseJSON val   {-|

@@ -16,16 +16,20 @@   import Data.Aeson (ToJSON(toJSON), Value)-import Data.JsonSpec.Spec (Field(Field), Rec(unRec),-  Specification(JsonArray), JSONStructure, JStruct, Tag, sym)+import Data.JsonSpec.Spec+  ( Field(Field), Ref(unRef), 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, id, maybe)+import Prelude+  ( Either(Left, Right), Functor(fmap), Maybe(Just, Nothing), 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@@ -84,11 +88,11 @@ instance (StructureToJSON a) => StructureToJSON (Maybe a) where   reprToJSON = maybe A.Null reprToJSON instance-    (StructureToJSON (JStruct ('(name, Rec env name spec) : env) spec))+    (StructureToJSON (JStruct env spec))   =>-    StructureToJSON (Rec env name spec)+    StructureToJSON (Ref env spec)   where-    reprToJSON = reprToJSON . unRec+    reprToJSON = reprToJSON . unRef   {- |

@@ -15,7 +15,7 @@   Tag(..),   Field(..),   unField,-  Rec(..),+  Ref(..),   JStruct,   FieldSpec(..),   (:::),@@ -178,7 +178,6 @@   | JsonRaw {-^ Some raw, uninterpreted JSON value -}  - {-| Specify a field in an object.  -} data FieldSpec   = Required Symbol Specification {-^ The field is required -}@@ -222,35 +221,19 @@   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 env k where+  Lookup ('(k, v) : more) k = v+  Lookup (_ : more) k = Lookup more k  -type family-  Lookup-    (key :: Symbol)-    (env :: [(Symbol, Type)])-  :: Type-  where-    Lookup key ( '(key, spec) : more ) = spec-    Lookup key ( _ : more ) = Lookup key more+type family PushAll (a :: [k]) (b :: [k]) :: [k] where+  PushAll '[] b = b+  PushAll (e : more) b = PushAll more (e : b)   type family   JStruct-    (env :: [(Symbol, Type)])+    (env :: [(Symbol, Specification)])     (spec :: Specification)   :: Type   where@@ -276,18 +259,21 @@     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+      JStruct (PushAll defs env) spec+    JStruct env (JsonRef ref) = Ref env (Lookup env ref)     JStruct env JsonRaw = Value   {-|-  This allows for recursive specifications.+  This is the "Haskell structure" type of 'JsonRef' references. -  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.+  The main reason why we need this is because of recursion, as explained+  below: +  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]@@ -295,16 +281,19 @@   >   type EncodingSpec Foo = JsonArray (EncodingSpec Foo)   >   toJSONStructure = ... can't be written +  ... because @EncodingSpec Foo@ would expand strictly into an array of+  @EncodingSpec Foo@, which would expand strictly... to infinity.+   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.+  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 you use a 'JsonRef' in the spec, the corresponding+  structural type will have a 'Ref' newtype wrapper around the+  "dereferenced" structure type.    For example: @@ -315,17 +304,22 @@   >       '[ '("Foo", JsonArray (JsonRef "Foo")) ]   >       (JsonRef "Foo")   >   toJSONStructure (Foo fs) =-  >     [ Rec (toJSONStructure f)-  >     | f <- fs-  >     ]+  >     Ref [ toJSONStructure <$> fs ]++  Strictly speaking, we wouldn't /necessarily/ have to translate every+  'JsonRef' into a 'Ref'. In principal we could get away with inserting a+  'Ref' somewhere in every mutually recursive cycle. But the type level+  programming to figure that out a) probably wouldn't do any favors to+  compilation times, b) is beyond what I'm willing to attempted right+  now, and c) requires some kind of deterministic and stable choice+  about where to insert the 'Ref' (which I'm not even certain exists)+  lest arbitrary 'HasJsonEncodingSpec' or 'HasJsonDecodingSpec' instances+  break when the members of the recursive cycle change, causing a new+  choice about where to place the 'Ref'. -}-newtype Rec env name spec = Rec-  { unRec ::-      JStruct-        ( '(name, Rec env name spec) : env)-        spec+newtype Ref env spec = Ref+  { unRef :: JStruct env spec   }-   {-| Structural representation of 'JsonTag'. (I.e. a constant string value.) -}

@@ -1,5 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-}@@ -11,8 +13,13 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wwarn #-} {- Because of GHC-69797 -}-{- But re-enable the errors we most care about -}+{-+  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@@ -20,22 +27,27 @@ 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), Rec(Rec, unRec),-  SpecJSON(SpecJSON), Specification(JsonArray, JsonBool, JsonDateTime,-  JsonEither, JsonInt, JsonLet, JsonNullable, JsonNum, JsonObject,-  JsonRaw, JsonRef, JsonString, JsonTag), Tag(Tag), (:::), (::?),-  eitherDecode, encode, unField)+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 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 @@ -431,7 +443,88 @@         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@@ -653,16 +746,16 @@          , Required "vertex3" (JsonRef "Vertex")          ])   toJSONStructure Triangle {vertex1, vertex2, vertex3} =-    (Field @"vertex1" (toJSONStructure vertex1),-    (Field @"vertex2" (toJSONStructure vertex2),-    (Field @"vertex3" (toJSONStructure 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" rawVertex1,-      (Field @"vertex2" rawVertex2,-      (Field @"vertex3" rawVertex3,+      (Field @"vertex1" (Ref rawVertex1),+      (Field @"vertex2" (Ref rawVertex2),+      (Field @"vertex3" (Ref rawVertex3),       ())))     = do       vertex1 <- fromJSONStructure rawVertex1@@ -689,20 +782,24 @@          ]         (JsonRef "LabelledTree")   toJSONStructure LabelledTree {label , children } =-    (Field @"label" label,-    (Field @"children"-      [ Rec (toJSONStructure child)-      | child <- children-      ],-    ()))+    Ref+      (Field @"label" label,+      (Field @"children"+        [ toJSONStructure child+        | child <- children+        ],+      ())) instance HasJsonDecodingSpec LabelledTree where   type DecodingSpec LabelledTree = EncodingSpec LabelledTree   fromJSONStructure-      (Field @"label" label,-      (Field @"children" children_,-      ()))+      (+        Ref+          (Field @"label" label,+          (Field @"children" children_,+          ()))+      )     = do-      children <- traverse (fromJSONStructure . unRec) children_+      children <- traverse fromJSONStructure children_       pure LabelledTree { label , children }  @@ -773,4 +870,97 @@          } ++{- 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 }++{- ========================================================================== -}