git.iko.soy/typeable/schematic
on 5be2bf6 help sign in
7db0b46
swap
0 ahead, 76 behind
30 files changed+517−1441
since splitsnapshots
unifiedsplit
.travis.yml+2−2 ChangeLog.md−36 README.md+26−145 release−43 release.nix−32 schematic.cabal+37−23 src/Data/Schematic.hs+115−18 src/Data/Schematic/DSL.hs−92 src/Data/Schematic/Generator.hs−91 src/Data/Schematic/Generator/Regex.hs−76 src/Data/Schematic/Instances.hs−4 src/Data/Schematic/JsonSchema.hs+10−29 src/Data/Schematic/Lens.hs+37−61 src/Data/Schematic/Migration.hs+8−45 src/Data/Schematic/Path.hs+32−18 src/Data/Schematic/Schema.hs+73−165 src/Data/Schematic/Schema.hs-boot−95 src/Data/Schematic/Utils.hs+42 src/Data/Schematic/Validation.hs+31−88 src/Data/Schematic/Verifier.hs−5 src/Data/Schematic/Verifier/Array.hs−14 src/Data/Schematic/Verifier/Common.hs−43 src/Data/Schematic/Verifier/Number.hs−31 src/Data/Schematic/Verifier/Text.hs−121 stack-13.21.yaml−7 stack.yaml+50−5 test/HelpersSpec.hs+6−6 test/JsonSchemaSpec.hs+10−67 test/LensSpec.hs+10−9 test/SchemaSpec.hs+28−70
.travis.yml+2−2
@@ -1,4 +1,4 @@
1−sudo: required
1+sudo: false
22
33language: c
44
@@ -22,4 +22,4 @@ script:
2222
2323cache:
2424 directories:
25− - $HOME/.stack
25+ - $HOME/.stack
ChangeLog.md−36
@@ -1,41 +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−
19−## 0.4.3.0 -- 2018-07-12
20−
21−GHC 8.4 support, dropping support for older GHC versions
22−
23−## 0.4.2.0
24−
25−Support ghc-8.4 and drop support for older versions
26−
27−## 0.4.1.0 -- 2017-11-05
28−
29−Convenience isomorphisms: txt, num, opt, bln etc
30−
31−## 0.4.1.0 -- 2017-11-01
32−
33−flens and fget now use type application syntax
34−
35−## 0.4.0.0 -- 2017-10-17
36−
37−Object building DSL, more convenience helpers, MCons simplified with Tagged
38−
393## 0.3.2.0 -- 2017-10-02
404
415Fixed FIndex bug, added bunch of convenience isomorphism, re-exports.
README.md+26−145
@@ -22,35 +22,9 @@ Be aware that library is experimental and subject to change a lot. The current s
2222$ stack install schematic
2323```
2424
25−## GHC Extensions
26−
27−To use this library without any hassle you should add a few GHC extension
28−either to a module or a cabal file:
29−
30−```
31−DataKinds
32−OverloadedLists
33−OverloadedStrings
34−TypeApplications
35−```
36−
37−`Overloaded`-extensions are being used only by `field` combinator,
38−so if you don't use it - feel free to disable it.
39−
40−## GHC Options
41−
42−I recommend using `{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}`
43−pragma in modules which declare schemas and schema migrations, because `schematic`
44−heavily uses promoted types which should be prefixed with "`" signs and they can
45−be dropped with this option, making it less noisy visually.
46−It's entirely optional and totally opinionated, so feel free to ignore this.
47−Through the documentation, the code is written without any explicit ticks for
48−the same reason.
49−Notice that they're still needed for type-level lists and tuples in schematic code.
50−
5125## Basic Examples
5226
53−```haskell
27+```
5428type SchemaExample
5529 = SchemaObject
5630 '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))
@@ -68,21 +42,21 @@ type SchemaExample
6842
6943This one is valid for example
7044
71−```haskell
45+```
7246schemaJson :: ByteString
7347schemaJson = "{\"foo\": [13], \"bar\": null}"
7448```
7549
7650Also valid
7751
78−```haskell
52+```
7953schemaJson :: ByteString
8054schemaJson = "{\"foo\": [13], \"bar\": \"bar\"}"
8155```
8256
8357it can be parsed and validated like this:
8458
85−```haskell
59+```
8660decodeAndValidateJson schemaJson :: ParseResult (JsonRepr SchemaExample)
8761```
8862
@@ -92,64 +66,24 @@ decodeAndValidateJson schemaJson :: ParseResult (JsonRepr SchemaExample)
9266* some of the runtime validations have failed, but it's structurally correct
9367 overall
9468
95−It implies a transport layer representation of that data that can be traversed
96−and transformed to whatever internal types user has.
97−It's called `JsonRepr`. Type parameter is the schema itself.
98−
99−```haskell
100−jsonExample :: JsonRepr SchemaExample
101−jsonExample = withRepr @SchemaExample
102− $ field @"foo" [12]
103− :& field @"bar" (Just "bar")
104− :& RNil
105−```
69+It implies a transport layer representation of that data that can be traversed and transformed to whatever internal types user has. It's called `JsonRepr`. Type parameter is the schema itself.
10670
107−The most basic and sugar-free way of constructing the same object will look like this:
10871
10972```
110−jsonExample' :: JsonRepr SchemaExample
111−jsonExample' = ReprObject $
73+jsonExample :: JsonRepr SchemaExample
74+jsonExample = ReprObject $
11275 FieldRepr (ReprArray [ReprNumber 12])
11376 :& FieldRepr (ReprOptional (Just (ReprText "bar")))
11477 :& RNil
11578```
11679
117−## Lens-compatibility
118−
119−It's possible to use `flens` to construct a field lens for a typed object in schematic. Let's suppose you have a schema like this:
120−
121−```haskell
122−type ArraySchema = SchemaArray '[AEq 1] (SchemaNumber '[NGt 10])
123−
124−type ArrayField = '("foo", ArraySchema)
125−
126−type FieldsSchema =
127− '[ ArrayField, '("bar", SchemaOptional (SchemaText '[TEnum '["foo", "bar"]]))]
128−
129−type SchemaExample = 'SchemaObject FieldsSchema
130−
131−```
132−
133−There are two ways of working with named fields in the objects:
134−
135−* Using the `fget` and `fset` functions: `fget @"foo" (fput newFooVal objectData) == newFooVal`
136−* Using the lens library: `set (flens @"foo") newFooVal objectData ^. flens @"foo" == newFooVal`
137−
13880## Migrations
13981
140−Usually migrations are implicit and hard to deal with, `schematic` deals with it
141−by giving tools to deal with it to a programmer, being as explicit as possible,
142−notifying the developer of a missing transition with a compile-time error.
143−It allows to build versioned HTTP APIs or migrate data from the older versions
144−when reading from the JSON storages.
145−
146−It's possible to represent schema changes as a series of migrations,
147−which describes a series of json-path/change pairs. Migrations can be applied in
148−succession.
82+It's possible to represent schema changes as a series of migrations, which describes a series of json-path/change pairs. Migrations can be applied in succession.
14983
15084This piece of code will apply a migration to the schema, decode and validate the latest version.
15185
152−```haskell
86+```
15387type SchemaExample
15488 = SchemaObject
15589 '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))
@@ -157,8 +91,8 @@ type SchemaExample
15791
15892type TestMigration =
15993 'Migration "test_revision"
160− '[ Diff '[ PKey "bar" ] (Update (SchemaText '[]))
161− , Diff '[ PKey "foo" ] (Update (SchemaNumber '[])) ]
94+ '[ 'Diff '[ 'PKey "bar" ] ('Update ('SchemaText '[]))
95+ , 'Diff '[ 'PKey "foo" ] ('Update ('SchemaNumber '[])) ]
16296
16397type VS = 'Versioned SchemaExample '[ TestMigration ]
16498
@@ -172,84 +106,31 @@ It's possible to decode the latest version like this:
172106decodeAndValidateJson schemaJsonTopVersion :: ParseResult (JsonRepr (TopVersion (AllVersions VS)))
173107```
174108
175−It's important to differentiate between schema migrations and data migrations.
176−Schema migration is a change of a schema acceptable by a JSON consumer. It transforms one schema to another.
177−Data migrations on the other hand are functions on the data itself. They transform values
178−acceptable by one schema to values acceptable by another.
179−Let's look at the situation when we have to add a field to a JSON Object of a current schema:
180−
181−```haskell
182−type SchemaExample = 'SchemaObject
183− '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]))
184− , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]
185−
186−jsonExample :: JsonRepr SchemaExample
187−jsonExample = withRepr @SchemaExample
188− $ field @"bar" (Just "bar")
189− :& field @"foo" [12]
190− :& RNil
191−
192−type AddQuuz =
193− 'Migration "add_field_quuz"
194− '[ 'Diff '[] ('AddKey "quuz" (SchemaNumber '[])) ]
195−
196−type DeleteQuuz =
197− 'Migration "remove_field_quuz"
198− '[ 'Diff '[] ( 'DeleteKey "quuz") ]
199−
200−type Migrations = '[ AddQuuz
201− , DeleteQuuz ]
202−
203−type VersionedJson = 'Versioned SchemaExample Migrations
109+## Lens-compatibility
204110
205−migrationList :: MigrationList Identity VersionedJson
206−migrationList
207− = (migrateObject (\r -> Identity $ field @"quuz" 42 :& r))
208− :&& shrinkObject
209− :&& MNil
111+It's possible to use `flens` to construct a field lens for a typed object in schematic. Let's suppose you have a schema like this:
210112
211113```
114+type ArraySchema = 'SchemaArray '[AEq 1] ('SchemaNumber '[NGt 10])
212115
213−In this instance `Migrations` is a list of schema migrations and
214−`MigrationList Identity VersionedJson` is a list of data migrations corresponding
215−to the list of schema migrations: `migrateObject (\r -> Identity $ field @"quuz" 42 :& r))`
216−will be used at runtime to transform `JsonRepr SchemaExample` to
217−`JsonRepr (SchemaByRevision "add_quuz" VersionedJson). `Identity` in the type of
218−`MigrationList` is a monad we choose to run our migrations in. If there's need to
219−do database queries or something like that, it can be changed to something more
220−appropriate by a user.
221−`migrateObject` takes a function transforming old fields into new ones, `shrinkObject`
222−allows to shrink the JSON object in case migration only removed fields.
223−
224−## How do I construct a value of `JsonRepr schema`?
116+type ArrayField = '("foo", ArraySchema)
225117
226−`JsonRepr schema` is a primary representation of a value serializable/deserializable
227−to JSON, but with a twist. It's guaranteed to correspond a type-level schema,
228−it's a type parameter of a same name.
229−It makes constructing it a little bit more involved, but luckily `schematic`
230−provides a DSL for doing so in a more straightforward fashion. An example would
231−look like this:
118+type FieldsSchema =
119+ '[ ArrayField, '("bar", 'SchemaOptional ('SchemaText '[TEnum '["foo", "bar"]]))]
232120
233−```haskell
234−type SchemaExample = 'SchemaObject
235− '[ '("foo", SchemaArray '[ AEq 1] (SchemaNumber '[NGt 10]))
236− , '("bar", SchemaOptional (SchemaText '[TEnum '["foo", "bar"]]))]
121+type SchemaExample = 'SchemaObject FieldsSchema
237122
238−jsonExample = withRepr @SchemaExample
239− $ field @"bar" (Just "bar")
240− :& field @"foo" [12]
241− :& RNil
242123```
243124
244−`@foo` syntax is an explicit type application, which is a feature of GHC 8+, it
245−makes type inference possible without relying on a bunch of `Proxy`s, which
246−makes it syntactically more terse.
125+There are two ways of working with named fields in the objects:
126+
127+* Using the `fget` and `fset` functions: `fget fooProxy (fput newFooVal objectData) == newFooVal`
128+* Using the lens library: `set (flens (Proxy @"foo")) newFooVal objectData ^. flens (Proxy @"foo") == newFooVal`
247129
248−[GHC Type Applications](https://ghc.haskell.org/trac/ghc/wiki/TypeApplication)
130+## Export to json-schema (draft 4)
249131
250−`schematic` provides instances for `OverloadedLists` and `OverloadedStrings`
251−GHC extensions to make use of string and list literals for values in a previous
252−example.
253132
133+## TODO
254134
255−## Export to json-schema (draft 4)
135+* Overall user friendliness
136+* Versioned http endpoints
releasedeleted−43
@@ -1,43 +0,0 @@
1−#!/bin/bash
2−
3−set -o xtrace
4−
5−dist=`stack path --dist-dir --stack-yaml ./stack.yaml 2> /dev/null`
6−
7−rootdir=`pwd`
8−
9−cabalfile=`ls *.cabal`
10−packagename="${cabalfile%%.*}"
11−version=`grep '^version:' schematic.cabal | rev | cut -d" " -f1 | rev`
12−
13−echo -e "\033[1;36mTesting library...\033[0m"
14−stack test 2> /dev/null
15−
16−echo -e "\033[1;36mRunning sdist...\033[0m"
17−cabal sdist
18−
19−echo -e "\033[1;36mGenerating documentation...\033[0m"
20−stack haddock 2> /dev/null
21−
22−if [ "$?" -eq "0" ]; then
23− echo -e "\033[1;32mUploading package to Hackage...\033[0m"
24− read -p "Hackage username: " username
25− read -p "Hackage password: " -s password
26− echo ""
27− cabal upload -u $username -p $password dist/$packagename-$version.tar.gz
28−
29− docdir=`find .stack-work -name "$packagename-$version-docs"`
30−
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
33− 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'."
40− exit $?
41−else
42− echo -e "\033[1;31mNot in a stack-powered project\033[0m"
43−fi
release.nixdeleted−32
@@ -1,32 +0,0 @@
1−{ schematicSrc ? { outPath = ./.; revCount = 0; gitTag = "dirty"; }
2−, supportedSystems ? [ "x86_64-linux" ]
3−}:
4−
5−let
6− _nixpkgs = import <nixpkgs> {};
7− inherit (_nixpkgs) pkgs lib;
8−
9− stackageOverlayPath = pkgs.fetchFromGitHub {
10− owner = "typeable";
11− repo = "nixpkgs-stackage";
12− rev = "abe0a03ba2bde609b0707ce45301ec836cb3ed29";
13− sha256 = "0ksdk83zbsgvs30izwsfyjh4xxwz8dsn9a5igrs3pjap4whpzqfv";
14− };
15−
16− nixpkgsArgs = {
17− overlays = [ (import stackageOverlayPath) ];
18− };
19−
20− release = import <nixpkgs/pkgs/top-level/release-lib.nix> { inherit nixpkgsArgs supportedSystems; };
21−
22− mkStackage = system:
23− let
24− nixpkgs = release.pkgsFor system;
25− stackage = nixpkgs.haskell.packages.stackage.lib.callStackage2nix "schematic" schematicSrc { inherit nixpkgs; };
26− in
27− stackage;
28−
29−in
30− lib.genAttrs supportedSystems (system: {
31− inherit (mkStackage system) schematic;
32− })
schematic.cabal+37−23
@@ -1,7 +1,6 @@
11name: schematic
2−version: 0.6.0.0
2+version: 0.3.2.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,14 +9,11 @@ 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
1716 exposed-modules: Data.Schematic
18− , Data.Schematic.DSL
19− , Data.Schematic.Generator
20− , Data.Schematic.Generator.Regex
2117 , Data.Schematic.Instances
2218 , Data.Schematic.JsonSchema
2319 , Data.Schematic.Helpers
@@ -26,11 +22,7 @@ library
2622 , Data.Schematic.Path
2723 , Data.Schematic.Schema
2824 , Data.Schematic.Validation
29− , Data.Schematic.Verifier
30− , Data.Schematic.Verifier.Array
31− , Data.Schematic.Verifier.Common
32− , Data.Schematic.Verifier.Number
33− , Data.Schematic.Verifier.Text
25+ , Data.Schematic.Utils
3426 ghc-options: -Wall
3527 default-extensions: ConstraintKinds
3628 , DataKinds
@@ -65,9 +57,9 @@ library
6557 , TypeOperators
6658 , TypeSynonymInstances
6759 , UndecidableInstances
68− build-depends: base >=4.11 && <5
60+ build-depends: base >=4.9 && <4.11
6961 , bytestring
70− , aeson >= 1.4.3.0 && < 1.6
62+ , aeson >= 1
7163 , containers
7264 , hjsonschema
7365 , mtl
@@ -75,14 +67,13 @@ library
7567 , regex-tdfa
7668 , regex-tdfa-text
7769 , scientific
78− , singletons >= 2.4
70+ , singletons >= 2.2
7971 , smallcheck
8072 , tagged
81− , template-haskell
8273 , text
8374 , union
8475 , unordered-containers
85− , validationt >= 0.2.1.0
76+ , validationt >= 0.1.0.1
8677 , vector
8778 , vinyl
8879 hs-source-dirs: src
@@ -93,9 +84,36 @@ test-suite spec
9384 hs-source-dirs: test
9485 main-is: Spec.hs
9586 default-language: Haskell2010
87+ default-extensions: ConstraintKinds
88+ , DataKinds
89+ , DeriveFunctor
90+ , DeriveFoldable
91+ , DeriveGeneric
92+ , DeriveDataTypeable
93+ , FlexibleContexts
94+ , FlexibleInstances
95+ , FunctionalDependencies
96+ , GADTs
97+ , KindSignatures
98+ , InstanceSigs
99+ , LambdaCase
100+ , MultiParamTypeClasses
101+ , OverloadedLists
102+ , OverloadedStrings
103+ , PolyKinds
104+ , QuasiQuotes
105+ , PartialTypeSignatures
106+ , RecordWildCards
107+ , ScopedTypeVariables
108+ , TemplateHaskell
109+ , TypeApplications
110+ , TypeFamilies
111+ , TypeInType
112+ , TypeOperators
113+ , TypeSynonymInstances
96114 build-depends: HUnit
97115 , aeson >= 1
98− , base >=4.11 && <4.13
116+ , base >=4.9 && <4.11
99117 , bytestring
100118 , containers
101119 , hjsonschema
@@ -112,13 +130,9 @@ test-suite spec
112130 , tagged
113131 , text
114132 , unordered-containers
115− , validationt >= 0.2.1.0
133+ , validationt >= 0.1.0.1
116134 , vinyl
117135 other-modules: SchemaSpec
118136 , HelpersSpec
119137 , LensSpec
120− , JsonSchemaSpec
121−
122−source-repository head
123− type: git
124− location: https://github.com/typeable/schematic
138+ , JsonSchemaSpec
src/Data/Schematic.hs+115−18
@@ -7,6 +7,7 @@ module Data.Schematic
77 , module Data.Schematic.Lens
88 , module Data.Schematic.Migration
99 , module Data.Schematic.Schema
10+ , module Data.Schematic.Utils
1011 , decodeAndValidateJson
1112 , parseAndValidateJson
1213 , parseAndValidateJsonBy
@@ -20,25 +21,56 @@ module Data.Schematic
2021 , ParseResult(..)
2122 , withRepr
2223 , field
24+ , (<:&>)
2325 ) where
2426
25−import Control.Monad.Validation
26−import Data.Aeson as J
27−import Data.Aeson.Types as J
28−import Data.ByteString.Lazy as BL
29−import Data.Functor.Identity as F
30−import Data.Schematic.DSL
31−import Data.Schematic.Helpers
32−import Data.Schematic.JsonSchema
33−import Data.Schematic.Lens
34−import Data.Schematic.Migration
35−import Data.Schematic.Schema
36−import Data.Schematic.Validation
37−import Data.Singletons.Prelude hiding ((:.))
38−import Data.Tagged
39−import Data.Text as T
27+import Control.Applicative
28+import Control.Monad.Validation
29+import Data.Aeson as J
30+import Data.Aeson.Types as J
31+import Data.ByteString.Lazy as BL
32+import Data.Functor.Identity
33+import Data.Kind
34+import Data.Schematic.Helpers
35+import Data.Schematic.JsonSchema
36+import Data.Schematic.Lens
37+import Data.Schematic.Migration
38+import Data.Schematic.Schema
39+import Data.Schematic.Utils
40+import Data.Schematic.Validation
41+import Data.Scientific
42+import Data.Singletons.Prelude
43+import Data.Singletons.TypeLits
44+import Data.Tagged
45+import Data.Text as T
46+import Data.Union
47+import qualified Data.Vector as V
48+import Data.Vinyl
4049
4150
51+parseAndValidateJson
52+ :: forall schema
53+ . (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
54+ => J.Value
55+ -> ParseResult (JsonRepr schema)
56+parseAndValidateJson v =
57+ case parseEither parseJSON v of
58+ Left s -> DecodingError $ T.pack s
59+ Right jsonRepr ->
60+ let
61+ validate = validateJsonRepr (sing :: Sing schema) [] jsonRepr
62+ res = runIdentity . runValidationTEither $ validate
63+ in case res of
64+ Left em -> ValidationError em
65+ Right () -> Valid jsonRepr
66+
67+parseAndValidateJsonBy
68+ :: (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
69+ => proxy schema
70+ -> J.Value
71+ -> ParseResult (JsonRepr schema)
72+parseAndValidateJsonBy _ = parseAndValidateJson
73+
4274parseAndValidateTopVersionJson
4375 :: forall proxy (v :: Versioned)
4476 . (SingI (TopVersion (AllVersions v)))
@@ -63,8 +95,7 @@ parseAndValidateWithMList
6395 -> J.Value
6496 -> m (ParseResult (JsonRepr (Head revisions)))
6597parseAndValidateWithMList MNil v = pure $ parseAndValidateJson v
66−parseAndValidateWithMList (Tagged f :&& tl) v =
67− case parseAndValidateJsonBy Proxy v of
98+parseAndValidateWithMList ((:&&) p f tl) v = case parseAndValidateJsonBy p v of
6899 Valid a -> pure $ Valid a
69100 DecodingError _ -> do
70101 pr <- parseAndValidateWithMList tl v
@@ -84,6 +115,10 @@ decodeAndValidateJson bs = case decode bs of
84115 Nothing -> DecodingError "malformed json"
85116 Just x -> parseAndValidateJson x
86117
118+type family MapSnd (l :: [(a,k)]) = (r :: [k]) where
119+ MapSnd '[] = '[]
120+ MapSnd ( '(a, b) ': tl) = b ': MapSnd tl
121+
87122decodeAndValidateVersionedWithMList
88123 :: Monad m
89124 => proxy versioned
@@ -96,8 +131,70 @@ decodeAndValidateVersionedWithMList _ mlist bs = case decode bs of
96131
97132decodeAndValidateVersionedWithPureMList
98133 :: proxy versioned
99− -> MList F.Identity (MapSnd (AllVersions versioned))
134+ -> MList Identity (MapSnd (AllVersions versioned))
100135 -> BL.ByteString
101136 -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))
102137decodeAndValidateVersionedWithPureMList a b c =
103138 runIdentity $ decodeAndValidateVersionedWithMList a b c
139+
140+-- convenience helpers
141+
142+type Constructor a
143+ = forall b. FSubset (FieldsOf a) b (FImage (FieldsOf a) b)
144+ => Tagged (FieldsOf a) (Rec FieldRepr b)
145+ -> JsonRepr ('SchemaObject (FieldsOf a))
146+
147+withRepr :: Constructor a
148+withRepr = ReprObject . unTagged . fmap fcast
149+
150+(<:&>)
151+ :: Applicative m
152+ => m (FieldRepr fns)
153+ -> m (Rec FieldRepr b)
154+ -> m (Rec FieldRepr (fns ': b))
155+(<:&>) = liftA2 (:&)
156+
157+infixr 7 <:&>
158+
159+class Representable s where
160+ type Repr s :: Type
161+ construct :: Sing fn -> Proxy s -> Repr s -> FieldRepr '(fn, s)
162+
163+instance SingI so => Representable ('SchemaObject so) where
164+ type Repr ('SchemaObject so) = Rec FieldRepr so
165+ construct sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprObject o
166+
167+instance (SingI cs, SingI sa) => Representable ('SchemaArray cs sa) where
168+ type Repr ('SchemaArray cs sa) = V.Vector (JsonRepr sa)
169+ construct sfn _ a = withKnownSymbol sfn $ FieldRepr $ ReprArray a
170+
171+instance SingI cs => Representable ('SchemaText cs) where
172+ type Repr ('SchemaText cs) = Text
173+ construct sfn _ t = withKnownSymbol sfn $ FieldRepr $ ReprText t
174+
175+instance SingI cs => Representable ('SchemaNumber cs) where
176+ type Repr ('SchemaNumber cs) = Scientific
177+ construct sfn _ n = withKnownSymbol sfn $ FieldRepr $ ReprNumber n
178+
179+instance Representable 'SchemaBoolean where
180+ type Repr 'SchemaBoolean = Bool
181+ construct sfn _ b = withKnownSymbol sfn $ FieldRepr $ ReprBoolean b
182+
183+instance SingI so => Representable ('SchemaOptional so) where
184+ type Repr ('SchemaOptional so) = Maybe (JsonRepr so)
185+ construct sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprOptional o
186+
187+instance SingI (h ': tl) => Representable ('SchemaUnion (h ': tl)) where
188+ type Repr ('SchemaUnion (h ': tl)) = Union JsonRepr (h ': tl)
189+ construct sfn _ u = withKnownSymbol sfn $ FieldRepr $ ReprUnion u
190+
191+type family FieldsOf (s :: Schema) :: [(Symbol, Schema)] where
192+ FieldsOf ('SchemaObject fs) = fs
193+
194+type FieldConstructor fn =
195+ forall fs. (Representable (ByField fn fs (FIndex fn fs)))
196+ => Repr (ByField fn fs (FIndex fn fs))
197+ -> Tagged fs (FieldRepr '(fn, (ByField fn fs (FIndex fn fs))))
198+
199+field :: forall fn. KnownSymbol fn => FieldConstructor fn
200+field = Tagged . construct (sing :: Sing fn) Proxy
src/Data/Schematic/DSL.hsdeleted−92
@@ -1,92 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
3−
4−module Data.Schematic.DSL where
5−
6−import Data.Kind
7−import Data.Schematic.Lens
8−import Data.Schematic.Schema
9−import Data.Scientific
10−import Data.Singletons
11−import Data.Singletons.Prelude hiding ((:.))
12−import Data.Singletons.TypeLits
13−import Data.Tagged
14−import Data.Text as T
15−import Data.Union
16−import qualified Data.Vector as V
17−import Data.Vinyl
18−import Data.Vinyl.Functor
19−
20−
21−#if MIN_VERSION_base(4,12,0)
22−type Constructor a
23− = forall fields b
24− . (fields ~ FieldsOf a, FSubset fields b (FImage fields b), RMap fields)
25− => Rec (Tagged fields :. FieldRepr) b
26− -> 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
34−withRepr :: Constructor a
35−withRepr = ReprObject . rmap (unTagged . getCompose) . fcast
36−
37−class Representable s where
38− constructField :: Sing fn -> Proxy s -> Repr s -> FieldRepr '(fn, s)
39−
40−instance SingI so => Representable ('SchemaObject so) where
41− constructField sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprObject o
42−
43−instance (SingI cs, SingI sa) => Representable ('SchemaArray cs sa) where
44− constructField sfn _ a = withKnownSymbol sfn $ FieldRepr $ ReprArray a
45−
46−instance SingI cs => Representable ('SchemaText cs) where
47− constructField sfn _ t = withKnownSymbol sfn $ FieldRepr $ ReprText t
48−
49−instance SingI cs => Representable ('SchemaNumber cs) where
50− constructField sfn _ n = withKnownSymbol sfn $ FieldRepr $ ReprNumber n
51−
52−instance Representable 'SchemaBoolean where
53− constructField sfn _ b = withKnownSymbol sfn $ FieldRepr $ ReprBoolean b
54−
55−instance SingI so => Representable ('SchemaOptional so) where
56− constructField sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprOptional o
57−
58−instance SingI (h ': tl) => Representable ('SchemaUnion (h ': tl)) where
59− constructField sfn _ u = withKnownSymbol sfn $ FieldRepr $ ReprUnion u
60−
61−construct :: Sing s -> Repr s -> JsonRepr s
62−construct s r = case s of
63− SSchemaObject _ -> ReprObject r
64− SSchemaArray _ _ -> ReprArray r
65− SSchemaText _ -> ReprText r
66− SSchemaNumber _ -> ReprNumber r
67− SSchemaBoolean -> ReprBoolean r
68− SSchemaOptional _ -> ReprOptional r
69− SSchemaNull -> ReprNull
70− SSchemaUnion ss -> case ss of
71− SNil -> error "unconstructable union"
72− SCons _ _ -> ReprUnion r
73−
74−type family FieldsOf (s :: Schema) :: [(Symbol, Schema)] where
75− FieldsOf ('SchemaObject fs) = fs
76−
77−type FieldConstructor fn =
78− forall byField fs. (byField ~ ByField fn fs (FIndex fn fs), Representable byField)
79− => Repr byField
80− -> (Tagged fs :. FieldRepr) '(fn, byField)
81−
82−field :: forall fn. KnownSymbol fn => FieldConstructor fn
83−field = Compose . Tagged . constructField (sing :: Sing fn) Proxy
84−
85−type family Repr (s :: Schema) = (ty :: Type) where
86− Repr ('SchemaObject so) = Rec FieldRepr so
87− Repr ('SchemaArray cs sa) = V.Vector (JsonRepr sa)
88− Repr ('SchemaText cs) = Text
89− Repr ('SchemaNumber cs) = Scientific
90− Repr 'SchemaBoolean = Bool
91− Repr ('SchemaOptional so) = Maybe (JsonRepr so)
92− Repr ('SchemaUnion (h ': tl)) = Union JsonRepr (h ': tl)
src/Data/Schematic/Generator.hsdeleted−91
@@ -1,91 +0,0 @@
1−module Data.Schematic.Generator where
2−
3−import Data.Maybe
4−import Data.Schematic.Generator.Regex
5−import {-# SOURCE #-} Data.Schematic.Schema
6−import Data.Schematic.Verifier
7−import Data.Scientific
8−import Data.Text (Text, pack)
9−import qualified Data.Vector as V
10−import Test.SmallCheck.Series
11−
12−maxHigh :: Int
13−maxHigh = 30
14−
15−minLow :: Int
16−minLow = 2
17−
18−textLengthSeries :: Monad m => [VerifiedTextConstraint] -> Series m Text
19−textLengthSeries =
20− \case
21− [VTEq eq] -> pure $ pack $ take (fromIntegral eq) $ cycle "sample"
22− [VTBounds ml mh] -> do
23− let
24− l = fromMaybe minLow (fromIntegral <$> ml) + 1
25− h = fromMaybe maxHigh (fromIntegral <$> mh) - 1
26− n <- generate $ \depth -> take depth [l .. h]
27− pure $ pack $ take (fromIntegral n) $ cycle "sample"
28− _ -> pure "error"
29−
30−textEnumSeries :: Monad m => [Text] -> Series m Text
31−textEnumSeries enum = generate $ \depth -> take depth enum
32−
33−textSeries :: Monad m => [DemotedTextConstraint] -> Series m Text
34−textSeries cs = do
35− let mvcs = verifyTextConstraints cs
36− case mvcs of
37− Just vcs -> do
38− n <- textSeries' vcs
39− pure n
40− Nothing -> pure "error"
41−
42−textSeries' :: Monad m => [VerifiedTextConstraint] -> Series m Text
43−textSeries' [] = pure "sample"
44−textSeries' vcs = do
45− let enums = listToMaybe [x | VTEnum x <- vcs]
46− case enums of
47− Just e -> textEnumSeries e
48− Nothing -> do
49− let regexps = listToMaybe [x | VTRegex x _ _ <- vcs]
50− case regexps of
51− Just e -> regexSeries e
52− Nothing -> textLengthSeries vcs
53−
54−numberSeries :: Monad m => [DemotedNumberConstraint] -> Series m Scientific
55−numberSeries cs = do
56− let mvcs = verifyNumberConstraints cs
57− case mvcs of
58− Just vcs -> do
59− n <- numberSeries' vcs
60− pure $ n
61− Nothing -> pure 0
62−
63−numberSeries' :: Monad m => VerifiedNumberConstraint -> Series m Scientific
64−numberSeries' =
65− \case
66− VNEq eq -> pure $ fromIntegral eq
67− VNBounds ml mh -> do
68− let l = fromMaybe minLow (fromIntegral <$> ml) + 1
69− h = fromMaybe maxHigh (fromIntegral <$> mh) - 1
70− n <- generate $ \depth -> take depth [l .. h]
71− pure $ fromIntegral n
72−
73−arraySeries
74− :: (Monad m, Serial m (JsonRepr s))
75− => [DemotedArrayConstraint]
76− -> Series m (V.Vector (JsonRepr s))
77−arraySeries cs = do
78− let mvcs = verifyArrayConstraint cs
79− case mvcs of
80− Just vcs -> arraySeries' vcs
81− Nothing -> pure V.empty
82−
83−arraySeries'
84− :: forall m s. (Monad m, Serial m (JsonRepr s))
85− => Maybe VerifiedArrayConstraint
86− -> Series m (V.Vector (JsonRepr s))
87−arraySeries' ml = do
88− objs <- V.replicateM (maybe minRepeat f ml) (series :: Series m (JsonRepr s))
89− pure $ objs
90− where
91− f (VAEq l) = fromIntegral l
src/Data/Schematic/Generator/Regex.hsdeleted−76
@@ -1,76 +0,0 @@
1−module Data.Schematic.Generator.Regex where
2−
3−import Control.Monad
4−import Data.List
5−import Data.Maybe
6−import 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)
13−
14−
15−minRepeat :: Int
16−minRepeat = 2
17−
18−maxRepeat :: Int
19−maxRepeat = 10
20−
21−regexSeries :: (Monad m) => Text -> Series m Text
22−regexSeries regexp =
23− case parseRegex . unpack $ regexp of
24− Right (p, _) -> toStrict . toLazyText <$> regexSeries' p
25− Left _ -> pure ""
26−
27−regexSeries' :: (Monad m) => Pattern -> Series m Builder
28−regexSeries' pt =
29− case pt of
30− PEmpty -> pure mempty
31− PChar {..} -> pure $ singleton getPatternChar
32− PAny {getPatternSet = PatternSet (Just cset) _ _ _} -> do
33− x <- generate $ \depth -> take depth $ S.toList cset
34− pure $ singleton x
35− PAnyNot {getPatternSet = PatternSet (Just cset) _ _ _} -> do
36− x <-
37− generate $ \depth ->
38− take depth $ notChars $ concatMap expandEscape $ S.toList cset
39− pure $ singleton x
40− PQuest p -> regexSeries' p \/ pure mempty
41− PPlus p -> regexSeries' $ PBound 1 Nothing p
42− PStar _ p -> regexSeries' $ PBound 0 Nothing p
43− PBound low mhigh p -> do
44− let high = fromMaybe (low + maxRepeat) mhigh
45− n <- generate $ \depth -> take depth [low .. high]
46− decDepth $ do
47− ps <- replicateM n $ regexSeries' p
48− pure $ mconcat ps
49− PConcat ps -> mconcat <$> mapM regexSeries' ps
50− POr xs -> regexSeries' =<< (generate $ \depth -> take depth xs)
51− PDot _ -> do
52− x <- generate $ \depth -> take depth $ notChars []
53− pure $ singleton x
54− PEscape {..} -> do
55− x <- generate $ \depth -> take depth $ expandEscape getPatternChar
56− pure $ singleton x
57− PCarat _ -> pure mempty
58− PDollar _ -> pure mempty
59− _ -> pure mempty
60− where
61− notChars = ([' ' .. '~'] \\)
62− expandEscape ch =
63− case ch of
64− 'n' -> "\n"
65− 't' -> "\t"
66− 'r' -> "\r"
67− 'f' -> "\f"
68− 'a' -> "\a"
69− 'e' -> "\ESC"
70− 'd' -> ['0' .. '9']
71− 'w' -> ['0' .. '9'] ++ '_' : ['a' .. 'z'] ++ ['A' .. 'Z']
72− 's' -> "\9\32"
73− 'D' -> notChars $ ['0' .. '9']
74− 'W' -> notChars $ ['0' .. '9'] ++ '_' : ['a' .. 'z'] ++ ['A' .. 'Z']
75− 'S' -> notChars "\9\32"
76− ch' -> [ch']
src/Data/Schematic/Instances.hs−4
@@ -4,7 +4,6 @@
44module Data.Schematic.Instances where
55
66import Data.Scientific
7−import Data.Text (Text, pack)
87import Data.Vector as V
98import Data.Vinyl
109import Test.SmallCheck.Series
@@ -22,6 +21,3 @@ instance Serial m a => Serial m (V.Vector a) where
2221
2322instance Monad m => Serial m Scientific where
2423 series = scientific <$> series <*> series
25−
26−instance Monad m => Serial m Text where
27− series = pack <$> series
src/Data/Schematic/JsonSchema.hs+10−29
@@ -12,10 +12,8 @@ import Control.Monad.State.Strict
1212import Data.Aeson as J
1313import Data.Foldable as F
1414import Data.HashMap.Strict as H
15−import Data.List as L
1615import Data.List.NonEmpty as NE
1716import Data.Schematic.Schema as S
18−import Data.Set as Set
1917import Data.Singletons
2018import Data.Text
2119import Data.Traversable
@@ -30,13 +28,13 @@ textConstraint :: DemotedTextConstraint -> State D4.Schema ()
3028textConstraint (DTEq n) = modify $ \s -> s
3129 { _schemaMinLength = pure $ fromIntegral n
3230 , _schemaMaxLength = pure $ fromIntegral n }
31+textConstraint (DTLt n) = modify $ \s -> s
32+ { _schemaMaxLength = pure . fromIntegral $ n + 1 }
3333textConstraint (DTLe n) = modify $ \s -> s
3434 { _schemaMaxLength = pure . fromIntegral $ n }
35−textConstraint (DTLt n) =
35+textConstraint (DTGt n) =
3636 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 }
37+ in modify $ \s -> s { _schemaMinLength = pure . fromIntegral $ n' }
4038textConstraint (DTGe n) = modify $ \s -> s
4139 { _schemaMinLength = pure . fromIntegral $ n }
4240textConstraint (DTRegex r) = modify $ \s -> s { _schemaPattern = pure r }
@@ -48,30 +46,18 @@ numberConstraint :: DemotedNumberConstraint -> State D4.Schema ()
4846numberConstraint (DNLe n) = modify $ \s -> s
4947 { _schemaMaximum = pure . fromIntegral $ n }
5048numberConstraint (DNLt n) = modify $ \s -> s
51− { _schemaMaximum = pure . fromIntegral $ n
52− , _schemaExclusiveMaximum = pure True }
49+ { _schemaMaximum = pure . fromIntegral $ n + 1 }
5350numberConstraint (DNGt n) = modify $ \s -> s
54− { _schemaMinimum = pure . fromIntegral $ n
55− , _schemaExclusiveMinimum = pure True }
56−numberConstraint (DNGe n) = modify $ \s -> s
5751 { _schemaMinimum = pure . fromIntegral $ n }
52+numberConstraint (DNGe n) =
53+ let n' = if n == 0 then 0 else n - 1
54+ in modify $ \s -> s { _schemaMinimum = pure . fromIntegral $ n' }
5855numberConstraint (DNEq n) = modify $ \s -> s
5956 { _schemaMinimum = pure $ fromIntegral n
6057 , _schemaMaximum = pure $ fromIntegral n }
6158
6259arrayConstraint :: 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 }
60+arrayConstraint (DAEq _) = pure ()
7561
7662toJsonSchema
7763 :: forall proxy schema
@@ -98,19 +84,14 @@ toJsonSchema' = \case
9884 res <- for objs $ \(n,s) -> do
9985 s' <- toJsonSchema' s
10086 pure (n, s')
101− let
102− nonOpt = \case
103− (_, DSchemaOptional _) -> False
104− _ -> True
10587 pure $ emptySchema
10688 { _schemaType = pure $ TypeValidatorString D4.SchemaObject
107− , _schemaRequired = pure $ Set.fromList $ fst <$> L.filter nonOpt objs
10889 , _schemaProperties = pure $ H.fromList res }
10990 DSchemaArray acs sch -> do
11091 res <- toJsonSchema' sch
11192 pure $ execState (traverse_ arrayConstraint acs) $ emptySchema
11293 { _schemaType = pure $ TypeValidatorString D4.SchemaArray
113− , _schemaItems = pure $ ItemsObject res }
94+ , _schemaItems = pure $ ItemsArray [res] }
11495 DSchemaNull -> pure $ emptySchema
11596 { _schemaType = pure $ TypeValidatorString D4.SchemaNull }
11697 DSchemaOptional sch -> do
src/Data/Schematic/Lens.hs+37−61
@@ -9,12 +9,6 @@ module Data.Schematic.Lens
99 , FImage
1010 , FSubset(..)
1111 , obj
12− , arr
13− , uni
14− , txt
15− , num
16− , opt
17− , bln
1812 , textRepr
1913 , numberRepr
2014 , boolRepr
@@ -24,11 +18,11 @@ module Data.Schematic.Lens
2418 ) where
2519
2620import Data.Profunctor
21+import Data.Proxy
2722import Data.Schematic.Schema
2823import Data.Scientific
2924import Data.Singletons
3025import Data.Text
31−import Data.Union
3226import Data.Vector as V
3327import Data.Vinyl
3428import Data.Vinyl.Functor
@@ -41,51 +35,51 @@ type family FIndex (r :: Symbol) (rs :: [(Symbol, Schema)]) :: Nat where
4135 FIndex r ( '(r, s) ': rs) = 'Z
4236 FIndex r ( s ': rs) = 'S (FIndex r rs)
4337
44−type Flens fn f g rs i
45− = Functor g
46− => (f '(fn, (ByField fn rs i)) -> g (f '(fn, (ByField fn rs i))))
47− -> Rec f rs
48− -> g (Rec f rs)
49−
50−type FGetter fn f rs i = Rec f rs -> f '(fn, (ByField fn rs i))
51−
5238class i ~ FIndex fn rs => FElem (fn :: Symbol) (rs :: [(Symbol, Schema)]) (i :: Nat) where
5339 type ByField fn rs i :: Schema
54− flens :: Flens fn f g rs i
40+ flens
41+ :: Functor g
42+ => proxy fn
43+ -> (FieldRepr '(fn, (ByField fn rs i)) -> g (FieldRepr '(fn, (ByField fn rs i))))
44+ -> Rec FieldRepr rs
45+ -> g (Rec FieldRepr rs)
5546
5647 -- | For Vinyl users who are not using the @lens@ package, we provide a getter.
57− fget :: FGetter fn f rs i
48+ fget
49+ :: proxy fn
50+ -> Rec FieldRepr rs
51+ -> FieldRepr '(fn, (ByField fn rs i))
5852
5953 -- | For Vinyl users who are not using the @lens@ package, we also provide a
6054 -- setter. In general, it will be unambiguous what field is being written to,
6155 -- and so we do not take a proxy argument here.
6256 fput
63− :: f '(fn, ByField fn rs i)
64− -> Rec f rs
65− -> Rec f rs
57+ :: FieldRepr '(fn, ByField fn rs i)
58+ -> Rec FieldRepr rs
59+ -> Rec FieldRepr rs
6660
6761instance FElem fn ('(fn, r) ': rs) 'Z where
6862 type ByField fn ('(fn, r) ': rs) 'Z = r
6963
70− flens f (x :& xs) = fmap (:& xs) (f x)
64+ flens _ f (x :& xs) = fmap (:& xs) (f x)
7165 {-# INLINE flens #-}
7266
73− fget = getConst . flens Const
67+ fget k = getConst . flens k Const
7468 {-# INLINE fget #-}
7569
76− fput y = getIdentity . flens (\_ -> Identity y)
70+ fput y = getIdentity . flens Proxy (\_ -> Identity y)
7771 {-# INLINE fput #-}
7872
7973instance (FIndex r (s ': rs) ~ 'S i, FElem r rs i) => FElem r (s ': rs) ('S i) where
8074 type ByField r (s ': rs) ('S i) = ByField r rs i
8175
82− flens f (x :& xs) = fmap (x :&) (flens f xs)
76+ flens p f (x :& xs) = fmap (x :&) (flens p f xs)
8377 {-# INLINE flens #-}
8478
85− fget = getConst . flens Const
79+ fget k = getConst . flens k Const
8680 {-# INLINE fget #-}
8781
88− fput y = getIdentity . flens (\_ -> Identity y)
82+ fput y = getIdentity . flens Proxy (\_ -> Identity y)
8983 {-# INLINE fput #-}
9084
9185-- This is an internal convenience helpers stolen from the @lens@ library.
@@ -121,24 +115,24 @@ class is ~ FImage rs ss
121115 -- > fsubset :: Lens' (Rec FieldRepr ss) (Rec FieldRepr rs)
122116 fsubset
123117 :: Functor g
124− => (Rec f rs -> g (Rec f rs))
125− -> Rec f ss
126− -> g (Rec f ss)
118+ => (Rec FieldRepr rs -> g (Rec FieldRepr rs))
119+ -> Rec FieldRepr ss
120+ -> g (Rec FieldRepr ss)
127121
128122 -- | The getter of the 'fsubset' lens is 'fcast', which takes a larger record
129123 -- to a smaller one by forgetting fields.
130124 fcast
131− :: Rec f ss
132− -> Rec f rs
125+ :: Rec FieldRepr ss
126+ -> Rec FieldRepr rs
133127 fcast = getConst . fsubset Const
134128 {-# INLINE fcast #-}
135129
136130 -- | The setter of the 'fsubset' lens is 'freplace', which allows a slice of
137131 -- a record to be replaced with different values.
138132 freplace
139− :: Rec f rs
140− -> Rec f ss
141− -> Rec f ss
133+ :: Rec FieldRepr rs
134+ -> Rec FieldRepr ss
135+ -> Rec FieldRepr ss
142136 freplace rs = getIdentity . fsubset (\_ -> Identity rs)
143137 {-# INLINE freplace #-}
144138
@@ -149,59 +143,41 @@ instance
149143 ( ByField fn ss i ~ s
150144 , FElem fn ss i
151145 , FSubset rs ss is) => FSubset ( '(fn,s) ': rs) ss (i ': is) where
152− fsubset = lens (\ss -> fget @fn ss :& fcast ss) set
146+ fsubset = lens (\ss -> fget Proxy ss :& fcast ss) set
153147 where
154− set :: Rec f ss -> Rec f ( '(fn,s) ': rs) -> Rec f ss
148+ set :: Rec FieldRepr ss -> Rec FieldRepr ( '(fn,s) ': rs) -> Rec FieldRepr ss
155149 set ss (r :& rs) = fput r $ freplace rs ss
156150
157151-- A bunch of @Iso@morphisms
158152textRepr
159− :: (KnownSymbol fn, SingI cs)
153+ :: (KnownSymbol fn, SingI fn, SingI cs)
160154 => Iso' (FieldRepr '(fn, ('SchemaText cs))) Text
161155textRepr = iso (\(FieldRepr (ReprText t)) -> t) (FieldRepr . ReprText)
162156
163157numberRepr
164− :: (KnownSymbol fn, SingI cs)
158+ :: (KnownSymbol fn, SingI fn, SingI cs)
165159 => Iso' (FieldRepr '(fn, ('SchemaNumber cs))) Scientific
166160numberRepr = iso (\(FieldRepr (ReprNumber n)) -> n) (FieldRepr . ReprNumber)
167161
168162boolRepr
169− :: (KnownSymbol fn)
163+ :: (KnownSymbol fn, SingI fn, SingI cs)
170164 => Iso' (FieldRepr '(fn, 'SchemaBoolean)) Bool
171165boolRepr = iso (\(FieldRepr (ReprBoolean b)) -> b) (FieldRepr . ReprBoolean)
172166
173167arrayRepr
174− :: (KnownSymbol fn, SingI cs, SingI schema)
168+ :: (KnownSymbol fn, SingI fn, SingI cs, SingI schema)
175169 => Iso' (FieldRepr '(fn, ('SchemaArray cs schema))) (V.Vector (JsonRepr schema))
176170arrayRepr = iso (\(FieldRepr (ReprArray a)) -> a) (FieldRepr . ReprArray)
177171
178172objectRepr
179− :: (KnownSymbol fn, SingI fields)
173+ :: (KnownSymbol fn, SingI fn, SingI fields)
180174 => Iso' (FieldRepr '(fn, ('SchemaObject fields))) (Rec FieldRepr fields)
181175objectRepr = iso (\(FieldRepr (ReprObject o)) -> o) (FieldRepr . ReprObject)
182176
183177optionalRepr
184− :: (KnownSymbol fn, SingI schema)
178+ :: (KnownSymbol fn, SingI fn, SingI schema)
185179 => Iso' (FieldRepr '(fn, ('SchemaOptional schema))) (Maybe (JsonRepr schema))
186180optionalRepr = iso (\(FieldRepr (ReprOptional r)) -> r) (FieldRepr . ReprOptional)
187181
188−obj :: Iso' (JsonRepr ('SchemaObject fields)) (Rec FieldRepr fields)
182+obj :: (SingI fields) => Iso' (JsonRepr ('SchemaObject fields)) (Rec FieldRepr fields)
189183obj = iso (\(ReprObject r) -> r) ReprObject
190−
191−arr :: Iso' (JsonRepr ('SchemaArray cs schema)) (V.Vector (JsonRepr schema))
192−arr = iso (\(ReprArray r) -> r) ReprArray
193−
194−uni :: Iso' (JsonRepr ('SchemaUnion (h ': tl))) (Union JsonRepr (h ': tl))
195−uni = iso (\(ReprUnion u) -> u) ReprUnion
196−
197−txt :: Iso' (JsonRepr ('SchemaText cs)) Text
198−txt = iso (\(ReprText t) -> t) ReprText
199−
200−num :: Iso' (JsonRepr ('SchemaNumber cs)) Scientific
201−num = iso (\(ReprNumber t) -> t) ReprNumber
202−
203−bln :: Iso' (JsonRepr 'SchemaBoolean) Bool
204−bln = iso (\(ReprBoolean b) -> b) ReprBoolean
205−
206−opt :: Iso' (JsonRepr ('SchemaOptional schema)) (Maybe (JsonRepr schema))
207−opt = iso (\(ReprOptional o) -> o) ReprOptional
src/Data/Schematic/Migration.hs+8−45
@@ -1,19 +1,13 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE TemplateHaskell #-}
43
54module Data.Schematic.Migration where
65
76import Data.Kind
8−import Data.Schematic.DSL
9−import Data.Schematic.Lens
107import Data.Schematic.Path
118import Data.Schematic.Schema
12−import Data.Singletons.Prelude hiding ((:.), All)
9+import Data.Singletons.Prelude hiding (All)
1310import Data.Singletons.TypeLits
14−import Data.Tagged
15−import Data.Vinyl
16−import Data.Vinyl.Functor
1711
1812
1913data Path
@@ -43,8 +37,8 @@ type family SchemaByKey (fs :: [(Symbol, Schema)]) (s :: Symbol) :: Schema where
4337 SchemaByKey ( '(a, s) ': tl) fn = SchemaByKey tl fn
4438
4539type family DeleteKey (acc :: [(Symbol, Schema)]) (fn :: Symbol) (fs :: [(Symbol, Schema)]) :: [(Symbol, Schema)] where
46− DeleteKey acc fn ('(fn, a) ': tl) = acc ++ tl
47− DeleteKey acc fn (fna ': tl) = acc ++ (fna ': tl)
40+ DeleteKey acc fn ('(fn, a) ': tl) = acc :++ tl
41+ DeleteKey acc fn (fna ': tl) = acc :++ (fna ': tl)
4842
4943type family UpdateKey
5044 (fn :: Symbol)
@@ -97,8 +91,7 @@ type family ElemOf (e :: k) (l :: [(a,k)]) :: Constraint where
9791type family AllVersions (vd :: Versioned) :: [(Revision, Schema)] where
9892 AllVersions ('Versioned s ms) = Reverse (AllVersions' '[ '("initial", s) ] ms)
9993
100−type family AllVersions' (acc :: [(Revision, Schema)]) (ms :: [Migration])
101− = (r :: [(Revision, Schema)]) where
94+type family AllVersions' (acc :: [(Revision, Schema)]) (ms :: [Migration]) = (r :: [(Revision, Schema)]) where
10295 AllVersions' acc '[] = acc
10396 AllVersions' ( '(rh, sh) ': tl ) (m ': ms) =
10497 AllVersions' ( '(rh, sh) ': ApplyMigration m sh ': tl ) ms
@@ -145,43 +138,13 @@ data instance Sing (v :: Versioned) where
145138 -> Sing (ms :: [Migration]) -- a bunch of migrations
146139 -> Sing ('Versioned s ms)
147140
148−type DataMigration s m h = Tagged s (JsonRepr h -> m (JsonRepr s))
149−
150−data MList :: (Type -> Type) -> [Schema] -> Type where
141+data MList :: (* -> *) -> [Schema] -> Type where
151142 MNil :: (Monad m, SingI s, TopLevel s) => MList m '[s]
152143 (:&&)
153144 :: (TopLevel s, SingI s)
154− => DataMigration s m h
145+ => proxy s
146+ -> (JsonRepr h -> m (JsonRepr s))
155147 -> MList m (h ': tl)
156148 -> MList m (s ': h ': tl)
157149
158150infixr 7 :&&
159−
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
166−migrateObject
167− :: forall m fs fh. (FSubset fs fs (FImage fs fs), Monad m)
168− => (Rec (Tagged fs :. FieldRepr) fh -> m (Rec (Tagged fs :. FieldRepr) fs))
169− -> Tagged ('SchemaObject fs) (JsonRepr ('SchemaObject fh) -> m (JsonRepr ('SchemaObject fs)))
170−#endif
171−migrateObject f = Tagged $ \(ReprObject r) -> do
172− res <- f $ rmap (Compose . Tagged) r
173− pure $ withRepr @('SchemaObject fs) res
174−
175−shrinkObject
176− :: forall rs ss m
177− . ( Monad m, FSubset rs ss (FImage rs ss) )
178− => Tagged
179− ('SchemaObject rs)
180− (JsonRepr ('SchemaObject ss) -> m (JsonRepr ('SchemaObject rs)))
181−shrinkObject = Tagged $ \(ReprObject r) -> pure $ ReprObject $ fcast r
182−
183−type family MapSnd (l :: [(a,k)]) = (r :: [k]) where
184− MapSnd '[] = '[]
185− MapSnd ( '(a, b) ': tl) = b ': MapSnd tl
186−
187−type MigrationList m vs = MList m (MapSnd (AllVersions vs))
src/Data/Schematic/Path.hs+32−18
@@ -1,36 +1,50 @@
11module Data.Schematic.Path where
22
33import Data.Foldable as F
4+import Data.Monoid
5+import Data.Schematic.Utils
6+import Data.Singletons
47import Data.Singletons.Prelude
58import Data.Singletons.TypeLits
69import Data.Text as T
7−import Data.Aeson.Internal
810
911
10−newtype JSONPathText = JSONPathText Text
11− deriving (Show)
12−
13−data PathSegment = PathKey Symbol | PathIx Nat
12+data PathSegment = Key Symbol | Ix Nat
1413
1514data 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)
15+ SKey :: (KnownSymbol k, Known (Sing k)) => Sing (k :: Symbol) -> Sing ('Key k)
16+ SIx :: (KnownNat n, Known (Sing n)) => Sing (n :: Nat) -> Sing ('Ix n)
17+
18+instance (KnownSymbol k, Known (Sing k))
19+ => Known (Sing ('Key k)) where
20+ known = SKey known
21+
22+instance (KnownNat n, Known (Sing n))
23+ => Known (Sing ('Ix n)) where
24+ known = SIx known
25+
26+data DemotedPathSegment = DKey Text | DIx Integer
27+ deriving (Show)
28+
29+-- | Textual representation of json path.
30+newtype JSONPath = JSONPath Text
31+ deriving (Show)
1832
19−demotePath :: Sing (ps :: [PathSegment]) -> JSONPath
33+demotePath :: Sing (ps :: [PathSegment]) -> [DemotedPathSegment]
2034demotePath = go []
2135 where
22− go :: JSONPath -> Sing (ps :: [PathSegment]) -> JSONPath
36+ go :: [DemotedPathSegment] -> Sing (ps :: [PathSegment]) -> [DemotedPathSegment]
2337 go acc SNil = acc
24− 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
38+ go acc (SCons p ps) = go (acc ++ [demote p]) ps
39+ demote :: Sing (ps :: PathSegment) -> DemotedPathSegment
40+ demote (SKey s) = DKey $ T.pack $ symbolVal s
41+ demote (SIx n) = DIx $ natVal n
2842
29−demotedPathToText :: JSONPath -> JSONPathText
30−demotedPathToText = JSONPathText . F.foldl' renderPathSegment ""
43+demotedPathToText :: [DemotedPathSegment] -> JSONPath
44+demotedPathToText = JSONPath . F.foldl' renderPathSegment ""
3145 where
32− renderPathSegment acc (Key t) = acc <> "." <> t
33− renderPathSegment acc (Index n) = acc <> "[" <> T.pack (show n) <> "]"
46+ renderPathSegment acc (DKey t) = acc <> "." <> t
47+ renderPathSegment acc (DIx n) = acc <> "[" <> T.pack (show n) <> "]"
3448
35−pathToText :: Sing (ps :: [PathSegment]) -> JSONPathText
49+pathToText :: Sing (ps :: [PathSegment]) -> JSONPath
3650pathToText = demotedPathToText . demotePath
src/Data/Schematic/Schema.hs+73−165
@@ -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)
@@ -24,10 +22,8 @@ import Data.Union
2422import Data.Vector as V
2523import Data.Vinyl hiding (Dict)
2624import qualified Data.Vinyl.TypeLevel as V
27−import GHC.Exts
2825import GHC.Generics (Generic)
29−import GHC.TypeLits
30− (SomeNat(..), SomeSymbol(..), someNatVal, someSymbolVal)
26+import GHC.TypeLits (SomeNat(..), SomeSymbol(..), someSymbolVal, someNatVal)
3127import Prelude as P
3228import Test.SmallCheck.Series
3329
@@ -51,33 +47,33 @@ data TextConstraint
5147instance SingKind TextConstraint where
5248 type Demote TextConstraint = DemotedTextConstraint
5349 fromSing = \case
54− STEq n -> withKnownNat n (DTEq . fromIntegral $ natVal n)
55− STLt n -> withKnownNat n (DTLt . fromIntegral $ natVal n)
56− STLe n -> withKnownNat n (DTLe . fromIntegral $ natVal n)
57− STGt n -> withKnownNat n (DTGt . fromIntegral $ natVal n)
58− STGe n -> withKnownNat n (DTGe . fromIntegral $ natVal n)
50+ STEq n -> withKnownNat n (DTEq $ natVal n)
51+ STLt n -> withKnownNat n (DTLt $ natVal n)
52+ STLe n -> withKnownNat n (DTLe $ natVal n)
53+ STGt n -> withKnownNat n (DTGt $ natVal n)
54+ STGe n -> withKnownNat n (DTGe $ natVal n)
5955 STRegex s -> withKnownSymbol s (DTRegex $ T.pack $ symbolVal s)
6056 STEnum s -> let
6157 d :: Sing (s :: [Symbol]) -> [Text]
62− d SNil = []
58+ d SNil = []
6359 d (SCons ss@SSym fs) = T.pack (symbolVal ss) : d fs
6460 in DTEnum $ d s
6561 toSing = \case
6662 DTEq n -> case someNatVal n of
6763 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STEq (SNat :: Sing n))
68− Nothing -> error "Negative singleton nat"
64+ Nothing -> error "Negative singleton nat"
6965 DTLt n -> case someNatVal n of
7066 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLt (SNat :: Sing n))
71− Nothing -> error "Negative singleton nat"
67+ Nothing -> error "Negative singleton nat"
7268 DTLe n -> case someNatVal n of
7369 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLe (SNat :: Sing n))
74− Nothing -> error "Negative singleton nat"
70+ Nothing -> error "Negative singleton nat"
7571 DTGt n -> case someNatVal n of
7672 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGt (SNat :: Sing n))
77− Nothing -> error "Negative singleton nat"
73+ Nothing -> error "Negative singleton nat"
7874 DTGe n -> case someNatVal n of
7975 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGe (SNat :: Sing n))
80− Nothing -> error "Negative singleton nat"
76+ Nothing -> error "Negative singleton nat"
8177 DTRegex s -> case someSymbolVal (T.unpack s) of
8278 SomeSymbol (_ :: Proxy n) -> SomeSing (STRegex (SSym :: Sing n))
8379 DTEnum ss -> case toSing ss of
@@ -91,7 +87,7 @@ data DemotedTextConstraint
9187 | DTGe Integer
9288 | DTRegex Text
9389 | DTEnum [Text]
94− deriving (Generic, Eq, Show)
90+ deriving (Generic)
9591
9692data instance Sing (tc :: TextConstraint) where
9793 STEq :: Sing n -> Sing ('TEq n)
@@ -132,7 +128,7 @@ data DemotedNumberConstraint
132128 | DNGt Integer
133129 | DNGe Integer
134130 | DNEq Integer
135− deriving (Generic, Eq, Show)
131+ deriving (Generic)
136132
137133data instance Sing (nc :: NumberConstraint) where
138134 SNEq :: Sing n -> Sing ('NEq n)
@@ -156,87 +152,51 @@ instance Eq (Sing ('NGe n)) where _ == _ = True
156152instance SingKind NumberConstraint where
157153 type Demote NumberConstraint = DemotedNumberConstraint
158154 fromSing = \case
159− SNEq n -> withKnownNat n (DNEq . fromIntegral $ natVal n)
160− SNGt n -> withKnownNat n (DNGt . fromIntegral $ natVal n)
161− SNGe n -> withKnownNat n (DNGe . fromIntegral $ natVal n)
162− SNLt n -> withKnownNat n (DNLt . fromIntegral $ natVal n)
163− SNLe n -> withKnownNat n (DNLe . fromIntegral $ natVal n)
155+ SNEq n -> withKnownNat n (DNEq $ natVal n)
156+ SNGt n -> withKnownNat n (DNGt $ natVal n)
157+ SNGe n -> withKnownNat n (DNGe $ natVal n)
158+ SNLt n -> withKnownNat n (DNLt $ natVal n)
159+ SNLe n -> withKnownNat n (DNLe $ natVal n)
164160 toSing = \case
165161 DNEq n -> case someNatVal n of
166162 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNEq (SNat :: Sing n))
167− Nothing -> error "Negative singleton nat"
163+ Nothing -> error "Negative singleton nat"
168164 DNGt n -> case someNatVal n of
169165 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGt (SNat :: Sing n))
170− Nothing -> error "Negative singleton nat"
166+ Nothing -> error "Negative singleton nat"
171167 DNGe n -> case someNatVal n of
172168 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGe (SNat :: Sing n))
173− Nothing -> error "Negative singleton nat"
169+ Nothing -> error "Negative singleton nat"
174170 DNLt n -> case someNatVal n of
175171 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLt (SNat :: Sing n))
176− Nothing -> error "Negative singleton nat"
172+ Nothing -> error "Negative singleton nat"
177173 DNLe n -> case someNatVal n of
178174 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLe (SNat :: Sing n))
179− Nothing -> error "Negative singleton nat"
175+ Nothing -> error "Negative singleton nat"
180176
181177data ArrayConstraint
182178 = AEq Nat
183− | AGt Nat
184− | AGe Nat
185− | ALt Nat
186− | ALe Nat
187179 deriving (Generic)
188180
189181data DemotedArrayConstraint
190182 = DAEq Integer
191− | DAGt Integer
192− | DAGe Integer
193− | DALt Integer
194− | DALe Integer
195− deriving (Generic, Eq, Show)
183+ deriving (Generic)
196184
197185data instance Sing (ac :: ArrayConstraint) where
198186 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)
203187
204188instance 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
209189
210190instance 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
215191
216192instance SingKind ArrayConstraint where
217193 type Demote ArrayConstraint = DemotedArrayConstraint
218194 fromSing = \case
219− 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)
195+ SAEq n -> withKnownNat n (DAEq $ natVal n)
224196 toSing = \case
225197 DAEq n -> case someNatVal n of
226198 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"
199+ Nothing -> error "Negative singleton nat"
240200
241201data Schema
242202 = SchemaText [TextConstraint]
@@ -258,7 +218,7 @@ data DemotedSchema
258218 | DSchemaNull
259219 | DSchemaOptional DemotedSchema
260220 | DSchemaUnion [DemotedSchema]
261− deriving (Generic, Eq, Show)
221+ deriving (Generic)
262222
263223data instance Sing (schema :: Schema) where
264224 SSchemaText :: Sing tcs -> Sing ('SchemaText tcs)
@@ -371,65 +331,61 @@ data JsonRepr :: Schema -> Type where
371331 ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)
372332 ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)
373333 ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)
374− ReprUnion :: Union JsonRepr (h ': tl) -> JsonRepr ('SchemaUnion (h ': tl))
375−
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
334+ ReprUnion
335+ -- :: USubsets (h ': tl)
336+ :: Union JsonRepr (h ': tl)
337+ -> JsonRepr ('SchemaUnion (h ': tl))
387338
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
339+-- | Move to the union package
340+type family UnionAll (f :: u -> *) (rs :: [u]) (c :: * -> Constraint) :: Constraint where
341+ UnionAll f '[] c = ()
342+ UnionAll f (r ': rs) c = (c (f r), UnionAll f rs c)
396343
397−instance (Monad m, Serial m (Rec FieldRepr fs))
398− => Serial m (JsonRepr ('SchemaObject fs)) where
399− series = cons1 ReprObject
344+-- instance (UnionAll f as Show) => Show (Union f as) where
345+-- show (This fa) = "This " P.++ show fa
346+-- show (That u) = "That " P.++ show u
400347
401−-- | Move to the union package
402348instance Show (JsonRepr ('SchemaText cs)) where
403349 show (ReprText t) = "ReprText " P.++ show t
404350
405351instance Show (JsonRepr ('SchemaNumber cs)) where
406352 show (ReprNumber n) = "ReprNumber " P.++ show n
407353
408−instance Show (JsonRepr 'SchemaBoolean) where
409− show (ReprBoolean n) = "ReprBoolean " P.++ show n
410−
411354instance Show (JsonRepr 'SchemaNull) where show _ = "ReprNull"
412355
413356instance Show (JsonRepr s) => Show (JsonRepr ('SchemaArray acs s)) where
414357 show (ReprArray v) = "ReprArray " P.++ show v
415358
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
423359instance V.RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where
424360 show (ReprObject fs) = "ReprObject " P.++ show fs
425−#endif
426361
427362instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where
428363 show (ReprOptional s) = "ReprOptional " P.++ show s
429364
430−instance Show (Union JsonRepr (h ': tl))
431− => Show (JsonRepr ('SchemaUnion (h ': tl))) where
432− show (ReprUnion s) = "ReprUnion " P.++ show s
365+deriving instance UnionAll f as Show => Show (Union f as)
366+
367+instance (Monad m, Serial m Text)
368+ => Serial m (JsonRepr ('SchemaText cs)) where
369+ series = cons1 ReprText
370+
371+instance (Monad m, Serial m Scientific)
372+ => Serial m (JsonRepr ('SchemaNumber cs)) where
373+ series = cons1 ReprNumber
374+
375+instance Monad m => Serial m (JsonRepr 'SchemaNull) where
376+ series = cons0 ReprNull
377+
378+instance (Serial m (V.Vector (JsonRepr s)))
379+ => Serial m (JsonRepr ('SchemaArray cs s)) where
380+ series = cons1 ReprArray
381+
382+instance (Serial m (JsonRepr s))
383+ => Serial m (JsonRepr ('SchemaOptional s)) where
384+ series = cons1 ReprOptional
385+
386+instance (Monad m, Serial m (Rec FieldRepr fs))
387+ => Serial m (JsonRepr ('SchemaObject fs)) where
388+ series = cons1 ReprObject
433389
434390instance Eq (Rec FieldRepr fs) => Eq (JsonRepr ('SchemaObject fs)) where
435391 ReprObject a == ReprObject b = a == b
@@ -440,9 +396,6 @@ instance Eq (JsonRepr ('SchemaText cs)) where
440396instance Eq (JsonRepr ('SchemaNumber cs)) where
441397 ReprNumber a == ReprNumber b = a == b
442398
443−instance Eq (JsonRepr 'SchemaBoolean) where
444− ReprBoolean a == ReprBoolean b = a == b
445−
446399instance Eq (JsonRepr 'SchemaNull) where
447400 ReprNull == ReprNull = True
448401
@@ -452,51 +405,6 @@ instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaArray as s)) where
452405instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaOptional s)) where
453406 ReprOptional a == ReprOptional b = a == b
454407
455−instance Eq (Union JsonRepr (h ': tl))
456− => Eq (JsonRepr ('SchemaUnion (h ': tl))) where
457− ReprUnion a == ReprUnion b = a == b
458−
459−instance Ord (Rec FieldRepr fs) => Ord (JsonRepr ('SchemaObject fs)) where
460− ReprObject a `compare` ReprObject b = a `compare` b
461−
462−instance Ord (JsonRepr ('SchemaText cs)) where
463− ReprText a `compare` ReprText b = a `compare` b
464−
465−instance Ord (JsonRepr ('SchemaNumber cs)) where
466− ReprNumber a `compare` ReprNumber b = a `compare` b
467−
468−instance Ord (JsonRepr 'SchemaBoolean) where
469− ReprBoolean a `compare` ReprBoolean b = a `compare` b
470−
471−instance Ord (JsonRepr 'SchemaNull) where
472− compare _ _ = EQ
473−
474−instance Ord (JsonRepr s) => Ord (JsonRepr ('SchemaArray as s)) where
475− ReprArray a `compare` ReprArray b = a `compare` b
476−
477−instance Ord (JsonRepr s) => Ord (JsonRepr ('SchemaOptional s)) where
478− ReprOptional a `compare` ReprOptional b = a `compare` b
479−
480−instance Ord (Union JsonRepr (h ': tl))
481− => Ord (JsonRepr ('SchemaUnion (h ': tl))) where
482− ReprUnion a `compare` ReprUnion b = a `compare` b
483−
484−instance IsList (JsonRepr ('SchemaArray cs s)) where
485− type Item (JsonRepr ('SchemaArray cs s)) = JsonRepr s
486− fromList = ReprArray . GHC.Exts.fromList
487− toList (ReprArray v) = GHC.Exts.toList v
488−
489−instance Num (JsonRepr ('SchemaNumber cs)) where
490− ReprNumber a + ReprNumber b = ReprNumber $ a + b
491− ReprNumber a - ReprNumber b = ReprNumber $ a - b
492− ReprNumber a * ReprNumber b = ReprNumber $ a * b
493− abs (ReprNumber a) = ReprNumber $ abs a
494− signum (ReprNumber a) = ReprNumber $ signum a
495− fromInteger = ReprNumber . fromIntegral
496−
497−instance IsString (JsonRepr ('SchemaText cs)) where
498− fromString = ReprText . fromString
499−
500408fromOptional
501409 :: SingI s
502410 => Sing ('SchemaOptional s)
@@ -542,25 +450,25 @@ instance SingI schema => J.FromJSON (JsonRepr schema) where
542450 fieldRepr <- case s of
543451 SSchemaText so -> case H.lookup fieldName h of
544452 Just v -> withSingI so $ FieldRepr <$> parseJSON v
545− Nothing -> fail $ "No text field: " P.++ show fieldName
453+ Nothing -> fail "schematext"
546454 SSchemaNumber so -> case H.lookup fieldName h of
547455 Just v -> withSingI so $ FieldRepr <$> parseJSON v
548− Nothing -> fail $ "No number field: " P.++ show fieldName
456+ Nothing -> fail "schemanumber"
549457 SSchemaBoolean -> case H.lookup fieldName h of
550458 Just v -> FieldRepr <$> parseJSON v
551− Nothing -> fail $ "No boolean field: " P.++ show fieldName
459+ Nothing -> fail "schemaboolean"
552460 SSchemaNull -> case H.lookup fieldName h of
553461 Just v -> FieldRepr <$> parseJSON v
554− Nothing -> fail $ "No null field: " P.++ show fieldName
462+ Nothing -> fail "schemanull"
555463 SSchemaArray sa sb -> case H.lookup fieldName h of
556464 Just v -> withSingI sa $ withSingI sb $ FieldRepr <$> parseJSON v
557− Nothing -> fail $ "No array field: " P.++ show fieldName
465+ Nothing -> fail "schemaarray"
558466 SSchemaObject so -> case H.lookup fieldName h of
559467 Just v -> withSingI so $ FieldRepr <$> parseJSON v
560− Nothing -> fail $ "No object field" P.++ show fieldName
468+ Nothing -> fail "schemaobject"
561469 SSchemaOptional so -> case H.lookup fieldName h of
562470 Just v -> withSingI so $ FieldRepr <$> parseJSON v
563− Nothing -> withSingI so $ pure $ FieldRepr $ ReprOptional Nothing
471+ Nothing -> fail "schemaoptional"
564472 SSchemaUnion ss -> withSingI ss $ FieldRepr <$> parseUnion ss value
565473 (fieldRepr :&) <$> demoteFields tl h
566474 ReprObject <$> withObject "Object" (demoteFields fs) value
@@ -572,7 +480,7 @@ instance J.ToJSON (JsonRepr a) where
572480 toJSON (ReprText t) = J.String t
573481 toJSON (ReprNumber n) = J.Number n
574482 toJSON (ReprOptional s) = case s of
575− Just v -> toJSON v
483+ Just v -> toJSON v
576484 Nothing -> J.Null
577485 toJSON (ReprArray v) = J.Array $ toJSON <$> v
578486 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/Utils.hsnew file+42
@@ -0,0 +1,42 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+
3+module Data.Schematic.Utils where
4+
5+import Data.Proxy
6+import Data.Singletons
7+import Data.Singletons.Prelude
8+import Data.Singletons.TypeLits
9+import Data.Vinyl hiding (Dict)
10+
11+
12+class Known a where
13+ known :: a
14+
15+instance Known (Proxy a) where
16+ known = Proxy
17+
18+instance KnownNat n => Known (Sing n) where
19+ known = SNat
20+
21+instance KnownSymbol s => Known (Sing s) where
22+ known = SSym
23+
24+instance (Known (Sing a), Known (Sing b)) => Known (Sing '(a,b)) where
25+ known = STuple2 known known
26+
27+instance Known (Sing '[]) where known = SNil
28+
29+instance (Known (Sing a), Known (Sing as)) => Known (Sing (a ': as)) where
30+ known = SCons known known
31+
32+instance Known (Rec Sing '[]) where
33+ known = RNil
34+
35+instance (Known (Sing a), Known (Rec Sing tl)) => Known (Rec Sing (a ': tl)) where
36+ known = known :& known
37+
38+data Dict c where
39+ Dict :: c => Dict c
40+
41+instance c => Known (Dict c) where
42+ known = Dict
src/Data/Schematic/Validation.hs+31−88
@@ -2,14 +2,12 @@ module Data.Schematic.Validation where
22
33import Control.Monad
44import Control.Monad.Validation
5−import Data.Aeson
6−import Data.Aeson.Internal
7−import Data.Aeson.Types
85import Data.Foldable
96import Data.Functor.Identity
107import Data.Monoid
118import Data.Schematic.Path
129import Data.Schematic.Schema
10+import Data.Schematic.Utils ()
1311import Data.Scientific
1412import Data.Singletons.Prelude
1513import Data.Singletons.TypeLits
@@ -33,10 +31,6 @@ data ParseResult a
3331 | ValidationError ErrorMap -- runtime
3432 deriving (Show, Eq, Functor, Foldable, Traversable)
3533
36−instance (TopLevel a, SingI a, FromJSON (JsonRepr a))
37− => FromJSON (ParseResult (JsonRepr a)) where
38− parseJSON = pure . parseAndValidateJson @a
39−
4034isValid :: ParseResult a -> Bool
4135isValid (Valid _) = True
4236isValid _ = False
@@ -50,51 +44,51 @@ isValidationError (ValidationError _) = True
5044isValidationError _ = False
5145
5246validateTextConstraint
53− :: JSONPathText
47+ :: JSONPath
5448 -> Text
5549 -> Sing (tcs :: TextConstraint)
5650 -> Validation ()
57−validateTextConstraint (JSONPathText path) t = \case
51+validateTextConstraint (JSONPath path) t = \case
5852 STEq n -> do
5953 let
6054 nlen = withKnownNat n $ natVal n
6155 predicate = nlen == (fromIntegral $ T.length t)
62− errMsg = "length should be == " <> T.pack (show nlen)
56+ errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)
6357 warn = vWarning $ mmSingleton path (pure errMsg)
6458 unless predicate warn
6559 STLt n -> do
6660 let
6761 nlen = withKnownNat n $ natVal n
68− predicate = nlen > (fromIntegral $ T.length t)
69− errMsg = "length should be < " <> T.pack (show nlen)
62+ predicate = nlen < (fromIntegral $ T.length t)
63+ errMsg = "length of " <> path <> " should be < " <> T.pack (show nlen)
7064 warn = vWarning $ mmSingleton path (pure errMsg)
7165 unless predicate warn
7266 STLe n -> do
7367 let
7468 nlen = withKnownNat n $ natVal n
75− predicate = nlen >= (fromIntegral $ T.length t)
76− errMsg = "length should be <= " <> T.pack (show nlen)
69+ predicate = nlen <= (fromIntegral $ T.length t)
70+ errMsg = "length of " <> path <> " should be <= " <> T.pack (show nlen)
7771 warn = vWarning $ mmSingleton path (pure errMsg)
7872 unless predicate warn
7973 STGt n -> do
8074 let
8175 nlen = withKnownNat n $ natVal n
82− predicate = nlen < (fromIntegral $ T.length t)
83− errMsg = "length should be > " <> T.pack (show nlen)
76+ predicate = nlen > (fromIntegral $ T.length t)
77+ errMsg = "length of " <> path <> " should be > " <> T.pack (show nlen)
8478 warn = vWarning $ mmSingleton path (pure errMsg)
8579 unless predicate warn
8680 STGe n -> do
8781 let
8882 nlen = withKnownNat n $ natVal n
89− predicate = nlen <= (fromIntegral $ T.length t)
90− errMsg = "length should be >= " <> T.pack (show nlen)
83+ predicate = nlen >= (fromIntegral $ T.length t)
84+ errMsg = "length of " <> path <> " should be >= " <> T.pack (show nlen)
9185 warn = vWarning $ mmSingleton path (pure errMsg)
9286 unless predicate warn
9387 STRegex r -> do
9488 let
9589 regex = withKnownSymbol r $ fromSing r
9690 predicate = matchTest (makeRegex (T.unpack regex) :: Regex) (T.unpack t)
97− errMsg = "must match " <> regex
91+ errMsg = path <> " must match " <> regex
9892 warn = vWarning $ mmSingleton path (pure errMsg)
9993 unless predicate warn
10094 STEnum ss -> do
@@ -102,97 +96,69 @@ validateTextConstraint (JSONPathText path) t = \case
10296 matching :: Sing (s :: [Symbol]) -> Bool
10397 matching SNil = False
10498 matching (SCons s@SSym fs) = T.pack (symbolVal s) == t || matching fs
105− errMsg = "must be one of " <> T.pack (show (fromSing ss))
99+ errMsg = path <> " must be one of " <> T.pack (show (fromSing ss))
106100 warn = vWarning $ mmSingleton path (pure errMsg)
107101 unless (matching ss) warn
108102
109103validateNumberConstraint
110− :: JSONPathText
104+ :: JSONPath
111105 -> Scientific
112106 -> Sing (tcs :: NumberConstraint)
113107 -> Validation ()
114−validateNumberConstraint (JSONPathText path) num = \case
108+validateNumberConstraint (JSONPath path) num = \case
115109 SNEq n -> do
116110 let
117111 nlen = withKnownNat n $ natVal n
118112 predicate = fromIntegral nlen == num
119− errMsg = "should be == " <> T.pack (show nlen)
113+ errMsg = path <> " should be == " <> T.pack (show nlen)
120114 warn = vWarning $ mmSingleton path (pure errMsg)
121115 unless predicate warn
122116 SNGt n -> do
123117 let
124118 nlen = withKnownNat n $ natVal n
125119 predicate = num > fromIntegral nlen
126− errMsg = "should be > " <> T.pack (show nlen)
120+ errMsg = path <> " should be > " <> T.pack (show nlen)
127121 warn = vWarning $ mmSingleton path (pure errMsg)
128122 unless predicate warn
129123 SNGe n -> do
130124 let
131125 nlen = withKnownNat n $ natVal n
132126 predicate = num >= fromIntegral nlen
133− errMsg = "should be >= " <> T.pack (show nlen)
127+ errMsg = path <> " should be >= " <> T.pack (show nlen)
134128 warn = vWarning $ mmSingleton path (pure errMsg)
135129 unless predicate warn
136130 SNLt n -> do
137131 let
138132 nlen = withKnownNat n $ natVal n
139− predicate = num < fromIntegral nlen
140− errMsg = "should be < " <> T.pack (show nlen)
133+ predicate = fromIntegral nlen < num
134+ errMsg = path <> " should be < " <> T.pack (show nlen)
141135 warn = vWarning $ mmSingleton path (pure errMsg)
142136 unless predicate warn
143137 SNLe n -> do
144138 let
145139 nlen = withKnownNat n $ natVal n
146− predicate = num <= fromIntegral nlen
147− errMsg = "should be <= " <> T.pack (show nlen)
140+ predicate = fromIntegral nlen <= num
141+ errMsg = path <> " should be <= " <> T.pack (show nlen)
148142 warn = vWarning $ mmSingleton path (pure errMsg)
149143 unless predicate warn
150144
151145validateArrayConstraint
152− :: JSONPathText
146+ :: JSONPath
153147 -> V.Vector a
154148 -> Sing (tcs :: ArrayConstraint)
155149 -> Validation ()
156−validateArrayConstraint (JSONPathText path) v = \case
150+validateArrayConstraint (JSONPath path) v = \case
157151 SAEq n -> do
158152 let
159153 nlen = withKnownNat n $ natVal n
160154 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)
155+ errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)
190156 warn = vWarning $ mmSingleton path (pure errMsg)
191157 unless predicate warn
192158
193159validateJsonRepr
194160 :: Sing schema
195− -> JSONPath
161+ -> [DemotedPathSegment]
196162 -> JsonRepr schema
197163 -> Validation ()
198164validateJsonRepr sschema dpath jr = case jr of
@@ -226,7 +192,7 @@ validateJsonRepr sschema dpath jr = case jr of
226192 process cs
227193 process acs
228194 for_ (V.indexed v) $ \(ix, jr') -> do
229− let newPath = dpath <> pure (Index $ fromIntegral ix)
195+ let newPath = dpath <> pure (DIx $ fromIntegral ix)
230196 validateJsonRepr s newPath jr'
231197 ReprOptional d -> case sschema of
232198 SSchemaOptional ss -> case d of
@@ -238,10 +204,10 @@ validateJsonRepr sschema dpath jr = case jr of
238204 go :: Rec FieldRepr (ts :: [(Symbol, Schema)] ) -> Validation ()
239205 go RNil = pure ()
240206 go (f@(FieldRepr d) :& ftl) = do
241− let newPath = dpath <> [Key (knownFieldName f)]
207+ let newPath = dpath <> [DKey (knownFieldName f)]
242208 validateJsonRepr (knownFieldSchema f) newPath d
243209 go ftl
244− ReprUnion _ -> pure () -- FIXME
210+ ReprUnion u -> pure ()
245211 -- case sschema of
246212 -- SSchemaUnion ss -> case ss of
247213 -- SCons s stl -> case umatch' s u of
@@ -250,7 +216,7 @@ validateJsonRepr sschema dpath jr = case jr of
250216 -- fail "impossible to produce subUnion, please report this as a bug"
251217 -- Just x -> do
252218 -- let
253− -- JSONPathText path = demotedPathToText dpath
219+ -- JSONPath path = demotedPathToText dpath
254220 -- case stl of
255221 -- SNil -> void $ vWarning $ mmSingleton path
256222 -- $ pure "union handling error, please report this as bug"
@@ -281,26 +247,3 @@ toUnion _ = ReprUnion . urelax
281247
282248umatch' :: UElem a as i => Sing a -> Union f as -> Maybe (f a)
283249umatch' _ u = umatch u
284−
285−parseAndValidateJson
286− :: forall schema
287− . (FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
288− => Value
289− -> ParseResult (JsonRepr schema)
290−parseAndValidateJson v =
291− case parseEither parseJSON v of
292− Left s -> DecodingError $ T.pack s
293− Right jsonRepr ->
294− let
295− validate = validateJsonRepr (sing :: Sing schema) [] jsonRepr
296− res = runIdentity . runValidationTEither $ validate
297− in case res of
298− Left em -> ValidationError em
299− Right () -> Valid jsonRepr
300−
301−parseAndValidateJsonBy
302− :: (FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
303− => proxy schema
304− -> Value
305− -> ParseResult (JsonRepr schema)
306−parseAndValidateJsonBy _ = parseAndValidateJson
src/Data/Schematic/Verifier.hsdeleted−5
@@ -1,5 +0,0 @@
1−module Data.Schematic.Verifier (module X) where
2−
3−import Data.Schematic.Verifier.Array as X
4−import Data.Schematic.Verifier.Number as X
5−import Data.Schematic.Verifier.Text as X
src/Data/Schematic/Verifier/Array.hsdeleted−14
@@ -1,14 +0,0 @@
1−module Data.Schematic.Verifier.Array where
2−
3−import {-# SOURCE #-} Data.Schematic.Schema
4−import Data.Schematic.Verifier.Common
5−
6−data VerifiedArrayConstraint =
7− VAEq Integer
8− deriving (Show)
9−
10−verifyArrayConstraint ::
11− [DemotedArrayConstraint] -> Maybe (Maybe VerifiedArrayConstraint)
12−verifyArrayConstraint cs = do
13− x <- verifyDNEq [x | DAEq x <- cs]
14− pure $ VAEq <$> x
src/Data/Schematic/Verifier/Common.hsdeleted−43
@@ -1,43 +0,0 @@
1−module Data.Schematic.Verifier.Common where
2−
3−import Data.List (nub)
4−
5−simplifyNumberConstraint :: ([Integer] -> Integer) -> [Integer] -> Maybe Integer
6−simplifyNumberConstraint f =
7− \case
8− [] -> Nothing
9− x -> Just $ f x
10−
11−simplifyDNLs :: [Integer] -> Maybe Integer
12−simplifyDNLs = simplifyNumberConstraint minimum
13−
14−simplifyDNGs :: [Integer] -> Maybe Integer
15−simplifyDNGs = simplifyNumberConstraint maximum
16−
17−verifyDNEq :: [Integer] -> Maybe (Maybe Integer)
18−verifyDNEq x =
19− case nub x of
20− [] -> Just Nothing
21− [y] -> Just $ Just y
22− (_:_:_) -> Nothing
23−
24−verify3 :: Maybe Integer -> Maybe Integer -> Maybe Integer -> Maybe ()
25−verify3 (Just x) (Just y) (Just z) =
26− if x < y && y < z
27− then Just ()
28− else Nothing
29−verify3 _ _ _ = Just ()
30−
31−verify2 :: Maybe Integer -> Maybe Integer -> Maybe ()
32−verify2 (Just x) (Just y) =
33− if x < y
34− then Just ()
35− else Nothing
36−verify2 _ _ = Just ()
37−
38−verifyEquations :: Maybe Integer -> Maybe Integer -> Maybe Integer -> Maybe ()
39−verifyEquations mgt meq mlt = do
40− verify3 mgt meq mlt
41− verify2 mgt meq
42− verify2 meq mlt
43− verify2 mgt mlt
src/Data/Schematic/Verifier/Number.hsdeleted−31
@@ -1,31 +0,0 @@
1−module Data.Schematic.Verifier.Number where
2−
3−import {-# SOURCE #-} Data.Schematic.Schema
4−import Data.Schematic.Verifier.Common
5−
6−toStrictNumber :: [DemotedNumberConstraint] -> [DemotedNumberConstraint]
7−toStrictNumber = map f
8− where
9− f (DNLe x) = DNLt (x + 1)
10− f (DNGe x) = DNGt (x - 1)
11− f x = x
12−
13−data VerifiedNumberConstraint
14− = VNEq Integer
15− | VNBounds (Maybe Integer) (Maybe Integer)
16− deriving (Show)
17−
18−verifyNumberConstraints
19− :: [DemotedNumberConstraint]
20− -> Maybe VerifiedNumberConstraint
21−verifyNumberConstraints cs' = do
22− let
23− cs = toStrictNumber cs'
24− mlt = simplifyDNLs [x | DNLt x <- cs]
25− mgt = simplifyDNGs [x | DNGt x <- cs]
26− meq <- verifyDNEq [x | DNEq x <- cs]
27− verifyEquations mgt meq mlt
28− Just $
29− case meq of
30− Just eq -> VNEq eq
31− Nothing -> VNBounds mgt mlt
src/Data/Schematic/Verifier/Text.hsdeleted−121
@@ -1,121 +0,0 @@
1−module Data.Schematic.Verifier.Text where
2−
3−import Control.Monad
4−import Data.Maybe
5−import {-# SOURCE #-} Data.Schematic.Schema
6−import Data.Schematic.Verifier.Common
7−import Data.Text (Text, unpack)
8−import Text.Regex.TDFA.Pattern
9−import Text.Regex.TDFA.ReadRegex (parseRegex)
10−
11−toStrictTextLength :: [DemotedTextConstraint] -> [DemotedTextConstraint]
12−toStrictTextLength = map f
13− where
14− f (DTLe x) = DTLt (x + 1)
15− f (DTGe x) = DTGt (x - 1)
16− f x = x
17−
18−data VerifiedTextConstraint
19− = VTEq Integer
20− | VTBounds (Maybe Integer) (Maybe Integer)
21− | VTRegex Text Integer (Maybe Integer)
22− | VTEnum [Text]
23− deriving (Show)
24−
25−verifyTextLengthConstraints
26− :: [DemotedTextConstraint]
27− -> Maybe (Maybe VerifiedTextConstraint)
28−verifyTextLengthConstraints cs' = do
29− let
30− cs = toStrictTextLength cs'
31− mlt = simplifyDNLs [x | DTLt x <- cs]
32− mgt = simplifyDNGs [x | DTGt x <- cs]
33− meq <- verifyDNEq [x | DTEq x <- cs]
34− verifyEquations mgt meq mlt
35− case all isNothing ([mgt, meq, mlt] :: [Maybe Integer]) of
36− True -> Just Nothing
37− _ ->
38− Just $
39− Just $
40− case meq of
41− Just eq -> VTEq eq
42− Nothing -> VTBounds mgt mlt
43−
44−regexLength :: Text -> Maybe (Int, Maybe Int)
45−regexLength regexp =
46− case parseRegex . unpack $ regexp of
47− Right (p, _) -> Just (minRegexLength p, maxRegexLength p)
48− Left _ -> Nothing
49−
50−minRegexLength :: Pattern -> Int
51−minRegexLength p =
52− 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
60− 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
68−
69−maxRegexLength :: Pattern -> Maybe Int
70−maxRegexLength p =
71− 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
79− 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
87−
88−verifyTextRegexConstraint
89− :: [DemotedTextConstraint]
90− -> Maybe (Maybe VerifiedTextConstraint)
91−verifyTextRegexConstraint cs = do
92− let regexps = [x | DTRegex x <- cs]
93− case regexps of
94− [] -> Just Nothing
95− [x] -> do
96− (l, mh) <- regexLength x
97− Just $ Just $ VTRegex x (fromIntegral l) (fromIntegral <$> mh)
98− _ -> Nothing
99−
100−verifyTextEnumConstraint
101− :: [DemotedTextConstraint]
102− -> Maybe (Maybe VerifiedTextConstraint)
103−verifyTextEnumConstraint cs = do
104− let enums = concat [x | DTEnum x <- cs]
105− case enums of
106− [] -> Just Nothing
107− x -> Just $ Just $ VTEnum x
108−
109−verifyTextConstraints
110− :: [DemotedTextConstraint]
111− -> Maybe [VerifiedTextConstraint]
112−verifyTextConstraints cs = do
113− 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
119− lengths <- verifyTextLengthConstraints cs
120− enums <- verifyTextEnumConstraint cs
121− 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+50−5
@@ -1,6 +1,51 @@
1−resolver: lts-14.22
1+resolver: nightly-2017-09-17
2+
3+# User packages to be built.
4+# Various formats can be used as shown in the example below.
5+#
6+# packages:
7+# - some-directory
8+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
9+# - location:
10+# git: https://github.com/commercialhaskell/stack.git
11+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
12+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
13+# extra-dep: true
14+# subdirs:
15+# - auto-update
16+# - wai
17+#
18+# A package marked 'extra-dep: true' will only be built if demanded by a
19+# non-dependency (i.e. a user package), and its test suites and benchmarks
20+# will not be run. This is useful for tweaking upstream packages.
21+packages:
22+- '.'
23+
224extra-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
25+- hjsonpointer-1.3.0
26+- hjsonschema-1.7.0
27+- validationt-0.2.0.0
28+
29+# Override default flag values for local packages and extra-deps
30+flags: {}
31+
32+# Extra package databases containing global packages
33+extra-package-dbs: []
34+
35+# Control whether we use the GHC we find on the path
36+# system-ghc: true
37+#
38+# Require a specific version of stack, using version ranges
39+# require-stack-version: -any # Default
40+# require-stack-version: ">=1.4"
41+#
42+# Override the architecture used by stack, especially useful on Windows
43+# arch: i386
44+# arch: x86_64
45+#
46+# Extra directories used by stack for building
47+# extra-include-dirs: [/path/to/dir]
48+# extra-lib-dirs: [/path/to/dir]
49+#
50+# Allow a newer minor version of GHC than the snapshot specifies
51+# compiler-check: newer-minor
test/HelpersSpec.hs+6−6
@@ -1,20 +1,20 @@
11{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
22
3−{-# LANGUAGE LambdaCase #-}
4−
5−{-# LANGUAGE DataKinds #-}
6−{-# LANGUAGE TypeApplications #-}
7−{-# LANGUAGE OverloadedStrings #-}
8−
93module HelpersSpec (spec, main) where
104
115import Control.Lens
6+import Data.Aeson
7+import Data.ByteString.Char8 as C8
8+import Data.ByteString.Lazy as BL
129import Data.ByteString.Lazy.Lens
1310import Data.Foldable
11+import Data.Functor.Identity
1412import Data.Monoid
13+import Data.Proxy
1514import Data.Schematic
1615import Data.Text as T
1716import Data.Text.Lens
17+import Data.Vinyl
1818import Test.Hspec
1919
2020
test/JsonSchemaSpec.hs+10−67
@@ -1,16 +1,8 @@
1−{-# LANGUAGE LambdaCase #-}
2−
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE TypeApplications #-}
5−{-# LANGUAGE OverloadedLists #-}
6−{-# LANGUAGE OverloadedStrings #-}
7−
81module JsonSchemaSpec (spec, main) where
92
103import Data.Aeson as J
114import Data.Maybe
125import Data.Proxy
13−import Data.ByteString.Lazy as B
146import Data.Schematic
157import Data.Vinyl
168import JSONSchema.Draft4 as D4
@@ -26,32 +18,19 @@ type FieldsSchema =
2618
2719type SchemaExample = 'SchemaObject FieldsSchema
2820
29−exampleData :: JsonRepr SchemaExample
30−exampleData = withRepr @SchemaExample $
31− field @"foo" [ReprNumber 13]
32− :& field @"bar" (pure (ReprText "foo"))
33− :& RNil
21+arrayData :: JsonRepr ArraySchema
22+arrayData = ReprArray [ReprNumber 13]
3423
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− ]
24+arrayField :: FieldRepr ArrayField
25+arrayField = FieldRepr arrayData
4126
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− ]
27+objectData :: Rec FieldRepr FieldsSchema
28+objectData = FieldRepr arrayData
29+ :& FieldRepr (ReprOptional (Just (ReprText "foo")))
30+ :& RNil
4831
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− ]
32+exampleData :: JsonRepr SchemaExample
33+exampleData = ReprObject objectData
5534
5635spec :: Spec
5736spec = do
@@ -60,42 +39,6 @@ spec = do
6039 fetchHTTPAndValidate schema (toJSON exampleData) >>= \case
6140 Left _ -> fail "failed to validate test example"
6241 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 ()
9942
10043main :: IO ()
10144main = hspec spec
test/LensSpec.hs+10−9
@@ -1,11 +1,7 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE TypeApplications #-}
3−{-# LANGUAGE OverloadedLists #-}
4−{-# LANGUAGE OverloadedStrings #-}
5−
61module LensSpec (spec, main) where
72
83import Control.Lens
4+import Data.Kind
95import Data.Proxy
106import Data.Schematic
117import Data.Vinyl
@@ -19,6 +15,8 @@ type ArrayField = '("foo", ArraySchema)
1915type FieldsSchema =
2016 '[ '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]])), ArrayField]
2117
18+type SchemaExample = 'SchemaObject FieldsSchema
19+
2220arrayData :: JsonRepr ArraySchema
2321arrayData = ReprArray [ReprNumber 13]
2422
@@ -30,6 +28,9 @@ objectData = FieldRepr (ReprOptional (Just (ReprText "foo")))
3028 :& FieldRepr arrayData
3129 :& RNil
3230
31+exampleData :: JsonRepr SchemaExample
32+exampleData = ReprObject objectData
33+
3334type BigRecord = Rec FieldRepr
3435 '[ '("f1", 'SchemaNumber '[])
3536 , '("f2", 'SchemaNumber '[])
@@ -303,15 +304,15 @@ spec = do
303304 newFooVal = FieldRepr $ ReprArray [ReprNumber 15]
304305 fooProxy = Proxy @"foo"
305306 it "gets the field from an object" $ do
306− fget @"foo" objectData `shouldBe` arrayField
307+ fget fooProxy objectData `shouldBe` arrayField
307308 it "sets the object field" $ do
308− fget @"foo" (fput newFooVal objectData) `shouldBe` newFooVal
309+ fget fooProxy (fput newFooVal objectData) `shouldBe` newFooVal
309310
310311 describe "(using lens library) " $ do
311312 it "get the field from an object" $ do
312− objectData ^. flens @"foo" `shouldBe` arrayField
313+ objectData ^. flens (Proxy @"foo") `shouldBe` arrayField
313314 it "sets the object field" $ do
314− set (flens @"foo") newFooVal objectData ^. flens @"foo"
315+ set (flens (Proxy @"foo")) newFooVal objectData ^. flens (Proxy @"foo")
315316 `shouldBe` newFooVal
316317
317318main :: IO ()
test/SchemaSpec.hs+28−70
@@ -1,78 +1,37 @@
11{-# OPTIONS_GHC -fprint-potential-instances #-}
22
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE OverloadedLists #-}
7−{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE RankNTypes #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TypeApplications #-}
11−
123module SchemaSpec (spec, main) where
134
14−import Control.Lens
155import Data.Aeson
166import Data.ByteString.Lazy
177import Data.Functor.Identity
188import Data.Proxy
199import Data.Schematic
20−import Data.Schematic.Generator
21−import Data.Singletons
22−import Data.Tagged
2310import Data.Vinyl
2411import Test.Hspec
25−import Test.Hspec.SmallCheck
26−import Test.SmallCheck as SC
27−import Test.SmallCheck.Drivers as SC
28−import Test.SmallCheck.Series as SC
29−
30−import Debug.Trace
3112
3213type SchemaExample = 'SchemaObject
3314 '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]))
3415 , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]
3516
36−type SchemaExample2 = 'SchemaObject
37− '[ '("foo", 'SchemaArray '[ 'AEq 2] ('SchemaText '[ 'TGt 10]))
38− , '("bar", 'SchemaOptional ('SchemaText '[ 'TRegex "[0-9]+"]))]
39−
40−jsonExample :: JsonRepr SchemaExample
41−jsonExample = withRepr @SchemaExample
42− $ field @"bar" (Just "bar")
43− :& field @"foo" [12]
44− :& RNil
45−
46−type AddQuuz =
47− 'Migration "add_field_quuz"
48− '[ 'Diff '[] ('AddKey "quuz" (SchemaNumber '[])) ]
17+example :: JsonRepr SchemaExample
18+example = withRepr @SchemaExample $
19+ field @"bar" (Just $ ReprText "bar")
20+ <:&> field @"foo" [ReprNumber 12]
21+ <:&> pure RNil
4922
50−type DeleteQuuz =
51− 'Migration "remove_field_quuz"
52− '[ 'Diff '[] ( 'DeleteKey "quuz") ]
23+type TestMigration =
24+ 'Migration "test_revision"
25+ '[ 'Diff '[ 'PKey "bar" ] ('Update ('SchemaText '[]))
26+ , 'Diff '[ 'PKey "foo" ] ('Update ('SchemaNumber '[])) ]
5327
54−type SwapFields =
55− 'Migration "swap_fields"
56− '[ 'Diff '[ 'PKey "bar" ] ('Update
57− ('SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10])))
58− , 'Diff '[ 'PKey "foo" ] ('Update
59− ('SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))) ]
28+type VS = 'Versioned SchemaExample '[ TestMigration ]
6029
61−type Migrations = '[ AddQuuz
62− , DeleteQuuz ]
63− -- , SwapFields ]
64−
65−type VersionedJson = 'Versioned SchemaExample Migrations
66−
67−migrationList :: MigrationList Identity VersionedJson
68−migrationList
69− = (migrateObject (\r -> Identity $ field @"quuz" 42 :& r))
70− :&& shrinkObject
71− -- :&& (migrateObject (\r -> Identity
72− -- $ field @"foo" (r ^. flens (Proxy @"bar") . _Just . optionalRepr)
73− -- :& field @"bar" (r ^. flens (Proxy @"foo") . arrayRepr)
74− -- :& RNil))
75− :&& MNil
30+jsonExample :: JsonRepr SchemaExample
31+jsonExample = ReprObject $
32+ FieldRepr (ReprArray [ReprNumber 12])
33+ :& FieldRepr (ReprOptional (Just (ReprText "bar")))
34+ :& RNil
7635
7736schemaJson :: ByteString
7837schemaJson = "{\"foo\": [13], \"bar\": null}"
@@ -80,11 +39,15 @@ schemaJson = "{\"foo\": [13], \"bar\": null}"
8039schemaJson2 :: ByteString
8140schemaJson2 = "{\"foo\": [3], \"bar\": null}"
8241
83−schemaJsonSeries :: Monad m => SC.Series m (JsonRepr SchemaExample)
84−schemaJsonSeries = series
85−
86−schemaJsonSeries2 :: Monad m => SC.Series m (JsonRepr SchemaExample2)
87−schemaJsonSeries2 = series
42+topObject
43+ :: JsonRepr
44+ ('SchemaObject
45+ '[ '("foo", 'SchemaNumber '[])
46+ , '("bar", 'SchemaText '[])])
47+topObject = ReprObject $
48+ FieldRepr (ReprNumber 42)
49+ :& FieldRepr (ReprText "test")
50+ :& RNil
8851
8952spec :: Spec
9053spec = do
@@ -106,17 +69,12 @@ spec = do
10669 -- `shouldSatisfy` isValid
10770 it "validates versioned json with a migration list" $ do
10871 decodeAndValidateVersionedWithPureMList
109− (Proxy @VersionedJson)
110− migrationList
72+ (Proxy @VS)
73+ ((:&&)
74+ (Proxy @(SchemaByRevision "test_revision" VS))
75+ (const $ Identity topObject) MNil)
11176 schemaJson
11277 `shouldSatisfy` isValid
113− it "validates json series" $ property $
114− SC.over schemaJsonSeries $ \x ->
115− isValid (parseAndValidateJson @SchemaExample (toJSON x))
116− it "validates json series 2" $ property $
117− SC.over schemaJsonSeries2 $ \x ->
118− isValid (parseAndValidateJson @SchemaExample2 (toJSON x))
119−
12078
12179main :: IO ()
12280main = hspec spec