git.iko.soy/typeable/schematic
on 2af991d help sign in
7db0b46
swap
0 ahead, 6 behind
7 files changed+42−51
since splitsnapshots
unifiedsplit
ChangeLog.md−4 schematic.cabal+3−7 src/Data/Schematic/Path.hs+20−17 src/Data/Schematic/Validation.hs+10−11 stack-13.21.yaml−7 stack-13.7.yaml+5 stack.yaml+4−5
ChangeLog.md−4
@@ -1,9 +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−
73## 0.5.1.0 -- 2021-01-15
84
95Fix the generation of json schema for numbers.
schematic.cabal+3−7
@@ -1,5 +1,5 @@
11name: schematic
2−version: 0.6.0.0
2+version: 0.5.1.0
33synopsis: JSON-biased spec and validation tool
44description: 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.
55license: BSD3
@@ -10,7 +10,7 @@ homepage: http://github.com/typeable/schematic
1010Bug-reports: http://github.com/typeable/schematic/issues/
1111category: Data
1212build-type: Simple
13−extra-source-files: ChangeLog.md, README.md
13+extra-source-files: ChangeLog.md
1414cabal-version: >=1.10
1515
1616library
@@ -67,7 +67,7 @@ library
6767 , UndecidableInstances
6868 build-depends: base >=4.11 && <5
6969 , bytestring
70− , aeson >= 1.4.3.0 && < 1.6
70+ , aeson >= 1 && < 1.4.3.0
7171 , containers
7272 , hjsonschema
7373 , mtl
@@ -118,7 +118,3 @@ test-suite spec
118118 , HelpersSpec
119119 , LensSpec
120120 , JsonSchemaSpec
121−
122−source-repository head
123− type: git
124− location: https://github.com/typeable/schematic
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/Validation.hs+10−11
@@ -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,11 +49,11 @@ 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
@@ -107,11 +106,11 @@ validateTextConstraint (JSONPathText path) t = \case
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
@@ -149,11 +148,11 @@ validateNumberConstraint (JSONPathText path) num = \case
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
@@ -192,7 +191,7 @@ validateArrayConstraint (JSONPathText path) v = \case
192191
193192validateJsonRepr
194193 :: Sing schema
195− -> JSONPath
194+ -> [DemotedPathSegment]
196195 -> JsonRepr schema
197196 -> Validation ()
198197validateJsonRepr sschema dpath jr = case jr of
@@ -226,7 +225,7 @@ validateJsonRepr sschema dpath jr = case jr of
226225 process cs
227226 process acs
228227 for_ (V.indexed v) $ \(ix, jr') -> do
229− let newPath = dpath <> pure (Index $ fromIntegral ix)
228+ let newPath = dpath <> pure (DIx $ fromIntegral ix)
230229 validateJsonRepr s newPath jr'
231230 ReprOptional d -> case sschema of
232231 SSchemaOptional ss -> case d of
@@ -238,7 +237,7 @@ validateJsonRepr sschema dpath jr = case jr of
238237 go :: Rec FieldRepr (ts :: [(Symbol, Schema)] ) -> Validation ()
239238 go RNil = pure ()
240239 go (f@(FieldRepr d) :& ftl) = do
241− let newPath = dpath <> [Key (knownFieldName f)]
240+ let newPath = dpath <> [DKey (knownFieldName f)]
242241 validateJsonRepr (knownFieldSchema f) newPath d
243242 go ftl
244243 ReprUnion _ -> pure () -- FIXME
@@ -250,7 +249,7 @@ validateJsonRepr sschema dpath jr = case jr of
250249 -- fail "impossible to produce subUnion, please report this as a bug"
251250 -- Just x -> do
252251 -- let
253− -- JSONPathText path = demotedPathToText dpath
252+ -- JSONPath path = demotedPathToText dpath
254253 -- case stl of
255254 -- SNil -> void $ vWarning $ mmSingleton path
256255 -- $ pure "union handling error, please report this as bug"
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-13.7.yamlnew file+5
@@ -0,0 +1,5 @@
1+resolver: lts-13.7
2+extra-deps:
3+ - hjsonpointer-1.4.0@rev:0
4+ - hjsonschema-1.9.0@rev:0
5+ - validationt-0.2.1.0
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