json-schema 0.6.1 → 0.6.1.1
raw patch · 4 files changed
+33/−38 lines, 4 filesdep ~generic-aesondep ~tastydep ~tasty-hunit
Dependency ranges changed: generic-aeson, tasty, tasty-hunit
Files
- CHANGELOG.md +7/−1
- json-schema.cabal +3/−3
- src/Data/JSON/Schema/Generic.hs +20/−32
- tests/Main.hs +3/−2
CHANGELOG.md view
@@ -1,4 +1,10 @@-## 0.6.1+# Changelog++#### 0.6.1.1++* Bugfix: Remove underscores from fields and constructors in generated schemas to match generic-aeson.++### 0.6.1 * Add JSONSchema instances for tuples up to length 15 (matching aeson 0.8 instances) * Specify uniqueness for JSONSchema instances for Set.
json-schema.cabal view
@@ -1,5 +1,5 @@ name: json-schema-version: 0.6.1+version: 0.6.1.1 synopsis: Types and type classes for defining JSON schemas. description: Types and type classes for defining JSON schemas. license: BSD3@@ -31,7 +31,7 @@ base == 4.* , aeson >= 0.6 && < 0.9 , containers >= 0.3 && < 0.6- , generic-aeson == 0.1.*+ , generic-aeson >= 0.1.1.1 && < 0.2 , generic-deriving == 1.6.* , tagged >= 0.2 && < 0.8 , text >= 0.10 && < 1.2@@ -50,7 +50,7 @@ , aeson , attoparsec >= 0.10 && < 0.13 , bytestring >= 0.10 && < 0.12- , generic-aeson == 0.1.*+ , generic-aeson >= 0.1.1.1 && < 0.2 , json-schema , tagged >= 0.2 && < 0.8 , tasty == 0.8.*
src/Data/JSON/Schema/Generic.hs view
@@ -14,7 +14,6 @@ module Data.JSON.Schema.Generic (gSchema) where import Control.Applicative hiding (empty, (<|>))-import Data.Char import Data.JSON.Schema.Combinators import Data.JSON.Schema.Types import Data.Maybe@@ -22,10 +21,14 @@ import Data.Text (Text) import GHC.Generics import Generics.Deriving.ConNames-import Generics.Generic.IsEnum+import Generics.Generic.Aeson.Util import qualified Data.Aeson.Types as Aeson import qualified Data.Text as T +-- | 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' (isEnum p) ((map T.pack . conNames . pv) p) (fmap from p)+ class GJSONSCHEMA f where gSchema' :: Bool -> [Text] -> Proxy (f a) -> Schema @@ -54,18 +57,6 @@ gR :: (f :+: g) r -> g r gR _ = undefined -gFst :: (f :*: g) r -> f r-gFst (f :*: _) = f--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' enm names p = gSchema' enm names (gFst <$> p) `merge` gSchema' enm names (gSnd <$> p) @@ -73,19 +64,14 @@ gSchema' True _ = toConstant . conNameT . pv gSchema' enm names = wrap . gSchema' enm names . fmap unM1 where- wrap = if multipleConstructors names- then field (firstLetterToLower $ conNameT (undefined :: M1 C c f p)) True+ wrap = if multipleCons names+ then field (conNameT (undefined :: M1 C c f p)) True else id instance GJSONSCHEMA f => GJSONSCHEMA (M1 D c f) where- gSchema' True names p | multipleConstructors names = const (Choice . fmap toConstant $ names) $ p+ gSchema' True names p | multipleCons names = const (Choice . fmap toConstant $ names) $ p gSchema' enm names p = gSchema' enm names . fmap unM1 $ p -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 (selNameT (undefined :: M1 S c f p)) False . schema . fmap (fromJust . unK1 . unM1) @@ -96,19 +82,21 @@ instance (Selector c, GJSONSCHEMA f) => GJSONSCHEMA (M1 S c f) where gSchema' enm names = wrap . gSchema' enm names . fmap unM1 where- wrap = case (T.pack . selName) (undefined :: M1 S c f p) of+ wrap = case selNameT (undefined :: M1 S c f p) of "" -> id s -> field s True -conNameT :: forall c (t :: * -> (* -> *) -> * -> *) (f :: * -> *) a. Constructor c => t c f a -> Text-conNameT x = T.pack . conName $ x+toConstant :: Text -> Schema+toConstant = Constant . Aeson.String . formatLabel -selNameT :: forall s (t :: * -> (* -> *) -> * -> *) (f :: * -> *) a. Selector s => t s f a -> Text-selNameT x = T.pack . selName $ x+gFst :: (f :*: g) r -> f r+gFst (f :*: _) = f -multipleConstructors :: [Text] -> Bool-multipleConstructors = (> 1) . length+gSnd :: (f :*: g) r -> g r+gSnd (_ :*: g) = g --- | 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' (isEnum p) ((map T.pack . conNames . pv) p) (fmap from p)+pv :: Proxy a -> a+pv _ = undefined++multipleCons :: [Text] -> Bool+multipleCons = (> 1) . length
tests/Main.hs view
@@ -11,7 +11,6 @@ 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)@@ -20,7 +19,9 @@ import Test.Tasty.HUnit import Test.Tasty.TH import qualified Data.Aeson.Types as A+ import qualified Data.JSON.Schema as S+import Data.JSON.Schema (JSONSchema (..), gSchema, Field (..)) data SingleCons = SingleCons deriving (Generic, Show, Eq) instance ToJSON SingleCons where toJSON = gtoJson@@ -191,7 +192,7 @@ 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}])+ 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