diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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` diff --git a/json-schema.cabal b/json-schema.cabal --- a/json-schema.cabal +++ b/json-schema.cabal @@ -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 diff --git a/src/Data/JSON/Schema/Combinators.hs b/src/Data/JSON/Schema/Combinators.hs --- a/src/Data/JSON/Schema/Combinators.hs +++ b/src/Data/JSON/Schema/Combinators.hs @@ -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 diff --git a/src/Data/JSON/Schema/Generic.hs b/src/Data/JSON/Schema/Generic.hs --- a/src/Data/JSON/Schema/Generic.hs +++ b/src/Data/JSON/Schema/Generic.hs @@ -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) diff --git a/src/Data/JSON/Schema/Types.hs b/src/Data/JSON/Schema/Types.hs --- a/src/Data/JSON/Schema/Types.hs +++ b/src/Data/JSON/Schema/Types.hs @@ -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 + ] diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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]