git.iko.soy/schematic
on master help sign in
swap
f5ed14a119 ahead, 0 behind
.travis.yml+2−2
since splitsnapshots
unifiedsplit
@@ -1,4 +1,4 @@
1−sudo: false
1+sudo: required
2
2
3language: c
3language: c
4
4
@@ -22,4 +22,4 @@ script:
22
22
23cache:
23cache:
24 directories:
24 directories:
25− - $HOME/.stack
25+ - $HOME/.stack
ChangeLog.md+50
@@ -1,5 +1,55 @@
1# Revision history for schematic
1# Revision history for schematic
2
2
3+## 0.5.0.0 -- 2019-02-20
4+
5+GHC 8.6, json generation by schema definition, validation bug fixes, better
6+parsing error messages.
7+
8+## 0.4.3.0 -- 2018-07-12
9+
10+GHC 8.4 support, dropping support for older GHC versions
11+
12+## 0.4.2.0
13+
14+Support ghc-8.4 and drop support for older versions
15+
16+## 0.4.1.0 -- 2017-11-05
17+
18+Convenience isomorphisms: txt, num, opt, bln etc
19+
20+## 0.4.1.0 -- 2017-11-01
21+
22+flens and fget now use type application syntax
23+
24+## 0.4.0.0 -- 2017-10-17
25+
26+Object building DSL, more convenience helpers, MCons simplified with Tagged
27+
28+## 0.3.2.0 -- 2017-10-02
29+
30+Fixed FIndex bug, added bunch of convenience isomorphism, re-exports.
31+
32+## 0.3.1.0 -- 2017-09-28
33+
34+Add UUID and ISO8601 helpers, json schema constraint export, fsubset lens
35+combinator.
36+
37+## 0.3.0.0 -- 2017-09-28
38+
39+Updated to GHC 8.2.1 and singletons 2.3.1
40+
41+## 0.2.1.0 -- 2017-09-26
42+
43+Add decodeAndValidateVersionedWithPureMList, fix tests
44+
45+## 0.2.0.0 -- 2017-09-26
46+
47+Migratable is deprecated, migrations are now possible in an arbitrary monad.
48+
49+## 0.1.5.0 -- 2017-08-22
50+
51+Lens compatibility for typed json objects.
52+
3## 0.1.0.0 -- YYYY-mm-dd
53## 0.1.0.0 -- YYYY-mm-dd
4
54
5* First version. Released on an unsuspecting world.
55* First version. Released on an unsuspecting world.
README.md+175−33
@@ -1,23 +1,16 @@
1# schematic
1# schematic
2
2
3−[![Build Status](https://travis-ci.org/dredozubov/schematic.svg?branch=master)](https://travis-ci.org/dredozubov/schematic)
3+[![Build Status](https://travis-ci.org/typeable/schematic.svg?branch=master)](https://travis-ci.org/typeable/schematic)
4
4
5## Goal
5## Goal
6
6
7The goal of the library is to provide a type-safe transport layer for serializing and validating JSON. It can be thought of as a subset of [json-schema](http://json-schema.org), which is basically a specification of a JSON document. The other goal is getting as much as possible from this specification for free. Right now the following bits are prototyped:
7The goal of the library is to provide a type-safe transport layer for serializing and validating JSON. It can be thought of as a subset of [json-schema](http://json-schema.org), which is basically a specification of a JSON document. The other goal is getting as much as possible from this specification for free. Right now the following bits are prototyped:
8
8
9−* All the instantiations of transport types are structurally follow the schema provided by user
9+* All of the instantiations of the transport types structurally follow the schema provided by user
10−* Serializers are generic, so they follow from the type-level schema and the're supposed to have roundtrip property by implementation.
10+* Serializers are generic, so they follow from the type-level schema and the're supposed to have a roundtrip property by an implementation.
11* Runtime value validators are generated from the schema. Validation errors are reported as a pairs of a json-path to the element and an error message.
11* Runtime value validators are generated from the schema. Validation errors are reported as a pairs of a json-path to the element and an error message.
12−* There are migrations. It's possible to describe a series of migrations to the schema and have all the machinery deserialize a user specified version of the schema if there's a few versions.
12+* There are migrations. It's possible to describe a series of migrations to the schema and have all the necessary machinery to deserialize a user specified version of the schema if there are multiple versions available.
13−
13+* Schematic schemas can be exported to [json-schema](http://json-schema.org)
14−## TODO
15−
16−* Making a migration system more usable. It should allow it to be used as a json safecopy solution minus the boilerplate.
17−* Describing versioned http endpoints
18−* Schema pretty-printing
19−* More validators
20−* Overall user friendliness
21
14
22Be aware that library is experimental and subject to change a lot. The current state can be viewed as a prototype.
15Be aware that library is experimental and subject to change a lot. The current state can be viewed as a prototype.
23
16
@@ -29,67 +22,134 @@ Be aware that library is experimental and subject to change a lot. The current s
29$ stack install schematic
22$ stack install schematic
30```
23```
31
24
32−## Basic Examples
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:
33
29
34```
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+
51+## Basic Examples
52+
53+```haskell
35type SchemaExample
54type SchemaExample
36 = SchemaObject
55 = SchemaObject
37 '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))
56 '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))
38 , '("bar", SchemaOptional (SchemaText '[TEnum '["foo", "bar"]]))]
57 , '("bar", SchemaOptional (SchemaText '[TEnum '["foo", "bar"]]))]
39```
58```
40
59
41−* This schema says that's structurally it's a JSON object which has two field:
60+* This schema says that's structurally it's a JSON object which has two fields:
42− * field "foo" contains an of numeric values
61+ * field "foo" contains an array of numeric values
43− * field "bar" contains an optional textual value
62+ * field "bar" contains an optional text value
44−* It also allows you to validate the JSON:
63+* It also allows you to validate JSON values itself:
45− * an array in "foo" must contain exactly one element
64+ * an array in "foo" contains exactly one element
46 * that element must be strictly greater than 10
65 * that element must be strictly greater than 10
47− * value of bar must be either "foo" or "bar" if presented
66+ * value of "bar" field must be either "foo" or "bar" if presented
48
67
49
68
50This one is valid for example
69This one is valid for example
51
70
52−```
71+```haskell
53schemaJson :: ByteString
72schemaJson :: ByteString
54schemaJson = "{\"foo\": [13], \"bar\": null}"
73schemaJson = "{\"foo\": [13], \"bar\": null}"
55```
74```
56
75
57Also valid
76Also valid
58
77
59−```
78+```haskell
60schemaJson :: ByteString
79schemaJson :: ByteString
61schemaJson = "{\"foo\": [13], \"bar\": \"bar\"}"
80schemaJson = "{\"foo\": [13], \"bar\": \"bar\"}"
62```
81```
63
82
64it can be parsed and validated like this:
83it can be parsed and validated like this:
65
84
66−```
85+```haskell
67decodeAndValidateJson schemaJson :: ParseResult (JsonRepr SchemaExample)
86decodeAndValidateJson schemaJson :: ParseResult (JsonRepr SchemaExample)
68```
87```
69
88
70`ParseResult` type encodes three possible situations:
89`ParseResult` type encodes three possible situations:
71−* json is structurally consistent with schema and runtime validations passed
90+* json is structurally consistent with a schema and runtime validations pass
72−* json source is malformed or doesn't correspond to schema structurally
91+* json source is malformed or doesn't correspond to a schema structurally
73−* some of the runtime validations failed, but it's structurally correct
92+* some of the runtime validations have failed, but it's structurally correct
93+ overall
94+
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.
74
98
75−I t's build a transport layer representation of that data that can be tranversed and transformed to whatever internal types user has. Transport layer represetation looks like this. Type parameter is the schema itself.
99+```haskell
100+jsonExample :: JsonRepr SchemaExample
101+jsonExample = withRepr @SchemaExample
102+ $ field @"foo" [12]
103+ :& field @"bar" (Just "bar")
104+ :& RNil
105+```
76
106
107+The most basic and sugar-free way of constructing the same object will look like this:
77
108
78```
109```
79−jsonExample :: JsonRepr SchemaExample
110+jsonExample' :: JsonRepr SchemaExample
80−jsonExample = ReprObject $
111+jsonExample' = ReprObject $
81 FieldRepr (ReprArray [ReprNumber 12])
112 FieldRepr (ReprArray [ReprNumber 12])
82 :& FieldRepr (ReprOptional (Just (ReprText "bar")))
113 :& FieldRepr (ReprOptional (Just (ReprText "bar")))
83 :& RNil
114 :& RNil
84```
115```
85
116
86−## Migrations
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:
87
120
88−It's possible to represent schema changes as a migration, which describes a series of json-path/change pairs. Migrations can be applied in succession.
121+```haskell
122+type ArraySchema = SchemaArray '[AEq 1] (SchemaNumber '[NGt 10])
89
123
90−This piece of code will apply a migration to the schema, then decodes and validates the latest version.
124+type ArrayField = '("foo", ArraySchema)
125+
126+type FieldsSchema =
127+ '[ ArrayField, '("bar", SchemaOptional (SchemaText '[TEnum '["foo", "bar"]]))]
128+
129+type SchemaExample = 'SchemaObject FieldsSchema
91
130
92```
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+
138+## Migrations
139+
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.
149+
150+This piece of code will apply a migration to the schema, decode and validate the latest version.
151+
152+```haskell
93type SchemaExample
153type SchemaExample
94 = SchemaObject
154 = SchemaObject
95 '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))
155 '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))
@@ -97,8 +157,8 @@ type SchemaExample
97
157
98type TestMigration =
158type TestMigration =
99 'Migration "test_revision"
159 'Migration "test_revision"
100− '[ 'Diff '[ 'PKey "bar" ] ('Update ('SchemaText '[]))
160+ '[ Diff '[ PKey "bar" ] (Update (SchemaText '[]))
101− , 'Diff '[ 'PKey "foo" ] ('Update ('SchemaNumber '[])) ]
161+ , Diff '[ PKey "foo" ] (Update (SchemaNumber '[])) ]
102
162
103type VS = 'Versioned SchemaExample '[ TestMigration ]
163type VS = 'Versioned SchemaExample '[ TestMigration ]
104
164
@@ -111,3 +171,85 @@ It's possible to decode the latest version like this:
111```
171```
112decodeAndValidateJson schemaJsonTopVersion :: ParseResult (JsonRepr (TopVersion (AllVersions VS)))
172decodeAndValidateJson schemaJsonTopVersion :: ParseResult (JsonRepr (TopVersion (AllVersions VS)))
113```
173```
174+
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
204+
205+migrationList :: MigrationList Identity VersionedJson
206+migrationList
207+ = (migrateObject (\r -> Identity $ field @"quuz" 42 :& r))
208+ :&& shrinkObject
209+ :&& MNil
210+
211+```
212+
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`?
225+
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:
232+
233+```haskell
234+type SchemaExample = 'SchemaObject
235+ '[ '("foo", SchemaArray '[ AEq 1] (SchemaNumber '[NGt 10]))
236+ , '("bar", SchemaOptional (SchemaText '[TEnum '["foo", "bar"]]))]
237+
238+jsonExample = withRepr @SchemaExample
239+ $ field @"bar" (Just "bar")
240+ :& field @"foo" [12]
241+ :& RNil
242+```
243+
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.
247+
248+[GHC Type Applications](https://ghc.haskell.org/trac/ghc/wiki/TypeApplication)
249+
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.
253+
254+
255+## Export to json-schema (draft 4)
releasenew file+43
@@ -0,0 +1,43 @@
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.nixnew file+32
@@ -0,0 +1,32 @@
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+40−45
@@ -1,15 +1,13 @@
1−-- Initial schematic.cabal generated by cabal init. For further
2−-- documentation, see http://haskell.org/cabal/users-guide/
3−
4name: schematic
1name: schematic
5−version: 0.1.1.0
2+version: 0.5.0.0
6synopsis: JSON-biased spec and validation tool
3synopsis: JSON-biased spec and validation tool
7−-- description:
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.
8license: BSD3
5license: BSD3
9license-file: LICENSE
6license-file: LICENSE
10author: Denis Redozubov
7author: Denis Redozubov
11maintainer: denis.redozubov@gmail.com
8maintainer: denis.redozubov@gmail.com
12−-- copyright:
9+homepage: http://github.com/typeable/schematic
10+Bug-reports: http://github.com/typeable/schematic/issues/
13category: Data
11category: Data
14build-type: Simple
12build-type: Simple
15extra-source-files: ChangeLog.md
13extra-source-files: ChangeLog.md
@@ -17,19 +15,29 @@ cabal-version: >=1.10
17
15
18library
16library
19 exposed-modules: Data.Schematic
17 exposed-modules: Data.Schematic
18+ , Data.Schematic.DSL
19+ , Data.Schematic.Generator
20− -- , Data.Schematic.Class
20+ , Data.Schematic.Generator.Regex
21 , Data.Schematic.Instances
21 , Data.Schematic.Instances
22+ , Data.Schematic.JsonSchema
23+ , Data.Schematic.Helpers
24+ , Data.Schematic.Lens
25+ , Data.Schematic.Migration
22 , Data.Schematic.Path
26 , Data.Schematic.Path
23 , Data.Schematic.Schema
27 , Data.Schematic.Schema
24 , Data.Schematic.Validation
28 , Data.Schematic.Validation
25− , Data.Schematic.Utils
29+ , Data.Schematic.Verifier
30+ , Data.Schematic.Verifier.Array
31+ , Data.Schematic.Verifier.Common
32+ , Data.Schematic.Verifier.Number
33+ , Data.Schematic.Verifier.Text
26 ghc-options: -Wall
34 ghc-options: -Wall
27− -- other-modules:
28 default-extensions: ConstraintKinds
35 default-extensions: ConstraintKinds
29 , DataKinds
36 , DataKinds
30 , DefaultSignatures
37 , DefaultSignatures
31 , DeriveFunctor
38 , DeriveFunctor
32 , DeriveFoldable
39 , DeriveFoldable
40+ , DeriveTraversable
33 , DeriveGeneric
41 , DeriveGeneric
34 , DeriveDataTypeable
42 , DeriveDataTypeable
35 , FlexibleContexts
43 , FlexibleContexts
@@ -52,22 +60,29 @@ library
52 , TemplateHaskell
60 , TemplateHaskell
53 , TypeApplications
61 , TypeApplications
54 , TypeFamilies
62 , TypeFamilies
63+ , TypeFamilyDependencies
55 , TypeInType
64 , TypeInType
56 , TypeOperators
65 , TypeOperators
57 , TypeSynonymInstances
66 , TypeSynonymInstances
58 , UndecidableInstances
67 , UndecidableInstances
59− build-depends: base >=4.9 && <4.10
68+ build-depends: base >=4.11 && <4.13
60 , bytestring
69 , bytestring
61 , aeson >= 1
70 , aeson >= 1
71+ , containers
72+ , hjsonschema
73+ , mtl
74+ , profunctors
62− , regex-compat
75+ , regex-tdfa
76+ , regex-tdfa-text
63 , scientific
77 , scientific
64− , singletons
78+ , singletons >= 2.4
65 , smallcheck
79 , smallcheck
66− , smallcheck-series
67 , tagged
80 , tagged
81+ , template-haskell
68 , text
82 , text
83+ , union
69 , unordered-containers
84 , unordered-containers
70− , validationt >= 0.1.0.1
85+ , validationt >= 0.2.1.0
71 , vector
86 , vector
72 , vinyl
87 , vinyl
73 hs-source-dirs: src
88 hs-source-dirs: src
@@ -78,48 +93,28 @@ test-suite spec
78 hs-source-dirs: test
93 hs-source-dirs: test
79 main-is: Spec.hs
94 main-is: Spec.hs
80 default-language: Haskell2010
95 default-language: Haskell2010
81− default-extensions: ConstraintKinds
82− , DataKinds
83− , DeriveFunctor
84− , DeriveFoldable
85− , DeriveGeneric
86− , DeriveDataTypeable
87− , FlexibleContexts
88− , FlexibleInstances
89− , FunctionalDependencies
90− , GADTs
91− , KindSignatures
92− , InstanceSigs
93− , MultiParamTypeClasses
94− , OverloadedLists
95− , OverloadedStrings
96− , PolyKinds
97− , QuasiQuotes
98− , PartialTypeSignatures
99− , RecordWildCards
100− , ScopedTypeVariables
101− , TemplateHaskell
102− , TypeApplications
103− , TypeFamilies
104− , TypeInType
105− , TypeOperators
106− , TypeSynonymInstances
107 build-depends: HUnit
96 build-depends: HUnit
108 , aeson >= 1
97 , aeson >= 1
109− , base >=4.9 && <4.10
98+ , base >=4.11 && <4.13
110 , bytestring
99 , bytestring
100+ , containers
101+ , hjsonschema
111 , hspec >= 2.2.0
102 , hspec >= 2.2.0
112 , hspec-core
103 , hspec-core
113 , hspec-discover
104 , hspec-discover
114 , hspec-smallcheck
105 , hspec-smallcheck
106+ , lens
107+ , regex-tdfa
115− , regex-compat
108+ , regex-tdfa-text
116 , schematic
109 , schematic
117 , smallcheck
110 , smallcheck
118− , smallcheck-series
119 , singletons
111 , singletons
120 , tagged
112 , tagged
121 , text
113 , text
122 , unordered-containers
114 , unordered-containers
123− , validationt >= 0.1.0.1
115+ , validationt >= 0.2.1.0
124 , vinyl
116 , vinyl
125− other-modules: SchemaSpec
117+ other-modules: SchemaSpec
118+ , HelpersSpec
119+ , LensSpec
120+ , JsonSchemaSpec
src/Data/Schematic.hs+48−79
@@ -2,50 +2,43 @@
2{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
3
3
4module Data.Schematic
4module Data.Schematic
5− ( module Data.Schematic.Schema
5+ ( module Data.Schematic.JsonSchema
6+ , module Data.Schematic.Helpers
7+ , module Data.Schematic.Lens
6 , module Data.Schematic.Migration
8 , module Data.Schematic.Migration
7− , module Data.Schematic.Utils
9+ , module Data.Schematic.Schema
8 , decodeAndValidateJson
10 , decodeAndValidateJson
9 , parseAndValidateJson
11 , parseAndValidateJson
10− , parseAndValidateVersionedJson
12+ , parseAndValidateJsonBy
11 , parseAndValidateTopVersionJson
13 , parseAndValidateTopVersionJson
12− , decodeAndValidateVersionedJson
14+ , parseAndValidateWithMList
15+ , decodeAndValidateVersionedWithMList
16+ , decodeAndValidateVersionedWithPureMList
13 , isValid
17 , isValid
14 , isDecodingError
18 , isDecodingError
15 , isValidationError
19 , isValidationError
16 , ParseResult(..)
20 , ParseResult(..)
17− , Migratable
21+ , withRepr
22+ , field
18 ) where
23 ) where
19
24
20import Control.Monad.Validation
25import Control.Monad.Validation
21import Data.Aeson as J
26import Data.Aeson as J
22import Data.Aeson.Types as J
27import Data.Aeson.Types as J
23import Data.ByteString.Lazy as BL
28import Data.ByteString.Lazy as BL
24−import Data.Functor.Identity
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
25import Data.Schematic.Migration
34import Data.Schematic.Migration
26import Data.Schematic.Schema
35import Data.Schematic.Schema
27−import Data.Schematic.Utils
28import Data.Schematic.Validation
36import Data.Schematic.Validation
29−import Data.Singletons.Prelude
37+import Data.Singletons.Prelude hiding ((:.))
38+import Data.Tagged
30import Data.Text as T
39import Data.Text as T
31
40
32
41
33−parseAndValidateJson
34− :: forall schema
35− . (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
36− => J.Value
37− -> ParseResult (JsonRepr schema)
38−parseAndValidateJson v =
39− case parseEither parseJSON v of
40− Left s -> DecodingError $ T.pack s
41− Right jsonRepr ->
42− let
43− validate = validateJsonRepr (sing :: Sing schema) [] jsonRepr
44− res = runIdentity . runValidationTEither $ validate
45− in case res of
46− Left em -> ValidationError em
47− Right () -> Valid jsonRepr
48−
49parseAndValidateTopVersionJson
42parseAndValidateTopVersionJson
50 :: forall proxy (v :: Versioned)
43 :: forall proxy (v :: Versioned)
51 . (SingI (TopVersion (AllVersions v)))
44 . (SingI (TopVersion (AllVersions v)))
@@ -64,56 +57,23 @@ parseAndValidateTopVersionJson _ v =
64 Left em -> ValidationError em
57 Left em -> ValidationError em
65 Right () -> Valid jsonRepr
58 Right () -> Valid jsonRepr
66
59
67−class Migratable (revisions :: [(Revision, Schema)]) where
60+parseAndValidateWithMList
68− mparse
61+ :: Monad m
69− :: Sing revisions
62+ => MList m revisions
70− -> J.Value
71− -> ParseResult (JsonRepr (Snd (Head revisions)))
72−
73−instance {-# OVERLAPPING #-} (TopLevel (Snd rev), SingI (Snd rev)) => Migratable '[rev] where
74− mparse _ = parseAndValidateJson
75−
76−instance {-# OVERLAPPABLE #-}
77− ( Migratable (Tail revisions)
78− , MigrateSchema (Snd (Head (Tail revisions))) (Snd (Head revisions))
79− , SingI (Snd (Head revisions)))
80− => Migratable revisions where
81− mparse s v = case parseEither parseJSON v of
82− Left _ -> migrate <$> mparse (sTail s) v
83− Right x -> Valid x
84−-- type family Migratable (revisions :: [(Revision, Schema)]) = (cs :: Constraint) where
85−-- Migratable '[rev] = (TopLevel (Snd rev), SingI (Snd rev))
86−-- Migratable revisions =
87−-- ( Migratable (Tail revisions)
88−-- , MigrateSchema (Snd (Head (Tail revisions))) (Snd (Head revisions))
89−-- , SingI (Snd (Head revisions)))
90−
91−-- mparseBySing
92−-- :: Sing schema
93−-- -> J.Value
94−-- -> ParseResult (JsonRepr (Snd (Head revisions)))
95−-- mparseBySing s v = undefined
96−
97−-- mparse
98−-- :: Migratable revisions
99−-- => Sing revisions
100−-- -> J.Value
101−-- -> ParseResult (JsonRepr (Snd (Head revisions)))
102−-- mparse s v =
103−-- let
104−-- st = sTail s
105−-- sth = sSnd $ sHead st
106−-- SCons x SNil -> parseAndValidateJson v
107−-- SCons sch _ -> case parseEither parseJSON v of
108−-- Left _ -> migrate <$> mparse (sTail s) v
109−-- Right x -> Valid x
110−
111−parseAndValidateVersionedJson
112− :: forall proxy v. (SingI (AllVersions v), Migratable (AllVersions v))
113− => proxy v
114 -> J.Value
63 -> J.Value
115− -> ParseResult (JsonRepr (Snd (Head (AllVersions v))))
64+ -> m (ParseResult (JsonRepr (Head revisions)))
116−parseAndValidateVersionedJson _ v = mparse (sing :: Sing (AllVersions v)) v
65+parseAndValidateWithMList MNil v = pure $ parseAndValidateJson v
66+parseAndValidateWithMList (Tagged f :&& tl) v =
67+ case parseAndValidateJsonBy Proxy v of
68+ Valid a -> pure $ Valid a
69+ DecodingError _ -> do
70+ pr <- parseAndValidateWithMList tl v
71+ let pr' = f <$> pr
72+ sequence pr'
73+ ValidationError _ -> do
74+ pr <- parseAndValidateWithMList tl v
75+ let pr' = f <$> pr
76+ sequence pr'
117
77
118decodeAndValidateJson
78decodeAndValidateJson
119 :: forall schema
79 :: forall schema
@@ -124,11 +84,20 @@ decodeAndValidateJson bs = case decode bs of
124 Nothing -> DecodingError "malformed json"
84 Nothing -> DecodingError "malformed json"
125 Just x -> parseAndValidateJson x
85 Just x -> parseAndValidateJson x
126
86
127−decodeAndValidateVersionedJson
87+decodeAndValidateVersionedWithMList
128− :: (Migratable (AllVersions versioned), SingI (AllVersions versioned))
88+ :: Monad m
129 => proxy versioned
89 => proxy versioned
90+ -> MList m (MapSnd (AllVersions versioned))
130 -> BL.ByteString
91 -> BL.ByteString
131− -> ParseResult (JsonRepr (Snd (Head (AllVersions versioned))))
92+ -> m (ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned)))))
132−decodeAndValidateVersionedJson vp bs = case decode bs of
93+decodeAndValidateVersionedWithMList _ mlist bs = case decode bs of
133− Nothing -> DecodingError "malformed json"
94+ Nothing -> pure $ DecodingError "malformed json"
134− Just x -> parseAndValidateVersionedJson vp x
95+ Just x -> parseAndValidateWithMList mlist x
96+
97+decodeAndValidateVersionedWithPureMList
98+ :: proxy versioned
99+ -> MList F.Identity (MapSnd (AllVersions versioned))
100+ -> BL.ByteString
101+ -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))
102+decodeAndValidateVersionedWithPureMList a b c =
103+ runIdentity $ decodeAndValidateVersionedWithMList a b c
src/Data/Schematic/DSL.hsnew file+92
@@ -0,0 +1,92 @@
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.hsnew file+91
@@ -0,0 +1,91 @@
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.hsnew file+76
@@ -0,0 +1,76 @@
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/Helpers.hsnew file+59
@@ -0,0 +1,59 @@
1+module Data.Schematic.Helpers where
2+
3+import Data.Schematic.Schema
4+import GHC.TypeLits
5+
6+
7+type UUIDRegex =
8+ 'TRegex "[0-9a-f]{8}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{12}"
9+
10+type IsUUID = '[UUIDRegex]
11+
12+-- [ "1985-04-12T23:20:50.52Z"
13+-- , "1996-12-19T16:39:57-08:00"
14+-- , "1990-12-31T23:59:60Z"
15+-- , "1990-12-31T15:59:60-08:00"
16+-- , "1937-01-01T12:00:27.87+00:20"
17+-- ]
18+
19+-- components
20+type ISO8601Date = "[1-9][0-9]{3}-(0[1-9]|1[0-2])-([0-2][0-9]|3[0-1])"
21+
22+type ISO8601Time = "([0-1][0-9]|2[0-3]):[0-5][0-9]:[0-5][0-9]"
23+
24+type ISO8601DateTime =
25+ AppendSymbol
26+ ISO8601Date
27+ (AppendSymbol "(T" (AppendSymbol ISO8601Time ")?"))
28+
29+type ISO8601UTC = "(Z|\\+00:00)"
30+
31+type ISO8601DateTimeUTC =
32+ AppendSymbol ISO8601Date (AppendSymbol "T" (AppendSymbol ISO8601Time ISO8601UTC))
33+
34+type ISO8601TZ = "\\+[0-1][0-9]:[0-6][0-9]"
35+
36+type ISO8601DateTimeZoned =
37+ AppendSymbol ISO8601Date (AppendSymbol "T" (AppendSymbol ISO8601Time ISO8601TZ))
38+
39+-- regexes
40+type ISO8601DateRegex = 'TRegex ISO8601Date
41+
42+type ISO8601TimeRegex = 'TRegex ISO8601Time
43+
44+type ISO8601DateTimeRegex = 'TRegex ISO8601DateTime
45+
46+type ISO8601DateTimeRegexUTC = 'TRegex ISO8601DateTimeUTC
47+
48+type ISO8601DateTimeRegexZoned = 'TRegex ISO8601DateTimeZoned
49+
50+-- constraints
51+type IsDate = '[ISO8601DateRegex]
52+
53+type IsTime = '[ISO8601TimeRegex]
54+
55+type IsDateTime = '[ISO8601DateTimeRegex]
56+
57+type IsZonedDateTime = '[ISO8601DateTimeRegexZoned]
58+
59+type IsUTCDateTime = '[ISO8601DateTimeRegexUTC]
src/Data/Schematic/Instances.hs+4
@@ -4,6 +4,7 @@
4module Data.Schematic.Instances where
4module Data.Schematic.Instances where
5
5
6import Data.Scientific
6import Data.Scientific
7+import Data.Text (Text, pack)
7import Data.Vector as V
8import Data.Vector as V
8import Data.Vinyl
9import Data.Vinyl
9import Test.SmallCheck.Series
10import Test.SmallCheck.Series
@@ -21,3 +22,6 @@ instance Serial m a => Serial m (V.Vector a) where
21
22
22instance Monad m => Serial m Scientific where
23instance Monad m => Serial m Scientific where
23 series = scientific <$> series <*> series
24 series = scientific <$> series <*> series
25+
26+instance Monad m => Serial m Text where
27+ series = pack <$> series
src/Data/Schematic/JsonSchema.hsnew file+124
@@ -0,0 +1,124 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE OverloadedLabels #-}
4+{-# LANGUAGE TemplateHaskell #-}
5+
6+module Data.Schematic.JsonSchema
7+ ( toJsonSchema
8+ , toJsonSchema'
9+ ) where
10+
11+import Control.Monad.State.Strict
12+import Data.Aeson as J
13+import Data.Foldable as F
14+import Data.HashMap.Strict as H
15+import Data.List as L
16+import Data.List.NonEmpty as NE
17+import Data.Schematic.Schema as S
18+import Data.Set as Set
19+import Data.Singletons
20+import Data.Text
21+import Data.Traversable
22+import JSONSchema.Draft4.Schema as D4
23+import JSONSchema.Validator.Draft4 as D4
24+
25+
26+draft4 :: Text
27+draft4 = "http://json-schema.org/draft-04/schema#"
28+
29+textConstraint :: DemotedTextConstraint -> State D4.Schema ()
30+textConstraint (DTEq n) = modify $ \s -> s
31+ { _schemaMinLength = pure $ fromIntegral n
32+ , _schemaMaxLength = pure $ fromIntegral n }
33+textConstraint (DTLe n) = modify $ \s -> s
34+ { _schemaMaxLength = pure . fromIntegral $ n }
35+textConstraint (DTLt n) =
36+ 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 }
40+textConstraint (DTGe n) = modify $ \s -> s
41+ { _schemaMinLength = pure . fromIntegral $ n }
42+textConstraint (DTRegex r) = modify $ \s -> s { _schemaPattern = pure r }
43+textConstraint (DTEnum ss) =
44+ let ss' = if F.length ss == 0 then [] else NE.fromList $ J.String <$> ss
45+ in modify $ \s -> s { _schemaEnum = pure ss' }
46+
47+numberConstraint :: DemotedNumberConstraint -> State D4.Schema ()
48+numberConstraint (DNLe n) = modify $ \s -> s
49+ { _schemaMaximum = pure . fromIntegral $ n }
50+numberConstraint (DNLt n) = modify $ \s -> s
51+ { _schemaMaximum = pure . fromIntegral $ n
52+ , _schemaExclusiveMaximum = pure True }
53+numberConstraint (DNGt n) = modify $ \s -> s
54+ { _schemaMinimum = pure . fromIntegral $ n
55+ , _schemaExclusiveMinimum = pure True }
56+numberConstraint (DNGe n) = modify $ \s -> s
57+ { _schemaMinimum = pure . fromIntegral $ n }
58+numberConstraint (DNEq n) = modify $ \s -> s
59+ { _schemaMinimum = pure $ fromIntegral n
60+ , _schemaMaximum = pure $ fromIntegral n }
61+
62+arrayConstraint :: 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 }
75+
76+toJsonSchema
77+ :: forall proxy schema
78+ . SingI schema
79+ => proxy (schema :: S.Schema)
80+ -> Maybe D4.Schema
81+toJsonSchema _ = do
82+ js <- toJsonSchema' $ fromSing (sing :: Sing schema)
83+ pure $ js { _schemaVersion = pure draft4 }
84+
85+toJsonSchema'
86+ :: DemotedSchema
87+ -> Maybe D4.Schema
88+toJsonSchema' = \case
89+ DSchemaText tcs ->
90+ pure $ execState (traverse_ textConstraint tcs) $ emptySchema
91+ { _schemaType = pure $ TypeValidatorString D4.SchemaString }
92+ DSchemaNumber ncs ->
93+ pure $ execState (traverse_ numberConstraint ncs) $ emptySchema
94+ { _schemaType = pure $ TypeValidatorString D4.SchemaNumber }
95+ DSchemaBoolean -> pure $ emptySchema
96+ { _schemaType = pure $ TypeValidatorString D4.SchemaBoolean }
97+ DSchemaObject objs -> do
98+ res <- for objs $ \(n,s) -> do
99+ s' <- toJsonSchema' s
100+ pure (n, s')
101+ let
102+ nonOpt = \case
103+ (_, DSchemaOptional _) -> False
104+ _ -> True
105+ pure $ emptySchema
106+ { _schemaType = pure $ TypeValidatorString D4.SchemaObject
107+ , _schemaRequired = pure $ Set.fromList $ fst <$> L.filter nonOpt objs
108+ , _schemaProperties = pure $ H.fromList res }
109+ DSchemaArray acs sch -> do
110+ res <- toJsonSchema' sch
111+ pure $ execState (traverse_ arrayConstraint acs) $ emptySchema
112+ { _schemaType = pure $ TypeValidatorString D4.SchemaArray
113+ , _schemaItems = pure $ ItemsObject res }
114+ DSchemaNull -> pure $ emptySchema
115+ { _schemaType = pure $ TypeValidatorString D4.SchemaNull }
116+ DSchemaOptional sch -> do
117+ snull <- toJsonSchema' DSchemaNull
118+ sres <- toJsonSchema' sch
119+ pure $ emptySchema { _schemaOneOf = pure (snull :| [sres]) }
120+ DSchemaUnion sch -> do
121+ schemaUnion <- traverse toJsonSchema' sch >>= \case
122+ [] -> Nothing
123+ x -> Just x
124+ pure $ emptySchema { _schemaAnyOf = pure $ NE.fromList schemaUnion }
src/Data/Schematic/Lens.hsnew file+207
@@ -0,0 +1,207 @@
1+{-# LANGUAGE UndecidableSuperClasses #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE AllowAmbiguousTypes #-}
4+{-# LANGUAGE InstanceSigs #-}
5+
6+module Data.Schematic.Lens
7+ ( FIndex
8+ , FElem(..)
9+ , FImage
10+ , FSubset(..)
11+ , obj
12+ , arr
13+ , uni
14+ , txt
15+ , num
16+ , opt
17+ , bln
18+ , textRepr
19+ , numberRepr
20+ , boolRepr
21+ , arrayRepr
22+ , objectRepr
23+ , optionalRepr
24+ ) where
25+
26+import Data.Profunctor
27+import Data.Schematic.Schema
28+import Data.Scientific
29+import Data.Singletons
30+import Data.Text
31+import Data.Union
32+import Data.Vector as V
33+import Data.Vinyl
34+import Data.Vinyl.Functor
35+import Data.Vinyl.TypeLevel (Nat(..))
36+import GHC.TypeLits (Symbol, KnownSymbol)
37+
38+
39+-- | A partial relation that gives the index of a value in a list.
40+type family FIndex (r :: Symbol) (rs :: [(Symbol, Schema)]) :: Nat where
41+ FIndex r ( '(r, s) ': rs) = 'Z
42+ FIndex r ( s ': rs) = 'S (FIndex r rs)
43+
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+
52+class i ~ FIndex fn rs => FElem (fn :: Symbol) (rs :: [(Symbol, Schema)]) (i :: Nat) where
53+ type ByField fn rs i :: Schema
54+ flens :: Flens fn f g rs i
55+
56+ -- | For Vinyl users who are not using the @lens@ package, we provide a getter.
57+ fget :: FGetter fn f rs i
58+
59+ -- | For Vinyl users who are not using the @lens@ package, we also provide a
60+ -- setter. In general, it will be unambiguous what field is being written to,
61+ -- and so we do not take a proxy argument here.
62+ fput
63+ :: f '(fn, ByField fn rs i)
64+ -> Rec f rs
65+ -> Rec f rs
66+
67+instance FElem fn ('(fn, r) ': rs) 'Z where
68+ type ByField fn ('(fn, r) ': rs) 'Z = r
69+
70+ flens f (x :& xs) = fmap (:& xs) (f x)
71+ {-# INLINE flens #-}
72+
73+ fget = getConst . flens Const
74+ {-# INLINE fget #-}
75+
76+ fput y = getIdentity . flens (\_ -> Identity y)
77+ {-# INLINE fput #-}
78+
79+instance (FIndex r (s ': rs) ~ 'S i, FElem r rs i) => FElem r (s ': rs) ('S i) where
80+ type ByField r (s ': rs) ('S i) = ByField r rs i
81+
82+ flens f (x :& xs) = fmap (x :&) (flens f xs)
83+ {-# INLINE flens #-}
84+
85+ fget = getConst . flens Const
86+ {-# INLINE fget #-}
87+
88+ fput y = getIdentity . flens (\_ -> Identity y)
89+ {-# INLINE fput #-}
90+
91+-- This is an internal convenience helpers stolen from the @lens@ library.
92+lens
93+ :: Functor f
94+ => (t -> s)
95+ -> (t -> a -> b)
96+ -> (s -> f a)
97+ -> t
98+ -> f b
99+lens sa sbt afb s = fmap (sbt s) $ afb (sa s)
100+{-# INLINE lens #-}
101+
102+type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
103+
104+type Iso' s a = Iso s s a a
105+
106+iso
107+ :: (s -> a) -> (b -> t)
108+ -> Iso s t a b
109+iso sa bt = dimap sa (fmap bt)
110+{-# INLINE iso #-}
111+
112+-- | A partial relation that gives the indices of a sublist in a larger list.
113+type family FImage (rs :: [(Symbol, Schema)]) (ss :: [(Symbol, Schema)]) :: [Nat] where
114+ FImage '[] ss = '[]
115+ FImage ('(fn,s) ': rs) ss = FIndex fn ss ': FImage rs ss
116+
117+class is ~ FImage rs ss
118+ => FSubset (rs :: [(Symbol, Schema)]) (ss :: [(Symbol, Schema)]) is where
119+ -- | This is a lens into a slice of the larger record. Morally, we have:
120+ --
121+ -- > fsubset :: Lens' (Rec FieldRepr ss) (Rec FieldRepr rs)
122+ fsubset
123+ :: Functor g
124+ => (Rec f rs -> g (Rec f rs))
125+ -> Rec f ss
126+ -> g (Rec f ss)
127+
128+ -- | The getter of the 'fsubset' lens is 'fcast', which takes a larger record
129+ -- to a smaller one by forgetting fields.
130+ fcast
131+ :: Rec f ss
132+ -> Rec f rs
133+ fcast = getConst . fsubset Const
134+ {-# INLINE fcast #-}
135+
136+ -- | The setter of the 'fsubset' lens is 'freplace', which allows a slice of
137+ -- a record to be replaced with different values.
138+ freplace
139+ :: Rec f rs
140+ -> Rec f ss
141+ -> Rec f ss
142+ freplace rs = getIdentity . fsubset (\_ -> Identity rs)
143+ {-# INLINE freplace #-}
144+
145+instance FSubset '[] ss '[] where
146+ fsubset = lens (const RNil) const
147+
148+instance
149+ ( ByField fn ss i ~ s
150+ , FElem fn ss i
151+ , FSubset rs ss is) => FSubset ( '(fn,s) ': rs) ss (i ': is) where
152+ fsubset = lens (\ss -> fget @fn ss :& fcast ss) set
153+ where
154+ set :: Rec f ss -> Rec f ( '(fn,s) ': rs) -> Rec f ss
155+ set ss (r :& rs) = fput r $ freplace rs ss
156+
157+-- A bunch of @Iso@morphisms
158+textRepr
159+ :: (KnownSymbol fn, SingI cs)
160+ => Iso' (FieldRepr '(fn, ('SchemaText cs))) Text
161+textRepr = iso (\(FieldRepr (ReprText t)) -> t) (FieldRepr . ReprText)
162+
163+numberRepr
164+ :: (KnownSymbol fn, SingI cs)
165+ => Iso' (FieldRepr '(fn, ('SchemaNumber cs))) Scientific
166+numberRepr = iso (\(FieldRepr (ReprNumber n)) -> n) (FieldRepr . ReprNumber)
167+
168+boolRepr
169+ :: (KnownSymbol fn)
170+ => Iso' (FieldRepr '(fn, 'SchemaBoolean)) Bool
171+boolRepr = iso (\(FieldRepr (ReprBoolean b)) -> b) (FieldRepr . ReprBoolean)
172+
173+arrayRepr
174+ :: (KnownSymbol fn, SingI cs, SingI schema)
175+ => Iso' (FieldRepr '(fn, ('SchemaArray cs schema))) (V.Vector (JsonRepr schema))
176+arrayRepr = iso (\(FieldRepr (ReprArray a)) -> a) (FieldRepr . ReprArray)
177+
178+objectRepr
179+ :: (KnownSymbol fn, SingI fields)
180+ => Iso' (FieldRepr '(fn, ('SchemaObject fields))) (Rec FieldRepr fields)
181+objectRepr = iso (\(FieldRepr (ReprObject o)) -> o) (FieldRepr . ReprObject)
182+
183+optionalRepr
184+ :: (KnownSymbol fn, SingI schema)
185+ => Iso' (FieldRepr '(fn, ('SchemaOptional schema))) (Maybe (JsonRepr schema))
186+optionalRepr = iso (\(FieldRepr (ReprOptional r)) -> r) (FieldRepr . ReprOptional)
187+
188+obj :: Iso' (JsonRepr ('SchemaObject fields)) (Rec FieldRepr fields)
189+obj = 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+64−40
@@ -1,14 +1,19 @@
1{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE CPP #-}
2−{-# LANGUAGE TemplateHaskell #-}
3+{-# LANGUAGE TemplateHaskell #-}
3
4
4module Data.Schematic.Migration where
5module Data.Schematic.Migration where
5
6
6import Data.Kind
7import Data.Kind
8+import Data.Schematic.DSL
9+import Data.Schematic.Lens
7import Data.Schematic.Path
10import Data.Schematic.Path
8import Data.Schematic.Schema
11import Data.Schematic.Schema
9−import Data.Singletons.Prelude hiding (All)
12+import Data.Singletons.Prelude hiding ((:.), All)
10import Data.Singletons.TypeLits
13import Data.Singletons.TypeLits
14+import Data.Tagged
11−-- import Data.Vinyl hiding (Dict)
15+import Data.Vinyl
16+import Data.Vinyl.Functor
12
17
13
18
14data Path
19data Path
@@ -16,7 +21,7 @@ data Path
16 | PTraverse -- traverse into the array
21 | PTraverse -- traverse into the array
17
22
18data instance Sing (p :: Path) where
23data instance Sing (p :: Path) where
19− SPKey :: KnownSymbol s => Sing s -> Sing ('PKey s)
24+ SPKey :: Sing s -> Sing ('PKey s)
20 SPTraverse :: Sing 'PTraverse
25 SPTraverse :: Sing 'PTraverse
21
26
22instance KnownSymbol s => SingI ('PKey s) where
27instance KnownSymbol s => SingI ('PKey s) where
@@ -38,8 +43,8 @@ type family SchemaByKey (fs :: [(Symbol, Schema)]) (s :: Symbol) :: Schema where
38 SchemaByKey ( '(a, s) ': tl) fn = SchemaByKey tl fn
43 SchemaByKey ( '(a, s) ': tl) fn = SchemaByKey tl fn
39
44
40type family DeleteKey (acc :: [(Symbol, Schema)]) (fn :: Symbol) (fs :: [(Symbol, Schema)]) :: [(Symbol, Schema)] where
45type family DeleteKey (acc :: [(Symbol, Schema)]) (fn :: Symbol) (fs :: [(Symbol, Schema)]) :: [(Symbol, Schema)] where
41− DeleteKey acc fn ('(fn, a) ': tl) = acc :++ tl
46+ DeleteKey acc fn ('(fn, a) ': tl) = acc ++ tl
42− DeleteKey acc fn (fna ': tl) = acc :++ (fna ': tl)
47+ DeleteKey acc fn (fna ': tl) = acc ++ (fna ': tl)
43
48
44type family UpdateKey
49type family UpdateKey
45 (fn :: Symbol)
50 (fn :: Symbol)
@@ -80,6 +85,9 @@ type family SchemaByRevision (r :: Revision) (vd :: Versioned) :: Schema where
80 SchemaByRevision r ('Versioned s (m ': ms)) =
85 SchemaByRevision r ('Versioned s (m ': ms)) =
81 SchemaByRevision r ('Versioned (Snd (ApplyMigration m s)) ms)
86 SchemaByRevision r ('Versioned (Snd (ApplyMigration m s)) ms)
82
87
88+type family InitialSchema (v :: Versioned) = (s :: Schema) where
89+ InitialSchema ('Versioned s ms) = s
90+
83type family ElemOf (e :: k) (l :: [(a,k)]) :: Constraint where
91type family ElemOf (e :: k) (l :: [(a,k)]) :: Constraint where
84 ElemOf e '[] = 'True ~ 'False
92 ElemOf e '[] = 'True ~ 'False
85 ElemOf e ( '(a, e) ': es) = ()
93 ElemOf e ( '(a, e) ': es) = ()
@@ -87,32 +95,26 @@ type family ElemOf (e :: k) (l :: [(a,k)]) :: Constraint where
87
95
88-- | Extracts revision/schema pairs from @Versioned@ in reverse order.
96-- | Extracts revision/schema pairs from @Versioned@ in reverse order.
89type family AllVersions (vd :: Versioned) :: [(Revision, Schema)] where
97type family AllVersions (vd :: Versioned) :: [(Revision, Schema)] where
90− AllVersions ('Versioned s ms) = AllVersions' '[ '("initial", s) ] ms
98+ AllVersions ('Versioned s ms) = Reverse (AllVersions' '[ '("initial", s) ] ms)
91
99
92−type family AllVersions' (acc :: [(Revision, Schema)]) (ms :: [Migration]) = (r :: [(Revision, Schema)]) where
100+type family AllVersions' (acc :: [(Revision, Schema)]) (ms :: [Migration])
101+ = (r :: [(Revision, Schema)]) where
93 AllVersions' acc '[] = acc
102 AllVersions' acc '[] = acc
94 AllVersions' ( '(rh, sh) ': tl ) (m ': ms) =
103 AllVersions' ( '(rh, sh) ': tl ) (m ': ms) =
95− AllVersions' ( ApplyMigration m sh ': tl ) ms
104+ AllVersions' ( '(rh, sh) ': ApplyMigration m sh ': tl ) ms
96
105
97type family TopVersion (rs :: [(Revision, Schema)]) :: Schema where
106type family TopVersion (rs :: [(Revision, Schema)]) :: Schema where
98 TopVersion ( '(rh, sh) ': tl) = sh
107 TopVersion ( '(rh, sh) ': tl) = sh
99
108
100−class MigrateSchema (a :: Schema) (b :: Schema) where
101− migrate :: JsonRepr a -> JsonRepr b
102−
103−instance MigrateSchema a a where
104− migrate = id
105−
106data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol
109data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol
107
110
108data instance Sing (a :: Action) where
111data instance Sing (a :: Action) where
109 SAddKey
112 SAddKey
110− :: (SingI n, SingI s)
111− => Sing n
113+ :: Sing n
112 -> Sing s
114 -> Sing s
113 -> Sing ('AddKey n s)
115 -> Sing ('AddKey n s)
114− SUpdate :: (SingI s) => Sing s -> Sing ('Update s)
116+ SUpdate :: Sing s -> Sing ('Update s)
115− SDeleteKey :: KnownSymbol s => Sing s -> Sing ('DeleteKey s)
117+ SDeleteKey :: Sing s -> Sing ('DeleteKey s)
116
118
117-- | User-supplied atomic difference between schemas.
119-- | User-supplied atomic difference between schemas.
118-- Migrations can consists of many differences.
120-- Migrations can consists of many differences.
@@ -120,8 +122,7 @@ data Diff = Diff [Path] Action
120
122
121data instance Sing (diff :: Diff) where
123data instance Sing (diff :: Diff) where
122 SDiff
124 SDiff
123− :: (SingI jp, SingI a)
124− => Sing (jp :: [Path])
125+ :: Sing (jp :: [Path])
125 -> Sing (a :: Action)
126 -> Sing (a :: Action)
126 -> Sing ('Diff jp a)
127 -> Sing ('Diff jp a)
127
128
@@ -132,8 +133,7 @@ data Migration = Migration Revision [Diff]
132
133
133data instance Sing (m :: Migration) where
134data instance Sing (m :: Migration) where
134 SMigration
135 SMigration
135− :: (KnownSymbol r, SingI ds)
136− => Sing r
136+ :: Sing r
137 -> Sing ds
137 -> Sing ds
138 -> Sing ('Migration r ds)
138 -> Sing ('Migration r ds)
139
139
@@ -141,23 +141,47 @@ data Versioned = Versioned Schema [Migration]
141
141
142data instance Sing (v :: Versioned) where
142data instance Sing (v :: Versioned) where
143 SVersioned
143 SVersioned
144− :: (SingI s, SingI ms)
145− => Sing (s :: Schema) -- base version
144+ :: Sing (s :: Schema) -- base version
146 -> Sing (ms :: [Migration]) -- a bunch of migrations
145 -> Sing (ms :: [Migration]) -- a bunch of migrations
147 -> Sing ('Versioned s ms)
146 -> Sing ('Versioned s ms)
148
147
149−-- type SchemaExample
148+type DataMigration s m h = Tagged s (JsonRepr h -> m (JsonRepr s))
149+
150+data MList :: (Type -> Type) -> [Schema] -> Type where
151+ MNil :: (Monad m, SingI s, TopLevel s) => MList m '[s]
152+ (:&&)
153+ :: (TopLevel s, SingI s)
154+ => DataMigration s m h
155+ -> MList m (h ': tl)
156+ -> MList m (s ': h ': tl)
157+
158+infixr 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
150−-- = 'SchemaObject
173+ pure $ withRepr @('SchemaObject fs) res
151−-- '[ '("foo", 'SchemaArray '[ 'AEq 1] ( 'SchemaNumber '[ 'NGt 10 ]))
174+
152−-- , '("bar", 'SchemaOptional ( 'SchemaText '[ 'TRegex "\\w+", 'TEnum '["foo", "bar"]]))]
175+shrinkObject
153−
176+ :: forall rs ss m
154−-- type VS =
177+ . ( Monad m, FSubset rs ss (FImage rs ss) )
155−-- 'Versioned SchemaExample
178+ => Tagged
156−-- '[ 'Migration "test_revision"
179+ ('SchemaObject rs)
157−-- '[ 'Diff '[ 'PKey "foo" ] ('Update ('SchemaText '[])) ] ]
180+ (JsonRepr ('SchemaObject ss) -> m (JsonRepr ('SchemaObject rs)))
158−
181+shrinkObject = Tagged $ \(ReprObject r) -> pure $ ReprObject $ fcast r
159−-- jsonExample :: JsonRepr (TopVersion (AllVersions VS))
182+
160−-- jsonExample = ReprObject $
183+type family MapSnd (l :: [(a,k)]) = (r :: [k]) where
161−-- FieldRepr (ReprText "foo")
184+ MapSnd '[] = '[]
162−-- :& FieldRepr (ReprOptional (Just (ReprText "bar")))
185+ MapSnd ( '(a, b) ': tl) = b ': MapSnd tl
163−-- :& RNil
186+
187+type MigrationList m vs = MList m (MapSnd (AllVersions vs))
src/Data/Schematic/Path.hs+6−17
@@ -1,9 +1,6 @@
1module Data.Schematic.Path where
1module Data.Schematic.Path where
2
2
3import Data.Foldable as F
3import Data.Foldable as F
4−import Data.Monoid
5−import Data.Schematic.Utils
6−import Data.Singletons
7import Data.Singletons.Prelude
4import Data.Singletons.Prelude
8import Data.Singletons.TypeLits
5import Data.Singletons.TypeLits
9import Data.Text as T
6import Data.Text as T
@@ -12,16 +9,8 @@ import Data.Text as T
12data PathSegment = Key Symbol | Ix Nat
9data PathSegment = Key Symbol | Ix Nat
13
10
14data instance Sing (jp :: PathSegment) where
11data instance Sing (jp :: PathSegment) where
15− SKey :: (KnownSymbol k, Known (Sing k)) => Sing (k :: Symbol) -> Sing ('Key k)
12+ SKey :: (SingI k) => Sing (k :: Symbol) -> Sing ('Key k)
16− SIx :: (KnownNat n, Known (Sing n)) => Sing (n :: Nat) -> Sing ('Ix n)
13+ SIx :: (SingI 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
14
26data DemotedPathSegment = DKey Text | DIx Integer
15data DemotedPathSegment = DKey Text | DIx Integer
27 deriving (Show)
16 deriving (Show)
@@ -35,10 +24,10 @@ demotePath = go []
35 where
24 where
36 go :: [DemotedPathSegment] -> Sing (ps :: [PathSegment]) -> [DemotedPathSegment]
25 go :: [DemotedPathSegment] -> Sing (ps :: [PathSegment]) -> [DemotedPathSegment]
37 go acc SNil = acc
26 go acc SNil = acc
38− go acc (SCons p ps) = go (acc ++ [demote p]) ps
27+ go acc (SCons p ps) = go (acc ++ [demotePathSeg p]) ps
39− demote :: Sing (ps :: PathSegment) -> DemotedPathSegment
28+ demotePathSeg :: Sing (ps :: PathSegment) -> DemotedPathSegment
40− demote (SKey s) = DKey $ T.pack $ symbolVal s
29+ demotePathSeg (SKey s) = DKey $ T.pack $ withKnownSymbol s $ symbolVal s
41− demote (SIx n) = DIx $ natVal n
30+ demotePathSeg (SIx n) = DIx $ withKnownNat n $ fromIntegral $ natVal n
42
31
43demotedPathToText :: [DemotedPathSegment] -> JSONPath
32demotedPathToText :: [DemotedPathSegment] -> JSONPath
44demotedPathToText = JSONPath . F.foldl' renderPathSegment ""
33demotedPathToText = JSONPath . F.foldl' renderPathSegment ""
src/Data/Schematic/Schema.hs+382−87
@@ -1,35 +1,36 @@
1{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE CPP #-}
2−{-# LANGUAGE OverloadedLists #-}
3+{-# LANGUAGE OverloadedLists #-}
3−{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE OverloadedStrings #-}
4{-# OPTIONS_GHC -fprint-explicit-kinds #-}
5{-# OPTIONS_GHC -fprint-explicit-kinds #-}
5
6
6module Data.Schematic.Schema where
7module Data.Schematic.Schema where
7
8
8−import Control.Applicative
9+import Control.Applicative ((<|>))
9−import Control.Monad
10+import Control.Monad
10−import Data.Aeson as J
11+import Data.Aeson as J
11−import Data.Aeson.Types as J
12+import Data.Aeson.Types as J
12−import Data.HashMap.Strict as H
13+import Data.HashMap.Strict as H
13−import Data.Kind
14+import Data.Kind
14−import Data.Maybe
15+import Data.Maybe
16+import Data.Schematic.Generator
15−import Data.Schematic.Instances ()
17+import Data.Schematic.Instances ()
16−
17−import Data.Scientific
18+import Data.Scientific
18−import Data.Singletons.Prelude.List hiding (All)
19+import Data.Singletons.Prelude.List hiding (All, Union)
19−import Data.Singletons.TH
20+import Data.Singletons.TH
20−import Data.Singletons.TypeLits
21+import Data.Singletons.TypeLits
21−import Data.Text as T
22+import Data.Text as T
23+import Data.Union
22−import Data.Vector as V
24+import Data.Vector as V
23−import Data.Vinyl hiding (Dict)
25+import Data.Vinyl hiding (Dict)
24−import Data.Vinyl.TypeLevel hiding (Nat)
26+import qualified Data.Vinyl.TypeLevel as V
27+import GHC.Exts
25−import GHC.Generics (Generic)
28+import GHC.Generics (Generic)
29+import GHC.TypeLits
30+ (SomeNat(..), SomeSymbol(..), someNatVal, someSymbolVal)
26−import Prelude as P
31+import Prelude as P
27−import Test.SmallCheck.Series
32+import Test.SmallCheck.Series
28−
33+
29−
30−type family All (c :: k -> Constraint) (s :: [k]) :: Constraint where
31− All c '[] = ()
32− All c (a ': as) = (c a, All c as)
33
34
34type family CRepr (s :: Schema) :: Type where
35type family CRepr (s :: Schema) :: Type where
35 CRepr ('SchemaText cs) = TextConstraint
36 CRepr ('SchemaText cs) = TextConstraint
@@ -39,77 +40,235 @@ type family CRepr (s :: Schema) :: Type where
39
40
40data TextConstraint
41data TextConstraint
41 = TEq Nat
42 = TEq Nat
43+ | TLt Nat
42 | TLe Nat
44 | TLe Nat
43 | TGt Nat
45 | TGt Nat
46+ | TGe Nat
44 | TRegex Symbol
47 | TRegex Symbol
45 | TEnum [Symbol]
48 | TEnum [Symbol]
46 deriving (Generic)
49 deriving (Generic)
47
50
51+instance SingKind TextConstraint where
52+ type Demote TextConstraint = DemotedTextConstraint
53+ 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)
59+ STRegex s -> withKnownSymbol s (DTRegex $ T.pack $ symbolVal s)
60+ STEnum s -> let
61+ d :: Sing (s :: [Symbol]) -> [Text]
62+ d SNil = []
63+ d (SCons ss@SSym fs) = T.pack (symbolVal ss) : d fs
64+ in DTEnum $ d s
65+ toSing = \case
66+ DTEq n -> case someNatVal n of
67+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (STEq (SNat :: Sing n))
68+ Nothing -> error "Negative singleton nat"
69+ DTLt n -> case someNatVal n of
70+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLt (SNat :: Sing n))
71+ Nothing -> error "Negative singleton nat"
72+ DTLe n -> case someNatVal n of
73+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLe (SNat :: Sing n))
74+ Nothing -> error "Negative singleton nat"
75+ DTGt n -> case someNatVal n of
76+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGt (SNat :: Sing n))
77+ Nothing -> error "Negative singleton nat"
78+ DTGe n -> case someNatVal n of
79+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGe (SNat :: Sing n))
80+ Nothing -> error "Negative singleton nat"
81+ DTRegex s -> case someSymbolVal (T.unpack s) of
82+ SomeSymbol (_ :: Proxy n) -> SomeSing (STRegex (SSym :: Sing n))
83+ DTEnum ss -> case toSing ss of
84+ SomeSing l -> SomeSing (STEnum l)
85+
86+data DemotedTextConstraint
87+ = DTEq Integer
88+ | DTLt Integer
89+ | DTLe Integer
90+ | DTGt Integer
91+ | DTGe Integer
92+ | DTRegex Text
93+ | DTEnum [Text]
94+ deriving (Generic, Eq, Show)
95+
48data instance Sing (tc :: TextConstraint) where
96data instance Sing (tc :: TextConstraint) where
49− STEq :: (KnownNat n) => Sing n -> Sing ('TEq n)
97+ STEq :: Sing n -> Sing ('TEq n)
98+ STLt :: Sing n -> Sing ('TLt n)
50− STLe :: (KnownNat n) => Sing n -> Sing ('TLe n)
99+ STLe :: Sing n -> Sing ('TLe n)
51− STGt :: (KnownNat n) => Sing n -> Sing ('TGt n)
100+ STGt :: Sing n -> Sing ('TGt n)
101+ STGe :: Sing n -> Sing ('TGe n)
52− STRegex :: (KnownSymbol s, SingI s) => Sing s -> Sing ('TRegex s)
102+ STRegex :: Sing s -> Sing ('TRegex s)
53− STEnum :: (All KnownSymbol ss, SingI ss) => Sing ss -> Sing ('TEnum ss)
103+ STEnum :: Sing ss -> Sing ('TEnum ss)
54
104
55instance (KnownNat n) => SingI ('TEq n) where sing = STEq sing
105instance (KnownNat n) => SingI ('TEq n) where sing = STEq sing
56instance (KnownNat n) => SingI ('TGt n) where sing = STGt sing
106instance (KnownNat n) => SingI ('TGt n) where sing = STGt sing
107+instance (KnownNat n) => SingI ('TGe n) where sing = STGe sing
108+instance (KnownNat n) => SingI ('TLt n) where sing = STLt sing
57instance (KnownNat n) => SingI ('TLe n) where sing = STLe sing
109instance (KnownNat n) => SingI ('TLe n) where sing = STLe sing
58instance (KnownSymbol s, SingI s) => SingI ('TRegex s) where sing = STRegex sing
110instance (KnownSymbol s, SingI s) => SingI ('TRegex s) where sing = STRegex sing
59−instance (All KnownSymbol ss, SingI ss) => SingI ('TEnum ss) where sing = STEnum sing
111+instance (SingI ss) => SingI ('TEnum ss) where sing = STEnum sing
60
112
61instance Eq (Sing ('TEq n)) where _ == _ = True
113instance Eq (Sing ('TEq n)) where _ == _ = True
114+instance Eq (Sing ('TLt n)) where _ == _ = True
62instance Eq (Sing ('TLe n)) where _ == _ = True
115instance Eq (Sing ('TLe n)) where _ == _ = True
63instance Eq (Sing ('TGt n)) where _ == _ = True
116instance Eq (Sing ('TGt n)) where _ == _ = True
117+instance Eq (Sing ('TGe n)) where _ == _ = True
64instance Eq (Sing ('TRegex t)) where _ == _ = True
118instance Eq (Sing ('TRegex t)) where _ == _ = True
65instance Eq (Sing ('TEnum ss)) where _ == _ = True
119instance Eq (Sing ('TEnum ss)) where _ == _ = True
66
120
67data NumberConstraint
121data NumberConstraint
68 = NLe Nat
122 = NLe Nat
123+ | NLt Nat
69 | NGt Nat
124 | NGt Nat
125+ | NGe Nat
70 | NEq Nat
126 | NEq Nat
71 deriving (Generic)
127 deriving (Generic)
72
128
129+data DemotedNumberConstraint
130+ = DNLe Integer
131+ | DNLt Integer
132+ | DNGt Integer
133+ | DNGe Integer
134+ | DNEq Integer
135+ deriving (Generic, Eq, Show)
136+
73data instance Sing (nc :: NumberConstraint) where
137data instance Sing (nc :: NumberConstraint) where
74− SNEq :: KnownNat n => Sing n -> Sing ('NEq n)
138+ SNEq :: Sing n -> Sing ('NEq n)
75− SNGt :: KnownNat n => Sing n -> Sing ('NGt n)
139+ SNGt :: Sing n -> Sing ('NGt n)
140+ SNGe :: Sing n -> Sing ('NGe n)
141+ SNLt :: Sing n -> Sing ('NLt n)
76− SNLe :: KnownNat n => Sing n -> Sing ('NLe n)
142+ SNLe :: Sing n -> Sing ('NLe n)
77
143
78instance KnownNat n => SingI ('NEq n) where sing = SNEq sing
144instance KnownNat n => SingI ('NEq n) where sing = SNEq sing
79instance KnownNat n => SingI ('NGt n) where sing = SNGt sing
145instance KnownNat n => SingI ('NGt n) where sing = SNGt sing
146+instance KnownNat n => SingI ('NGe n) where sing = SNGe sing
147+instance KnownNat n => SingI ('NLt n) where sing = SNLt sing
80instance KnownNat n => SingI ('NLe n) where sing = SNLe sing
148instance KnownNat n => SingI ('NLe n) where sing = SNLe sing
81
149
82instance Eq (Sing ('NEq n)) where _ == _ = True
150instance Eq (Sing ('NEq n)) where _ == _ = True
151+instance Eq (Sing ('NLt n)) where _ == _ = True
83instance Eq (Sing ('NLe n)) where _ == _ = True
152instance Eq (Sing ('NLe n)) where _ == _ = True
84instance Eq (Sing ('NGt n)) where _ == _ = True
153instance Eq (Sing ('NGt n)) where _ == _ = True
154+instance Eq (Sing ('NGe n)) where _ == _ = True
155+
156+instance SingKind NumberConstraint where
157+ type Demote NumberConstraint = DemotedNumberConstraint
158+ 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)
164+ toSing = \case
165+ DNEq n -> case someNatVal n of
166+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNEq (SNat :: Sing n))
167+ Nothing -> error "Negative singleton nat"
168+ DNGt n -> case someNatVal n of
169+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGt (SNat :: Sing n))
170+ Nothing -> error "Negative singleton nat"
171+ DNGe n -> case someNatVal n of
172+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGe (SNat :: Sing n))
173+ Nothing -> error "Negative singleton nat"
174+ DNLt n -> case someNatVal n of
175+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLt (SNat :: Sing n))
176+ Nothing -> error "Negative singleton nat"
177+ DNLe n -> case someNatVal n of
178+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLe (SNat :: Sing n))
179+ Nothing -> error "Negative singleton nat"
85
180
86data ArrayConstraint
181data ArrayConstraint
87 = AEq Nat
182 = AEq Nat
183+ | AGt Nat
184+ | AGe Nat
185+ | ALt Nat
186+ | ALe Nat
88 deriving (Generic)
187 deriving (Generic)
89
188
189+data DemotedArrayConstraint
190+ = DAEq Integer
191+ | DAGt Integer
192+ | DAGe Integer
193+ | DALt Integer
194+ | DALe Integer
195+ deriving (Generic, Eq, Show)
196+
90data instance Sing (ac :: ArrayConstraint) where
197data instance Sing (ac :: ArrayConstraint) where
91− SAEq :: KnownNat n => Sing n -> Sing ('AEq n)
198+ 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)
92
203
93instance KnownNat n => SingI ('AEq n) where sing = SAEq sing
204instance 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
94
209
95instance Eq (Sing ('AEq n)) where _ == _ = True
210instance 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
215+
216+instance SingKind ArrayConstraint where
217+ type Demote ArrayConstraint = DemotedArrayConstraint
218+ 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)
224+ toSing = \case
225+ DAEq n -> case someNatVal n of
226+ 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"
96
240
97data Schema
241data Schema
98 = SchemaText [TextConstraint]
242 = SchemaText [TextConstraint]
243+ | SchemaBoolean
99 | SchemaNumber [NumberConstraint]
244 | SchemaNumber [NumberConstraint]
100 | SchemaObject [(Symbol, Schema)]
245 | SchemaObject [(Symbol, Schema)]
101 | SchemaArray [ArrayConstraint] Schema
246 | SchemaArray [ArrayConstraint] Schema
102 | SchemaNull
247 | SchemaNull
103 | SchemaOptional Schema
248 | SchemaOptional Schema
249+ | SchemaUnion [Schema]
104 deriving (Generic)
250 deriving (Generic)
105
251
252+data DemotedSchema
253+ = DSchemaText [DemotedTextConstraint]
254+ | DSchemaNumber [DemotedNumberConstraint]
255+ | DSchemaBoolean
256+ | DSchemaObject [(Text, DemotedSchema)]
257+ | DSchemaArray [DemotedArrayConstraint] DemotedSchema
258+ | DSchemaNull
259+ | DSchemaOptional DemotedSchema
260+ | DSchemaUnion [DemotedSchema]
261+ deriving (Generic, Eq, Show)
262+
106data instance Sing (schema :: Schema) where
263data instance Sing (schema :: Schema) where
107− SSchemaText :: SingI tcs => Sing tcs -> Sing ('SchemaText tcs)
264+ SSchemaText :: Sing tcs -> Sing ('SchemaText tcs)
108− SSchemaNumber :: SingI ncs => Sing ncs -> Sing ('SchemaNumber ncs)
265+ SSchemaNumber :: Sing ncs -> Sing ('SchemaNumber ncs)
266+ SSchemaBoolean :: Sing 'SchemaBoolean
109− SSchemaArray :: (SingI acs, SingI schema) => Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)
267+ SSchemaArray :: Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)
110− SSchemaObject :: SingI fields => Sing fields -> Sing ('SchemaObject fields)
268+ SSchemaObject :: Sing fields -> Sing ('SchemaObject fields)
111− SSchemaOptional :: SingI s => Sing s -> Sing ('SchemaOptional s)
269+ SSchemaOptional :: Sing s -> Sing ('SchemaOptional s)
112 SSchemaNull :: Sing 'SchemaNull
270 SSchemaNull :: Sing 'SchemaNull
271+ SSchemaUnion :: Sing ss -> Sing ('SchemaUnion ss)
113
272
114instance SingI sl => SingI ('SchemaText sl) where
273instance SingI sl => SingI ('SchemaText sl) where
115 sing = SSchemaText sing
274 sing = SSchemaText sing
@@ -117,19 +276,52 @@ instance SingI sl => SingI ('SchemaNumber sl) where
117 sing = SSchemaNumber sing
276 sing = SSchemaNumber sing
118instance SingI 'SchemaNull where
277instance SingI 'SchemaNull where
119 sing = SSchemaNull
278 sing = SSchemaNull
279+instance SingI 'SchemaBoolean where
280+ sing = SSchemaBoolean
120instance (SingI ac, SingI s) => SingI ('SchemaArray ac s) where
281instance (SingI ac, SingI s) => SingI ('SchemaArray ac s) where
121 sing = SSchemaArray sing sing
282 sing = SSchemaArray sing sing
122instance SingI stl => SingI ('SchemaObject stl) where
283instance SingI stl => SingI ('SchemaObject stl) where
123 sing = SSchemaObject sing
284 sing = SSchemaObject sing
124instance SingI s => SingI ('SchemaOptional s) where
285instance SingI s => SingI ('SchemaOptional s) where
125 sing = SSchemaOptional sing
286 sing = SSchemaOptional sing
287+instance SingI s => SingI ('SchemaUnion s) where
288+ sing = SSchemaUnion sing
126
289
127instance Eq (Sing ('SchemaText cs)) where _ == _ = True
290instance Eq (Sing ('SchemaText cs)) where _ == _ = True
128instance Eq (Sing ('SchemaNumber cs)) where _ == _ = True
291instance Eq (Sing ('SchemaNumber cs)) where _ == _ = True
129instance Eq (Sing 'SchemaNull) where _ == _ = True
292instance Eq (Sing 'SchemaNull) where _ == _ = True
293+instance Eq (Sing 'SchemaBoolean) where _ == _ = True
130instance Eq (Sing ('SchemaArray as s)) where _ == _ = True
294instance Eq (Sing ('SchemaArray as s)) where _ == _ = True
131instance Eq (Sing ('SchemaObject cs)) where _ == _ = True
295instance Eq (Sing ('SchemaObject cs)) where _ == _ = True
132instance Eq (Sing ('SchemaOptional s)) where _ == _ = True
296instance Eq (Sing ('SchemaOptional s)) where _ == _ = True
297+instance Eq (Sing ('SchemaUnion s)) where _ == _ = True
298+
299+instance SingKind Schema where
300+ type Demote Schema = DemotedSchema
301+ fromSing = \case
302+ SSchemaText cs -> DSchemaText $ fromSing cs
303+ SSchemaNumber cs -> DSchemaNumber $ fromSing cs
304+ SSchemaBoolean -> DSchemaBoolean
305+ SSchemaArray cs s -> DSchemaArray (fromSing cs) (fromSing s)
306+ SSchemaOptional s -> DSchemaOptional $ fromSing s
307+ SSchemaNull -> DSchemaNull
308+ SSchemaObject cs -> DSchemaObject $ fromSing cs
309+ SSchemaUnion ss -> DSchemaUnion $ fromSing ss
310+ toSing = \case
311+ DSchemaText cs -> case toSing cs of
312+ SomeSing scs -> SomeSing $ SSchemaText scs
313+ DSchemaNumber cs -> case toSing cs of
314+ SomeSing scs -> SomeSing $ SSchemaNumber scs
315+ DSchemaBoolean -> SomeSing $ SSchemaBoolean
316+ DSchemaArray cs sch -> case (toSing cs, toSing sch) of
317+ (SomeSing scs, SomeSing ssch) -> SomeSing $ SSchemaArray scs ssch
318+ DSchemaOptional sch -> case toSing sch of
319+ SomeSing ssch -> SomeSing $ SSchemaOptional ssch
320+ DSchemaNull -> SomeSing SSchemaNull
321+ DSchemaObject cs -> case toSing cs of
322+ SomeSing scs -> SomeSing $ SSchemaObject scs
323+ DSchemaUnion ss -> case toSing ss of
324+ SomeSing sss -> SomeSing $ SSchemaUnion sss
133
325
134data FieldRepr :: (Symbol, Schema) -> Type where
326data FieldRepr :: (Symbol, Schema) -> Type where
135 FieldRepr
327 FieldRepr
@@ -137,6 +329,10 @@ data FieldRepr :: (Symbol, Schema) -> Type where
137 => JsonRepr schema
329 => JsonRepr schema
138 -> FieldRepr '(name, schema)
330 -> FieldRepr '(name, schema)
139
331
332+-- | Forgetful Functor Ufr
333+toJsonRepr :: FieldRepr '(fn, sch) -> JsonRepr sch
334+toJsonRepr (FieldRepr x) = x
335+
140knownFieldName
336knownFieldName
141 :: forall proxy (fieldName :: Symbol) schema
337 :: forall proxy (fieldName :: Symbol) schema
142 . KnownSymbol fieldName
338 . KnownSymbol fieldName
@@ -163,45 +359,36 @@ instance
163 => Serial m (FieldRepr '(name, schema)) where
359 => Serial m (FieldRepr '(name, schema)) where
164 series = FieldRepr <$> series
360 series = FieldRepr <$> series
165
361
362+type family USubsets (u :: [k]) :: Constraint where
363+ USubsets '[] = ()
364+ USubsets (h ': tl) = (USubset tl (h ': tl) (V.RImage tl (h ': tl)), USubsets tl)
365+
166data JsonRepr :: Schema -> Type where
366data JsonRepr :: Schema -> Type where
167 ReprText :: Text -> JsonRepr ('SchemaText cs)
367 ReprText :: Text -> JsonRepr ('SchemaText cs)
168 ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)
368 ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)
369+ ReprBoolean :: Bool -> JsonRepr 'SchemaBoolean
169 ReprNull :: JsonRepr 'SchemaNull
370 ReprNull :: JsonRepr 'SchemaNull
170 ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)
371 ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)
171 ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)
372 ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)
172 ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)
373 ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)
374+ ReprUnion :: Union JsonRepr (h ': tl) -> JsonRepr ('SchemaUnion (h ': tl))
173
375
174−instance Show (JsonRepr ('SchemaText cs)) where
175− show (ReprText t) = "ReprText " P.++ show t
176−
177−instance Show (JsonRepr ('SchemaNumber cs)) where
178− show (ReprNumber n) = "ReprNumber " P.++ show n
179−
180−instance Show (JsonRepr 'SchemaNull) where show _ = "ReprNull"
181−
182−instance Show (JsonRepr s) => Show (JsonRepr ('SchemaArray acs s)) where
183− show (ReprArray v) = "ReprArray " P.++ show v
184−
185−instance RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where
186− show (ReprObject fs) = "ReprObject " P.++ show fs
187−
188−instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where
189− show (ReprOptional s) = "ReprOptional " P.++ show s
190−
191−instance (Monad m, Serial m Text)
376+instance (Monad m, Serial m Text, SingI cs)
192 => Serial m (JsonRepr ('SchemaText cs)) where
377 => Serial m (JsonRepr ('SchemaText cs)) where
193− series = cons1 ReprText
378+ series = decDepth $ fmap ReprText $ textSeries $ fromSing (sing :: Sing cs)
194
379
195−instance (Monad m, Serial m Scientific)
380+instance (Monad m, Serial m Scientific, SingI cs)
196 => Serial m (JsonRepr ('SchemaNumber cs)) where
381 => Serial m (JsonRepr ('SchemaNumber cs)) where
197− series = cons1 ReprNumber
382+ series = decDepth $ fmap ReprNumber
383+ $ numberSeries $ fromSing (sing :: Sing cs)
198
384
199instance Monad m => Serial m (JsonRepr 'SchemaNull) where
385instance Monad m => Serial m (JsonRepr 'SchemaNull) where
200 series = cons0 ReprNull
386 series = cons0 ReprNull
201
387
202−instance (Serial m (V.Vector (JsonRepr s)))
388+instance (Serial m (JsonRepr s), Serial m (V.Vector (JsonRepr s)), SingI cs)
203 => Serial m (JsonRepr ('SchemaArray cs s)) where
389 => Serial m (JsonRepr ('SchemaArray cs s)) where
204− series = cons1 ReprArray
390+ series = decDepth $ fmap ReprArray
391+ $ arraySeries $ fromSing (sing :: Sing cs)
205
392
206instance (Serial m (JsonRepr s))
393instance (Serial m (JsonRepr s))
207 => Serial m (JsonRepr ('SchemaOptional s)) where
394 => Serial m (JsonRepr ('SchemaOptional s)) where
@@ -211,6 +398,39 @@ instance (Monad m, Serial m (Rec FieldRepr fs))
211 => Serial m (JsonRepr ('SchemaObject fs)) where
398 => Serial m (JsonRepr ('SchemaObject fs)) where
212 series = cons1 ReprObject
399 series = cons1 ReprObject
213
400
401+-- | Move to the union package
402+instance Show (JsonRepr ('SchemaText cs)) where
403+ show (ReprText t) = "ReprText " P.++ show t
404+
405+instance Show (JsonRepr ('SchemaNumber cs)) where
406+ show (ReprNumber n) = "ReprNumber " P.++ show n
407+
408+instance Show (JsonRepr 'SchemaBoolean) where
409+ show (ReprBoolean n) = "ReprBoolean " P.++ show n
410+
411+instance Show (JsonRepr 'SchemaNull) where show _ = "ReprNull"
412+
413+instance Show (JsonRepr s) => Show (JsonRepr ('SchemaArray acs s)) where
414+ show (ReprArray v) = "ReprArray " P.++ show v
415+
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
423+instance V.RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where
424+ show (ReprObject fs) = "ReprObject " P.++ show fs
425+#endif
426+
427+instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where
428+ show (ReprOptional s) = "ReprOptional " P.++ show s
429+
430+instance Show (Union JsonRepr (h ': tl))
431+ => Show (JsonRepr ('SchemaUnion (h ': tl))) where
432+ show (ReprUnion s) = "ReprUnion " P.++ show s
433+
214instance Eq (Rec FieldRepr fs) => Eq (JsonRepr ('SchemaObject fs)) where
434instance Eq (Rec FieldRepr fs) => Eq (JsonRepr ('SchemaObject fs)) where
215 ReprObject a == ReprObject b = a == b
435 ReprObject a == ReprObject b = a == b
216
436
@@ -220,6 +440,9 @@ instance Eq (JsonRepr ('SchemaText cs)) where
220instance Eq (JsonRepr ('SchemaNumber cs)) where
440instance Eq (JsonRepr ('SchemaNumber cs)) where
221 ReprNumber a == ReprNumber b = a == b
441 ReprNumber a == ReprNumber b = a == b
222
442
443+instance Eq (JsonRepr 'SchemaBoolean) where
444+ ReprBoolean a == ReprBoolean b = a == b
445+
223instance Eq (JsonRepr 'SchemaNull) where
446instance Eq (JsonRepr 'SchemaNull) where
224 ReprNull == ReprNull = True
447 ReprNull == ReprNull = True
225
448
@@ -229,6 +452,51 @@ instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaArray as s)) where
229instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaOptional s)) where
452instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaOptional s)) where
230 ReprOptional a == ReprOptional b = a == b
453 ReprOptional a == ReprOptional b = a == b
231
454
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+
232fromOptional
500fromOptional
233 :: SingI s
501 :: SingI s
234 => Sing ('SchemaOptional s)
502 => Sing ('SchemaOptional s)
@@ -236,49 +504,75 @@ fromOptional
236 -> Parser (Maybe (JsonRepr s))
504 -> Parser (Maybe (JsonRepr s))
237fromOptional _ = parseJSON
505fromOptional _ = parseJSON
238
506
507+parseUnion
508+ :: FromJSON (JsonRepr ('SchemaUnion ss))
509+ => sing (ss :: [Schema])
510+ -> Value
511+ -> Parser (JsonRepr ('SchemaUnion ss))
512+parseUnion _ val = parseJSON val
513+
514+instance FromJSON (Union JsonRepr '[]) where
515+ parseJSON = fail "empty union"
516+
517+instance (SingI a, FromJSON (Union JsonRepr as)) => FromJSON (Union JsonRepr (a ': as)) where
518+ parseJSON val = (This <$> parseJSON val)
519+ <|> (That <$> (parseJSON val :: Parser (Union JsonRepr as)))
520+
521+instance ToJSON (Union JsonRepr as) where
522+ toJSON (This fa) = toJSON fa
523+ toJSON (That u) = toJSON u
524+
239instance SingI schema => J.FromJSON (JsonRepr schema) where
525instance SingI schema => J.FromJSON (JsonRepr schema) where
240 parseJSON value = case sing :: Sing schema of
526 parseJSON value = case sing :: Sing schema of
241− SSchemaText _ -> withText "String" (pure . ReprText) value
527+ SSchemaText _ -> withText "String" (pure . ReprText) value
242− SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value
528+ SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value
529+ SSchemaBoolean -> ReprBoolean <$> parseJSON value
243− SSchemaNull -> case value of
530+ SSchemaNull -> case value of
244 J.Null -> pure ReprNull
531 J.Null -> pure ReprNull
245 _ -> typeMismatch "Null" value
532 _ -> typeMismatch "Null" value
246− so@(SSchemaOptional _) -> ReprOptional <$> fromOptional so value
533+ so@(SSchemaOptional s) -> withSingI s $ ReprOptional <$> fromOptional so value
534+ SSchemaArray sa sb -> withSingI sa $ withSingI sb
247− SSchemaArray _ _ -> withArray "Array" (fmap ReprArray . traverse parseJSON) value
535+ $ withArray "Array" (fmap ReprArray . traverse parseJSON) value
248− SSchemaObject fs -> do
536+ SSchemaObject fs -> do
249 let
537 let
250 demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (Rec FieldRepr s)
538 demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (Rec FieldRepr s)
251 demoteFields SNil _ = pure RNil
539 demoteFields SNil _ = pure RNil
252 demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do
540 demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do
253 let fieldName = T.pack $ symbolVal (Proxy @fn)
541 let fieldName = T.pack $ symbolVal (Proxy @fn)
254 fieldRepr <- case s of
542 fieldRepr <- case s of
543+ SSchemaText so -> case H.lookup fieldName h of
544+ Just v -> withSingI so $ FieldRepr <$> parseJSON v
545+ Nothing -> fail $ "No text field: " P.++ show fieldName
546+ SSchemaNumber so -> case H.lookup fieldName h of
547+ Just v -> withSingI so $ FieldRepr <$> parseJSON v
548+ Nothing -> fail $ "No number field: " P.++ show fieldName
255− SSchemaText _ -> case H.lookup fieldName h of
549+ SSchemaBoolean -> case H.lookup fieldName h of
256 Just v -> FieldRepr <$> parseJSON v
550 Just v -> FieldRepr <$> parseJSON v
257− Nothing -> fail "schematext"
551+ Nothing -> fail $ "No boolean field: " P.++ show fieldName
258− SSchemaNumber _ -> case H.lookup fieldName h of
259− Just v -> FieldRepr <$> parseJSON v
260− Nothing -> fail "schemanumber"
261 SSchemaNull -> case H.lookup fieldName h of
552 SSchemaNull -> case H.lookup fieldName h of
262 Just v -> FieldRepr <$> parseJSON v
553 Just v -> FieldRepr <$> parseJSON v
263− Nothing -> fail "schemanull"
554+ Nothing -> fail $ "No null field: " P.++ show fieldName
264− SSchemaArray _ _ -> case H.lookup fieldName h of
555+ SSchemaArray sa sb -> case H.lookup fieldName h of
265− Just v -> FieldRepr <$> parseJSON v
556+ Just v -> withSingI sa $ withSingI sb $ FieldRepr <$> parseJSON v
266− Nothing -> fail "schemaarray"
557+ Nothing -> fail $ "No array field: " P.++ show fieldName
267− SSchemaObject _ -> case H.lookup fieldName h of
558+ SSchemaObject so -> case H.lookup fieldName h of
268− Just v -> FieldRepr <$> parseJSON v
559+ Just v -> withSingI so $ FieldRepr <$> parseJSON v
269− Nothing -> fail "schemaobject"
560+ Nothing -> fail $ "No object field" P.++ show fieldName
270− SSchemaOptional _ -> case H.lookup fieldName h of
561+ SSchemaOptional so -> case H.lookup fieldName h of
271− Just v -> FieldRepr <$> parseJSON v
562+ Just v -> withSingI so $ FieldRepr <$> parseJSON v
272− Nothing -> fail "schemaoptional"
563+ Nothing -> withSingI so $ pure $ FieldRepr $ ReprOptional Nothing
564+ SSchemaUnion ss -> withSingI ss $ FieldRepr <$> parseUnion ss value
273 (fieldRepr :&) <$> demoteFields tl h
565 (fieldRepr :&) <$> demoteFields tl h
274 ReprObject <$> withObject "Object" (demoteFields fs) value
566 ReprObject <$> withObject "Object" (demoteFields fs) value
567+ SSchemaUnion ss -> parseUnion ss value
275
568
276instance J.ToJSON (JsonRepr a) where
569instance J.ToJSON (JsonRepr a) where
277 toJSON ReprNull = J.Null
570 toJSON ReprNull = J.Null
571+ toJSON (ReprBoolean b) = J.Bool b
278 toJSON (ReprText t) = J.String t
572 toJSON (ReprText t) = J.String t
279 toJSON (ReprNumber n) = J.Number n
573 toJSON (ReprNumber n) = J.Number n
280 toJSON (ReprOptional s) = case s of
574 toJSON (ReprOptional s) = case s of
281− Just v -> toJSON v
575+ Just v -> toJSON v
282 Nothing -> J.Null
576 Nothing -> J.Null
283 toJSON (ReprArray v) = J.Array $ toJSON <$> v
577 toJSON (ReprArray v) = J.Array $ toJSON <$> v
284 toJSON (ReprObject r) = J.Object . H.fromList . fold $ r
578 toJSON (ReprObject r) = J.Object . H.fromList . fold $ r
@@ -291,6 +585,7 @@ instance J.ToJSON (JsonRepr a) where
291 fold = \case
585 fold = \case
292 RNil -> []
586 RNil -> []
293 fr@(FieldRepr _) :& tl -> (extract fr) : fold tl
587 fr@(FieldRepr _) :& tl -> (extract fr) : fold tl
588+ toJSON (ReprUnion u) = toJSON u
294
589
295class FalseConstraint a
590class FalseConstraint a
296
591
src/Data/Schematic/Schema.hs-bootnew file+95
@@ -0,0 +1,95 @@
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.hsdeleted−42
@@ -1,42 +0,0 @@
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+153−25
@@ -2,20 +2,24 @@ module Data.Schematic.Validation where
2
2
3import Control.Monad
3import Control.Monad
4import Control.Monad.Validation
4import Control.Monad.Validation
5+import Data.Aeson
6+import Data.Aeson.Types
5import Data.Foldable
7import Data.Foldable
6import Data.Functor.Identity
8import Data.Functor.Identity
7import Data.Monoid
9import Data.Monoid
8import Data.Schematic.Path
10import Data.Schematic.Path
9import Data.Schematic.Schema
11import Data.Schematic.Schema
10−import Data.Schematic.Utils ()
11import Data.Scientific
12import Data.Scientific
12import Data.Singletons.Prelude
13import Data.Singletons.Prelude
13import Data.Singletons.TypeLits
14import Data.Singletons.TypeLits
14import Data.Text as T
15import Data.Text as T
16+import Data.Traversable
17+import Data.Union
15import Data.Vector as V
18import Data.Vector as V
16import Data.Vinyl
19import Data.Vinyl
20+import Data.Vinyl.TypeLevel
17import Prelude as P
21import Prelude as P
18−import Text.Regex
22+import Text.Regex.TDFA
19
23
20
24
21type Validation a = ValidationT ErrorMap Identity a
25type Validation a = ValidationT ErrorMap Identity a
@@ -26,7 +30,11 @@ data ParseResult a
26 = Valid a
30 = Valid a
27 | DecodingError Text -- static
31 | DecodingError Text -- static
28 | ValidationError ErrorMap -- runtime
32 | ValidationError ErrorMap -- runtime
29− deriving (Show, Eq, Functor)
33+ deriving (Show, Eq, Functor, Foldable, Traversable)
34+
35+instance (TopLevel a, SingI a, FromJSON (JsonRepr a))
36+ => FromJSON (ParseResult (JsonRepr a)) where
37+ parseJSON = pure . parseAndValidateJson @a
30
38
31isValid :: ParseResult a -> Bool
39isValid :: ParseResult a -> Bool
32isValid (Valid _) = True
40isValid (Valid _) = True
@@ -48,30 +56,44 @@ validateTextConstraint
48validateTextConstraint (JSONPath path) t = \case
56validateTextConstraint (JSONPath path) t = \case
49 STEq n -> do
57 STEq n -> do
50 let
58 let
51− nlen = natVal n
59+ nlen = withKnownNat n $ natVal n
52 predicate = nlen == (fromIntegral $ T.length t)
60 predicate = nlen == (fromIntegral $ T.length t)
61+ errMsg = "length should be == " <> T.pack (show nlen)
62+ warn = vWarning $ mmSingleton path (pure errMsg)
63+ unless predicate warn
64+ STLt n -> do
65+ let
66+ nlen = withKnownNat n $ natVal n
67+ predicate = nlen > (fromIntegral $ T.length t)
53− errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)
68+ errMsg = "length should be < " <> T.pack (show nlen)
54 warn = vWarning $ mmSingleton path (pure errMsg)
69 warn = vWarning $ mmSingleton path (pure errMsg)
55 unless predicate warn
70 unless predicate warn
56 STLe n -> do
71 STLe n -> do
57 let
72 let
58− nlen = natVal n
73+ nlen = withKnownNat n $ natVal n
59− predicate = nlen <= (fromIntegral $ T.length t)
74+ predicate = nlen >= (fromIntegral $ T.length t)
60− errMsg = "length of " <> path <> " should be <= " <> T.pack (show nlen)
75+ errMsg = "length should be <= " <> T.pack (show nlen)
61 warn = vWarning $ mmSingleton path (pure errMsg)
76 warn = vWarning $ mmSingleton path (pure errMsg)
62 unless predicate warn
77 unless predicate warn
63 STGt n -> do
78 STGt n -> do
64 let
79 let
65− nlen = natVal n
80+ nlen = withKnownNat n $ natVal n
66− predicate = nlen > (fromIntegral $ T.length t)
81+ predicate = nlen < (fromIntegral $ T.length t)
82+ errMsg = "length should be > " <> T.pack (show nlen)
83+ warn = vWarning $ mmSingleton path (pure errMsg)
84+ unless predicate warn
85+ STGe n -> do
86+ let
87+ nlen = withKnownNat n $ natVal n
88+ predicate = nlen <= (fromIntegral $ T.length t)
67− errMsg = "length of " <> path <> " should be > " <> T.pack (show nlen)
89+ errMsg = "length should be >= " <> T.pack (show nlen)
68 warn = vWarning $ mmSingleton path (pure errMsg)
90 warn = vWarning $ mmSingleton path (pure errMsg)
69 unless predicate warn
91 unless predicate warn
70 STRegex r -> do
92 STRegex r -> do
71 let
93 let
72− regex = symbolVal r
94+ regex = withKnownSymbol r $ fromSing r
73− predicate = maybe False (const True) $ matchRegex (mkRegex regex) (T.unpack t)
95+ predicate = matchTest (makeRegex (T.unpack regex) :: Regex) (T.unpack t)
74− errMsg = path <> " must match " <> T.pack (show regex)
96+ errMsg = "must match " <> regex
75 warn = vWarning $ mmSingleton path (pure errMsg)
97 warn = vWarning $ mmSingleton path (pure errMsg)
76 unless predicate warn
98 unless predicate warn
77 STEnum ss -> do
99 STEnum ss -> do
@@ -79,7 +101,7 @@ validateTextConstraint (JSONPath path) t = \case
79 matching :: Sing (s :: [Symbol]) -> Bool
101 matching :: Sing (s :: [Symbol]) -> Bool
80 matching SNil = False
102 matching SNil = False
81 matching (SCons s@SSym fs) = T.pack (symbolVal s) == t || matching fs
103 matching (SCons s@SSym fs) = T.pack (symbolVal s) == t || matching fs
82− errMsg = path <> " must be one of " <> T.pack (show (fromSing ss))
104+ errMsg = "must be one of " <> T.pack (show (fromSing ss))
83 warn = vWarning $ mmSingleton path (pure errMsg)
105 warn = vWarning $ mmSingleton path (pure errMsg)
84 unless (matching ss) warn
106 unless (matching ss) warn
85
107
@@ -91,23 +113,37 @@ validateNumberConstraint
91validateNumberConstraint (JSONPath path) num = \case
113validateNumberConstraint (JSONPath path) num = \case
92 SNEq n -> do
114 SNEq n -> do
93 let
115 let
94− nlen = natVal n
116+ nlen = withKnownNat n $ natVal n
95 predicate = fromIntegral nlen == num
117 predicate = fromIntegral nlen == num
96− errMsg = path <> " should be == " <> T.pack (show nlen)
118+ errMsg = "should be == " <> T.pack (show nlen)
97 warn = vWarning $ mmSingleton path (pure errMsg)
119 warn = vWarning $ mmSingleton path (pure errMsg)
98 unless predicate warn
120 unless predicate warn
99 SNGt n -> do
121 SNGt n -> do
100 let
122 let
101− nlen = natVal n
123+ nlen = withKnownNat n $ natVal n
102 predicate = num > fromIntegral nlen
124 predicate = num > fromIntegral nlen
103− errMsg = path <> " should be > " <> T.pack (show nlen)
125+ errMsg = "should be > " <> T.pack (show nlen)
126+ warn = vWarning $ mmSingleton path (pure errMsg)
127+ unless predicate warn
128+ SNGe n -> do
129+ let
130+ nlen = withKnownNat n $ natVal n
131+ predicate = num >= fromIntegral nlen
132+ errMsg = "should be >= " <> T.pack (show nlen)
133+ warn = vWarning $ mmSingleton path (pure errMsg)
134+ unless predicate warn
135+ SNLt n -> do
136+ let
137+ nlen = withKnownNat n $ natVal n
138+ predicate = num < fromIntegral nlen
139+ errMsg = "should be < " <> T.pack (show nlen)
104 warn = vWarning $ mmSingleton path (pure errMsg)
140 warn = vWarning $ mmSingleton path (pure errMsg)
105 unless predicate warn
141 unless predicate warn
106 SNLe n -> do
142 SNLe n -> do
107 let
143 let
108− nlen = natVal n
144+ nlen = withKnownNat n $ natVal n
109− predicate = fromIntegral nlen <= num
145+ predicate = num <= fromIntegral nlen
110− errMsg = path <> " should be <= " <> T.pack (show nlen)
146+ errMsg = "should be <= " <> T.pack (show nlen)
111 warn = vWarning $ mmSingleton path (pure errMsg)
147 warn = vWarning $ mmSingleton path (pure errMsg)
112 unless predicate warn
148 unless predicate warn
113
149
@@ -119,9 +155,37 @@ validateArrayConstraint
119validateArrayConstraint (JSONPath path) v = \case
155validateArrayConstraint (JSONPath path) v = \case
120 SAEq n -> do
156 SAEq n -> do
121 let
157 let
122− nlen = natVal n
158+ nlen = withKnownNat n $ natVal n
123 predicate = nlen == fromIntegral (V.length v)
159 predicate = nlen == fromIntegral (V.length v)
124− errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)
160+ errMsg = "length should be == " <> T.pack (show nlen)
161+ warn = vWarning $ mmSingleton path (pure errMsg)
162+ unless predicate warn
163+ SAGt n -> do
164+ let
165+ nlen = withKnownNat n $ natVal n
166+ predicate = fromIntegral (V.length v) > nlen
167+ errMsg = "length should be > " <> T.pack (show nlen)
168+ warn = vWarning $ mmSingleton path (pure errMsg)
169+ unless predicate warn
170+ SAGe n -> do
171+ let
172+ nlen = withKnownNat n $ natVal n
173+ predicate = fromIntegral (V.length v) >= nlen
174+ errMsg = "length should be >= " <> T.pack (show nlen)
175+ warn = vWarning $ mmSingleton path (pure errMsg)
176+ unless predicate warn
177+ SALt n -> do
178+ let
179+ nlen = withKnownNat n $ natVal n
180+ predicate = fromIntegral (V.length v) < nlen
181+ errMsg = "length should be < " <> T.pack (show nlen)
182+ warn = vWarning $ mmSingleton path (pure errMsg)
183+ unless predicate warn
184+ SALe n -> do
185+ let
186+ nlen = withKnownNat n $ natVal n
187+ predicate = fromIntegral (V.length v) <= nlen
188+ errMsg = "length should be <= " <> T.pack (show nlen)
125 warn = vWarning $ mmSingleton path (pure errMsg)
189 warn = vWarning $ mmSingleton path (pure errMsg)
126 unless predicate warn
190 unless predicate warn
127
191
@@ -150,6 +214,7 @@ validateJsonRepr sschema dpath jr = case jr of
150 process cs
214 process cs
151 process scs
215 process scs
152 ReprNull -> pure ()
216 ReprNull -> pure ()
217+ ReprBoolean _ -> pure ()
153 ReprArray v -> case sschema of
218 ReprArray v -> case sschema of
154 SSchemaArray acs s -> do
219 SSchemaArray acs s -> do
155 let
220 let
@@ -169,9 +234,72 @@ validateJsonRepr sschema dpath jr = case jr of
169 ReprObject fs -> case sschema of
234 ReprObject fs -> case sschema of
170 SSchemaObject _ -> go fs
235 SSchemaObject _ -> go fs
171 where
236 where
172− go :: Rec FieldRepr (ts :: [ (Symbol, Schema) ] ) -> Validation ()
237+ go :: Rec FieldRepr (ts :: [(Symbol, Schema)] ) -> Validation ()
173 go RNil = pure ()
238 go RNil = pure ()
174 go (f@(FieldRepr d) :& ftl) = do
239 go (f@(FieldRepr d) :& ftl) = do
175 let newPath = dpath <> [DKey (knownFieldName f)]
240 let newPath = dpath <> [DKey (knownFieldName f)]
176 validateJsonRepr (knownFieldSchema f) newPath d
241 validateJsonRepr (knownFieldSchema f) newPath d
177 go ftl
242 go ftl
243+ ReprUnion _ -> pure () -- FIXME
244+ -- case sschema of
245+ -- SSchemaUnion ss -> case ss of
246+ -- SCons s stl -> case umatch' s u of
247+ -- Nothing -> case urestrict u of
248+ -- Nothing ->
249+ -- fail "impossible to produce subUnion, please report this as a bug"
250+ -- Just x -> do
251+ -- let
252+ -- JSONPath path = demotedPathToText dpath
253+ -- case stl of
254+ -- SNil -> void $ vWarning $ mmSingleton path
255+ -- $ pure "union handling error, please report this as bug"
256+ -- SCons s' stl' ->
257+ -- validateJsonRepr (SSchemaUnion (SCons s' stl')) dpath
258+ -- $ toUnion (SCons s' stl') x
259+ -- Just x -> validateJsonRepr s dpath x
260+
261+-- subUnion
262+-- :: Sing (s ': stl)
263+-- -> ( USubset stl (s ': stl) (RImage stl (s ': stl))
264+-- => Union f (s ': stl)
265+-- -> Maybe (Union f stl) )
266+-- subUnion (SCons s stl) = urestrict
267+
268+-- withUSubset
269+-- :: Sing (s ': stl)
270+-- -> (USubset stl (s ': stl) (RImage stl (s ': stl)) => Maybe (Union f stl))
271+-- -> Maybe (Union f stl)
272+-- withUSubset (SCons s stl) r = r
273+
274+toUnion
275+ :: USubset s' (s ': ss) (RImage s' (s ': ss))
276+ => Sing (s ': ss)
277+ -> Union JsonRepr s'
278+ -> JsonRepr ('SchemaUnion (s ': ss))
279+toUnion _ = ReprUnion . urelax
280+
281+umatch' :: UElem a as i => Sing a -> Union f as -> Maybe (f a)
282+umatch' _ u = umatch u
283+
284+parseAndValidateJson
285+ :: forall schema
286+ . (FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
287+ => Value
288+ -> ParseResult (JsonRepr schema)
289+parseAndValidateJson v =
290+ case parseEither parseJSON v of
291+ Left s -> DecodingError $ T.pack s
292+ Right jsonRepr ->
293+ let
294+ validate = validateJsonRepr (sing :: Sing schema) [] jsonRepr
295+ res = runIdentity . runValidationTEither $ validate
296+ in case res of
297+ Left em -> ValidationError em
298+ Right () -> Valid jsonRepr
299+
300+parseAndValidateJsonBy
301+ :: (FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
302+ => proxy schema
303+ -> Value
304+ -> ParseResult (JsonRepr schema)
305+parseAndValidateJsonBy _ = parseAndValidateJson
src/Data/Schematic/Verifier.hsnew file+5
@@ -0,0 +1,5 @@
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.hsnew file+14
@@ -0,0 +1,14 @@
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.hsnew file+43
@@ -0,0 +1,43 @@
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.hsnew file+31
@@ -0,0 +1,31 @@
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.hsnew file+121
@@ -0,0 +1,121 @@
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.7.yamlnew file+5
@@ -0,0 +1,5 @@
1+resolver: lts-13.7
2+extra-deps:
3+ - hjsonpointer-1.4.0@rev:0
4+ - hjsonschema-1.9.0@rev:0
5+ - validationt-0.2.1.0
stack.yaml+4−53
@@ -1,54 +1,5 @@
1−resolver: lts-8.12
1+resolver: lts-12.0
2−#resolver: ghc-8.0.2
3−
4−# User packages to be built.
5−# Various formats can be used as shown in the example below.
6−#
7−# packages:
8−# - some-directory
9−# - https://example.com/foo/bar/baz-0.0.2.tar.gz
10−# - location:
11−# git: https://github.com/commercialhaskell/stack.git
12−# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
13−# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
14−# extra-dep: true
15−# subdirs:
16−# - auto-update
17−# - wai
18−#
19−# A package marked 'extra-dep: true' will only be built if demanded by a
20−# non-dependency (i.e. a user package), and its test suites and benchmarks
21−# will not be run. This is useful for tweaking upstream packages.
22−packages:
23−#- location:
24− #git: https://github.com/typeable/validationt.git
25− #commit: 24578c9fd408179358c641ee1fff0eb182591f4b
26−- '.'
27−
28extra-deps:
2extra-deps:
3+ - hjsonpointer-1.4.0@rev:0
4+ - hjsonschema-1.9.0@rev:0
29−- validationt-0.2.0.0
5+ - validationt-0.2.1.0
30−- smallcheck-series-0.6
31−
32−# Override default flag values for local packages and extra-deps
33−flags: {}
34−
35−# Extra package databases containing global packages
36−extra-package-dbs: []
37−
38−# Control whether we use the GHC we find on the path
39−# system-ghc: true
40−#
41−# Require a specific version of stack, using version ranges
42−# require-stack-version: -any # Default
43−# require-stack-version: ">=1.4"
44−#
45−# Override the architecture used by stack, especially useful on Windows
46−# arch: i386
47−# arch: x86_64
48−#
49−# Extra directories used by stack for building
50−# extra-include-dirs: [/path/to/dir]
51−# extra-lib-dirs: [/path/to/dir]
52−#
53−# Allow a newer minor version of GHC than the snapshot specifies
54−# compiler-check: newer-minor
test/HelpersSpec.hsnew file+124
@@ -0,0 +1,124 @@
1+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
2+
3+{-# LANGUAGE LambdaCase #-}
4+
5+{-# LANGUAGE DataKinds #-}
6+{-# LANGUAGE TypeApplications #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+
9+module HelpersSpec (spec, main) where
10+
11+import Control.Lens
12+import Data.ByteString.Lazy.Lens
13+import Data.Foldable
14+import Data.Monoid
15+import Data.Schematic
16+import Data.Text as T
17+import Data.Text.Lens
18+import Test.Hspec
19+
20+
21+type UUIDSchema = 'SchemaObject '[ '("uuid", 'SchemaText IsUUID) ]
22+
23+-- | Taken from UUID RFC 4122
24+uuid :: Text
25+uuid = "f81d4fae-7dec-11d0-a765-00a0c91e6bf6"
26+
27+type ISO8601DateSchema = 'SchemaObject '[ '("date", 'SchemaText IsDate) ]
28+
29+iso8601dates :: [Text]
30+iso8601dates = [ "1985-04-12" ]
31+
32+invalidIso8601dates :: [Text]
33+invalidIso8601dates = [ "1999-13-12" ]
34+
35+type ISO8601TimeSchema = 'SchemaObject '[ '("time", 'SchemaText IsTime) ]
36+
37+iso8601times :: [Text]
38+iso8601times =
39+ [ "19:23:00"
40+ , "00:00:00"
41+ , "23:47:12" ]
42+
43+invalidIso8601times :: [Text]
44+invalidIso8601times =
45+ [ "00:60:00"
46+ , "24:01:02" ]
47+
48+type ISO8601DateTimeSchema = 'SchemaObject '[ '("datetime", 'SchemaText IsDateTime) ]
49+
50+-- | Taken from ISO8601 RFC 3339
51+iso8601datetimes :: [Text]
52+iso8601datetimes =
53+ iso8601dates <>
54+ [ "1985-04-12T23:20:50.52Z"
55+ , "1996-12-19T16:39:57-08:00"
56+ , "1990-12-31T23:59:60Z"
57+ , "1990-12-31T15:59:60-08:00"
58+ , "1937-01-01T12:00:27.87+00:20"
59+ ]
60+
61+invalidIso8601datetimes :: [Text]
62+invalidIso8601datetimes =
63+ [ "1996-13-129T16:39:57-08:00"
64+ , "1990-2-31T23:59:60Z"
65+ , "1990-12-32T15:59:70"
66+ , "1937-01-1T12::27.87+24:20"
67+ ]
68+
69+spec :: Spec
70+spec = do
71+ describe "UUID: " $ do
72+ it "validates correct UUID" $ do
73+ let
74+ uuidJson = "{\"uuid\": \"" <> (uuid ^. unpacked . packedChars) <> "\" }"
75+ (decodeAndValidateJson uuidJson :: ParseResult (JsonRepr UUIDSchema))
76+ `shouldSatisfy` isValid
77+
78+ it "fails to validate incorrect UUID" $ do
79+ let
80+ incorrectJson = "{\"uuid\": \"incorrect\" }"
81+ (decodeAndValidateJson incorrectJson :: ParseResult (JsonRepr UUIDSchema))
82+ `shouldSatisfy` isValidationError
83+
84+ describe "ISO8601 date: " $ do
85+ for_ iso8601dates $ \dt -> do
86+ it ("validates correct date - " <> dt ^. unpacked) $ do
87+ let json = "{\"date\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"
88+ (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601DateSchema))
89+ `shouldSatisfy` isValid
90+
91+ for_ invalidIso8601dates $ \dt -> do
92+ it ("fails to validate incorrect date - " <> dt ^. unpacked) $ do
93+ let json = "{\"date\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"
94+ (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601DateSchema))
95+ `shouldSatisfy` isValidationError
96+
97+ describe "ISO8601 time: " $ do
98+ for_ iso8601times $ \dt -> do
99+ it ("validates correct time - " <> dt ^. unpacked) $ do
100+ let json = "{\"time\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"
101+ (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601TimeSchema))
102+ `shouldSatisfy` isValid
103+
104+ for_ invalidIso8601times $ \dt -> do
105+ it ("fails to validate incorrect time - " <> dt ^. unpacked) $ do
106+ let json = "{\"time\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"
107+ (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601TimeSchema))
108+ `shouldSatisfy` isValidationError
109+
110+ describe "ISO8601 datetime: " $ do
111+ for_ iso8601datetimes $ \dt -> do
112+ it ("validates correct datetime - " <> dt ^. unpacked) $ do
113+ let json = "{\"datetime\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"
114+ (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601DateTimeSchema))
115+ `shouldSatisfy` isValid
116+
117+ for_ invalidIso8601datetimes $ \dt -> do
118+ it ("fails to validate incorrect datetime - " <> dt ^. unpacked) $ do
119+ let json = "{\"datetime\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"
120+ (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601DateTimeSchema))
121+ `shouldSatisfy` isValidationError
122+
123+main :: IO ()
124+main = hspec spec
test/JsonSchemaSpec.hsnew file+101
@@ -0,0 +1,101 @@
1+{-# LANGUAGE LambdaCase #-}
2+
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE TypeApplications #-}
5+{-# LANGUAGE OverloadedLists #-}
6+{-# LANGUAGE OverloadedStrings #-}
7+
8+module JsonSchemaSpec (spec, main) where
9+
10+import Data.Aeson as J
11+import Data.Maybe
12+import Data.Proxy
13+import Data.ByteString.Lazy as B
14+import Data.Schematic
15+import Data.Vinyl
16+import JSONSchema.Draft4 as D4
17+import Test.Hspec
18+
19+
20+type ArraySchema = 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10])
21+
22+type ArrayField = '("foo", ArraySchema)
23+
24+type FieldsSchema =
25+ '[ ArrayField, '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]
26+
27+type SchemaExample = 'SchemaObject FieldsSchema
28+
29+exampleData :: JsonRepr SchemaExample
30+exampleData = withRepr @SchemaExample $
31+ field @"foo" [ReprNumber 13]
32+ :& field @"bar" (pure (ReprText "foo"))
33+ :& RNil
34+
35+type SchemaArrayExample = 'SchemaObject
36+ '[ '("a1", 'SchemaArray '[ 'AGt 1 ] ('SchemaNumber '[]))
37+ , '("a2", 'SchemaArray '[ 'AGe 1 ] ('SchemaNumber '[]))
38+ , '("a3", 'SchemaArray '[ 'ALt 1 ] ('SchemaNumber '[]))
39+ , '("a4", 'SchemaArray '[ 'ALe 1 ] ('SchemaNumber '[]))
40+ ]
41+
42+type SchemaNumberExample = 'SchemaObject
43+ '[ '("n1", 'SchemaNumber '[ 'NGt 1 ])
44+ , '("n2", 'SchemaNumber '[ 'NGe 1 ])
45+ , '("n3", 'SchemaNumber '[ 'NLt 1 ])
46+ , '("n4", 'SchemaNumber '[ 'NLe 1 ])
47+ ]
48+
49+type SchemaTextExample = 'SchemaObject
50+ '[ '("t1", 'SchemaText '[ 'TGt 1 ])
51+ , '("t2", 'SchemaText '[ 'TGe 1 ])
52+ , '("t3", 'SchemaText '[ 'TLt 1 ])
53+ , '("t4", 'SchemaText '[ 'TLe 1 ])
54+ ]
55+
56+spec :: Spec
57+spec = do
58+ it "validates simple schema" $ do
59+ let schema = D4.SchemaWithURI (fromJust $ toJsonSchema (Proxy @SchemaExample)) Nothing
60+ fetchHTTPAndValidate schema (toJSON exampleData) >>= \case
61+ Left _ -> fail "failed to validate test example"
62+ 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 ()
99+
100+main :: IO ()
101+main = hspec spec
test/LensSpec.hsnew file+318
@@ -0,0 +1,318 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE TypeApplications #-}
3+{-# LANGUAGE OverloadedLists #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+
6+module LensSpec (spec, main) where
7+
8+import Control.Lens
9+import Data.Proxy
10+import Data.Schematic
11+import Data.Vinyl
12+import Test.Hspec
13+
14+
15+type ArraySchema = 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10])
16+
17+type ArrayField = '("foo", ArraySchema)
18+
19+type FieldsSchema =
20+ '[ '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]])), ArrayField]
21+
22+arrayData :: JsonRepr ArraySchema
23+arrayData = ReprArray [ReprNumber 13]
24+
25+arrayField :: FieldRepr ArrayField
26+arrayField = FieldRepr arrayData
27+
28+objectData :: Rec FieldRepr FieldsSchema
29+objectData = FieldRepr (ReprOptional (Just (ReprText "foo")))
30+ :& FieldRepr arrayData
31+ :& RNil
32+
33+type BigRecord = Rec FieldRepr
34+ '[ '("f1", 'SchemaNumber '[])
35+ , '("f2", 'SchemaNumber '[])
36+ , '("f3", 'SchemaNumber '[])
37+ , '("f4", 'SchemaNumber '[])
38+ , '("f5", 'SchemaNumber '[])
39+ , '("f6", 'SchemaNumber '[])
40+ , '("f7", 'SchemaNumber '[])
41+ , '("f8", 'SchemaNumber '[])
42+ , '("f9", 'SchemaNumber '[])
43+ , '("f10", 'SchemaNumber '[])
44+ , '("f11", 'SchemaNumber '[])
45+ , '("f12", 'SchemaNumber '[])
46+ , '("f13", 'SchemaNumber '[])
47+ , '("f14", 'SchemaNumber '[])
48+ , '("f15", 'SchemaNumber '[])
49+ , '("f16", 'SchemaNumber '[])
50+ , '("f17", 'SchemaNumber '[])
51+ , '("f18", 'SchemaNumber '[])
52+ , '("f19", 'SchemaNumber '[])
53+ , '("f20", 'SchemaNumber '[])
54+ , '("f21", 'SchemaNumber '[])
55+ , '("f22", 'SchemaNumber '[])
56+ , '("f23", 'SchemaNumber '[])
57+ , '("f24", 'SchemaNumber '[])
58+ , '("f25", 'SchemaNumber '[])
59+ , '("f26", 'SchemaNumber '[])
60+ , '("f27", 'SchemaNumber '[])
61+ , '("f28", 'SchemaNumber '[])
62+ , '("f29", 'SchemaNumber '[])
63+ , '("f30", 'SchemaNumber '[])
64+ , '("f31", 'SchemaNumber '[])
65+ , '("f32", 'SchemaNumber '[])
66+ , '("f33", 'SchemaNumber '[])
67+ , '("f34", 'SchemaNumber '[])
68+ , '("f35", 'SchemaNumber '[])
69+ , '("f36", 'SchemaNumber '[])
70+ , '("f37", 'SchemaNumber '[])
71+ , '("f38", 'SchemaNumber '[])
72+ , '("f39", 'SchemaNumber '[])
73+ , '("f40", 'SchemaNumber '[])
74+ , '("f41", 'SchemaNumber '[])
75+ , '("f42", 'SchemaNumber '[])
76+ , '("f43", 'SchemaNumber '[])
77+ , '("f44", 'SchemaNumber '[])
78+ , '("f45", 'SchemaNumber '[])
79+ , '("f46", 'SchemaNumber '[])
80+ , '("f47", 'SchemaNumber '[])
81+ , '("f48", 'SchemaNumber '[])
82+ , '("f49", 'SchemaNumber '[])
83+ , '("f50", 'SchemaNumber '[])
84+ , '("f51", 'SchemaNumber '[])
85+ , '("f52", 'SchemaNumber '[])
86+ , '("f53", 'SchemaNumber '[])
87+ , '("f54", 'SchemaNumber '[])
88+ , '("f55", 'SchemaNumber '[])
89+ , '("f56", 'SchemaNumber '[])
90+ , '("f57", 'SchemaNumber '[])
91+ , '("f58", 'SchemaNumber '[])
92+ , '("f59", 'SchemaNumber '[])
93+ , '("f60", 'SchemaNumber '[])
94+ , '("f61", 'SchemaNumber '[])
95+ , '("f62", 'SchemaNumber '[])
96+ , '("f63", 'SchemaNumber '[])
97+ , '("f64", 'SchemaNumber '[])
98+ , '("f65", 'SchemaNumber '[])
99+ , '("f66", 'SchemaNumber '[])
100+ , '("f67", 'SchemaNumber '[])
101+ , '("f68", 'SchemaNumber '[])
102+ , '("f69", 'SchemaNumber '[])
103+ , '("f70", 'SchemaNumber '[])
104+ , '("f71", 'SchemaNumber '[])
105+ , '("f72", 'SchemaNumber '[])
106+ , '("f73", 'SchemaNumber '[])
107+ , '("f74", 'SchemaNumber '[])
108+ , '("f75", 'SchemaNumber '[])
109+ , '("f76", 'SchemaNumber '[])
110+ , '("f77", 'SchemaNumber '[])
111+ , '("f78", 'SchemaNumber '[])
112+ , '("f79", 'SchemaNumber '[])
113+ , '("f80", 'SchemaNumber '[])
114+ , '("f81", 'SchemaNumber '[])
115+ , '("f82", 'SchemaNumber '[])
116+ , '("f83", 'SchemaNumber '[])
117+ , '("f84", 'SchemaNumber '[])
118+ , '("f85", 'SchemaNumber '[])
119+ , '("f86", 'SchemaNumber '[])
120+ , '("f87", 'SchemaNumber '[])
121+ , '("f88", 'SchemaNumber '[])
122+ , '("f89", 'SchemaNumber '[])
123+ , '("f90", 'SchemaNumber '[])
124+ , '("f91", 'SchemaNumber '[])
125+ , '("f92", 'SchemaNumber '[])
126+ , '("f93", 'SchemaNumber '[])
127+ , '("f94", 'SchemaNumber '[])
128+ , '("f95", 'SchemaNumber '[])
129+ , '("f96", 'SchemaNumber '[])
130+ , '("f97", 'SchemaNumber '[])
131+ , '("f98", 'SchemaNumber '[])
132+ , '("f99", 'SchemaNumber '[])
133+ , '("f100", 'SchemaNumber '[])
134+ , '("f101", 'SchemaNumber '[])
135+ , '("f102", 'SchemaNumber '[])
136+ , '("f103", 'SchemaNumber '[])
137+ , '("f104", 'SchemaNumber '[])
138+ , '("f105", 'SchemaNumber '[])
139+ , '("f106", 'SchemaNumber '[])
140+ , '("f107", 'SchemaNumber '[])
141+ , '("f108", 'SchemaNumber '[])
142+ , '("f109", 'SchemaNumber '[])
143+ , '("f110", 'SchemaNumber '[])
144+ , '("f111", 'SchemaNumber '[])
145+ , '("f112", 'SchemaNumber '[])
146+ , '("f113", 'SchemaNumber '[])
147+ , '("f114", 'SchemaNumber '[])
148+ , '("f115", 'SchemaNumber '[])
149+ , '("f116", 'SchemaNumber '[])
150+ , '("f117", 'SchemaNumber '[])
151+ , '("f118", 'SchemaNumber '[])
152+ , '("f119", 'SchemaNumber '[])
153+ , '("f120", 'SchemaNumber '[])
154+ , '("f121", 'SchemaNumber '[])
155+ , '("f122", 'SchemaNumber '[])
156+ , '("f123", 'SchemaNumber '[])
157+ , '("f124", 'SchemaNumber '[])
158+ , '("f125", 'SchemaNumber '[])
159+ , '("f126", 'SchemaNumber '[])
160+ , '("f127", 'SchemaNumber '[])
161+ , '("f128", 'SchemaNumber '[])
162+ , '("f129", 'SchemaNumber '[])
163+ , '("f130", 'SchemaNumber '[])
164+ ]
165+
166+_bigRecord :: BigRecord
167+_bigRecord =
168+ FieldRepr (ReprNumber 1)
169+ :& FieldRepr (ReprNumber 2)
170+ :& FieldRepr (ReprNumber 3)
171+ :& FieldRepr (ReprNumber 4)
172+ :& FieldRepr (ReprNumber 5)
173+ :& FieldRepr (ReprNumber 6)
174+ :& FieldRepr (ReprNumber 7)
175+ :& FieldRepr (ReprNumber 8)
176+ :& FieldRepr (ReprNumber 9)
177+ :& FieldRepr (ReprNumber 10)
178+ :& FieldRepr (ReprNumber 11)
179+ :& FieldRepr (ReprNumber 12)
180+ :& FieldRepr (ReprNumber 13)
181+ :& FieldRepr (ReprNumber 14)
182+ :& FieldRepr (ReprNumber 15)
183+ :& FieldRepr (ReprNumber 16)
184+ :& FieldRepr (ReprNumber 17)
185+ :& FieldRepr (ReprNumber 18)
186+ :& FieldRepr (ReprNumber 19)
187+ :& FieldRepr (ReprNumber 20)
188+ :& FieldRepr (ReprNumber 21)
189+ :& FieldRepr (ReprNumber 22)
190+ :& FieldRepr (ReprNumber 23)
191+ :& FieldRepr (ReprNumber 24)
192+ :& FieldRepr (ReprNumber 25)
193+ :& FieldRepr (ReprNumber 26)
194+ :& FieldRepr (ReprNumber 27)
195+ :& FieldRepr (ReprNumber 28)
196+ :& FieldRepr (ReprNumber 29)
197+ :& FieldRepr (ReprNumber 30)
198+ :& FieldRepr (ReprNumber 31)
199+ :& FieldRepr (ReprNumber 32)
200+ :& FieldRepr (ReprNumber 33)
201+ :& FieldRepr (ReprNumber 34)
202+ :& FieldRepr (ReprNumber 35)
203+ :& FieldRepr (ReprNumber 36)
204+ :& FieldRepr (ReprNumber 37)
205+ :& FieldRepr (ReprNumber 38)
206+ :& FieldRepr (ReprNumber 39)
207+ :& FieldRepr (ReprNumber 40)
208+ :& FieldRepr (ReprNumber 41)
209+ :& FieldRepr (ReprNumber 42)
210+ :& FieldRepr (ReprNumber 43)
211+ :& FieldRepr (ReprNumber 44)
212+ :& FieldRepr (ReprNumber 45)
213+ :& FieldRepr (ReprNumber 46)
214+ :& FieldRepr (ReprNumber 47)
215+ :& FieldRepr (ReprNumber 48)
216+ :& FieldRepr (ReprNumber 49)
217+ :& FieldRepr (ReprNumber 50)
218+ :& FieldRepr (ReprNumber 51)
219+ :& FieldRepr (ReprNumber 52)
220+ :& FieldRepr (ReprNumber 53)
221+ :& FieldRepr (ReprNumber 54)
222+ :& FieldRepr (ReprNumber 55)
223+ :& FieldRepr (ReprNumber 56)
224+ :& FieldRepr (ReprNumber 57)
225+ :& FieldRepr (ReprNumber 58)
226+ :& FieldRepr (ReprNumber 59)
227+ :& FieldRepr (ReprNumber 60)
228+ :& FieldRepr (ReprNumber 61)
229+ :& FieldRepr (ReprNumber 62)
230+ :& FieldRepr (ReprNumber 63)
231+ :& FieldRepr (ReprNumber 64)
232+ :& FieldRepr (ReprNumber 65)
233+ :& FieldRepr (ReprNumber 66)
234+ :& FieldRepr (ReprNumber 67)
235+ :& FieldRepr (ReprNumber 68)
236+ :& FieldRepr (ReprNumber 69)
237+ :& FieldRepr (ReprNumber 70)
238+ :& FieldRepr (ReprNumber 71)
239+ :& FieldRepr (ReprNumber 72)
240+ :& FieldRepr (ReprNumber 73)
241+ :& FieldRepr (ReprNumber 74)
242+ :& FieldRepr (ReprNumber 75)
243+ :& FieldRepr (ReprNumber 76)
244+ :& FieldRepr (ReprNumber 77)
245+ :& FieldRepr (ReprNumber 78)
246+ :& FieldRepr (ReprNumber 79)
247+ :& FieldRepr (ReprNumber 80)
248+ :& FieldRepr (ReprNumber 81)
249+ :& FieldRepr (ReprNumber 82)
250+ :& FieldRepr (ReprNumber 83)
251+ :& FieldRepr (ReprNumber 84)
252+ :& FieldRepr (ReprNumber 85)
253+ :& FieldRepr (ReprNumber 86)
254+ :& FieldRepr (ReprNumber 87)
255+ :& FieldRepr (ReprNumber 88)
256+ :& FieldRepr (ReprNumber 89)
257+ :& FieldRepr (ReprNumber 90)
258+ :& FieldRepr (ReprNumber 91)
259+ :& FieldRepr (ReprNumber 92)
260+ :& FieldRepr (ReprNumber 93)
261+ :& FieldRepr (ReprNumber 94)
262+ :& FieldRepr (ReprNumber 95)
263+ :& FieldRepr (ReprNumber 96)
264+ :& FieldRepr (ReprNumber 97)
265+ :& FieldRepr (ReprNumber 98)
266+ :& FieldRepr (ReprNumber 99)
267+ :& FieldRepr (ReprNumber 100)
268+ :& FieldRepr (ReprNumber 101)
269+ :& FieldRepr (ReprNumber 102)
270+ :& FieldRepr (ReprNumber 103)
271+ :& FieldRepr (ReprNumber 104)
272+ :& FieldRepr (ReprNumber 105)
273+ :& FieldRepr (ReprNumber 106)
274+ :& FieldRepr (ReprNumber 107)
275+ :& FieldRepr (ReprNumber 108)
276+ :& FieldRepr (ReprNumber 109)
277+ :& FieldRepr (ReprNumber 110)
278+ :& FieldRepr (ReprNumber 111)
279+ :& FieldRepr (ReprNumber 112)
280+ :& FieldRepr (ReprNumber 113)
281+ :& FieldRepr (ReprNumber 114)
282+ :& FieldRepr (ReprNumber 115)
283+ :& FieldRepr (ReprNumber 116)
284+ :& FieldRepr (ReprNumber 117)
285+ :& FieldRepr (ReprNumber 118)
286+ :& FieldRepr (ReprNumber 119)
287+ :& FieldRepr (ReprNumber 120)
288+ :& FieldRepr (ReprNumber 121)
289+ :& FieldRepr (ReprNumber 122)
290+ :& FieldRepr (ReprNumber 123)
291+ :& FieldRepr (ReprNumber 124)
292+ :& FieldRepr (ReprNumber 125)
293+ :& FieldRepr (ReprNumber 126)
294+ :& FieldRepr (ReprNumber 127)
295+ :& FieldRepr (ReprNumber 128)
296+ :& FieldRepr (ReprNumber 129)
297+ :& FieldRepr (ReprNumber 130)
298+ :& RNil
299+
300+spec :: Spec
301+spec = do
302+ let
303+ newFooVal = FieldRepr $ ReprArray [ReprNumber 15]
304+ fooProxy = Proxy @"foo"
305+ it "gets the field from an object" $ do
306+ fget @"foo" objectData `shouldBe` arrayField
307+ it "sets the object field" $ do
308+ fget @"foo" (fput newFooVal objectData) `shouldBe` newFooVal
309+
310+ describe "(using lens library) " $ do
311+ it "get the field from an object" $ do
312+ objectData ^. flens @"foo" `shouldBe` arrayField
313+ it "sets the object field" $ do
314+ set (flens @"foo") newFooVal objectData ^. flens @"foo"
315+ `shouldBe` newFooVal
316+
317+main :: IO ()
318+main = hspec spec
test/SchemaSpec.hs+78−29
@@ -1,45 +1,78 @@
1{-# OPTIONS_GHC -fprint-potential-instances #-}
1{-# OPTIONS_GHC -fprint-potential-instances #-}
2
2
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+
3module SchemaSpec (spec, main) where
12module SchemaSpec (spec, main) where
4
13
5−import Control.Monad
14+import Control.Lens
6−import Data.ByteString.Lazy
7import Data.Aeson
15import Data.Aeson
16+import Data.ByteString.Lazy
17+import Data.Functor.Identity
8import Data.Proxy
18import Data.Proxy
9import Data.Schematic
19import Data.Schematic
20+import Data.Schematic.Generator
10import Data.Singletons
21import Data.Singletons
22+import Data.Tagged
11import Data.Vinyl
23import Data.Vinyl
12import Test.Hspec
24import Test.Hspec
13import Test.Hspec.SmallCheck
25import Test.Hspec.SmallCheck
14−import Test.SmallCheck
26+import Test.SmallCheck as SC
27+import Test.SmallCheck.Drivers as SC
15−import Test.SmallCheck.Series.Instances
28+import Test.SmallCheck.Series as SC
16
29
30+import Debug.Trace
17
31
18−type SchemaExample
32+type SchemaExample = 'SchemaObject
19− = SchemaObject
20− '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))
33+ '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]))
21− , '("bar", SchemaOptional (SchemaText '[TEnum '["foo", "bar"]]))]
34+ , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]
22
35
23−type VS =
36+type SchemaExample2 = 'SchemaObject
24− 'Versioned SchemaExample
37+ '[ '("foo", 'SchemaArray '[ 'AEq 2] ('SchemaText '[ 'TGt 10]))
25− '[ 'Migration "test_revision"
38+ , '("bar", 'SchemaOptional ('SchemaText '[ 'TRegex "[0-9]+"]))]
26− '[ 'Diff '[ 'PKey "bar" ] ('Update ('SchemaText '[]))
27− , 'Diff '[ 'PKey "foo" ] ('Update ('SchemaNumber '[])) ] ]
28
39
29−exampleTest :: JsonRepr (SchemaOptional (SchemaText '[TEq 3]))
40+jsonExample :: JsonRepr SchemaExample
30−exampleTest = ReprOptional (Just (ReprText "lil"))
41+jsonExample = withRepr @SchemaExample
42+ $ field @"bar" (Just "bar")
43+ :& field @"foo" [12]
44+ :& RNil
31
45
32−exampleNumber :: JsonRepr (SchemaNumber '[NGt 10])
46+type AddQuuz =
33−exampleNumber = ReprNumber 12
47+ 'Migration "add_field_quuz"
48+ '[ 'Diff '[] ('AddKey "quuz" (SchemaNumber '[])) ]
34
49
35−exampleArray :: JsonRepr (SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))
50+type DeleteQuuz =
36−exampleArray = ReprArray [exampleNumber]
51+ 'Migration "remove_field_quuz"
52+ '[ 'Diff '[] ( 'DeleteKey "quuz") ]
37
53
38−jsonExample :: JsonRepr SchemaExample
54+type SwapFields =
39−jsonExample = ReprObject $
55+ 'Migration "swap_fields"
40− FieldRepr (ReprArray [ReprNumber 12])
56+ '[ 'Diff '[ 'PKey "bar" ] ('Update
41− :& FieldRepr (ReprOptional (Just (ReprText "bar")))
57+ ('SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10])))
58+ , 'Diff '[ 'PKey "foo" ] ('Update
59+ ('SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))) ]
60+
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)
42− :& RNil
74+ -- :& RNil))
75+ :&& MNil
43
76
44schemaJson :: ByteString
77schemaJson :: ByteString
45schemaJson = "{\"foo\": [13], \"bar\": null}"
78schemaJson = "{\"foo\": [13], \"bar\": null}"
@@ -47,8 +80,11 @@ schemaJson = "{\"foo\": [13], \"bar\": null}"
47schemaJson2 :: ByteString
80schemaJson2 :: ByteString
48schemaJson2 = "{\"foo\": [3], \"bar\": null}"
81schemaJson2 = "{\"foo\": [3], \"bar\": null}"
49
82
50−schemaJsonTopVersion :: ByteString
83+schemaJsonSeries :: Monad m => SC.Series m (JsonRepr SchemaExample)
51−schemaJsonTopVersion = "{ \"foo\": 42, \"bar\": \"bar\" }"
84+schemaJsonSeries = series
85+
86+schemaJsonSeries2 :: Monad m => SC.Series m (JsonRepr SchemaExample2)
87+schemaJsonSeries2 = series
52
88
53spec :: Spec
89spec :: Spec
54spec = do
90spec = do
@@ -65,9 +101,22 @@ spec = do
65 it "validates incorrect representation" $
101 it "validates incorrect representation" $
66 ((decodeAndValidateJson schemaJson2) :: ParseResult (JsonRepr SchemaExample))
102 ((decodeAndValidateJson schemaJson2) :: ParseResult (JsonRepr SchemaExample))
67 `shouldSatisfy` isValidationError
103 `shouldSatisfy` isValidationError
68− it "validates versioned json" $ do
104+ -- it "validates versioned json" $ do
69− (decodeAndValidateVersionedJson (Proxy @VS) schemaJsonTopVersion)
105+ -- decodeAndValidateVersionedJson (Proxy @VS) schemaJson
106+ -- `shouldSatisfy` isValid
107+ it "validates versioned json with a migration list" $ do
108+ decodeAndValidateVersionedWithPureMList
109+ (Proxy @VersionedJson)
110+ migrationList
111+ schemaJson
70− `shouldSatisfy` isValid
112+ `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+
71
120
72main :: IO ()
121main :: IO ()
73main = hspec spec
122main = hspec spec