git.iko.soy/typeable/schematic
on 6cc400e help sign in
7db0b46
swap
0 ahead, 26 behind
20 files changed+209−533
since splitsnapshots
unifiedsplit
ChangeLog.md−16 release+8−16 schematic.cabal+5−10 src/Data/Schematic/DSL.hs+2−11 src/Data/Schematic/Generator.hs+39−12 src/Data/Schematic/Generator/Regex.hs+10−10 src/Data/Schematic/JsonSchema.hs+9−21 src/Data/Schematic/Migration.hs+2−10 src/Data/Schematic/Path.hs+20−17 src/Data/Schematic/Schema.hs+16−109 src/Data/Schematic/Schema.hs-boot−95 src/Data/Schematic/Validation.hs+27−56 src/Data/Schematic/Verifier/Array.hs+1−1 src/Data/Schematic/Verifier/Common.hs+2−2 src/Data/Schematic/Verifier/Number.hs+9−9 src/Data/Schematic/Verifier/Text.hs+55−58 stack-13.21.yaml−7 stack.yaml+4−5 test/JsonSchemaSpec.hs−58 test/SchemaSpec.hs−10
ChangeLog.md−16
@@ -1,21 +1,5 @@
11# Revision history for schematic
22
3−## 0.6.0.0 -- 2021-01-15
4−
5−Added compatability with aeson-1.4.3.0. Since version 1.4.3 the module `Data.Aeson` started exporting `JSONPath`, which was conflicting with our own `JSONPath`. Furthermore, started using `JSONPathElement` from `aeson` instead of `DemotedPathSegment`.
6−
7−## 0.5.1.0 -- 2021-01-15
8−
9−Fix the generation of json schema for numbers.
10−Add array constraints.
11−Fix the generation of text and number constraints.
12−Remove jsonpath from the error message.
13−
14−## 0.5.0.0 -- 2019-02-20
15−
16−GHC 8.6, json generation by schema definition, validation bug fixes, better
17−parsing error messages.
18−
193## 0.4.3.0 -- 2018-07-12
204
215GHC 8.4 support, dropping support for older GHC versions
release+8−16
@@ -4,12 +4,6 @@ set -o xtrace
44
55dist=`stack path --dist-dir --stack-yaml ./stack.yaml 2> /dev/null`
66
7−rootdir=`pwd`
8−
9−cabalfile=`ls *.cabal`
10−packagename="${cabalfile%%.*}"
11−version=`grep '^version:' schematic.cabal | rev | cut -d" " -f1 | rev`
12−
137echo -e "\033[1;36mTesting library...\033[0m"
148stack test 2> /dev/null
159
@@ -24,19 +18,17 @@ if [ "$?" -eq "0" ]; then
2418 read -p "Hackage username: " username
2519 read -p "Hackage password: " -s password
2620 echo ""
27− cabal upload -u $username -p $password dist/$packagename-$version.tar.gz
21+ cabal upload -u $username -p $password dist/$1-$2.tar.gz
2822
29− docdir=`find .stack-work -name "$packagename-$version-docs"`
23+ docdir=$dist/doc/html
24+ cd $docdir
25+ doc=$1-$2-docs
3026
31− echo -e "Compressing documentation from \033[1;34m$docdir\033[0m for \033[1;35m$packagename\033[0m-\033[1;33m$version\033[1;30m"
32− tar -c -v -z --format=ustar -f $docdir.tar.gz $docdir
27+ echo -e "Compressing documentation from \033[1;34m$docdir\033[0m for \033[1;35m$1\033[0m-\033[1;33m$2\033[1;30m"
28+ cp -r $1 $doc
29+ tar -c -v -z --format=ustar -f $doc.tar.gz $doc
3330 echo -e "\033[1;32mUploading documentation to Hackage...\033[0m"
34− cd $docdir
35− cd ..
36− curl -X PUT -H 'Content-Type: application/x-tar' -H 'Content-Encoding: gzip' --data-binary "$packagename-$version-docs.tar.gz" "https://$username:$password@hackage.haskell.org/package/$packagename-$version/candidate/docs"
37− open "https://hackage.haskell.org/package/$packagename-$version/candidate/"
38− cd $rootdir
39− echo "To publish the candidate, use 'cabal upload --publish'."
31+ curl -X PUT -H 'Content-Type: application/x-tar' -H 'Content-Encoding: gzip' --data-binary "@$doc.tar.gz" "https://$username:$password@hackage.haskell.org/package/$1-$2/docs"
4032 exit $?
4133else
4234 echo -e "\033[1;31mNot in a stack-powered project\033[0m"
schematic.cabal+5−10
@@ -1,7 +1,6 @@
11name: schematic
2−version: 0.6.0.0
2+version: 0.4.3.0
33synopsis: JSON-biased spec and validation tool
4−description: JSON-biased spec and validation tool. Makes possible to have a schema as a haskell type and derive json instances, validation actions, JSON generation for property-test generically. Built-in lens support.
54license: BSD3
65license-file: LICENSE
76author: Denis Redozubov
@@ -10,7 +9,7 @@ homepage: http://github.com/typeable/schematic
109Bug-reports: http://github.com/typeable/schematic/issues/
1110category: Data
1211build-type: Simple
13−extra-source-files: ChangeLog.md, README.md
12+extra-source-files: ChangeLog.md
1413cabal-version: >=1.10
1514
1615library
@@ -65,9 +64,9 @@ library
6564 , TypeOperators
6665 , TypeSynonymInstances
6766 , UndecidableInstances
68− build-depends: base >=4.11 && <5
67+ build-depends: base >=4.11 && <4.12
6968 , bytestring
70− , aeson >= 1.4.3.0 && < 1.6
69+ , aeson >= 1
7170 , containers
7271 , hjsonschema
7372 , mtl
@@ -95,7 +94,7 @@ test-suite spec
9594 default-language: Haskell2010
9695 build-depends: HUnit
9796 , aeson >= 1
98− , base >=4.11 && <4.13
97+ , base >=4.11 && <4.12
9998 , bytestring
10099 , containers
101100 , hjsonschema
@@ -118,7 +117,3 @@ test-suite spec
118117 , HelpersSpec
119118 , LensSpec
120119 , JsonSchemaSpec
121−
122−source-repository head
123− type: git
124− location: https://github.com/typeable/schematic
src/Data/Schematic/DSL.hs+2−11
@@ -1,5 +1,4 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
32
43module Data.Schematic.DSL where
54
@@ -18,19 +17,11 @@ import Data.Vinyl
1817import Data.Vinyl.Functor
1918
2019
21−#if MIN_VERSION_base(4,12,0)
2220type Constructor a
23− = forall fields b
24− . (fields ~ FieldsOf a, FSubset fields b (FImage fields b), RMap fields)
21+ = forall fields b. (fields ~ FieldsOf a, FSubset fields b (FImage fields b))
2522 => Rec (Tagged fields :. FieldRepr) b
2623 -> JsonRepr ('SchemaObject fields)
27−#else
28−type Constructor a
29− = forall fields b
30− . (fields ~ FieldsOf a, FSubset fields b (FImage fields b))
31− => Rec (Tagged fields :. FieldRepr) b
32− -> JsonRepr ('SchemaObject fields)
33−#endif
24+
3425withRepr :: Constructor a
3526withRepr = ReprObject . rmap (unTagged . getCompose) . fcast
3627
src/Data/Schematic/Generator.hs+39−12
@@ -1,12 +1,15 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
12module Data.Schematic.Generator where
23
34import Data.Maybe
4−import Data.Schematic.Generator.Regex
5−import {-# SOURCE #-} Data.Schematic.Schema
6−import Data.Schematic.Verifier
5+import Data.Schematic.Schema
76import Data.Scientific
7+import Data.Singletons
88import Data.Text (Text, pack)
99import qualified Data.Vector as V
10+import Data.Vinyl
11+import Data.Schematic.Generator.Regex
12+import Data.Schematic.Verifier
1013import Test.SmallCheck.Series
1114
1215maxHigh :: Int
@@ -18,14 +21,13 @@ minLow = 2
1821textLengthSeries :: Monad m => [VerifiedTextConstraint] -> Series m Text
1922textLengthSeries =
2023 \case
21− [VTEq eq] -> pure $ pack $ take (fromIntegral eq) $ cycle "sample"
24+ [VTEq eq] -> pure $ pack $ take (fromIntegral eq) $ cycle "sample"
2225 [VTBounds ml mh] -> do
23− let
24− l = fromMaybe minLow (fromIntegral <$> ml) + 1
25− h = fromMaybe maxHigh (fromIntegral <$> mh) - 1
26+ let l = fromMaybe minLow (fromIntegral <$> ml) + 1
27+ h = fromMaybe maxHigh (fromIntegral <$> mh) - 1
2628 n <- generate $ \depth -> take depth [l .. h]
2729 pure $ pack $ take (fromIntegral n) $ cycle "sample"
28− _ -> pure "error"
30+ _ -> pure "error"
2931
3032textEnumSeries :: Monad m => [Text] -> Series m Text
3133textEnumSeries enum = generate $ \depth -> take depth enum
@@ -36,8 +38,8 @@ textSeries cs = do
3638 case mvcs of
3739 Just vcs -> do
3840 n <- textSeries' vcs
39− pure n
40− Nothing -> pure "error"
41+ pure $ n
42+ Nothing -> pure "error"
4143
4244textSeries' :: Monad m => [VerifiedTextConstraint] -> Series m Text
4345textSeries' [] = pure "sample"
@@ -48,7 +50,7 @@ textSeries' vcs = do
4850 Nothing -> do
4951 let regexps = listToMaybe [x | VTRegex x _ _ <- vcs]
5052 case regexps of
51− Just e -> regexSeries e
53+ Just e -> regexSeries e
5254 Nothing -> textLengthSeries vcs
5355
5456numberSeries :: Monad m => [DemotedNumberConstraint] -> Series m Scientific
@@ -78,7 +80,7 @@ arraySeries cs = do
7880 let mvcs = verifyArrayConstraint cs
7981 case mvcs of
8082 Just vcs -> arraySeries' vcs
81− Nothing -> pure V.empty
83+ Nothing -> pure V.empty
8284
8385arraySeries'
8486 :: forall m s. (Monad m, Serial m (JsonRepr s))
@@ -89,3 +91,28 @@ arraySeries' ml = do
8991 pure $ objs
9092 where
9193 f (VAEq l) = fromIntegral l
94+
95+instance (Monad m, Serial m Text, SingI cs)
96+ => Serial m (JsonRepr ('SchemaText cs)) where
97+ series = decDepth $ fmap ReprText $ textSeries $ fromSing (sing :: Sing cs)
98+
99+instance (Monad m, Serial m Scientific, SingI cs)
100+ => Serial m (JsonRepr ('SchemaNumber cs)) where
101+ series = decDepth $ fmap ReprNumber
102+ $ numberSeries $ fromSing (sing :: Sing cs)
103+
104+instance Monad m => Serial m (JsonRepr 'SchemaNull) where
105+ series = cons0 ReprNull
106+
107+instance (Serial m (JsonRepr s), Serial m (V.Vector (JsonRepr s)), SingI cs)
108+ => Serial m (JsonRepr ('SchemaArray cs s)) where
109+ series = decDepth $ fmap ReprArray
110+ $ arraySeries $ fromSing (sing :: Sing cs)
111+
112+instance (Serial m (JsonRepr s))
113+ => Serial m (JsonRepr ('SchemaOptional s)) where
114+ series = cons1 ReprOptional
115+
116+instance (Monad m, Serial m (Rec FieldRepr fs))
117+ => Serial m (JsonRepr ('SchemaObject fs)) where
118+ series = cons1 ReprObject
src/Data/Schematic/Generator/Regex.hs+10−10
@@ -1,15 +1,15 @@
11module Data.Schematic.Generator.Regex where
22
3−import Control.Monad
4−import Data.List
5−import Data.Maybe
3+import Control.Monad
4+import Data.List
5+import Data.Maybe
66import qualified Data.Set as S
7−import Data.Text (Text, unpack)
8−import Data.Text.Lazy (toStrict)
9−import Data.Text.Lazy.Builder (Builder, singleton, toLazyText)
10−import Test.SmallCheck.Series
11−import Text.Regex.TDFA.Pattern
12−import Text.Regex.TDFA.ReadRegex (parseRegex)
7+import Data.Text (Text, unpack)
8+import Data.Text.Lazy (toStrict)
9+import Data.Text.Lazy.Builder (Builder, singleton, toLazyText)
10+import Test.SmallCheck.Series
11+import Text.Regex.TDFA.Pattern
12+import Text.Regex.TDFA.ReadRegex (parseRegex)
1313
1414
1515minRepeat :: Int
@@ -22,7 +22,7 @@ regexSeries :: (Monad m) => Text -> Series m Text
2222regexSeries regexp =
2323 case parseRegex . unpack $ regexp of
2424 Right (p, _) -> toStrict . toLazyText <$> regexSeries' p
25− Left _ -> pure ""
25+ Left _ -> pure ""
2626
2727regexSeries' :: (Monad m) => Pattern -> Series m Builder
2828regexSeries' pt =
src/Data/Schematic/JsonSchema.hs+9−21
@@ -30,13 +30,13 @@ textConstraint :: DemotedTextConstraint -> State D4.Schema ()
3030textConstraint (DTEq n) = modify $ \s -> s
3131 { _schemaMinLength = pure $ fromIntegral n
3232 , _schemaMaxLength = pure $ fromIntegral n }
33+textConstraint (DTLt n) = modify $ \s -> s
34+ { _schemaMaxLength = pure . fromIntegral $ n + 1 }
3335textConstraint (DTLe n) = modify $ \s -> s
3436 { _schemaMaxLength = pure . fromIntegral $ n }
35−textConstraint (DTLt n) =
37+textConstraint (DTGt n) =
3638 let n' = if n == 0 then 0 else n - 1
37− in modify $ \s -> s { _schemaMaxLength = pure . fromIntegral $ n' }
38−textConstraint (DTGt n) = modify $ \s -> s
39− { _schemaMinLength = pure . fromIntegral $ n + 1 }
39+ in modify $ \s -> s { _schemaMinLength = pure . fromIntegral $ n' }
4040textConstraint (DTGe n) = modify $ \s -> s
4141 { _schemaMinLength = pure . fromIntegral $ n }
4242textConstraint (DTRegex r) = modify $ \s -> s { _schemaPattern = pure r }
@@ -48,30 +48,18 @@ numberConstraint :: DemotedNumberConstraint -> State D4.Schema ()
4848numberConstraint (DNLe n) = modify $ \s -> s
4949 { _schemaMaximum = pure . fromIntegral $ n }
5050numberConstraint (DNLt n) = modify $ \s -> s
51− { _schemaMaximum = pure . fromIntegral $ n
52− , _schemaExclusiveMaximum = pure True }
51+ { _schemaMaximum = pure . fromIntegral $ n + 1 }
5352numberConstraint (DNGt n) = modify $ \s -> s
54− { _schemaMinimum = pure . fromIntegral $ n
55− , _schemaExclusiveMinimum = pure True }
56−numberConstraint (DNGe n) = modify $ \s -> s
5753 { _schemaMinimum = pure . fromIntegral $ n }
54+numberConstraint (DNGe n) =
55+ let n' = if n == 0 then 0 else n - 1
56+ in modify $ \s -> s { _schemaMinimum = pure . fromIntegral $ n' }
5857numberConstraint (DNEq n) = modify $ \s -> s
5958 { _schemaMinimum = pure $ fromIntegral n
6059 , _schemaMaximum = pure $ fromIntegral n }
6160
6261arrayConstraint :: DemotedArrayConstraint -> State D4.Schema ()
63−arrayConstraint (DALe n) = modify $ \s -> s
64− { _schemaMaxItems = pure . fromIntegral $ n }
65−arrayConstraint (DALt n) =
66− let n' = if n == 0 then 0 else n - 1
67− in modify $ \s -> s { _schemaMaxItems = pure . fromIntegral $ n' }
68−arrayConstraint (DAGt n) = modify $ \s -> s
69− { _schemaMinItems = pure . fromIntegral $ n + 1 }
70−arrayConstraint (DAGe n) = modify $ \s -> s
71− { _schemaMinItems = pure . fromIntegral $ n }
72−arrayConstraint (DAEq n) = modify $ \s -> s
73− { _schemaMinItems = pure $ fromIntegral n
74− , _schemaMaxItems = pure $ fromIntegral n }
62+arrayConstraint (DAEq _) = pure ()
7563
7664toJsonSchema
7765 :: forall proxy schema
src/Data/Schematic/Migration.hs+2−10
@@ -1,6 +1,5 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE TemplateHaskell #-}
43
54module Data.Schematic.Migration where
65
@@ -9,7 +8,7 @@ import Data.Schematic.DSL
98import Data.Schematic.Lens
109import Data.Schematic.Path
1110import Data.Schematic.Schema
12−import Data.Singletons.Prelude hiding ((:.), All)
11+import Data.Singletons.Prelude hiding (All, (:.))
1312import Data.Singletons.TypeLits
1413import Data.Tagged
1514import Data.Vinyl
@@ -157,17 +156,10 @@ data MList :: (Type -> Type) -> [Schema] -> Type where
157156
158157infixr 7 :&&
159158
160−#if MIN_VERSION_base(4,12,0)
161−migrateObject
162− :: forall m fs fh. (FSubset fs fs (FImage fs fs), Monad m, RMap fh, RMap fs)
163− => (Rec (Tagged fs :. FieldRepr) fh -> m (Rec (Tagged fs :. FieldRepr) fs))
164− -> Tagged ('SchemaObject fs) (JsonRepr ('SchemaObject fh) -> m (JsonRepr ('SchemaObject fs)))
165−#else
166159migrateObject
167160 :: forall m fs fh. (FSubset fs fs (FImage fs fs), Monad m)
168161 => (Rec (Tagged fs :. FieldRepr) fh -> m (Rec (Tagged fs :. FieldRepr) fs))
169162 -> Tagged ('SchemaObject fs) (JsonRepr ('SchemaObject fh) -> m (JsonRepr ('SchemaObject fs)))
170−#endif
171163migrateObject f = Tagged $ \(ReprObject r) -> do
172164 res <- f $ rmap (Compose . Tagged) r
173165 pure $ withRepr @('SchemaObject fs) res
src/Data/Schematic/Path.hs+20−17
@@ -4,33 +4,36 @@ import Data.Foldable as F
44import Data.Singletons.Prelude
55import Data.Singletons.TypeLits
66import Data.Text as T
7−import Data.Aeson.Internal
87
98
10−newtype JSONPathText = JSONPathText Text
11− deriving (Show)
12−
13−data PathSegment = PathKey Symbol | PathIx Nat
9+data PathSegment = Key Symbol | Ix Nat
1410
1511data instance Sing (jp :: PathSegment) where
16− SKey :: (SingI k) => Sing (k :: Symbol) -> Sing ('PathKey k)
17− SIx :: (SingI n) => Sing (n :: Nat) -> Sing ('PathIx n)
12+ SKey :: (SingI k) => Sing (k :: Symbol) -> Sing ('Key k)
13+ SIx :: (SingI n) => Sing (n :: Nat) -> Sing ('Ix n)
14+
15+data DemotedPathSegment = DKey Text | DIx Integer
16+ deriving (Show)
17+
18+-- | Textual representation of json path.
19+newtype JSONPath = JSONPath Text
20+ deriving (Show)
1821
19−demotePath :: Sing (ps :: [PathSegment]) -> JSONPath
22+demotePath :: Sing (ps :: [PathSegment]) -> [DemotedPathSegment]
2023demotePath = go []
2124 where
22− go :: JSONPath -> Sing (ps :: [PathSegment]) -> JSONPath
25+ go :: [DemotedPathSegment] -> Sing (ps :: [PathSegment]) -> [DemotedPathSegment]
2326 go acc SNil = acc
2427 go acc (SCons p ps) = go (acc ++ [demotePathSeg p]) ps
25− demotePathSeg :: Sing (ps :: PathSegment) -> JSONPathElement
26− demotePathSeg (SKey s) = Key $ T.pack $ withKnownSymbol s $ symbolVal s
27− demotePathSeg (SIx n) = Index $ withKnownNat n $ fromIntegral $ natVal n
28+ demotePathSeg :: Sing (ps :: PathSegment) -> DemotedPathSegment
29+ demotePathSeg (SKey s) = DKey $ T.pack $ withKnownSymbol s $ symbolVal s
30+ demotePathSeg (SIx n) = DIx $ withKnownNat n $ fromIntegral $ natVal n
2831
29−demotedPathToText :: JSONPath -> JSONPathText
30−demotedPathToText = JSONPathText . F.foldl' renderPathSegment ""
32+demotedPathToText :: [DemotedPathSegment] -> JSONPath
33+demotedPathToText = JSONPath . F.foldl' renderPathSegment ""
3134 where
32− renderPathSegment acc (Key t) = acc <> "." <> t
33− renderPathSegment acc (Index n) = acc <> "[" <> T.pack (show n) <> "]"
35+ renderPathSegment acc (DKey t) = acc <> "." <> t
36+ renderPathSegment acc (DIx n) = acc <> "[" <> T.pack (show n) <> "]"
3437
35−pathToText :: Sing (ps :: [PathSegment]) -> JSONPathText
38+pathToText :: Sing (ps :: [PathSegment]) -> JSONPath
3639pathToText = demotedPathToText . demotePath
src/Data/Schematic/Schema.hs+16−109
@@ -1,7 +1,6 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE OverloadedLists #-}
4−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE OverloadedLists #-}
3+{-# LANGUAGE OverloadedStrings #-}
54{-# OPTIONS_GHC -fprint-explicit-kinds #-}
65
76module Data.Schematic.Schema where
@@ -13,7 +12,6 @@ import Data.Aeson.Types as J
1312import Data.HashMap.Strict as H
1413import Data.Kind
1514import Data.Maybe
16−import Data.Schematic.Generator
1715import Data.Schematic.Instances ()
1816import Data.Scientific
1917import Data.Singletons.Prelude.List hiding (All, Union)
@@ -26,8 +24,7 @@ import Data.Vinyl hiding (Dict)
2624import qualified Data.Vinyl.TypeLevel as V
2725import GHC.Exts
2826import GHC.Generics (Generic)
29−import GHC.TypeLits
30− (SomeNat(..), SomeSymbol(..), someNatVal, someSymbolVal)
27+import GHC.TypeLits (SomeNat(..), SomeSymbol(..), someSymbolVal, someNatVal)
3128import Prelude as P
3229import Test.SmallCheck.Series
3330
@@ -59,25 +56,25 @@ instance SingKind TextConstraint where
5956 STRegex s -> withKnownSymbol s (DTRegex $ T.pack $ symbolVal s)
6057 STEnum s -> let
6158 d :: Sing (s :: [Symbol]) -> [Text]
62− d SNil = []
59+ d SNil = []
6360 d (SCons ss@SSym fs) = T.pack (symbolVal ss) : d fs
6461 in DTEnum $ d s
6562 toSing = \case
6663 DTEq n -> case someNatVal n of
6764 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STEq (SNat :: Sing n))
68− Nothing -> error "Negative singleton nat"
65+ Nothing -> error "Negative singleton nat"
6966 DTLt n -> case someNatVal n of
7067 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLt (SNat :: Sing n))
71− Nothing -> error "Negative singleton nat"
68+ Nothing -> error "Negative singleton nat"
7269 DTLe n -> case someNatVal n of
7370 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLe (SNat :: Sing n))
74− Nothing -> error "Negative singleton nat"
71+ Nothing -> error "Negative singleton nat"
7572 DTGt n -> case someNatVal n of
7673 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGt (SNat :: Sing n))
77− Nothing -> error "Negative singleton nat"
74+ Nothing -> error "Negative singleton nat"
7875 DTGe n -> case someNatVal n of
7976 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGe (SNat :: Sing n))
80− Nothing -> error "Negative singleton nat"
77+ Nothing -> error "Negative singleton nat"
8178 DTRegex s -> case someSymbolVal (T.unpack s) of
8279 SomeSymbol (_ :: Proxy n) -> SomeSing (STRegex (SSym :: Sing n))
8380 DTEnum ss -> case toSing ss of
@@ -164,79 +161,43 @@ instance SingKind NumberConstraint where
164161 toSing = \case
165162 DNEq n -> case someNatVal n of
166163 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNEq (SNat :: Sing n))
167− Nothing -> error "Negative singleton nat"
164+ Nothing -> error "Negative singleton nat"
168165 DNGt n -> case someNatVal n of
169166 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGt (SNat :: Sing n))
170− Nothing -> error "Negative singleton nat"
167+ Nothing -> error "Negative singleton nat"
171168 DNGe n -> case someNatVal n of
172169 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGe (SNat :: Sing n))
173− Nothing -> error "Negative singleton nat"
170+ Nothing -> error "Negative singleton nat"
174171 DNLt n -> case someNatVal n of
175172 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLt (SNat :: Sing n))
176− Nothing -> error "Negative singleton nat"
173+ Nothing -> error "Negative singleton nat"
177174 DNLe n -> case someNatVal n of
178175 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLe (SNat :: Sing n))
179− Nothing -> error "Negative singleton nat"
176+ Nothing -> error "Negative singleton nat"
180177
181178data ArrayConstraint
182179 = AEq Nat
183− | AGt Nat
184− | AGe Nat
185− | ALt Nat
186− | ALe Nat
187180 deriving (Generic)
188181
189182data DemotedArrayConstraint
190183 = DAEq Integer
191− | DAGt Integer
192− | DAGe Integer
193− | DALt Integer
194− | DALe Integer
195184 deriving (Generic, Eq, Show)
196185
197186data instance Sing (ac :: ArrayConstraint) where
198187 SAEq :: Sing n -> Sing ('AEq n)
199− SAGt :: Sing n -> Sing ('AGt n)
200− SAGe :: Sing n -> Sing ('AGe n)
201− SALt :: Sing n -> Sing ('ALt n)
202− SALe :: Sing n -> Sing ('ALe n)
203188
204189instance KnownNat n => SingI ('AEq n) where sing = SAEq sing
205−instance KnownNat n => SingI ('AGt n) where sing = SAGt sing
206−instance KnownNat n => SingI ('AGe n) where sing = SAGe sing
207−instance KnownNat n => SingI ('ALt n) where sing = SALt sing
208−instance KnownNat n => SingI ('ALe n) where sing = SALe sing
209190
210191instance Eq (Sing ('AEq n)) where _ == _ = True
211−instance Eq (Sing ('AGt n)) where _ == _ = True
212−instance Eq (Sing ('AGe n)) where _ == _ = True
213−instance Eq (Sing ('ALt n)) where _ == _ = True
214−instance Eq (Sing ('ALe n)) where _ == _ = True
215192
216193instance SingKind ArrayConstraint where
217194 type Demote ArrayConstraint = DemotedArrayConstraint
218195 fromSing = \case
219196 SAEq n -> withKnownNat n (DAEq . fromIntegral $ natVal n)
220− SAGt n -> withKnownNat n (DAGt . fromIntegral $ natVal n)
221− SAGe n -> withKnownNat n (DAGe . fromIntegral $ natVal n)
222− SALt n -> withKnownNat n (DALt . fromIntegral $ natVal n)
223− SALe n -> withKnownNat n (DALe . fromIntegral $ natVal n)
224197 toSing = \case
225198 DAEq n -> case someNatVal n of
226199 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SAEq (SNat :: Sing n))
227− Nothing -> error "Negative singleton nat"
228− DAGt n -> case someNatVal n of
229− Just (SomeNat (_ :: Proxy n)) -> SomeSing (SAGt (SNat :: Sing n))
230− Nothing -> error "Negative singleton nat"
231− DAGe n -> case someNatVal n of
232− Just (SomeNat (_ :: Proxy n)) -> SomeSing (SAGe (SNat :: Sing n))
233− Nothing -> error "Negative singleton nat"
234− DALt n -> case someNatVal n of
235− Just (SomeNat (_ :: Proxy n)) -> SomeSing (SALt (SNat :: Sing n))
236− Nothing -> error "Negative singleton nat"
237− DALe n -> case someNatVal n of
238− Just (SomeNat (_ :: Proxy n)) -> SomeSing (SALe (SNat :: Sing n))
239− Nothing -> error "Negative singleton nat"
200+ Nothing -> error "Negative singleton nat"
240201
241202data Schema
242203 = SchemaText [TextConstraint]
@@ -373,31 +334,6 @@ data JsonRepr :: Schema -> Type where
373334 ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)
374335 ReprUnion :: Union JsonRepr (h ': tl) -> JsonRepr ('SchemaUnion (h ': tl))
375336
376−instance (Monad m, Serial m Text, SingI cs)
377− => Serial m (JsonRepr ('SchemaText cs)) where
378− series = decDepth $ fmap ReprText $ textSeries $ fromSing (sing :: Sing cs)
379−
380−instance (Monad m, Serial m Scientific, SingI cs)
381− => Serial m (JsonRepr ('SchemaNumber cs)) where
382− series = decDepth $ fmap ReprNumber
383− $ numberSeries $ fromSing (sing :: Sing cs)
384−
385−instance Monad m => Serial m (JsonRepr 'SchemaNull) where
386− series = cons0 ReprNull
387−
388−instance (Serial m (JsonRepr s), Serial m (V.Vector (JsonRepr s)), SingI cs)
389− => Serial m (JsonRepr ('SchemaArray cs s)) where
390− series = decDepth $ fmap ReprArray
391− $ arraySeries $ fromSing (sing :: Sing cs)
392−
393−instance (Serial m (JsonRepr s))
394− => Serial m (JsonRepr ('SchemaOptional s)) where
395− series = cons1 ReprOptional
396−
397−instance (Monad m, Serial m (Rec FieldRepr fs))
398− => Serial m (JsonRepr ('SchemaObject fs)) where
399− series = cons1 ReprObject
400−
401337-- | Move to the union package
402338instance Show (JsonRepr ('SchemaText cs)) where
403339 show (ReprText t) = "ReprText " P.++ show t
@@ -405,32 +341,17 @@ instance Show (JsonRepr ('SchemaText cs)) where
405341instance Show (JsonRepr ('SchemaNumber cs)) where
406342 show (ReprNumber n) = "ReprNumber " P.++ show n
407343
408−instance Show (JsonRepr 'SchemaBoolean) where
409− show (ReprBoolean n) = "ReprBoolean " P.++ show n
410−
411344instance Show (JsonRepr 'SchemaNull) where show _ = "ReprNull"
412345
413346instance Show (JsonRepr s) => Show (JsonRepr ('SchemaArray acs s)) where
414347 show (ReprArray v) = "ReprArray " P.++ show v
415348
416−#if MIN_VERSION_base(4,12,0)
417−instance
418− ( V.RecAll FieldRepr fs Show, RMap fs, ReifyConstraint Show FieldRepr fs
419− , RecordToList fs )
420− => Show (JsonRepr ('SchemaObject fs)) where
421− show (ReprObject fs) = "ReprObject " P.++ show fs
422−#else
423349instance V.RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where
424350 show (ReprObject fs) = "ReprObject " P.++ show fs
425−#endif
426351
427352instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where
428353 show (ReprOptional s) = "ReprOptional " P.++ show s
429354
430−instance Show (Union JsonRepr (h ': tl))
431− => Show (JsonRepr ('SchemaUnion (h ': tl))) where
432− show (ReprUnion s) = "ReprUnion " P.++ show s
433−
434355instance Eq (Rec FieldRepr fs) => Eq (JsonRepr ('SchemaObject fs)) where
435356 ReprObject a == ReprObject b = a == b
436357
@@ -440,9 +361,6 @@ instance Eq (JsonRepr ('SchemaText cs)) where
440361instance Eq (JsonRepr ('SchemaNumber cs)) where
441362 ReprNumber a == ReprNumber b = a == b
442363
443−instance Eq (JsonRepr 'SchemaBoolean) where
444− ReprBoolean a == ReprBoolean b = a == b
445−
446364instance Eq (JsonRepr 'SchemaNull) where
447365 ReprNull == ReprNull = True
448366
@@ -452,10 +370,6 @@ instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaArray as s)) where
452370instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaOptional s)) where
453371 ReprOptional a == ReprOptional b = a == b
454372
455−instance Eq (Union JsonRepr (h ': tl))
456− => Eq (JsonRepr ('SchemaUnion (h ': tl))) where
457− ReprUnion a == ReprUnion b = a == b
458−
459373instance Ord (Rec FieldRepr fs) => Ord (JsonRepr ('SchemaObject fs)) where
460374 ReprObject a `compare` ReprObject b = a `compare` b
461375
@@ -465,9 +379,6 @@ instance Ord (JsonRepr ('SchemaText cs)) where
465379instance Ord (JsonRepr ('SchemaNumber cs)) where
466380 ReprNumber a `compare` ReprNumber b = a `compare` b
467381
468−instance Ord (JsonRepr 'SchemaBoolean) where
469− ReprBoolean a `compare` ReprBoolean b = a `compare` b
470−
471382instance Ord (JsonRepr 'SchemaNull) where
472383 compare _ _ = EQ
473384
@@ -477,10 +388,6 @@ instance Ord (JsonRepr s) => Ord (JsonRepr ('SchemaArray as s)) where
477388instance Ord (JsonRepr s) => Ord (JsonRepr ('SchemaOptional s)) where
478389 ReprOptional a `compare` ReprOptional b = a `compare` b
479390
480−instance Ord (Union JsonRepr (h ': tl))
481− => Ord (JsonRepr ('SchemaUnion (h ': tl))) where
482− ReprUnion a `compare` ReprUnion b = a `compare` b
483−
484391instance IsList (JsonRepr ('SchemaArray cs s)) where
485392 type Item (JsonRepr ('SchemaArray cs s)) = JsonRepr s
486393 fromList = ReprArray . GHC.Exts.fromList
@@ -572,7 +479,7 @@ instance J.ToJSON (JsonRepr a) where
572479 toJSON (ReprText t) = J.String t
573480 toJSON (ReprNumber n) = J.Number n
574481 toJSON (ReprOptional s) = case s of
575− Just v -> toJSON v
482+ Just v -> toJSON v
576483 Nothing -> J.Null
577484 toJSON (ReprArray v) = J.Array $ toJSON <$> v
578485 toJSON (ReprObject r) = J.Object . H.fromList . fold $ r
src/Data/Schematic/Schema.hs-bootdeleted−95
@@ -1,95 +0,0 @@
1−module Data.Schematic.Schema where
2−
3−import Data.Kind
4−import Data.Maybe
5−import Data.Schematic.Instances ()
6−import Data.Scientific
7−import Data.Singletons.TH
8−import Data.Singletons.TypeLits
9−import Data.Text as T
10−import Data.Union
11−import Data.Vector as V
12−import Data.Vinyl hiding (Dict)
13−import Prelude as P
14−
15−data TextConstraint
16− = TEq Nat
17− | TLt Nat
18− | TLe Nat
19− | TGt Nat
20− | TGe Nat
21− | TRegex Symbol
22− | TEnum [Symbol]
23−
24−data DemotedTextConstraint
25− = DTEq Integer
26− | DTLt Integer
27− | DTLe Integer
28− | DTGt Integer
29− | DTGe Integer
30− | DTRegex Text
31− | DTEnum [Text]
32−
33−data NumberConstraint
34− = NLe Nat
35− | NLt Nat
36− | NGt Nat
37− | NGe Nat
38− | NEq Nat
39−
40−data DemotedNumberConstraint
41− = DNLe Integer
42− | DNLt Integer
43− | DNGt Integer
44− | DNGe Integer
45− | DNEq Integer
46−
47−data ArrayConstraint
48− = AEq Nat
49− | AGt Nat
50− | AGe Nat
51− | ALt Nat
52− | ALe Nat
53−
54−data DemotedArrayConstraint
55− = DAEq Integer
56− | DAGt Integer
57− | DAGe Integer
58− | DALt Integer
59− | DALe Integer
60−
61−data Schema
62− = SchemaText [TextConstraint]
63− | SchemaBoolean
64− | SchemaNumber [NumberConstraint]
65− | SchemaObject [(Symbol, Schema)]
66− | SchemaArray [ArrayConstraint] Schema
67− | SchemaNull
68− | SchemaOptional Schema
69− | SchemaUnion [Schema]
70−
71−data DemotedSchema
72− = DSchemaText [DemotedTextConstraint]
73− | DSchemaNumber [DemotedNumberConstraint]
74− | DSchemaBoolean
75− | DSchemaObject [(Text, DemotedSchema)]
76− | DSchemaArray [DemotedArrayConstraint] DemotedSchema
77− | DSchemaNull
78− | DSchemaOptional DemotedSchema
79− | DSchemaUnion [DemotedSchema]
80−
81−data FieldRepr :: (Symbol, Schema) -> Type where
82− FieldRepr
83− :: (SingI schema, KnownSymbol name)
84− => JsonRepr schema
85− -> FieldRepr '(name, schema)
86−
87−data JsonRepr :: Schema -> Type where
88− ReprText :: Text -> JsonRepr ('SchemaText cs)
89− ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)
90− ReprBoolean :: Bool -> JsonRepr 'SchemaBoolean
91− ReprNull :: JsonRepr 'SchemaNull
92− ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)
93− ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)
94− ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)
95− ReprUnion :: Union JsonRepr (h ': tl) -> JsonRepr ('SchemaUnion (h ': tl))
src/Data/Schematic/Validation.hs+27−56
@@ -3,7 +3,6 @@ module Data.Schematic.Validation where
33import Control.Monad
44import Control.Monad.Validation
55import Data.Aeson
6−import Data.Aeson.Internal
76import Data.Aeson.Types
87import Data.Foldable
98import Data.Functor.Identity
@@ -50,51 +49,51 @@ isValidationError (ValidationError _) = True
5049isValidationError _ = False
5150
5251validateTextConstraint
53− :: JSONPathText
52+ :: JSONPath
5453 -> Text
5554 -> Sing (tcs :: TextConstraint)
5655 -> Validation ()
57−validateTextConstraint (JSONPathText path) t = \case
56+validateTextConstraint (JSONPath path) t = \case
5857 STEq n -> do
5958 let
6059 nlen = withKnownNat n $ natVal n
6160 predicate = nlen == (fromIntegral $ T.length t)
62− errMsg = "length should be == " <> T.pack (show nlen)
61+ errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)
6362 warn = vWarning $ mmSingleton path (pure errMsg)
6463 unless predicate warn
6564 STLt n -> do
6665 let
6766 nlen = withKnownNat n $ natVal n
68− predicate = nlen > (fromIntegral $ T.length t)
69− errMsg = "length should be < " <> T.pack (show nlen)
67+ predicate = nlen < (fromIntegral $ T.length t)
68+ errMsg = "length of " <> path <> " should be < " <> T.pack (show nlen)
7069 warn = vWarning $ mmSingleton path (pure errMsg)
7170 unless predicate warn
7271 STLe n -> do
7372 let
7473 nlen = withKnownNat n $ natVal n
75− predicate = nlen >= (fromIntegral $ T.length t)
76− errMsg = "length should be <= " <> T.pack (show nlen)
74+ predicate = nlen <= (fromIntegral $ T.length t)
75+ errMsg = "length of " <> path <> " should be <= " <> T.pack (show nlen)
7776 warn = vWarning $ mmSingleton path (pure errMsg)
7877 unless predicate warn
7978 STGt n -> do
8079 let
8180 nlen = withKnownNat n $ natVal n
82− predicate = nlen < (fromIntegral $ T.length t)
83− errMsg = "length should be > " <> T.pack (show nlen)
81+ predicate = nlen > (fromIntegral $ T.length t)
82+ errMsg = "length of " <> path <> " should be > " <> T.pack (show nlen)
8483 warn = vWarning $ mmSingleton path (pure errMsg)
8584 unless predicate warn
8685 STGe n -> do
8786 let
8887 nlen = withKnownNat n $ natVal n
89− predicate = nlen <= (fromIntegral $ T.length t)
90− errMsg = "length should be >= " <> T.pack (show nlen)
88+ predicate = nlen >= (fromIntegral $ T.length t)
89+ errMsg = "length of " <> path <> " should be >= " <> T.pack (show nlen)
9190 warn = vWarning $ mmSingleton path (pure errMsg)
9291 unless predicate warn
9392 STRegex r -> do
9493 let
9594 regex = withKnownSymbol r $ fromSing r
9695 predicate = matchTest (makeRegex (T.unpack regex) :: Regex) (T.unpack t)
97− errMsg = "must match " <> regex
96+ errMsg = path <> " must match " <> regex
9897 warn = vWarning $ mmSingleton path (pure errMsg)
9998 unless predicate warn
10099 STEnum ss -> do
@@ -102,97 +101,69 @@ validateTextConstraint (JSONPathText path) t = \case
102101 matching :: Sing (s :: [Symbol]) -> Bool
103102 matching SNil = False
104103 matching (SCons s@SSym fs) = T.pack (symbolVal s) == t || matching fs
105− errMsg = "must be one of " <> T.pack (show (fromSing ss))
104+ errMsg = path <> " must be one of " <> T.pack (show (fromSing ss))
106105 warn = vWarning $ mmSingleton path (pure errMsg)
107106 unless (matching ss) warn
108107
109108validateNumberConstraint
110− :: JSONPathText
109+ :: JSONPath
111110 -> Scientific
112111 -> Sing (tcs :: NumberConstraint)
113112 -> Validation ()
114−validateNumberConstraint (JSONPathText path) num = \case
113+validateNumberConstraint (JSONPath path) num = \case
115114 SNEq n -> do
116115 let
117116 nlen = withKnownNat n $ natVal n
118117 predicate = fromIntegral nlen == num
119− errMsg = "should be == " <> T.pack (show nlen)
118+ errMsg = path <> " should be == " <> T.pack (show nlen)
120119 warn = vWarning $ mmSingleton path (pure errMsg)
121120 unless predicate warn
122121 SNGt n -> do
123122 let
124123 nlen = withKnownNat n $ natVal n
125124 predicate = num > fromIntegral nlen
126− errMsg = "should be > " <> T.pack (show nlen)
125+ errMsg = path <> " should be > " <> T.pack (show nlen)
127126 warn = vWarning $ mmSingleton path (pure errMsg)
128127 unless predicate warn
129128 SNGe n -> do
130129 let
131130 nlen = withKnownNat n $ natVal n
132131 predicate = num >= fromIntegral nlen
133− errMsg = "should be >= " <> T.pack (show nlen)
132+ errMsg = path <> " should be >= " <> T.pack (show nlen)
134133 warn = vWarning $ mmSingleton path (pure errMsg)
135134 unless predicate warn
136135 SNLt n -> do
137136 let
138137 nlen = withKnownNat n $ natVal n
139138 predicate = num < fromIntegral nlen
140− errMsg = "should be < " <> T.pack (show nlen)
139+ errMsg = path <> " should be < " <> T.pack (show nlen)
141140 warn = vWarning $ mmSingleton path (pure errMsg)
142141 unless predicate warn
143142 SNLe n -> do
144143 let
145144 nlen = withKnownNat n $ natVal n
146145 predicate = num <= fromIntegral nlen
147− errMsg = "should be <= " <> T.pack (show nlen)
146+ errMsg = path <> " should be <= " <> T.pack (show nlen)
148147 warn = vWarning $ mmSingleton path (pure errMsg)
149148 unless predicate warn
150149
151150validateArrayConstraint
152− :: JSONPathText
151+ :: JSONPath
153152 -> V.Vector a
154153 -> Sing (tcs :: ArrayConstraint)
155154 -> Validation ()
156−validateArrayConstraint (JSONPathText path) v = \case
155+validateArrayConstraint (JSONPath path) v = \case
157156 SAEq n -> do
158157 let
159158 nlen = withKnownNat n $ natVal n
160159 predicate = nlen == fromIntegral (V.length v)
161− errMsg = "length should be == " <> T.pack (show nlen)
162− warn = vWarning $ mmSingleton path (pure errMsg)
163− unless predicate warn
164− SAGt n -> do
165− let
166− nlen = withKnownNat n $ natVal n
167− predicate = fromIntegral (V.length v) > nlen
168− errMsg = "length should be > " <> T.pack (show nlen)
169− warn = vWarning $ mmSingleton path (pure errMsg)
170− unless predicate warn
171− SAGe n -> do
172− let
173− nlen = withKnownNat n $ natVal n
174− predicate = fromIntegral (V.length v) >= nlen
175− errMsg = "length should be >= " <> T.pack (show nlen)
176− warn = vWarning $ mmSingleton path (pure errMsg)
177− unless predicate warn
178− SALt n -> do
179− let
180− nlen = withKnownNat n $ natVal n
181− predicate = fromIntegral (V.length v) < nlen
182− errMsg = "length should be < " <> T.pack (show nlen)
183− warn = vWarning $ mmSingleton path (pure errMsg)
184− unless predicate warn
185− SALe n -> do
186− let
187− nlen = withKnownNat n $ natVal n
188− predicate = fromIntegral (V.length v) <= nlen
189− errMsg = "length should be <= " <> T.pack (show nlen)
160+ errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)
190161 warn = vWarning $ mmSingleton path (pure errMsg)
191162 unless predicate warn
192163
193164validateJsonRepr
194165 :: Sing schema
195− -> JSONPath
166+ -> [DemotedPathSegment]
196167 -> JsonRepr schema
197168 -> Validation ()
198169validateJsonRepr sschema dpath jr = case jr of
@@ -226,7 +197,7 @@ validateJsonRepr sschema dpath jr = case jr of
226197 process cs
227198 process acs
228199 for_ (V.indexed v) $ \(ix, jr') -> do
229− let newPath = dpath <> pure (Index $ fromIntegral ix)
200+ let newPath = dpath <> pure (DIx $ fromIntegral ix)
230201 validateJsonRepr s newPath jr'
231202 ReprOptional d -> case sschema of
232203 SSchemaOptional ss -> case d of
@@ -238,7 +209,7 @@ validateJsonRepr sschema dpath jr = case jr of
238209 go :: Rec FieldRepr (ts :: [(Symbol, Schema)] ) -> Validation ()
239210 go RNil = pure ()
240211 go (f@(FieldRepr d) :& ftl) = do
241− let newPath = dpath <> [Key (knownFieldName f)]
212+ let newPath = dpath <> [DKey (knownFieldName f)]
242213 validateJsonRepr (knownFieldSchema f) newPath d
243214 go ftl
244215 ReprUnion _ -> pure () -- FIXME
@@ -250,7 +221,7 @@ validateJsonRepr sschema dpath jr = case jr of
250221 -- fail "impossible to produce subUnion, please report this as a bug"
251222 -- Just x -> do
252223 -- let
253− -- JSONPathText path = demotedPathToText dpath
224+ -- JSONPath path = demotedPathToText dpath
254225 -- case stl of
255226 -- SNil -> void $ vWarning $ mmSingleton path
256227 -- $ pure "union handling error, please report this as bug"
src/Data/Schematic/Verifier/Array.hs+1−1
@@ -1,6 +1,6 @@
11module Data.Schematic.Verifier.Array where
22
3−import {-# SOURCE #-} Data.Schematic.Schema
3+import Data.Schematic
44import Data.Schematic.Verifier.Common
55
66data VerifiedArrayConstraint =
src/Data/Schematic/Verifier/Common.hs+2−2
@@ -17,8 +17,8 @@ simplifyDNGs = simplifyNumberConstraint maximum
1717verifyDNEq :: [Integer] -> Maybe (Maybe Integer)
1818verifyDNEq x =
1919 case nub x of
20− [] -> Just Nothing
21− [y] -> Just $ Just y
20+ [] -> Just Nothing
21+ [y] -> Just $ Just y
2222 (_:_:_) -> Nothing
2323
2424verify3 :: Maybe Integer -> Maybe Integer -> Maybe Integer -> Maybe ()
src/Data/Schematic/Verifier/Number.hs+9−9
@@ -1,6 +1,6 @@
11module Data.Schematic.Verifier.Number where
22
3−import {-# SOURCE #-} Data.Schematic.Schema
3+import Data.Schematic
44import Data.Schematic.Verifier.Common
55
66toStrictNumber :: [DemotedNumberConstraint] -> [DemotedNumberConstraint]
@@ -8,21 +8,21 @@ toStrictNumber = map f
88 where
99 f (DNLe x) = DNLt (x + 1)
1010 f (DNGe x) = DNGt (x - 1)
11− f x = x
11+ f x = x
1212
1313data VerifiedNumberConstraint
1414 = VNEq Integer
15− | VNBounds (Maybe Integer) (Maybe Integer)
15+ | VNBounds (Maybe Integer)
16+ (Maybe Integer)
1617 deriving (Show)
1718
18−verifyNumberConstraints
19− :: [DemotedNumberConstraint]
19+verifyNumberConstraints ::
20+ [DemotedNumberConstraint]
2021 -> Maybe VerifiedNumberConstraint
2122verifyNumberConstraints cs' = do
22− let
23− cs = toStrictNumber cs'
24− mlt = simplifyDNLs [x | DNLt x <- cs]
25− mgt = simplifyDNGs [x | DNGt x <- cs]
23+ let cs = toStrictNumber cs'
24+ mlt = simplifyDNLs [x | DNLt x <- cs]
25+ mgt = simplifyDNGs [x | DNGt x <- cs]
2626 meq <- verifyDNEq [x | DNEq x <- cs]
2727 verifyEquations mgt meq mlt
2828 Just $
src/Data/Schematic/Verifier/Text.hs+55−58
@@ -2,7 +2,7 @@ module Data.Schematic.Verifier.Text where
22
33import Control.Monad
44import Data.Maybe
5−import {-# SOURCE #-} Data.Schematic.Schema
5+import Data.Schematic
66import Data.Schematic.Verifier.Common
77import Data.Text (Text, unpack)
88import Text.Regex.TDFA.Pattern
@@ -13,28 +13,29 @@ toStrictTextLength = map f
1313 where
1414 f (DTLe x) = DTLt (x + 1)
1515 f (DTGe x) = DTGt (x - 1)
16− f x = x
16+ f x = x
1717
1818data VerifiedTextConstraint
1919 = VTEq Integer
20− | VTBounds (Maybe Integer) (Maybe Integer)
21− | VTRegex Text Integer (Maybe Integer)
20+ | VTBounds (Maybe Integer)
21+ (Maybe Integer)
22+ | VTRegex Text
23+ Integer
24+ (Maybe Integer)
2225 | VTEnum [Text]
2326 deriving (Show)
2427
25−verifyTextLengthConstraints
26− :: [DemotedTextConstraint]
27− -> Maybe (Maybe VerifiedTextConstraint)
28+verifyTextLengthConstraints ::
29+ [DemotedTextConstraint] -> Maybe (Maybe VerifiedTextConstraint)
2830verifyTextLengthConstraints cs' = do
29− let
30− cs = toStrictTextLength cs'
31− mlt = simplifyDNLs [x | DTLt x <- cs]
32− mgt = simplifyDNGs [x | DTGt x <- cs]
31+ let cs = toStrictTextLength cs'
32+ mlt = simplifyDNLs [x | DTLt x <- cs]
33+ mgt = simplifyDNGs [x | DTGt x <- cs]
3334 meq <- verifyDNEq [x | DTEq x <- cs]
3435 verifyEquations mgt meq mlt
3536 case all isNothing ([mgt, meq, mlt] :: [Maybe Integer]) of
3637 True -> Just Nothing
37− _ ->
38+ _ ->
3839 Just $
3940 Just $
4041 case meq of
@@ -45,77 +46,73 @@ regexLength :: Text -> Maybe (Int, Maybe Int)
4546regexLength regexp =
4647 case parseRegex . unpack $ regexp of
4748 Right (p, _) -> Just (minRegexLength p, maxRegexLength p)
48− Left _ -> Nothing
49+ Left _ -> Nothing
4950
5051minRegexLength :: Pattern -> Int
5152minRegexLength p =
5253 case p of
53− PEmpty -> 0
54− PChar {..} -> 1
55− PAny {..} -> 1
56− PAnyNot {..} -> 1
57− PQuest _ -> 0
58− PPlus sch -> minRegexLength $ PBound 1 Nothing sch
59− PStar _ sch -> minRegexLength $ PBound 0 Nothing sch
54+ PEmpty -> 0
55+ PChar {..} -> 1
56+ PAny {..} -> 1
57+ PAnyNot {..} -> 1
58+ PQuest _ -> 0
59+ PPlus sch -> minRegexLength $ PBound 1 Nothing sch
60+ PStar _ sch -> minRegexLength $ PBound 0 Nothing sch
6061 PBound low _ sch -> low * minRegexLength sch
61− PConcat ps -> sum $ fmap minRegexLength ps
62− POr xs -> minimum $ fmap minRegexLength xs
63− PDot _ -> 1
64− PEscape {..} -> 1
65− PCarat _ -> 0
66− PDollar _ -> 0
67− _ -> 0
62+ PConcat ps -> sum $ fmap minRegexLength ps
63+ POr xs -> minimum $ fmap minRegexLength xs
64+ PDot _ -> 1
65+ PEscape {..} -> 1
66+ PCarat _ -> 0
67+ PDollar _ -> 0
68+ _ -> 0
6869
6970maxRegexLength :: Pattern -> Maybe Int
7071maxRegexLength p =
7172 case p of
72− PEmpty -> Just 0
73− PChar _ _ -> Just 1
74− PAny _ _ -> Just 1
75− PAnyNot _ _ -> Just 1
76− PQuest _ -> Just 0
77− PPlus _ -> Nothing
78− PStar _ _ -> Nothing
73+ PEmpty -> Just 0
74+ PChar _ _ -> Just 1
75+ PAny _ _ -> Just 1
76+ PAnyNot _ _ -> Just 1
77+ PQuest _ -> Just 0
78+ PPlus _ -> Nothing
79+ PStar _ _ -> Nothing
7980 PBound _ mhigh sch -> (*) <$> mhigh <*> maxRegexLength sch
80− PConcat ps -> sum <$> mapM maxRegexLength ps
81− POr xs -> maximum <$> mapM maxRegexLength xs
82− PDot _ -> Just 1
83− PEscape _ _ -> Just 1
84− PCarat _ -> Just 0
85− PDollar _ -> Just 0
86− _ -> Just 0
81+ PConcat ps -> sum <$> mapM maxRegexLength ps
82+ POr xs -> maximum <$> mapM maxRegexLength xs
83+ PDot _ -> Just 1
84+ PEscape _ _ -> Just 1
85+ PCarat _ -> Just 0
86+ PDollar _ -> Just 0
87+ _ -> Just 0
8788
88−verifyTextRegexConstraint
89− :: [DemotedTextConstraint]
90− -> Maybe (Maybe VerifiedTextConstraint)
89+verifyTextRegexConstraint ::
90+ [DemotedTextConstraint] -> Maybe (Maybe VerifiedTextConstraint)
9191verifyTextRegexConstraint cs = do
9292 let regexps = [x | DTRegex x <- cs]
9393 case regexps of
94− [] -> Just Nothing
94+ [] -> Just Nothing
9595 [x] -> do
9696 (l, mh) <- regexLength x
9797 Just $ Just $ VTRegex x (fromIntegral l) (fromIntegral <$> mh)
98− _ -> Nothing
98+ _ -> Nothing
9999
100−verifyTextEnumConstraint
101− :: [DemotedTextConstraint]
102− -> Maybe (Maybe VerifiedTextConstraint)
100+verifyTextEnumConstraint ::
101+ [DemotedTextConstraint] -> Maybe (Maybe VerifiedTextConstraint)
103102verifyTextEnumConstraint cs = do
104103 let enums = concat [x | DTEnum x <- cs]
105104 case enums of
106105 [] -> Just Nothing
107− x -> Just $ Just $ VTEnum x
106+ x -> Just $ Just $ VTEnum x
108107
109−verifyTextConstraints
110− :: [DemotedTextConstraint]
111− -> Maybe [VerifiedTextConstraint]
108+verifyTextConstraints ::
109+ [DemotedTextConstraint] -> Maybe [VerifiedTextConstraint]
112110verifyTextConstraints cs = do
113111 regexp <- verifyTextRegexConstraint cs
114− void $
115− case regexp of
116− Just (VTRegex _ l mh) ->
117− verifyTextLengthConstraints (DTGe l : cs ++ maybeToList (DTLe <$> mh))
118− _ -> pure Nothing
112+ void $ case regexp of
113+ Just (VTRegex _ l mh) ->
114+ verifyTextLengthConstraints (DTGe l : cs ++ maybeToList (DTLe <$> mh))
115+ _ -> pure Nothing
119116 lengths <- verifyTextLengthConstraints cs
120117 enums <- verifyTextEnumConstraint cs
121118 return $ catMaybes [lengths, enums, regexp]
stack-13.21.yamldeleted−7
@@ -1,7 +0,0 @@
1−resolver: lts-13.21
2−extra-deps:
3− - hjsonpointer-1.4.0@rev:0
4− - hjsonschema-1.9.0@rev:0
5− - validationt-0.3.0
6−nix:
7− packages: [pcre, pkg-config, zlib]
stack.yaml+4−5
@@ -1,6 +1,5 @@
1−resolver: lts-14.22
1+resolver: lts-12.0
22extra-deps:
3−- hjsonpointer-1.4.0@rev:0
4−- hjsonschema-1.9.0@rev:0
5−- git: https://github.com/typeable/validationt.git
6− commit: 97fea97c4015ab5e99f3efb2c73e1fef4b8857d8
3+ - hjsonpointer-1.4.0@rev:0
4+ - hjsonschema-1.9.0@rev:0
5+ - validationt-0.2.1.0
test/JsonSchemaSpec.hs−58
@@ -10,7 +10,6 @@ module JsonSchemaSpec (spec, main) where
1010import Data.Aeson as J
1111import Data.Maybe
1212import Data.Proxy
13−import Data.ByteString.Lazy as B
1413import Data.Schematic
1514import Data.Vinyl
1615import JSONSchema.Draft4 as D4
@@ -32,27 +31,6 @@ exampleData = withRepr @SchemaExample $
3231 :& field @"bar" (pure (ReprText "foo"))
3332 :& RNil
3433
35−type SchemaArrayExample = 'SchemaObject
36− '[ '("a1", 'SchemaArray '[ 'AGt 1 ] ('SchemaNumber '[]))
37− , '("a2", 'SchemaArray '[ 'AGe 1 ] ('SchemaNumber '[]))
38− , '("a3", 'SchemaArray '[ 'ALt 1 ] ('SchemaNumber '[]))
39− , '("a4", 'SchemaArray '[ 'ALe 1 ] ('SchemaNumber '[]))
40− ]
41−
42−type SchemaNumberExample = 'SchemaObject
43− '[ '("n1", 'SchemaNumber '[ 'NGt 1 ])
44− , '("n2", 'SchemaNumber '[ 'NGe 1 ])
45− , '("n3", 'SchemaNumber '[ 'NLt 1 ])
46− , '("n4", 'SchemaNumber '[ 'NLe 1 ])
47− ]
48−
49−type SchemaTextExample = 'SchemaObject
50− '[ '("t1", 'SchemaText '[ 'TGt 1 ])
51− , '("t2", 'SchemaText '[ 'TGe 1 ])
52− , '("t3", 'SchemaText '[ 'TLt 1 ])
53− , '("t4", 'SchemaText '[ 'TLe 1 ])
54− ]
55−
5634spec :: Spec
5735spec = do
5836 it "validates simple schema" $ do
@@ -60,42 +38,6 @@ spec = do
6038 fetchHTTPAndValidate schema (toJSON exampleData) >>= \case
6139 Left _ -> fail "failed to validate test example"
6240 Right _ -> pure ()
63− it "validates schema with arrays" $ do
64− let
65− schema = D4.SchemaWithURI (fromJust $ toJsonSchema (Proxy @SchemaArrayExample)) Nothing
66− obj = withRepr @SchemaArrayExample $
67− field @"a1" [ReprNumber 13, ReprNumber 13]
68− :& field @"a2" [ReprNumber 13]
69− :& field @"a3" []
70− :& field @"a4" [ReprNumber 13]
71− :& RNil
72− fetchHTTPAndValidate schema (toJSON obj) >>= \case
73− Left e -> fail "failed to validate test example"
74− Right _ -> pure ()
75− it "validates schema with numbers" $ do
76− let
77− schema = D4.SchemaWithURI (fromJust $ toJsonSchema (Proxy @SchemaNumberExample)) Nothing
78− obj = withRepr @SchemaNumberExample $
79− field @"n1" 1.1
80− :& field @"n2" 1
81− :& field @"n3" 0.9
82− :& field @"n4" 1.0
83− :& RNil
84− fetchHTTPAndValidate schema (toJSON obj) >>= \case
85− Left e -> fail "failed to validate test example"
86− Right _ -> pure ()
87− it "validates schema with strings" $ do
88− let
89− schema = D4.SchemaWithURI (fromJust $ toJsonSchema (Proxy @SchemaTextExample)) Nothing
90− obj = withRepr @SchemaTextExample $
91− field @"t1" "11"
92− :& field @"t2" "1"
93− :& field @"t3" ""
94− :& field @"t4" "1"
95− :& RNil
96− fetchHTTPAndValidate schema (toJSON obj) >>= \case
97− Left e -> fail "failed to validate test example"
98− Right _ -> pure ()
9941
10042main :: IO ()
10143main = hspec spec
test/SchemaSpec.hs−10
@@ -33,10 +33,6 @@ type SchemaExample = 'SchemaObject
3333 '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]))
3434 , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]
3535
36−type SchemaExample2 = 'SchemaObject
37− '[ '("foo", 'SchemaArray '[ 'AEq 2] ('SchemaText '[ 'TGt 10]))
38− , '("bar", 'SchemaOptional ('SchemaText '[ 'TRegex "[0-9]+"]))]
39−
4036jsonExample :: JsonRepr SchemaExample
4137jsonExample = withRepr @SchemaExample
4238 $ field @"bar" (Just "bar")
@@ -83,9 +79,6 @@ schemaJson2 = "{\"foo\": [3], \"bar\": null}"
8379schemaJsonSeries :: Monad m => SC.Series m (JsonRepr SchemaExample)
8480schemaJsonSeries = series
8581
86−schemaJsonSeries2 :: Monad m => SC.Series m (JsonRepr SchemaExample2)
87−schemaJsonSeries2 = series
88−
8982spec :: Spec
9083spec = do
9184 -- it "show/read JsonRepr properly" $
@@ -113,9 +106,6 @@ spec = do
113106 it "validates json series" $ property $
114107 SC.over schemaJsonSeries $ \x ->
115108 isValid (parseAndValidateJson @SchemaExample (toJSON x))
116− it "validates json series 2" $ property $
117− SC.over schemaJsonSeries2 $ \x ->
118− isValid (parseAndValidateJson @SchemaExample2 (toJSON x))
119109
120110
121111main :: IO ()