json-schema 0.5 → 0.6
raw patch · 6 files changed
+446/−64 lines, 6 filesdep +HUnitdep +attoparsecdep +bytestringdep ~aesondep ~basedep ~generic-aeson
Dependencies added: HUnit, attoparsec, bytestring, json-schema, tasty, tasty-hunit, tasty-th, time
Dependency ranges changed: aeson, base, generic-aeson, text
Files
- CHANGELOG.md +17/−0
- json-schema.cabal +24/−4
- src/Data/JSON/Schema/Combinators.hs +28/−7
- src/Data/JSON/Schema/Generic.hs +39/−23
- src/Data/JSON/Schema/Types.hs +121/−30
- tests/Main.hs +217/−0
CHANGELOG.md view
@@ -1,3 +1,20 @@+## 0.6++Breaking changes:++* Add `Constant Aeson.Value` type to `Schema`+* Change Number to take a `Bound` for the boundary. Before this the upper bound could not be `-1`.+* Change `Value` and `Array` to take a `LengthBound`. The difference from Number is that these values should always be `>= 0` if present.++Minor:++* Add `Bound { lower :: Maybe Int, upper :: Maybe Int }`+* Add `unbounded` as a shorthand for a `Bound` without restrictions+* Add `LengthBound { lowerLength :: Maybe Int, upperLength :: Maybe Int }`+* Add `unboundedLength` as a shorthand for a `LengthBound` without restrictions+* Add remaining `JSONSchema` instances based on existing Aeson instances. `UTCTime`, `Set`, Lazy `Text`, and tuples up to length 7.+* Add `enum` combinator as a shorthand for creating a `Choice` of `Constant`s+ ## 0.5 * `JSONSchema` instances for `Data.Vector`, `Data.Map`, and `Data.HashMap`
json-schema.cabal view
@@ -1,5 +1,5 @@ name: json-schema-version: 0.5+version: 0.6 synopsis: Types and type classes for defining JSON schemas. description: Types and type classes for defining JSON schemas. license: BSD3@@ -8,7 +8,7 @@ maintainer: code@silk.co category: Data build-type: Simple-cabal-version: >=1.6+cabal-version: >=1.8 extra-source-files: CHANGELOG.md@@ -34,7 +34,27 @@ , generic-aeson == 0.1.* , generic-deriving == 1.6.* , tagged >= 0.2 && < 0.8- -- No bounds, since we only use the Text type.- , text+ , text >= 0.10 && < 1.2+ , time >= 1.2 && < 1.5 , unordered-containers == 0.2.* , vector == 0.10.*++test-suite json-schema-generic-aeson-tests+ ghc-options: -Wall+ hs-source-dirs: tests+ main-is: Main.hs+ type: exitcode-stdio-1.0+ build-depends:+ base+ , HUnit >= 1.2 && < 1.3+ , aeson+ , attoparsec+ , bytestring >= 0.10 && < 0.12+ , generic-aeson+ , tagged >= 0.2 && < 0.8+ , json-schema+ , tagged >= 0.2 && < 0.8+ , tasty+ , tasty-hunit+ , tasty-th+ , text
src/Data/JSON/Schema/Combinators.hs view
@@ -1,7 +1,24 @@ -- | Combinators for creating JSON schemas.-module Data.JSON.Schema.Combinators where+module Data.JSON.Schema.Combinators+ ( SchemaC+ , (<|>)+ , (<+>)+ , merge+ , field+ , value+ , number+ , array+ , addField+ , addFields+ , empty+ , enum+ , unbounded+ , unboundedLength+ ) where import Data.JSON.Schema.Types+import Data.Text (Text)+import qualified Data.Aeson as Aeson -- | A schema combinator. type SchemaC = Schema -> Schema@@ -29,30 +46,34 @@ merge v1 v2 = v1 <+> v2 -- | Create an object with a single field.-field :: String -> Bool -> Schema -> Schema+field :: Text -> Bool -> Schema -> Schema field k r v = Object [Field k r v] -- | An unbounded string. value :: Schema-value = Value 0 (-1)+value = Value unboundedLength -- | An unbounded number. number :: Schema-number = Number 0 (-1)+number = Number unbounded -- | An unbounded array with non-unique values. array :: Schema -> Schema-array = Array 0 (-1) False+array = Array unboundedLength False -- | Add a field to an object, or tuple if passed a non-object.-addField :: String -> Bool -> Schema -> SchemaC+addField :: Text -> Bool -> Schema -> SchemaC addField k r v = merge $ field k r v -- | Add multiple fields to an object, or tuple if passed a -- non-object.-addFields :: [(String, Bool, Schema)] -> SchemaC+addFields :: [(Text, Bool, Schema)] -> SchemaC addFields = flip $ foldr (\(k, r, v) -> addField k r v) -- | An empty object. empty :: Schema empty = Object []++-- | A choice between constant values.+enum :: [Aeson.Value] -> Schema+enum = Choice . map Constant
src/Data/JSON/Schema/Generic.hs view
@@ -2,6 +2,7 @@ FlexibleContexts , FlexibleInstances , OverlappingInstances+ , OverloadedStrings , ScopedTypeVariables , TupleSections , TypeFamilies@@ -18,12 +19,15 @@ import Data.JSON.Schema.Types import Data.Maybe import Data.Proxy+import Data.Text (Text) import GHC.Generics import Generics.Deriving.ConNames import Generics.Generic.IsEnum+import qualified Data.Aeson.Types as Aeson+import qualified Data.Text as T class GJSONSCHEMA f where- gSchema' :: Bool -> Bool -> Proxy (f a) -> Schema+ gSchema' :: Bool -> [Text] -> Proxy (f a) -> Schema -- Recursive positions disabled for now, it causes infintite data structures. This is a problem to be solved! {-@@ -35,15 +39,15 @@ gSchema' _ _ = schema . fmap unK1 instance GJSONSCHEMA (K1 i String) where- gSchema' _ _ _ = Value 0 (-1)+ gSchema' _ _ _ = Value unboundedLength instance GJSONSCHEMA U1 where gSchema' _ _ _ = empty instance (GJSONSCHEMA f, GJSONSCHEMA g) => GJSONSCHEMA (f :+: g) where- gSchema' mc enm p =- gSchema' mc enm (gL <$> p)- <|> gSchema' mc enm (gR <$> p)+ gSchema' enm names p =+ gSchema' enm names (gL <$> p)+ <|> gSchema' enm names (gR <$> p) where gL :: (f :+: g) r -> f r gL _ = undefined@@ -56,43 +60,55 @@ gSnd :: (f :*: g) r -> g r gSnd (_ :*: g) = g +pv :: Proxy a -> a+pv _ = undefined++toConstant :: Text -> Schema+toConstant = Constant . Aeson.String . firstLetterToLower+ instance (GJSONSCHEMA f, GJSONSCHEMA g) => GJSONSCHEMA (f :*: g) where- gSchema' mc enm p = gSchema' mc enm (gFst <$> p) `merge` gSchema' mc enm (gSnd <$> p)+ gSchema' enm names p = gSchema' enm names (gFst <$> p) `merge` gSchema' enm names (gSnd <$> p) instance (Constructor c, GJSONSCHEMA f) => GJSONSCHEMA (M1 C c f) where- gSchema' _ True = const $ Value 0 (-1)- gSchema' mc enm = wrap . gSchema' mc enm . fmap unM1+ gSchema' True _ = toConstant . conNameT . pv+ gSchema' enm names = wrap . gSchema' enm names . fmap unM1 where- wrap = if mc- then field (firstLetterToLower $ conName (undefined :: M1 C c f p)) True+ wrap = if multipleConstructors names+ then field (firstLetterToLower $ conNameT (undefined :: M1 C c f p)) True else id instance GJSONSCHEMA f => GJSONSCHEMA (M1 D c f) where- gSchema' mc enm = gSchema' mc enm . fmap unM1+ gSchema' True names p | multipleConstructors names = const (Choice . fmap toConstant $ names) $ p+ gSchema' enm names p = gSchema' enm names . fmap unM1 $ p -firstLetterToLower :: String -> String-firstLetterToLower "" = ""-firstLetterToLower (l:ls) = toLower l : ls+firstLetterToLower :: Text -> Text+firstLetterToLower m = case T.uncons m of+ Nothing -> ""+ Just (l, ls) -> T.cons (toLower l) ls instance (Selector c, JSONSchema a) => GJSONSCHEMA (M1 S c (K1 i (Maybe a))) where- gSchema' _ _ = field (selName (undefined :: M1 S c f p)) False . schema . fmap (fromJust . unK1 . unM1)+ gSchema' _ _ = field (selNameT (undefined :: M1 S c f p)) False . schema . fmap (fromJust . unK1 . unM1) -- TODO This instance does not correspond to the generic-aeson representation for Maybe instance Selector c => GJSONSCHEMA (M1 S c (K1 i (Maybe String))) where- gSchema' _ _ _ = field (selName (undefined :: M1 S c f p)) False $ Value 0 (-1)+ gSchema' _ _ _ = field (selNameT (undefined :: M1 S c f p)) False $ Value unboundedLength instance (Selector c, GJSONSCHEMA f) => GJSONSCHEMA (M1 S c f) where- gSchema' mc enm = wrap . gSchema' mc enm . fmap unM1+ gSchema' enm names = wrap . gSchema' enm names . fmap unM1 where- wrap = case selName (undefined :: M1 S c f p) of+ wrap = case (T.pack . selName) (undefined :: M1 S c f p) of "" -> id s -> field s True -multipleConstructors :: (Generic a, ConNames (Rep a)) => Proxy a -> Bool-multipleConstructors = (> 1) . length . conNames . pv- where pv :: Proxy a -> a- pv _ = undefined+conNameT :: forall c (t :: * -> (* -> *) -> * -> *) (f :: * -> *) a. Constructor c => t c f a -> Text+conNameT x = T.pack . conName $ x +selNameT :: forall s (t :: * -> (* -> *) -> * -> *) (f :: * -> *) a. Selector s => t s f a -> Text+selNameT x = T.pack . selName $ x++multipleConstructors :: [Text] -> Bool+multipleConstructors = (> 1) . length+ -- | Derive a JSON schema for types with an instance of 'Generic'. gSchema :: (Generic a, GJSONSCHEMA (Rep a), ConNames (Rep a), GIsEnum (Rep a)) => Proxy a -> Schema-gSchema p = gSchema' (multipleConstructors p) (isEnum p) (fmap from p)+gSchema p = gSchema' (isEnum p) ((map T.pack . conNames . pv) p) (fmap from p)
src/Data/JSON/Schema/Types.hs view
@@ -1,47 +1,78 @@ {-# LANGUAGE FlexibleInstances+ , OverloadedStrings , TypeSynonymInstances #-} -- | Types for defining JSON schemas.-module Data.JSON.Schema.Types where+module Data.JSON.Schema.Types+ ( JSONSchema (..)+ , Schema (..)+ , Field (..)+ , Bound (..)+ , LengthBound (..)+ , unbounded+ , unboundedLength+ ) where import Data.Maybe import Data.Proxy import Data.String import Data.Text (Text)+import Data.Time.Clock (UTCTime) import Data.Vector (Vector) import Data.Word (Word32)+import qualified Data.Aeson.Types as Aeson import qualified Data.HashMap.Strict as H import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Text.Lazy as L import qualified Data.Vector as V --- | A schema is any JSON value.-type Schema = Value- -- | A schema for a JSON value.-data Value =- Choice [Value] -- ^ A choice of multiple values, e.g. for sum types.- | Object [Field] -- ^ A JSON object.- | Map Value -- ^ A JSON object with arbitrary keys.- | Array Int Int Bool Value -- ^ An array. The integers represent the- -- lower and upper bound of the array- -- size. The value -1 indicates no bound.- -- The boolean denotes whether items have- -- to unique.- | Tuple [Value] -- ^ A fixed-length tuple of different values.- | Value Int Int -- ^ A string. The integers denote the lower and- -- upper bound of the length of the string. The- -- value -1 indicates no bound.- | Boolean- | Number Int Int -- ^ A number. The integers denote the lower and- -- upper bound on the value. The value -1- -- indicates no bound.- | Null- | Any+data Schema =+ Choice [Schema] -- ^ A choice of multiple values, e.g. for sum types.+ | Object [Field] -- ^ A JSON object.+ | Map Schema -- ^ A JSON object with arbitrary keys.+ | Array LengthBound Bool Schema+ -- ^ An array. The LengthBound represent the+ -- lower and upper bound of the array+ -- size. The value 'unboundedLength' indicates no bound.+ -- The boolean denotes whether items have+ -- to be unique.+ | Tuple [Schema] -- ^ A fixed-length tuple of different values.+ | Value LengthBound -- ^ A string. The LengthBound denote the lower and+ -- upper bound of the length of the string. The+ -- value 'unboundedLength' indicates no bound.+ | Boolean -- ^ A Bool.+ | Number Bound -- ^ A number. The Bound denote the lower and+ -- upper bound on the value. The value 'unbounded'+ -- indicates no bound.+ | Constant Aeson.Value -- ^ A Value that never changes. Can be+ -- combined with Choice to create enumerables.+ | Null -- ^ Only null is allowed.+ | Any -- ^ Anything value is allowed. deriving (Eq, Show) +-- | A type for bounds on number domains. Use Nothing when no lower or upper bound makes sense+data Bound = Bound+ { lower :: Maybe Int+ , upper :: Maybe Int+ } deriving (Eq, Show)++-- | A type for bounds on lengths for strings and arrays. Use Nothing when no lower or upper bound makes sense+data LengthBound = LengthBound+ { lowerLength :: Maybe Int+ , upperLength :: Maybe Int+ } deriving (Eq, Show)++unbounded :: Bound+unbounded = Bound Nothing Nothing++unboundedLength :: LengthBound+unboundedLength = LengthBound Nothing Nothing+ -- | A field in an object.-data Field = Field { key :: String, required :: Bool, content :: Schema } deriving (Eq, Show)+data Field = Field { key :: Text, required :: Bool, content :: Schema } deriving (Eq, Show) -- | Class representing JSON schemas class JSONSchema a where@@ -51,31 +82,91 @@ schema _ = Null instance JSONSchema Int where- schema _ = Number 0 (-1)+ schema _ = Number unbounded instance JSONSchema Integer where- schema _ = Number 0 (-1)+ schema _ = Number unbounded instance JSONSchema Word32 where- schema _ = Number 0 4294967295+ schema _ = Number unbounded instance JSONSchema Bool where schema _ = Boolean instance JSONSchema Text where- schema _ = Value 0 (-1)+ schema _ = Value unboundedLength +instance JSONSchema L.Text where+ schema _ = Value unboundedLength+ instance JSONSchema a => JSONSchema (Maybe a) where schema p = Choice [Object [Field "Just" True $ schema $ fmap fromJust p], Object [Field "Nothing" True Null]] instance JSONSchema a => JSONSchema [a] where- schema = Array 0 (-1) False . schema . fmap head+ schema = Array unboundedLength False . schema . fmap head instance JSONSchema a => JSONSchema (Vector a) where- schema = Array 0 (-1) False . schema . fmap V.head+ schema = Array unboundedLength False . schema . fmap V.head instance (IsString k, JSONSchema v) => JSONSchema (M.Map k v) where schema = Map . schema . fmap (head . M.elems) instance (IsString k, JSONSchema v) => JSONSchema (H.HashMap k v) where schema = Map . schema . fmap (head . H.elems)++instance JSONSchema UTCTime where+ schema _ = Value LengthBound { lowerLength = Just 20, upperLength = Just 24 }++instance JSONSchema a => JSONSchema (S.Set a) where+ schema = schema . fmap S.toList++instance (JSONSchema a, JSONSchema b) => JSONSchema (a, b) where+ schema s = Tuple+ [ schema . fmap fst $ s+ , schema . fmap snd $ s+ ]++instance (JSONSchema a, JSONSchema b, JSONSchema c) => JSONSchema (a, b, c) where+ schema s = Tuple+ [ schema . fmap (\(a,_,_) -> a) $ s+ , schema . fmap (\(_,b,_) -> b) $ s+ , schema . fmap (\(_,_,c) -> c) $ s+ ]++instance (JSONSchema a, JSONSchema b, JSONSchema c, JSONSchema d) => JSONSchema (a, b, c, d) where+ schema s = Tuple+ [ schema . fmap (\(a,_,_,_) -> a) $ s+ , schema . fmap (\(_,b,_,_) -> b) $ s+ , schema . fmap (\(_,_,c,_) -> c) $ s+ , schema . fmap (\(_,_,_,d) -> d) $ s+ ]++instance (JSONSchema a, JSONSchema b, JSONSchema c, JSONSchema d, JSONSchema e) => JSONSchema (a, b, c, d, e) where+ schema s = Tuple+ [ schema . fmap (\(a,_,_,_,_) -> a) $ s+ , schema . fmap (\(_,b,_,_,_) -> b) $ s+ , schema . fmap (\(_,_,c,_,_) -> c) $ s+ , schema . fmap (\(_,_,_,d,_) -> d) $ s+ , schema . fmap (\(_,_,_,_,e) -> e) $ s+ ]++instance (JSONSchema a, JSONSchema b, JSONSchema c, JSONSchema d, JSONSchema e, JSONSchema f) => JSONSchema (a, b, c, d, e, f) where+ schema s = Tuple+ [ schema . fmap (\(a,_,_,_,_,_) -> a) $ s+ , schema . fmap (\(_,b,_,_,_,_) -> b) $ s+ , schema . fmap (\(_,_,c,_,_,_) -> c) $ s+ , schema . fmap (\(_,_,_,d,_,_) -> d) $ s+ , schema . fmap (\(_,_,_,_,e,_) -> e) $ s+ , schema . fmap (\(_,_,_,_,_,f) -> f) $ s+ ]++instance (JSONSchema a, JSONSchema b, JSONSchema c, JSONSchema d, JSONSchema e, JSONSchema f, JSONSchema g) => JSONSchema (a, b, c, d, e, f, g) where+ schema s = Tuple+ [ schema . fmap (\(a,_,_,_,_,_,_) -> a) $ s+ , schema . fmap (\(_,b,_,_,_,_,_) -> b) $ s+ , schema . fmap (\(_,_,c,_,_,_,_) -> c) $ s+ , schema . fmap (\(_,_,_,d,_,_,_) -> d) $ s+ , schema . fmap (\(_,_,_,_,e,_,_) -> e) $ s+ , schema . fmap (\(_,_,_,_,_,f,_) -> f) $ s+ , schema . fmap (\(_,_,_,_,_,_,g) -> g) $ s+ ]
+ tests/Main.hs view
@@ -0,0 +1,217 @@+{-# OPTIONS -fno-warn-missing-signatures #-}+{-# LANGUAGE+ DeriveGeneric+ , OverloadedStrings+ , TemplateHaskell+ , TypeFamilies+ #-}+module Main (main) where++import Data.Aeson hiding (Result)+import Data.Aeson.Parser+import Data.Attoparsec.Lazy+import Data.ByteString.Lazy (ByteString)+import Data.JSON.Schema (JSONSchema (..), gSchema, Field (..))+import Data.List (intersperse)+import Data.Proxy+import GHC.Generics (Generic)+import Generics.Generic.Aeson+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.TH+import qualified Data.Aeson.Types as A+import qualified Data.JSON.Schema as S++data SingleCons = SingleCons deriving (Generic, Show, Eq)+instance ToJSON SingleCons where toJSON = gtoJson+instance FromJSON SingleCons where parseJSON = gparseJson+instance JSONSchema SingleCons where schema = gSchema++case_constructorWithoutFields = do+ eq (unsafeParse "\"singleCons\"", Right SingleCons)+ (toJSON SingleCons , encDec SingleCons)+ eq (S.Constant (A.String "singleCons"))+ (schema (Proxy :: Proxy SingleCons))++data Record = Record { field :: Int } deriving (Generic, Show, Eq)+instance ToJSON Record where toJSON = gtoJson+instance FromJSON Record where parseJSON = gparseJson+instance JSONSchema Record where schema = gSchema+case_record = do+ eq (unsafeParse "{\"field\":1}" , Right (Record { field = 1 }))+ (toJSON Record { field = 1 }, encDec Record { field = 1 })+ eq (S.Object [S.Field {S.key = "field", S.required = True, S.content = S.Number S.unbounded}])+ (schema (Proxy :: Proxy Record))++data RecordTwoFields = D { d1 :: Int, d2 :: String } deriving (Generic, Show, Eq)+instance ToJSON RecordTwoFields where toJSON = gtoJson+instance FromJSON RecordTwoFields where parseJSON = gparseJson+instance JSONSchema RecordTwoFields where schema = gSchema+case_recordWithFields = do+ eq (unsafeParse "{\"d1\":1,\"d2\":\"aap\"}" , Right (D {d1 = 1, d2 = "aap"}))+ (toJSON D { d1 = 1, d2 = "aap" }, encDec D { d1 = 1, d2 = "aap" })+ eq (S.Object [Field {key = "d1", required = True, content = S.Number S.unbounded}, Field {key = "d2", required = True, content = S.Value S.unboundedLength }])+ (schema (Proxy :: Proxy RecordTwoFields))++data E = E Int deriving (Generic, Show, Eq)+instance ToJSON E where toJSON = gtoJson+instance FromJSON E where parseJSON = gparseJson+instance JSONSchema E where schema = gSchema+case_constructorOneField = do+ eq (unsafeParse "1" , Right (E 1))+ (toJSON (E 1) , encDec (E 1))+ eq (S.Number S.unbounded)+ (schema (Proxy :: Proxy E))++data F = F Int String deriving (Generic, Show, Eq)+instance ToJSON F where toJSON = gtoJson+instance FromJSON F where parseJSON = gparseJson+instance JSONSchema F where schema = gSchema+case_constructorWithFields = do+ eq (unsafeParse "[1,\"aap\"]",Right (F 1 "aap"))+ (toJSON (F 1 "aap"), encDec (F 1 "aap"))+ eq (S.Tuple [S.Number S.unbounded, S.Value S.unboundedLength])+ (schema (Proxy :: Proxy F))++data G = G1 Int | G2 String deriving (Generic, Show, Eq)+instance ToJSON G where toJSON = gtoJson+instance FromJSON G where parseJSON = gparseJson+instance JSONSchema G where schema = gSchema+case_sumConstructorsWithField = do+ eq (unsafeParse "{\"g1\":1}",unsafeParse "{\"g2\":\"aap\"}",Right (G1 1),Right (G2 "aap"))+ (toJSON (G1 1), toJSON (G2 "aap"), encDec (G1 1), encDec (G2 "aap"))+ eq (S.Choice [S.Object [Field {key = "g1", required = True, content = S.Number S.unbounded}],S.Object [Field {key = "g2", required = True, content = S.Value S.unboundedLength }]])+ (schema (Proxy :: Proxy G))++data H = H1 { h1 :: Int } | H2 { h2 :: String } deriving (Generic, Show, Eq)+instance ToJSON H where toJSON = gtoJson+instance FromJSON H where parseJSON = gparseJson+instance JSONSchema H where schema = gSchema+case_sumRecord = do+ eq (unsafeParse "{\"h1\":{\"h1\":1}}",unsafeParse "{\"h2\":{\"h2\":\"aap\"}}",Right (H1 {h1 = 1}),Right (H2 {h2 = "aap"}))+ (toJSON (H1 1), toJSON (H2 "aap"), encDec (H1 1), encDec (H2 "aap"))+ eq (S.Choice [S.Object [Field {key = "h1", required = True, content = S.Object [Field {key = "h1", required = True, content = S.Number S.unbounded}]}],S.Object [Field {key = "h2", required = True, content = S.Object [Field {key = "h2", required = True, content = S.Value S.unboundedLength}]}]])+ (schema (Proxy :: Proxy H))++data J = J1 { j1 :: Int, j2 :: String } | J2 deriving (Generic, Show, Eq)+instance ToJSON J where toJSON = gtoJson+instance FromJSON J where parseJSON = gparseJson+instance JSONSchema J where schema = gSchema+case_sumRecordConstructorWithoutFields = do+ eq (unsafeParse "{\"j1\":{\"j1\":1,\"j2\":\"aap\"}}",unsafeParse "{\"j2\":{}}",Right (J1 {j1 = 1, j2 = "aap"}),Right J2)+ (toJSON (J1 1 "aap"), toJSON J2, encDec (J1 1 "aap"), encDec J2)+ eq (S.Choice [S.Object [Field {key = "j1", required = True, content = S.Object [Field {key = "j1", required = True, content = S.Number S.unbounded},Field {key = "j2", required = True, content = S.Value S.unboundedLength }]}],S.Object [Field {key = "j2", required = True, content = S.Object []}]])+ (schema (Proxy :: Proxy J))++data L = L1 | L2 Int String deriving (Generic, Show, Eq)+instance ToJSON L where toJSON = gtoJson+instance FromJSON L where parseJSON = gparseJson+instance JSONSchema L where schema = gSchema+case_sumConstructorWithoutFieldsConstructorWithFields = do+ eq (unsafeParse "{\"l1\":{}}",unsafeParse "{\"l2\":[1,\"aap\"]}",Right L1,Right (L2 1 "aap"))+ (toJSON L1, toJSON (L2 1 "aap"), encDec L1, encDec (L2 1 "aap"))+ eq (S.Choice [S.Object [Field {key = "l1", required = True, content = S.Object []}],S.Object [Field {key = "l2", required = True, content = S.Tuple [S.Number S.unbounded, S.Value S.unboundedLength]}]])+ (schema (Proxy :: Proxy L))++data M = M1 | M2 Int M deriving (Generic, Show, Eq)+instance ToJSON M where toJSON = gtoJson+instance FromJSON M where parseJSON = gparseJson+instance JSONSchema M where schema = gSchema+case_sumConstructorWithoutFieldsConstructorWithRecursiveField = do+ eq (unsafeParse "{\"m1\":{}}",unsafeParse "{\"m2\":[1,{\"m1\":{}}]}",unsafeParse "{\"m2\":[1,{\"m2\":[2,{\"m1\":{}}]}]}",Right M1,Right (M2 1 M1),Right (M2 1 (M2 2 M1)))+ (toJSON M1, toJSON (M2 1 M1), toJSON (M2 1 (M2 2 M1)), encDec M1, encDec (M2 1 M1), encDec (M2 1 (M2 2 M1)))+-- TODO Recursion+-- eq (S.Any)+-- (schema (Proxy :: Proxy x))++data N = N1 | N2 { n1 :: Int, n2 :: N } deriving (Generic, Show, Eq)+instance ToJSON N where toJSON = gtoJson+instance FromJSON N where parseJSON = gparseJson+instance JSONSchema N where schema = gSchema+case_sum_constructorWithoutFields_record = do+ eq (unsafeParse "{\"n1\":{}}",unsafeParse "{\"n2\":{\"n2\":{\"n1\":{}},\"n1\":1}}",unsafeParse "{\"n2\":{\"n1\":1,\"n2\":{\"n2\":{\"n1\":2,\"n2\":{\"n1\":{}}}}}}",Right N1,Right (N2 {n1 = 1, n2 = N1}),Right (N2 {n1 = 1, n2 = N2 {n1 = 2, n2 = N1}}))+ (toJSON N1, toJSON (N2 1 N1), toJSON (N2 1 (N2 2 N1)), encDec N1, encDec (N2 1 N1), encDec (N2 1 (N2 2 N1)))+ -- TODO Recursive types produce infinite schemas+ -- schema (Proxy :: Proxy N) @=? schema (Proxy :: Proxy N)++data O = O { o :: [Int] } deriving (Generic, Show, Eq)+instance ToJSON O where toJSON = gtoJson+instance FromJSON O where parseJSON = gparseJson+instance JSONSchema O where schema = gSchema+case_recordListField = do+ eq (unsafeParse "{\"o\":[1,2,3]}",Right (O {o = [1,2,3]}))+ (toJSON (O [1,2,3]), encDec (O [1,2,3]))+ eq (S.Object [Field {key = "o", required = True, content = S.Array S.unboundedLength False (S.Number S.unbounded)}])+ (schema (Proxy :: Proxy O))++data P = P [Int] deriving (Generic, Show, Eq)+instance ToJSON P where toJSON = gtoJson+instance FromJSON P where parseJSON = gparseJson+instance JSONSchema P where schema = gSchema+case_constructorListField = do+ eq (unsafeParse "[1,2,3]",Right (P [1,2,3]))+ (toJSON (P [1,2,3]), encDec (P [1,2,3]))+ eq (S.Array S.unboundedLength False (S.Number S.unbounded))+ (schema (Proxy :: Proxy P))++data Q = Q Int Int Int deriving (Generic, Show, Eq)+instance ToJSON Q where toJSON = gtoJson+instance FromJSON Q where parseJSON = gparseJson+instance JSONSchema Q where schema = gSchema+case_ConstructorSameTypedFields = do+ eq (unsafeParse "[1,2,3]",Right (Q 1 2 3))+ (toJSON (Q 1 2 3), encDec (Q 1 2 3))+ eq (S.Tuple [S.Number S.unbounded, S.Number S.unbounded, S.Number S.unbounded])+ (schema (Proxy :: Proxy Q))++data T = T { r1 :: Maybe Int } deriving (Generic, Show, Eq)+instance ToJSON T where toJSON = gtoJson+instance FromJSON T where parseJSON = gparseJson+instance JSONSchema T where schema = gSchema+case_RecordMaybeField = do+ eq (unsafeParse "{}", unsafeParse "{\"r1\":1}",Right (T {r1 = Nothing}),Right (T {r1 = Just 1}))+ (toJSON (T Nothing), toJSON (T (Just 1)), encDec (T Nothing), encDec (T (Just 1)))+ eq (S.Object [Field {key = "r1", required = False, content = S.Number S.unbounded}])+ (schema (Proxy :: Proxy T))++data V = V1 | V2 | V3 deriving (Generic, Show, Eq)+instance ToJSON V where toJSON = gtoJson+instance FromJSON V where parseJSON = gparseJson+instance JSONSchema V where schema = gSchema+case_constructorsWithoutFields = do+ eq (unsafeParse "\"v1\"",unsafeParse "\"v2\"",Right V1,Right V2)+ (toJSON V1, toJSON V2, encDec V1, encDec V2)+ eq (S.Choice [S.Constant (A.String "v1"), S.Constant (A.String "v2"), S.Constant (A.String "v3")])+ (schema (Proxy :: Proxy V))++data W = W { underscore1_ :: Int, _underscore2 :: Int } deriving (Generic, Show, Eq)+instance ToJSON W where toJSON = gtoJson+instance FromJSON W where parseJSON = gparseJson+instance JSONSchema W where schema = gSchema+case_recordWithUnderscoredFields = do+ eq (unsafeParse "{\"underscore1\":1,\"underscore2\":2}",Right (W {underscore1_ = 1, _underscore2 = 2}))+ (toJSON (W 1 2), encDec (W 1 2))+ eq (S.Object [Field {key = "underscore1_", required = True, content = S.Number S.unbounded},Field {key = "_underscore2", required = True, content = S.Number S.unbounded}])+ (schema (Proxy :: Proxy W))++-- Helpers++encDec :: (FromJSON a, ToJSON a) => a -> Either String a+encDec a = case (parse value . encode) a of+ Done _ r -> case fromJSON r of A.Success v -> Right v; Error s -> Left $ "fromJSON r=" ++ show r ++ ", s=" ++ s+ Fail _ ss e -> Left . concat $ intersperse "," (ss ++ [e])++unsafeParse :: ByteString -> Value+unsafeParse = fromResult . parse value++fromResult (Done _ r) = r+fromResult _ = error "Boo"++eq :: (Show a, Eq a) => a -> a -> Assertion+eq = (@=?)++tests :: TestTree+tests = $testGroupGenerator++main :: IO ()+main = defaultMain $ testGroup "generic-aeson" [tests]