summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAdamBergmark <>2015-12-18 18:27:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-12-18 18:27:00 (GMT)
commit2eb8b0f37760e990f6269397b99ecc40e5c19db9 (patch)
tree19288796f39c7b4fe125b13017575cef0ad9f732
parent237c0b7dc0ac104870022646e410ea7174232ae1 (diff)
version 0.7.4.10.7.4.1
-rw-r--r--CHANGELOG.md4
-rw-r--r--json-schema.cabal10
-rw-r--r--src/Data/JSON/Schema/Generic.hs41
-rw-r--r--src/Data/JSON/Schema/Validate.hs12
-rw-r--r--tests/Main.hs8
5 files changed, 45 insertions, 30 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index b0a89b9..f0c7ca0 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,9 @@
# Changelog
+#### 0.7.4.1
+
+* aeson-0.10 produces new error messages so the test-suite was updated to reflect this.
+
### 0.7.4.0
* Raise upper length limit of `UTCTime` since aeson-0.9 increased the precision.
diff --git a/json-schema.cabal b/json-schema.cabal
index 43c7e13..ba0ab21 100644
--- a/json-schema.cabal
+++ b/json-schema.cabal
@@ -1,5 +1,5 @@
name: json-schema
-version: 0.7.4.0
+version: 0.7.4.1
synopsis: Types and type classes for defining JSON schemas.
description: Types and type classes for defining JSON schemas.
.
@@ -35,10 +35,10 @@ library
Data.JSON.Schema.Validate
build-depends:
base >= 4.4 && < 5
- , aeson >= 0.7 && < 0.10
+ , aeson >= 0.7 && < 0.11
, containers >= 0.3 && < 0.6
, generic-aeson == 0.2.*
- , generic-deriving >= 1.6 && < 1.9
+ , generic-deriving >= 1.6 && < 1.10
, mtl >= 2.1 && < 2.3
, scientific == 0.3.*
, text >= 0.10 && < 1.3
@@ -63,13 +63,13 @@ test-suite json-schema-generic-aeson-tests
Test.Validate
build-depends:
base >= 4.4 && < 5
- , aeson >= 0.7 && < 0.10
+ , aeson >= 0.7 && < 0.11
, aeson-utils >= 0.2 && < 0.4
, attoparsec >= 0.10 && < 0.14
, bytestring >= 0.10 && < 0.12
, generic-aeson == 0.2.*
, json-schema
- , tasty == 0.10.*
+ , tasty >= 0.10 && < 0.12
, tasty-hunit == 0.9.*
, tasty-th == 0.1.*
, text >= 0.10 && < 1.3
diff --git a/src/Data/JSON/Schema/Generic.hs b/src/Data/JSON/Schema/Generic.hs
index a696024..c092bb7 100644
--- a/src/Data/JSON/Schema/Generic.hs
+++ b/src/Data/JSON/Schema/Generic.hs
@@ -55,8 +55,8 @@ instance GJSONSchema U1 where
gSchema' _ _ _ _ = empty
instance (GJSONSchema f, GJSONSchema g) => GJSONSchema (f :+: g) where
- gSchema' set enm names p =
- gSchema' set enm names (gL <$> p)
+ gSchema' set enm names p
+ = gSchema' set enm names (gL <$> p)
<|> gSchema' set enm names (gR <$> p)
where
gL :: (f :+: g) r -> f r
@@ -65,19 +65,28 @@ instance (GJSONSchema f, GJSONSchema g) => GJSONSchema (f :+: g) where
gR _ = undefined
instance (GJSONSchema f, GJSONSchema g) => GJSONSchema (f :*: g) where
- gSchema' set enm names p = gSchema' set enm names (gFst <$> p) `merge` gSchema' set enm names (gSnd <$> p)
+ gSchema' set enm names p = gSchema' set enm names (gFst <$> p)
+ `merge` gSchema' set enm names (gSnd <$> p)
+ where
+ gFst :: (f :*: g) r -> f r
+ gFst (f :*: _) = f
+
+ gSnd :: (f :*: g) r -> g r
+ gSnd (_ :*: g) = g
instance (Constructor c, GJSONSchema f) => GJSONSchema (M1 C c f) where
- gSchema' set True _ = toConstant set . conNameT set . pv
- gSchema' set enm names = wrap . gSchema' set enm names . fmap unM1
- where
- wrap = if multipleCons names
- then field (conNameT set (undefined :: M1 C c f p)) True
- else id
+ gSchema' set enm names
+ | enm = toConstant set . conNameT set . pv
+ | otherwise = wrap . gSchema' set enm names . fmap unM1
+ where
+ wrap = if multipleCons names
+ then field (conNameT set (undefined :: M1 C c f p)) True
+ else id
instance GJSONSchema f => GJSONSchema (M1 D c f) where
- gSchema' set True names p | multipleCons names = const (Choice . fmap (toConstant set) $ names) $ p
- gSchema' set enm names p = gSchema' set enm names . fmap unM1 $ p
+ gSchema' set enm names p
+ | enm && multipleCons names = Choice $ toConstant set <$> names
+ | otherwise = gSchema' set enm names . fmap unM1 $ p
instance (Selector c, JSONSchema a) => GJSONSchema (M1 S c (K1 i (Maybe a))) where
gSchema' set _ _ =
@@ -87,7 +96,8 @@ instance (Selector c, JSONSchema a) => GJSONSchema (M1 S c (K1 i (Maybe a))) whe
where
maybeElemSchema :: Proxy (M1 S c (K1 i (Maybe a)) p) -> Schema
maybeElemSchema = s
- where s = schema . fmap (fromJust . unK1 . unM1)
+ where
+ s = schema . fmap (fromJust . unK1 . unM1)
instance Selector c => GJSONSchema (M1 S c (K1 i (Maybe String))) where
gSchema' set _ _ _ =
@@ -98,16 +108,11 @@ instance Selector c => GJSONSchema (M1 S c (K1 i (Maybe String))) where
instance (Selector c, GJSONSchema f) => GJSONSchema (M1 S c f) where
gSchema' set enm names = wrap . gSchema' set enm names . fmap unM1
where
- wrap = maybe id (\s -> field s True) $ selNameT set (undefined :: M1 S c f p)
+ wrap = maybe id (`field` True) $ selNameT set (undefined :: M1 S c f p)
toConstant :: Settings -> Text -> Schema
toConstant set = Constant . Aeson.String . formatLabel set
-gFst :: (f :*: g) r -> f r
-gFst (f :*: _) = f
-
-gSnd :: (f :*: g) r -> g r
-gSnd (_ :*: g) = g
pv :: Proxy a -> a
pv _ = undefined
diff --git a/src/Data/JSON/Schema/Validate.hs b/src/Data/JSON/Schema/Validate.hs
index 9aff8cd..01208ed 100644
--- a/src/Data/JSON/Schema/Validate.hs
+++ b/src/Data/JSON/Schema/Validate.hs
@@ -68,7 +68,7 @@ cond :: ErrorType -> Bool -> M ()
cond e p = if p then ok else err e
nestPath :: Text -> M a -> M a
-nestPath p m = local (`V.snoc` p) $ m
+nestPath p = local (`V.snoc` p)
validate' :: Schema -> Value -> M ()
validate' sch val = case (sch, val) of
@@ -101,7 +101,7 @@ validate' sch val = case (sch, val) of
do inLowerLength b (V.length vs)
inUpperLength b (V.length vs)
if u then unique vs else ok
- sequence_ $ zipWith
+ zipWithM_
(\i -> nestPath (T.pack (show i)) . validate' s)
[(0::Int)..] (V.toList vs)
( S.Boolean {}, _ ) -> err $ Mismatch sch val
@@ -126,24 +126,24 @@ unique vs = do
inLower :: S.Bound -> Scientific -> M ()
inLower b v =
- if (maybe True ((<= v) . fromIntegral) . S.lower $ b)
+ if maybe True ((<= v) . fromIntegral) . S.lower $ b
then ok
else err (BoundError b v)
inUpper :: S.Bound -> Scientific -> M ()
inUpper b v =
- if (maybe True ((>= v) . fromIntegral) . S.upper $ b)
+ if maybe True ((>= v) . fromIntegral) . S.upper $ b
then ok
else err (BoundError b v)
inLowerLength :: S.LengthBound -> Int -> M ()
inLowerLength b v =
- if (maybe True (<= v) . S.lowerLength $ b)
+ if maybe True (<= v) . S.lowerLength $ b
then ok
else err (LengthBoundError b v)
inUpperLength :: S.LengthBound -> Int -> M ()
inUpperLength b v =
- if (maybe True (>= v) . S.upperLength $ b)
+ if maybe True (>= v) . S.upperLength $ b
then ok
else err (LengthBoundError b v)
diff --git a/tests/Main.hs b/tests/Main.hs
index 562ba20..b20413d 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -1,6 +1,7 @@
{-# OPTIONS -fno-warn-missing-signatures #-}
{-# LANGUAGE
- DeriveGeneric
+ CPP
+ , DeriveGeneric
, OverloadedStrings
, ScopedTypeVariables
, TemplateHaskell
@@ -267,8 +268,13 @@ case_constructorWithMaybeField = do
bidir "[null,2]" b
valid b
+#if MIN_VERSION_aeson(0,10,0)
+ eq (Left "Error in $: expected Int, encountered Boolean" :: Either String X)
+ (eitherDecode "[true,2]")
+#else
eq (Left "when expecting a Int, encountered Boolean instead" :: Either String X)
(eitherDecode "[true,2]")
+#endif
eq (Tuple [nullable number, number])
(schema (Proxy :: Proxy X))