git.iko.soy/typeable/schematic
on master help sign in
swap
7db0b46112 ahead, 0 behind
31 files changed+2446−474
since splitsnapshots
unifiedsplit
.travis.yml+2−2 ChangeLog.md+56 README.md+164−42 release+43 release.nix+32 schematic.cabal+41−46 src/Data/Schematic.hs+38−82 src/Data/Schematic/DSL.hs+92 src/Data/Schematic/Generator.hs+91 src/Data/Schematic/Generator/Regex.hs+76 src/Data/Schematic/Helpers.hs+59 src/Data/Schematic/Instances.hs+4 src/Data/Schematic/JsonSchema.hs+124 src/Data/Schematic/Lens.hs+168−27 src/Data/Schematic/Migration.hs+48−14 src/Data/Schematic/Path.hs+18−32 src/Data/Schematic/Schema.hs+330−39 src/Data/Schematic/Schema.hs-boot+95 src/Data/Schematic/Utils.hs−42 src/Data/Schematic/Validation.hs+156−27 src/Data/Schematic/Verifier.hs+5 src/Data/Schematic/Verifier/Array.hs+14 src/Data/Schematic/Verifier/Common.hs+43 src/Data/Schematic/Verifier/Number.hs+31 src/Data/Schematic/Verifier/Text.hs+121 stack-13.21.yaml+7 stack.yaml+5−52 test/HelpersSpec.hs+124 test/JsonSchemaSpec.hs+101 test/LensSpec.hs+280−14 test/SchemaSpec.hs+78−55
.travis.yml+2−2
@@ -1,4 +1,4 @@
1−sudo: false
1+sudo: required
22
33language: c
44
@@ -22,4 +22,4 @@ script:
2222
2323cache:
2424 directories:
25− - $HOME/.stack
25+ - $HOME/.stack
ChangeLog.md+56
@@ -1,5 +1,61 @@
11# Revision history for schematic
22
3+## 0.6.0.0 -- 2021-01-15
4+
5+Added compatability with aeson-1.4.3.0. Since version 1.4.3 the module `Data.Aeson` started exporting `JSONPath`, which was conflicting with our own `JSONPath`. Furthermore, started using `JSONPathElement` from `aeson` instead of `DemotedPathSegment`.
6+
7+## 0.5.1.0 -- 2021-01-15
8+
9+Fix the generation of json schema for numbers.
10+Add array constraints.
11+Fix the generation of text and number constraints.
12+Remove jsonpath from the error message.
13+
14+## 0.5.0.0 -- 2019-02-20
15+
16+GHC 8.6, json generation by schema definition, validation bug fixes, better
17+parsing error messages.
18+
19+## 0.4.3.0 -- 2018-07-12
20+
21+GHC 8.4 support, dropping support for older GHC versions
22+
23+## 0.4.2.0
24+
25+Support ghc-8.4 and drop support for older versions
26+
27+## 0.4.1.0 -- 2017-11-05
28+
29+Convenience isomorphisms: txt, num, opt, bln etc
30+
31+## 0.4.1.0 -- 2017-11-01
32+
33+flens and fget now use type application syntax
34+
35+## 0.4.0.0 -- 2017-10-17
36+
37+Object building DSL, more convenience helpers, MCons simplified with Tagged
38+
39+## 0.3.2.0 -- 2017-10-02
40+
41+Fixed FIndex bug, added bunch of convenience isomorphism, re-exports.
42+
43+## 0.3.1.0 -- 2017-09-28
44+
45+Add UUID and ISO8601 helpers, json schema constraint export, fsubset lens
46+combinator.
47+
48+## 0.3.0.0 -- 2017-09-28
49+
50+Updated to GHC 8.2.1 and singletons 2.3.1
51+
52+## 0.2.1.0 -- 2017-09-26
53+
54+Add decodeAndValidateVersionedWithPureMList, fix tests
55+
56+## 0.2.0.0 -- 2017-09-26
57+
58+Migratable is deprecated, migrations are now possible in an arbitrary monad.
359
460## 0.1.5.0 -- 2017-08-22
561
README.md+164−42
@@ -1,22 +1,16 @@
11# schematic
22
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)
44
55## Goal
66
77The 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:
88
9−* All the instantiations of transport types are 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.
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 a roundtrip property by an implementation.
1111* 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.
13−
14−## TODO
15−
16−* Describing versioned http endpoints
17−* Schema pretty-printing
18−* More validators
19−* Overall user friendliness
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+* Schematic schemas can be exported to [json-schema](http://json-schema.org)
2014
2115Be aware that library is experimental and subject to change a lot. The current state can be viewed as a prototype.
2216
@@ -28,67 +22,134 @@ Be aware that library is experimental and subject to change a lot. The current s
2822$ stack install schematic
2923```
3024
31−## 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:
3229
3330```
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
3454type SchemaExample
3555 = SchemaObject
3656 '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))
3757 , '("bar", SchemaOptional (SchemaText '[TEnum '["foo", "bar"]]))]
3858```
3959
40−* This schema says that's structurally it's a JSON object which has two field:
41− * field "foo" contains an of numeric values
42− * field "bar" contains an optional textual value
43−* It also allows you to validate the JSON:
44− * an array in "foo" must contain exactly one element
60+* This schema says that's structurally it's a JSON object which has two fields:
61+ * field "foo" contains an array of numeric values
62+ * field "bar" contains an optional text value
63+* It also allows you to validate JSON values itself:
64+ * an array in "foo" contains exactly one element
4565 * that element must be strictly greater than 10
46− * value of bar must be either "foo" or "bar" if presented
66+ * value of "bar" field must be either "foo" or "bar" if presented
4767
4868
4969This one is valid for example
5070
51−```
71+```haskell
5272schemaJson :: ByteString
5373schemaJson = "{\"foo\": [13], \"bar\": null}"
5474```
5575
5676Also valid
5777
58−```
78+```haskell
5979schemaJson :: ByteString
6080schemaJson = "{\"foo\": [13], \"bar\": \"bar\"}"
6181```
6282
6383it can be parsed and validated like this:
6484
65−```
85+```haskell
6686decodeAndValidateJson schemaJson :: ParseResult (JsonRepr SchemaExample)
6787```
6888
6989`ParseResult` type encodes three possible situations:
70−* json is structurally consistent with schema and runtime validations passed
71−* json source is malformed or doesn't correspond to schema structurally
72−* some of the runtime validations failed, but it's structurally correct
90+* json is structurally consistent with a schema and runtime validations pass
91+* json source is malformed or doesn't correspond to a schema structurally
92+* some of the runtime validations have failed, but it's structurally correct
93+ overall
7394
74−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.
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.
7598
99+```haskell
100+jsonExample :: JsonRepr SchemaExample
101+jsonExample = withRepr @SchemaExample
102+ $ field @"foo" [12]
103+ :& field @"bar" (Just "bar")
104+ :& RNil
105+```
106+
107+The most basic and sugar-free way of constructing the same object will look like this:
76108
77109```
78−jsonExample :: JsonRepr SchemaExample
79−jsonExample = ReprObject $
110+jsonExample' :: JsonRepr SchemaExample
111+jsonExample' = ReprObject $
80112 FieldRepr (ReprArray [ReprNumber 12])
81113 :& FieldRepr (ReprOptional (Just (ReprText "bar")))
82114 :& RNil
83115```
84116
85−## Migrations
117+## Lens-compatibility
86118
87−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.
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:
88120
89−This piece of code will apply a migration to the schema, then decodes and validates the latest version.
121+```haskell
122+type ArraySchema = SchemaArray '[AEq 1] (SchemaNumber '[NGt 10])
123+
124+type ArrayField = '("foo", ArraySchema)
125+
126+type FieldsSchema =
127+ '[ ArrayField, '("bar", SchemaOptional (SchemaText '[TEnum '["foo", "bar"]]))]
128+
129+type SchemaExample = 'SchemaObject FieldsSchema
90130
91131```
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
92153type SchemaExample
93154 = SchemaObject
94155 '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))
@@ -96,8 +157,8 @@ type SchemaExample
96157
97158type TestMigration =
98159 'Migration "test_revision"
99− '[ 'Diff '[ 'PKey "bar" ] ('Update ('SchemaText '[]))
100− , 'Diff '[ 'PKey "foo" ] ('Update ('SchemaNumber '[])) ]
160+ '[ Diff '[ PKey "bar" ] (Update (SchemaText '[]))
161+ , Diff '[ PKey "foo" ] (Update (SchemaNumber '[])) ]
101162
102163type VS = 'Versioned SchemaExample '[ TestMigration ]
103164
@@ -111,23 +172,84 @@ It's possible to decode the latest version like this:
111172decodeAndValidateJson schemaJsonTopVersion :: ParseResult (JsonRepr (TopVersion (AllVersions VS)))
112173```
113174
114−## Lens-compatibility
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:
115180
116−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:
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
117210
118211```
119−type ArraySchema = 'SchemaArray '[AEq 1] ('SchemaNumber '[NGt 10])
120212
121−type ArrayField = '("foo", ArraySchema)
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.
122223
123−type FieldsSchema =
124− '[ ArrayField, '("bar", 'SchemaOptional ('SchemaText '[TEnum '["foo", "bar"]]))]
224+## How do I construct a value of `JsonRepr schema`?
125225
126−type SchemaExample = 'SchemaObject FieldsSchema
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"]]))]
127237
238+jsonExample = withRepr @SchemaExample
239+ $ field @"bar" (Just "bar")
240+ :& field @"foo" [12]
241+ :& RNil
128242```
129243
130−There are two ways of working with named fields in the objects:
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+
131254
132−* Using the `fget` and `fset` functions: `fget fooProxy (fput newFooVal objectData) == newFooVal`
133−* Using the lens library: `set (flens (Proxy @"foo")) newFooVal objectData ^. flens (Proxy @"foo") == newFooVal`
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+41−46
@@ -1,36 +1,43 @@
1−-- Initial schematic.cabal generated by cabal init. For further
2−-- documentation, see http://haskell.org/cabal/users-guide/
3−
41name: schematic
5−version: 0.1.4.0
2+version: 0.6.0.0
63synopsis: 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.
85license: BSD3
96license-file: LICENSE
107author: Denis Redozubov
118maintainer: denis.redozubov@gmail.com
12−-- copyright:
9+homepage: http://github.com/typeable/schematic
10+Bug-reports: http://github.com/typeable/schematic/issues/
1311category: Data
1412build-type: Simple
15−extra-source-files: ChangeLog.md
13+extra-source-files: ChangeLog.md, README.md
1614cabal-version: >=1.10
1715
1816library
1917 exposed-modules: Data.Schematic
18+ , Data.Schematic.DSL
19+ , Data.Schematic.Generator
20+ , Data.Schematic.Generator.Regex
2021 , Data.Schematic.Instances
22+ , Data.Schematic.JsonSchema
23+ , Data.Schematic.Helpers
2124 , Data.Schematic.Lens
2225 , Data.Schematic.Migration
2326 , Data.Schematic.Path
2427 , Data.Schematic.Schema
2528 , Data.Schematic.Validation
26− , 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
2734 ghc-options: -Wall
28− -- other-modules:
2935 default-extensions: ConstraintKinds
3036 , DataKinds
3137 , DefaultSignatures
3238 , DeriveFunctor
3339 , DeriveFoldable
40+ , DeriveTraversable
3441 , DeriveGeneric
3542 , DeriveDataTypeable
3643 , FlexibleContexts
@@ -58,18 +65,24 @@ library
5865 , TypeOperators
5966 , TypeSynonymInstances
6067 , UndecidableInstances
61− build-depends: base >=4.9 && <4.10
68+ build-depends: base >=4.11 && <5
6269 , bytestring
63− , aeson >= 1
64− , regex-compat
70+ , aeson >= 1.4.3.0 && < 1.6
71+ , containers
72+ , hjsonschema
73+ , mtl
74+ , profunctors
75+ , regex-tdfa
76+ , regex-tdfa-text
6577 , scientific
66− , singletons
78+ , singletons >= 2.4
6779 , smallcheck
68− , smallcheck-series
6980 , tagged
81+ , template-haskell
7082 , text
83+ , union
7184 , unordered-containers
72− , validationt >= 0.1.0.1
85+ , validationt >= 0.2.1.0
7386 , vector
7487 , vinyl
7588 hs-source-dirs: src
@@ -80,50 +93,32 @@ test-suite spec
8093 hs-source-dirs: test
8194 main-is: Spec.hs
8295 default-language: Haskell2010
83− default-extensions: ConstraintKinds
84− , DataKinds
85− , DeriveFunctor
86− , DeriveFoldable
87− , DeriveGeneric
88− , DeriveDataTypeable
89− , FlexibleContexts
90− , FlexibleInstances
91− , FunctionalDependencies
92− , GADTs
93− , KindSignatures
94− , InstanceSigs
95− , MultiParamTypeClasses
96− , OverloadedLists
97− , OverloadedStrings
98− , PolyKinds
99− , QuasiQuotes
100− , PartialTypeSignatures
101− , RecordWildCards
102− , ScopedTypeVariables
103− , TemplateHaskell
104− , TypeApplications
105− , TypeFamilies
106− , TypeInType
107− , TypeOperators
108− , TypeSynonymInstances
10996 build-depends: HUnit
11097 , aeson >= 1
111− , base >=4.9 && <4.10
98+ , base >=4.11 && <4.13
11299 , bytestring
100+ , containers
101+ , hjsonschema
113102 , hspec >= 2.2.0
114103 , hspec-core
115104 , hspec-discover
116105 , hspec-smallcheck
117106 , lens
118− , regex-compat
107+ , regex-tdfa
108+ , regex-tdfa-text
119109 , schematic
120110 , smallcheck
121− , smallcheck-series
122111 , singletons
123112 , tagged
124113 , text
125114 , unordered-containers
126− , validationt >= 0.1.0.1
115+ , validationt >= 0.2.1.0
127116 , vinyl
128117 other-modules: SchemaSpec
129− , LensSpec
118+ , HelpersSpec
119+ , LensSpec
120+ , JsonSchemaSpec
121+
122+source-repository head
123+ type: git
124+ location: https://github.com/typeable/schematic
src/Data/Schematic.hs+38−82
@@ -2,62 +2,43 @@
22{-# LANGUAGE AllowAmbiguousTypes #-}
33
44module Data.Schematic
5− ( module Data.Schematic.Schema
5+ ( module Data.Schematic.JsonSchema
6+ , module Data.Schematic.Helpers
67 , module Data.Schematic.Lens
78 , module Data.Schematic.Migration
8− , module Data.Schematic.Utils
9+ , module Data.Schematic.Schema
910 , decodeAndValidateJson
1011 , parseAndValidateJson
1112 , parseAndValidateJsonBy
12− , parseAndValidateVersionedJson
1313 , parseAndValidateTopVersionJson
14− , decodeAndValidateVersionedJson
1514 , parseAndValidateWithMList
1615 , decodeAndValidateVersionedWithMList
16+ , decodeAndValidateVersionedWithPureMList
1717 , isValid
1818 , isDecodingError
1919 , isValidationError
2020 , ParseResult(..)
21− , Migratable
21+ , withRepr
22+ , field
2223 ) where
2324
2425import Control.Monad.Validation
2526import Data.Aeson as J
2627import Data.Aeson.Types as J
2728import Data.ByteString.Lazy as BL
28−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
2933import Data.Schematic.Lens
3034import Data.Schematic.Migration
3135import Data.Schematic.Schema
32−import Data.Schematic.Utils
3336import Data.Schematic.Validation
34−import Data.Singletons.Prelude
37+import Data.Singletons.Prelude hiding ((:.))
38+import Data.Tagged
3539import Data.Text as T
3640
3741
38−parseAndValidateJson
39− :: forall schema
40− . (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
41− => J.Value
42− -> ParseResult (JsonRepr schema)
43−parseAndValidateJson v =
44− case parseEither parseJSON v of
45− Left s -> DecodingError $ T.pack s
46− Right jsonRepr ->
47− let
48− validate = validateJsonRepr (sing :: Sing schema) [] jsonRepr
49− res = runIdentity . runValidationTEither $ validate
50− in case res of
51− Left em -> ValidationError em
52− Right () -> Valid jsonRepr
53−
54−parseAndValidateJsonBy
55− :: (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
56− => proxy schema
57− -> J.Value
58− -> ParseResult (JsonRepr schema)
59−parseAndValidateJsonBy _ = parseAndValidateJson
60−
6142parseAndValidateTopVersionJson
6243 :: forall proxy (v :: Versioned)
6344 . (SingI (TopVersion (AllVersions v)))
@@ -76,44 +57,23 @@ parseAndValidateTopVersionJson _ v =
7657 Left em -> ValidationError em
7758 Right () -> Valid jsonRepr
7859
79−class Migratable (revisions :: [(Revision, Schema)]) where
80− mparse
81− :: Sing revisions
82− -> J.Value
83− -> ParseResult (JsonRepr (Snd (Head revisions)))
84−
85−instance
86− {-# OVERLAPPING #-}
87− ( TopLevel (Snd rev), SingI (Snd rev) )
88− => Migratable '[rev] where
89− mparse _ = parseAndValidateJson
90−
91−instance {-# OVERLAPPABLE #-}
92− ( Migratable (Tail revisions)
93− , MigrateSchema (Snd (Head (Tail revisions))) (Snd (Head revisions))
94− , SingI (Snd (Head revisions)))
95− => Migratable revisions where
96− mparse s v = case parseEither parseJSON v of
97− Left _ ->
98− migrate <$> (mparse (sTail s) v :: ParseResult (JsonRepr (Snd (Head (Tail revisions)))))
99− Right x -> Valid x
100−
101−parseAndValidateVersionedJson
102− :: forall proxy v. (SingI (AllVersions v), Migratable (AllVersions v))
103− => proxy v
104− -> J.Value
105− -> ParseResult (JsonRepr (Snd (Head (AllVersions v))))
106−parseAndValidateVersionedJson _ v = mparse (sing :: Sing (AllVersions v)) v
107−
10860parseAndValidateWithMList
109− :: MList revisions
61+ :: Monad m
62+ => MList m revisions
11063 -> J.Value
111− -> ParseResult (JsonRepr (Head revisions))
112−parseAndValidateWithMList MNil v = parseAndValidateJson v
113−parseAndValidateWithMList ((:&&) p f tl) v = case parseAndValidateJsonBy p v of
114− Valid a -> Valid a
115− DecodingError _ -> f <$> parseAndValidateWithMList tl v
116− ValidationError _ -> f <$> parseAndValidateWithMList tl v
64+ -> m (ParseResult (JsonRepr (Head revisions)))
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'
11777
11878decodeAndValidateJson
11979 :: forall schema
@@ -124,24 +84,20 @@ decodeAndValidateJson bs = case decode bs of
12484 Nothing -> DecodingError "malformed json"
12585 Just x -> parseAndValidateJson x
12686
127−decodeAndValidateVersionedJson
128− :: (Migratable (AllVersions versioned), SingI (AllVersions versioned))
87+decodeAndValidateVersionedWithMList
88+ :: Monad m
12989 => proxy versioned
90+ -> MList m (MapSnd (AllVersions versioned))
13091 -> BL.ByteString
131− -> ParseResult (JsonRepr (Snd (Head (AllVersions versioned))))
132−decodeAndValidateVersionedJson vp bs = case decode bs of
133− Nothing -> DecodingError "malformed json"
134− Just x -> parseAndValidateVersionedJson vp x
135−
136−type family MapSnd (l :: [(a,k)]) = (r :: [k]) where
137− MapSnd '[] = '[]
138− MapSnd ( '(a, b) ': tl) = b ': MapSnd tl
92+ -> m (ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned)))))
93+decodeAndValidateVersionedWithMList _ mlist bs = case decode bs of
94+ Nothing -> pure $ DecodingError "malformed json"
95+ Just x -> parseAndValidateWithMList mlist x
13996
140−decodeAndValidateVersionedWithMList
97+decodeAndValidateVersionedWithPureMList
14198 :: proxy versioned
142− -> MList (MapSnd (AllVersions versioned))
99+ -> MList F.Identity (MapSnd (AllVersions versioned))
143100 -> BL.ByteString
144101 -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))
145−decodeAndValidateVersionedWithMList _ mlist bs = case decode bs of
146− Nothing -> DecodingError "malformed json"
147− Just x -> parseAndValidateWithMList mlist x
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 @@
44module Data.Schematic.Instances where
55
66import Data.Scientific
7+import Data.Text (Text, pack)
78import Data.Vector as V
89import Data.Vinyl
910import Test.SmallCheck.Series
@@ -21,3 +22,6 @@ instance Serial m a => Serial m (V.Vector a) where
2122
2223instance Monad m => Serial m Scientific where
2324 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.hs+168−27
@@ -3,64 +3,205 @@
33{-# LANGUAGE AllowAmbiguousTypes #-}
44{-# LANGUAGE InstanceSigs #-}
55
6−module Data.Schematic.Lens where
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
725
8−import Data.Proxy
26+import Data.Profunctor
927import 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
1033import Data.Vinyl
1134import Data.Vinyl.Functor
1235import Data.Vinyl.TypeLevel (Nat(..))
13−import GHC.TypeLits (Symbol)
36+import GHC.TypeLits (Symbol, KnownSymbol)
1437
1538
1639-- | A partial relation that gives the index of a value in a list.
1740type family FIndex (r :: Symbol) (rs :: [(Symbol, Schema)]) :: Nat where
18− FIndex r ( '(fn, s) ': rs) = 'Z
19− FIndex r ( s ': rs) = 'S (FIndex r rs)
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))
2051
2152class i ~ FIndex fn rs => FElem (fn :: Symbol) (rs :: [(Symbol, Schema)]) (i :: Nat) where
22− type ByRevision fn rs i :: Schema
23− flens
24− :: Functor g
25− => proxy fn
26− -> (FieldRepr '(fn, (ByRevision fn rs i)) -> g (FieldRepr '(fn, (ByRevision fn rs i))))
27− -> Rec FieldRepr rs
28− -> g (Rec FieldRepr rs)
53+ type ByField fn rs i :: Schema
54+ flens :: Flens fn f g rs i
2955
3056 -- | For Vinyl users who are not using the @lens@ package, we provide a getter.
31− fget
32− :: proxy fn
33− -> Rec FieldRepr rs
34− -> FieldRepr '(fn, (ByRevision fn rs i))
57+ fget :: FGetter fn f rs i
3558
3659 -- | For Vinyl users who are not using the @lens@ package, we also provide a
3760 -- setter. In general, it will be unambiguous what field is being written to,
3861 -- and so we do not take a proxy argument here.
3962 fput
40− :: FieldRepr '(fn, ByRevision fn rs i)
41− -> Rec FieldRepr rs
42− -> Rec FieldRepr rs
63+ :: f '(fn, ByField fn rs i)
64+ -> Rec f rs
65+ -> Rec f rs
4366
4467instance FElem fn ('(fn, r) ': rs) 'Z where
45− type ByRevision fn ('(fn, r) ': rs) 'Z = r
68+ type ByField fn ('(fn, r) ': rs) 'Z = r
4669
47− flens _ f (x :& xs) = fmap (:& xs) (f x)
70+ flens f (x :& xs) = fmap (:& xs) (f x)
4871 {-# INLINE flens #-}
4972
50− fget k = getConst . flens k Const
73+ fget = getConst . flens Const
5174 {-# INLINE fget #-}
5275
53− fput y = getIdentity . flens Proxy (\_ -> Identity y)
76+ fput y = getIdentity . flens (\_ -> Identity y)
5477 {-# INLINE fput #-}
5578
5679instance (FIndex r (s ': rs) ~ 'S i, FElem r rs i) => FElem r (s ': rs) ('S i) where
57− type ByRevision fn (s ': rs) ('S i) = ByRevision fn rs i
80+ type ByField r (s ': rs) ('S i) = ByField r rs i
5881
59− flens p f (x :& xs) = fmap (x :&) (flens p f xs)
82+ flens f (x :& xs) = fmap (x :&) (flens f xs)
6083 {-# INLINE flens #-}
6184
62− fget k = getConst . flens k Const
85+ fget = getConst . flens Const
6386 {-# INLINE fget #-}
6487
65− fput y = getIdentity . flens Proxy (\_ -> Identity y)
88+ fput y = getIdentity . flens (\_ -> Identity y)
6689 {-# 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+48−14
@@ -1,13 +1,19 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE TemplateHaskell #-}
34
45module Data.Schematic.Migration where
56
67import Data.Kind
8+import Data.Schematic.DSL
9+import Data.Schematic.Lens
710import Data.Schematic.Path
811import Data.Schematic.Schema
9−import Data.Singletons.Prelude hiding (All)
12+import Data.Singletons.Prelude hiding ((:.), All)
1013import Data.Singletons.TypeLits
14+import Data.Tagged
15+import Data.Vinyl
16+import Data.Vinyl.Functor
1117
1218
1319data Path
@@ -37,8 +43,8 @@ type family SchemaByKey (fs :: [(Symbol, Schema)]) (s :: Symbol) :: Schema where
3743 SchemaByKey ( '(a, s) ': tl) fn = SchemaByKey tl fn
3844
3945type family DeleteKey (acc :: [(Symbol, Schema)]) (fn :: Symbol) (fs :: [(Symbol, Schema)]) :: [(Symbol, Schema)] where
40− DeleteKey acc fn ('(fn, a) ': tl) = acc :++ tl
41− DeleteKey acc fn (fna ': tl) = acc :++ (fna ': tl)
46+ DeleteKey acc fn ('(fn, a) ': tl) = acc ++ tl
47+ DeleteKey acc fn (fna ': tl) = acc ++ (fna ': tl)
4248
4349type family UpdateKey
4450 (fn :: Symbol)
@@ -91,7 +97,8 @@ type family ElemOf (e :: k) (l :: [(a,k)]) :: Constraint where
9197type family AllVersions (vd :: Versioned) :: [(Revision, Schema)] where
9298 AllVersions ('Versioned s ms) = Reverse (AllVersions' '[ '("initial", s) ] ms)
9399
94−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
95102 AllVersions' acc '[] = acc
96103 AllVersions' ( '(rh, sh) ': tl ) (m ': ms) =
97104 AllVersions' ( '(rh, sh) ': ApplyMigration m sh ': tl ) ms
@@ -99,9 +106,6 @@ type family AllVersions' (acc :: [(Revision, Schema)]) (ms :: [Migration]) = (r
99106type family TopVersion (rs :: [(Revision, Schema)]) :: Schema where
100107 TopVersion ( '(rh, sh) ': tl) = sh
101108
102−class MigrateSchema (a :: Schema) (b :: Schema) where
103− migrate :: JsonRepr a -> JsonRepr b
104−
105109data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol
106110
107111data instance Sing (a :: Action) where
@@ -141,13 +145,43 @@ data instance Sing (v :: Versioned) where
141145 -> Sing (ms :: [Migration]) -- a bunch of migrations
142146 -> Sing ('Versioned s ms)
143147
144−data MList :: [Schema] -> Type where
145− MNil :: (SingI s, TopLevel s) => MList '[s]
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]
146152 (:&&)
147153 :: (TopLevel s, SingI s)
148− => proxy s
149− -> (JsonRepr h -> JsonRepr s)
150− -> MList (h ': tl)
151− -> MList (s ': h ': tl)
154+ => DataMigration s m h
155+ -> MList m (h ': tl)
156+ -> MList m (s ': h ': tl)
152157
153158infixr 7 :&&
159+
160+#if MIN_VERSION_base(4,12,0)
161+migrateObject
162+ :: forall m fs fh. (FSubset fs fs (FImage fs fs), Monad m, RMap fh, RMap fs)
163+ => (Rec (Tagged fs :. FieldRepr) fh -> m (Rec (Tagged fs :. FieldRepr) fs))
164+ -> Tagged ('SchemaObject fs) (JsonRepr ('SchemaObject fh) -> m (JsonRepr ('SchemaObject fs)))
165+#else
166+migrateObject
167+ :: forall m fs fh. (FSubset fs fs (FImage fs fs), Monad m)
168+ => (Rec (Tagged fs :. FieldRepr) fh -> m (Rec (Tagged fs :. FieldRepr) fs))
169+ -> Tagged ('SchemaObject fs) (JsonRepr ('SchemaObject fh) -> m (JsonRepr ('SchemaObject fs)))
170+#endif
171+migrateObject f = Tagged $ \(ReprObject r) -> do
172+ res <- f $ rmap (Compose . Tagged) r
173+ pure $ withRepr @('SchemaObject fs) res
174+
175+shrinkObject
176+ :: forall rs ss m
177+ . ( Monad m, FSubset rs ss (FImage rs ss) )
178+ => Tagged
179+ ('SchemaObject rs)
180+ (JsonRepr ('SchemaObject ss) -> m (JsonRepr ('SchemaObject rs)))
181+shrinkObject = Tagged $ \(ReprObject r) -> pure $ ReprObject $ fcast r
182+
183+type family MapSnd (l :: [(a,k)]) = (r :: [k]) where
184+ MapSnd '[] = '[]
185+ MapSnd ( '(a, b) ': tl) = b ': MapSnd tl
186+
187+type MigrationList m vs = MList m (MapSnd (AllVersions vs))
src/Data/Schematic/Path.hs+18−32
@@ -1,50 +1,36 @@
11module Data.Schematic.Path where
22
33import Data.Foldable as F
4−import Data.Monoid
5−import Data.Schematic.Utils
6−import Data.Singletons
74import Data.Singletons.Prelude
85import Data.Singletons.TypeLits
96import Data.Text as T
7+import Data.Aeson.Internal
108
119
12−data PathSegment = Key Symbol | Ix Nat
13−
14−data instance Sing (jp :: PathSegment) where
15− SKey :: (KnownSymbol k, Known (Sing k)) => Sing (k :: Symbol) -> Sing ('Key k)
16− SIx :: (KnownNat n, Known (Sing n)) => Sing (n :: Nat) -> Sing ('Ix n)
17−
18−instance (KnownSymbol k, Known (Sing k))
19− => Known (Sing ('Key k)) where
20− known = SKey known
21−
22−instance (KnownNat n, Known (Sing n))
23− => Known (Sing ('Ix n)) where
24− known = SIx known
25−
26−data DemotedPathSegment = DKey Text | DIx Integer
10+newtype JSONPathText = JSONPathText Text
2711 deriving (Show)
2812
29−-- | Textual representation of json path.
30−newtype JSONPath = JSONPath Text
31− deriving (Show)
13+data PathSegment = PathKey Symbol | PathIx Nat
14+
15+data instance Sing (jp :: PathSegment) where
16+ SKey :: (SingI k) => Sing (k :: Symbol) -> Sing ('PathKey k)
17+ SIx :: (SingI n) => Sing (n :: Nat) -> Sing ('PathIx n)
3218
33−demotePath :: Sing (ps :: [PathSegment]) -> [DemotedPathSegment]
19+demotePath :: Sing (ps :: [PathSegment]) -> JSONPath
3420demotePath = go []
3521 where
36− go :: [DemotedPathSegment] -> Sing (ps :: [PathSegment]) -> [DemotedPathSegment]
22+ go :: JSONPath -> Sing (ps :: [PathSegment]) -> JSONPath
3723 go acc SNil = acc
38− go acc (SCons p ps) = go (acc ++ [demote p]) ps
39− demote :: Sing (ps :: PathSegment) -> DemotedPathSegment
40− demote (SKey s) = DKey $ T.pack $ symbolVal s
41− demote (SIx n) = DIx $ natVal n
24+ go acc (SCons p ps) = go (acc ++ [demotePathSeg p]) ps
25+ demotePathSeg :: Sing (ps :: PathSegment) -> JSONPathElement
26+ demotePathSeg (SKey s) = Key $ T.pack $ withKnownSymbol s $ symbolVal s
27+ demotePathSeg (SIx n) = Index $ withKnownNat n $ fromIntegral $ natVal n
4228
43−demotedPathToText :: [DemotedPathSegment] -> JSONPath
44−demotedPathToText = JSONPath . F.foldl' renderPathSegment ""
29+demotedPathToText :: JSONPath -> JSONPathText
30+demotedPathToText = JSONPathText . F.foldl' renderPathSegment ""
4531 where
46− renderPathSegment acc (DKey t) = acc <> "." <> t
47− renderPathSegment acc (DIx n) = acc <> "[" <> T.pack (show n) <> "]"
32+ renderPathSegment acc (Key t) = acc <> "." <> t
33+ renderPathSegment acc (Index n) = acc <> "[" <> T.pack (show n) <> "]"
4834
49−pathToText :: Sing (ps :: [PathSegment]) -> JSONPath
35+pathToText :: Sing (ps :: [PathSegment]) -> JSONPathText
5036pathToText = demotedPathToText . demotePath
src/Data/Schematic/Schema.hs+330−39
@@ -1,35 +1,37 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE OverloadedLists #-}
3−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE OverloadedLists #-}
4+{-# LANGUAGE OverloadedStrings #-}
45{-# OPTIONS_GHC -fprint-explicit-kinds #-}
56
67module Data.Schematic.Schema where
78
8−import Control.Applicative ()
9+import Control.Applicative ((<|>))
910import Control.Monad
1011import Data.Aeson as J
1112import Data.Aeson.Types as J
1213import Data.HashMap.Strict as H
1314import Data.Kind
1415import Data.Maybe
16+import Data.Schematic.Generator
1517import Data.Schematic.Instances ()
1618import Data.Scientific
17−import Data.Singletons.Prelude.List hiding (All)
19+import Data.Singletons.Prelude.List hiding (All, Union)
1820import Data.Singletons.TH
1921import Data.Singletons.TypeLits
2022import Data.Text as T
23+import Data.Union
2124import Data.Vector as V
2225import Data.Vinyl hiding (Dict)
2326import qualified Data.Vinyl.TypeLevel as V
27+import GHC.Exts
2428import GHC.Generics (Generic)
29+import GHC.TypeLits
30+ (SomeNat(..), SomeSymbol(..), someNatVal, someSymbolVal)
2531import Prelude as P
2632import Test.SmallCheck.Series
2733
2834
29−type family All (c :: k -> Constraint) (s :: [k]) :: Constraint where
30− All c '[] = ()
31− All c (a ': as) = (c a, All c as)
32−
3335type family CRepr (s :: Schema) :: Type where
3436 CRepr ('SchemaText cs) = TextConstraint
3537 CRepr ('SchemaNumber cs) = NumberConstraint
@@ -38,77 +40,235 @@ type family CRepr (s :: Schema) :: Type where
3840
3941data TextConstraint
4042 = TEq Nat
43+ | TLt Nat
4144 | TLe Nat
4245 | TGt Nat
46+ | TGe Nat
4347 | TRegex Symbol
4448 | TEnum [Symbol]
4549 deriving (Generic)
4650
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+
4796data instance Sing (tc :: TextConstraint) where
4897 STEq :: Sing n -> Sing ('TEq n)
98+ STLt :: Sing n -> Sing ('TLt n)
4999 STLe :: Sing n -> Sing ('TLe n)
50100 STGt :: Sing n -> Sing ('TGt n)
101+ STGe :: Sing n -> Sing ('TGe n)
51102 STRegex :: Sing s -> Sing ('TRegex s)
52− STEnum :: All KnownSymbol ss => Sing ss -> Sing ('TEnum ss)
103+ STEnum :: Sing ss -> Sing ('TEnum ss)
53104
54105instance (KnownNat n) => SingI ('TEq n) where sing = STEq sing
55106instance (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
56109instance (KnownNat n) => SingI ('TLe n) where sing = STLe sing
57110instance (KnownSymbol s, SingI s) => SingI ('TRegex s) where sing = STRegex sing
58−instance (All KnownSymbol ss, SingI ss) => SingI ('TEnum ss) where sing = STEnum sing
111+instance (SingI ss) => SingI ('TEnum ss) where sing = STEnum sing
59112
60113instance Eq (Sing ('TEq n)) where _ == _ = True
114+instance Eq (Sing ('TLt n)) where _ == _ = True
61115instance Eq (Sing ('TLe n)) where _ == _ = True
62116instance Eq (Sing ('TGt n)) where _ == _ = True
117+instance Eq (Sing ('TGe n)) where _ == _ = True
63118instance Eq (Sing ('TRegex t)) where _ == _ = True
64119instance Eq (Sing ('TEnum ss)) where _ == _ = True
65120
66121data NumberConstraint
67122 = NLe Nat
123+ | NLt Nat
68124 | NGt Nat
125+ | NGe Nat
69126 | NEq Nat
70127 deriving (Generic)
71128
129+data DemotedNumberConstraint
130+ = DNLe Integer
131+ | DNLt Integer
132+ | DNGt Integer
133+ | DNGe Integer
134+ | DNEq Integer
135+ deriving (Generic, Eq, Show)
136+
72137data instance Sing (nc :: NumberConstraint) where
73138 SNEq :: Sing n -> Sing ('NEq n)
74139 SNGt :: Sing n -> Sing ('NGt n)
140+ SNGe :: Sing n -> Sing ('NGe n)
141+ SNLt :: Sing n -> Sing ('NLt n)
75142 SNLe :: Sing n -> Sing ('NLe n)
76143
77144instance KnownNat n => SingI ('NEq n) where sing = SNEq sing
78145instance 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
79148instance KnownNat n => SingI ('NLe n) where sing = SNLe sing
80149
81150instance Eq (Sing ('NEq n)) where _ == _ = True
151+instance Eq (Sing ('NLt n)) where _ == _ = True
82152instance Eq (Sing ('NLe n)) where _ == _ = True
83153instance 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"
84180
85181data ArrayConstraint
86182 = AEq Nat
183+ | AGt Nat
184+ | AGe Nat
185+ | ALt Nat
186+ | ALe Nat
87187 deriving (Generic)
88188
189+data DemotedArrayConstraint
190+ = DAEq Integer
191+ | DAGt Integer
192+ | DAGe Integer
193+ | DALt Integer
194+ | DALe Integer
195+ deriving (Generic, Eq, Show)
196+
89197data instance Sing (ac :: ArrayConstraint) where
90198 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)
91203
92204instance 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
93209
94210instance 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"
95240
96241data Schema
97242 = SchemaText [TextConstraint]
243+ | SchemaBoolean
98244 | SchemaNumber [NumberConstraint]
99245 | SchemaObject [(Symbol, Schema)]
100246 | SchemaArray [ArrayConstraint] Schema
101247 | SchemaNull
102248 | SchemaOptional Schema
249+ | SchemaUnion [Schema]
103250 deriving (Generic)
104251
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+
105263data instance Sing (schema :: Schema) where
106264 SSchemaText :: Sing tcs -> Sing ('SchemaText tcs)
107265 SSchemaNumber :: Sing ncs -> Sing ('SchemaNumber ncs)
266+ SSchemaBoolean :: Sing 'SchemaBoolean
108267 SSchemaArray :: Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)
109268 SSchemaObject :: Sing fields -> Sing ('SchemaObject fields)
110269 SSchemaOptional :: Sing s -> Sing ('SchemaOptional s)
111270 SSchemaNull :: Sing 'SchemaNull
271+ SSchemaUnion :: Sing ss -> Sing ('SchemaUnion ss)
112272
113273instance SingI sl => SingI ('SchemaText sl) where
114274 sing = SSchemaText sing
@@ -116,19 +276,52 @@ instance SingI sl => SingI ('SchemaNumber sl) where
116276 sing = SSchemaNumber sing
117277instance SingI 'SchemaNull where
118278 sing = SSchemaNull
279+instance SingI 'SchemaBoolean where
280+ sing = SSchemaBoolean
119281instance (SingI ac, SingI s) => SingI ('SchemaArray ac s) where
120282 sing = SSchemaArray sing sing
121283instance SingI stl => SingI ('SchemaObject stl) where
122284 sing = SSchemaObject sing
123285instance SingI s => SingI ('SchemaOptional s) where
124286 sing = SSchemaOptional sing
287+instance SingI s => SingI ('SchemaUnion s) where
288+ sing = SSchemaUnion sing
125289
126290instance Eq (Sing ('SchemaText cs)) where _ == _ = True
127291instance Eq (Sing ('SchemaNumber cs)) where _ == _ = True
128292instance Eq (Sing 'SchemaNull) where _ == _ = True
293+instance Eq (Sing 'SchemaBoolean) where _ == _ = True
129294instance Eq (Sing ('SchemaArray as s)) where _ == _ = True
130295instance Eq (Sing ('SchemaObject cs)) where _ == _ = True
131296instance 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
132325
133326data FieldRepr :: (Symbol, Schema) -> Type where
134327 FieldRepr
@@ -166,53 +359,77 @@ instance
166359 => Serial m (FieldRepr '(name, schema)) where
167360 series = FieldRepr <$> series
168361
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+
169366data JsonRepr :: Schema -> Type where
170367 ReprText :: Text -> JsonRepr ('SchemaText cs)
171368 ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)
369+ ReprBoolean :: Bool -> JsonRepr 'SchemaBoolean
172370 ReprNull :: JsonRepr 'SchemaNull
173371 ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)
174372 ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)
175373 ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)
374+ ReprUnion :: Union JsonRepr (h ': tl) -> JsonRepr ('SchemaUnion (h ': tl))
375+
376+instance (Monad m, Serial m Text, SingI cs)
377+ => Serial m (JsonRepr ('SchemaText cs)) where
378+ series = decDepth $ fmap ReprText $ textSeries $ fromSing (sing :: Sing cs)
379+
380+instance (Monad m, Serial m Scientific, SingI cs)
381+ => Serial m (JsonRepr ('SchemaNumber cs)) where
382+ series = decDepth $ fmap ReprNumber
383+ $ numberSeries $ fromSing (sing :: Sing cs)
384+
385+instance Monad m => Serial m (JsonRepr 'SchemaNull) where
386+ series = cons0 ReprNull
387+
388+instance (Serial m (JsonRepr s), Serial m (V.Vector (JsonRepr s)), SingI cs)
389+ => Serial m (JsonRepr ('SchemaArray cs s)) where
390+ series = decDepth $ fmap ReprArray
391+ $ arraySeries $ fromSing (sing :: Sing cs)
176392
393+instance (Serial m (JsonRepr s))
394+ => Serial m (JsonRepr ('SchemaOptional s)) where
395+ series = cons1 ReprOptional
396+
397+instance (Monad m, Serial m (Rec FieldRepr fs))
398+ => Serial m (JsonRepr ('SchemaObject fs)) where
399+ series = cons1 ReprObject
400+
401+-- | Move to the union package
177402instance Show (JsonRepr ('SchemaText cs)) where
178403 show (ReprText t) = "ReprText " P.++ show t
179404
180405instance Show (JsonRepr ('SchemaNumber cs)) where
181406 show (ReprNumber n) = "ReprNumber " P.++ show n
182407
408+instance Show (JsonRepr 'SchemaBoolean) where
409+ show (ReprBoolean n) = "ReprBoolean " P.++ show n
410+
183411instance Show (JsonRepr 'SchemaNull) where show _ = "ReprNull"
184412
185413instance Show (JsonRepr s) => Show (JsonRepr ('SchemaArray acs s)) where
186414 show (ReprArray v) = "ReprArray " P.++ show v
187415
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
188423instance V.RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where
189424 show (ReprObject fs) = "ReprObject " P.++ show fs
425+#endif
190426
191427instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where
192428 show (ReprOptional s) = "ReprOptional " P.++ show s
193429
194−instance (Monad m, Serial m Text)
195− => Serial m (JsonRepr ('SchemaText cs)) where
196− series = cons1 ReprText
197−
198−instance (Monad m, Serial m Scientific)
199− => Serial m (JsonRepr ('SchemaNumber cs)) where
200− series = cons1 ReprNumber
201−
202−instance Monad m => Serial m (JsonRepr 'SchemaNull) where
203− series = cons0 ReprNull
204−
205−instance (Serial m (V.Vector (JsonRepr s)))
206− => Serial m (JsonRepr ('SchemaArray cs s)) where
207− series = cons1 ReprArray
208−
209−instance (Serial m (JsonRepr s))
210− => Serial m (JsonRepr ('SchemaOptional s)) where
211− series = cons1 ReprOptional
212−
213−instance (Monad m, Serial m (Rec FieldRepr fs))
214− => Serial m (JsonRepr ('SchemaObject fs)) where
215− series = cons1 ReprObject
430+instance Show (Union JsonRepr (h ': tl))
431+ => Show (JsonRepr ('SchemaUnion (h ': tl))) where
432+ show (ReprUnion s) = "ReprUnion " P.++ show s
216433
217434instance Eq (Rec FieldRepr fs) => Eq (JsonRepr ('SchemaObject fs)) where
218435 ReprObject a == ReprObject b = a == b
@@ -223,6 +440,9 @@ instance Eq (JsonRepr ('SchemaText cs)) where
223440instance Eq (JsonRepr ('SchemaNumber cs)) where
224441 ReprNumber a == ReprNumber b = a == b
225442
443+instance Eq (JsonRepr 'SchemaBoolean) where
444+ ReprBoolean a == ReprBoolean b = a == b
445+
226446instance Eq (JsonRepr 'SchemaNull) where
227447 ReprNull == ReprNull = True
228448
@@ -232,6 +452,51 @@ instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaArray as s)) where
232452instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaOptional s)) where
233453 ReprOptional a == ReprOptional b = a == b
234454
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+
235500fromOptional
236501 :: SingI s
237502 => Sing ('SchemaOptional s)
@@ -239,10 +504,29 @@ fromOptional
239504 -> Parser (Maybe (JsonRepr s))
240505fromOptional _ = parseJSON
241506
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+
242525instance SingI schema => J.FromJSON (JsonRepr schema) where
243526 parseJSON value = case sing :: Sing schema of
244527 SSchemaText _ -> withText "String" (pure . ReprText) value
245528 SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value
529+ SSchemaBoolean -> ReprBoolean <$> parseJSON value
246530 SSchemaNull -> case value of
247531 J.Null -> pure ReprNull
248532 _ -> typeMismatch "Null" value
@@ -258,31 +542,37 @@ instance SingI schema => J.FromJSON (JsonRepr schema) where
258542 fieldRepr <- case s of
259543 SSchemaText so -> case H.lookup fieldName h of
260544 Just v -> withSingI so $ FieldRepr <$> parseJSON v
261− Nothing -> fail "schematext"
545+ Nothing -> fail $ "No text field: " P.++ show fieldName
262546 SSchemaNumber so -> case H.lookup fieldName h of
263547 Just v -> withSingI so $ FieldRepr <$> parseJSON v
264− Nothing -> fail "schemanumber"
548+ Nothing -> fail $ "No number field: " P.++ show fieldName
549+ SSchemaBoolean -> case H.lookup fieldName h of
550+ Just v -> FieldRepr <$> parseJSON v
551+ Nothing -> fail $ "No boolean field: " P.++ show fieldName
265552 SSchemaNull -> case H.lookup fieldName h of
266553 Just v -> FieldRepr <$> parseJSON v
267− Nothing -> fail "schemanull"
554+ Nothing -> fail $ "No null field: " P.++ show fieldName
268555 SSchemaArray sa sb -> case H.lookup fieldName h of
269556 Just v -> withSingI sa $ withSingI sb $ FieldRepr <$> parseJSON v
270− Nothing -> fail "schemaarray"
557+ Nothing -> fail $ "No array field: " P.++ show fieldName
271558 SSchemaObject so -> case H.lookup fieldName h of
272559 Just v -> withSingI so $ FieldRepr <$> parseJSON v
273− Nothing -> fail "schemaobject"
560+ Nothing -> fail $ "No object field" P.++ show fieldName
274561 SSchemaOptional so -> case H.lookup fieldName h of
275562 Just v -> withSingI so $ FieldRepr <$> parseJSON v
276− Nothing -> fail "schemaoptional"
563+ Nothing -> withSingI so $ pure $ FieldRepr $ ReprOptional Nothing
564+ SSchemaUnion ss -> withSingI ss $ FieldRepr <$> parseUnion ss value
277565 (fieldRepr :&) <$> demoteFields tl h
278566 ReprObject <$> withObject "Object" (demoteFields fs) value
567+ SSchemaUnion ss -> parseUnion ss value
279568
280569instance J.ToJSON (JsonRepr a) where
281570 toJSON ReprNull = J.Null
571+ toJSON (ReprBoolean b) = J.Bool b
282572 toJSON (ReprText t) = J.String t
283573 toJSON (ReprNumber n) = J.Number n
284574 toJSON (ReprOptional s) = case s of
285− Just v -> toJSON v
575+ Just v -> toJSON v
286576 Nothing -> J.Null
287577 toJSON (ReprArray v) = J.Array $ toJSON <$> v
288578 toJSON (ReprObject r) = J.Object . H.fromList . fold $ r
@@ -295,6 +585,7 @@ instance J.ToJSON (JsonRepr a) where
295585 fold = \case
296586 RNil -> []
297587 fr@(FieldRepr _) :& tl -> (extract fr) : fold tl
588+ toJSON (ReprUnion u) = toJSON u
298589
299590class FalseConstraint a
300591
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+156−27
@@ -2,20 +2,25 @@ module Data.Schematic.Validation where
22
33import Control.Monad
44import Control.Monad.Validation
5+import Data.Aeson
6+import Data.Aeson.Internal
7+import Data.Aeson.Types
58import Data.Foldable
69import Data.Functor.Identity
710import Data.Monoid
811import Data.Schematic.Path
912import Data.Schematic.Schema
10−import Data.Schematic.Utils ()
1113import Data.Scientific
1214import Data.Singletons.Prelude
1315import Data.Singletons.TypeLits
1416import Data.Text as T
17+import Data.Traversable
18+import Data.Union
1519import Data.Vector as V
1620import Data.Vinyl
21+import Data.Vinyl.TypeLevel
1722import Prelude as P
18−import Text.Regex
23+import Text.Regex.TDFA
1924
2025
2126type Validation a = ValidationT ErrorMap Identity a
@@ -26,7 +31,11 @@ data ParseResult a
2631 = Valid a
2732 | DecodingError Text -- static
2833 | ValidationError ErrorMap -- runtime
29− deriving (Show, Eq, Functor)
34+ deriving (Show, Eq, Functor, Foldable, Traversable)
35+
36+instance (TopLevel a, SingI a, FromJSON (JsonRepr a))
37+ => FromJSON (ParseResult (JsonRepr a)) where
38+ parseJSON = pure . parseAndValidateJson @a
3039
3140isValid :: ParseResult a -> Bool
3241isValid (Valid _) = True
@@ -41,37 +50,51 @@ isValidationError (ValidationError _) = True
4150isValidationError _ = False
4251
4352validateTextConstraint
44− :: JSONPath
53+ :: JSONPathText
4554 -> Text
4655 -> Sing (tcs :: TextConstraint)
4756 -> Validation ()
48−validateTextConstraint (JSONPath path) t = \case
57+validateTextConstraint (JSONPathText path) t = \case
4958 STEq n -> do
5059 let
5160 nlen = withKnownNat n $ natVal n
5261 predicate = nlen == (fromIntegral $ T.length t)
53− errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)
62+ errMsg = "length should be == " <> T.pack (show nlen)
63+ warn = vWarning $ mmSingleton path (pure errMsg)
64+ unless predicate warn
65+ STLt n -> do
66+ let
67+ nlen = withKnownNat n $ natVal n
68+ predicate = nlen > (fromIntegral $ T.length t)
69+ errMsg = "length should be < " <> T.pack (show nlen)
5470 warn = vWarning $ mmSingleton path (pure errMsg)
5571 unless predicate warn
5672 STLe n -> do
5773 let
5874 nlen = withKnownNat n $ natVal n
59− predicate = nlen <= (fromIntegral $ T.length t)
60− errMsg = "length of " <> path <> " should be <= " <> T.pack (show nlen)
75+ predicate = nlen >= (fromIntegral $ T.length t)
76+ errMsg = "length should be <= " <> T.pack (show nlen)
6177 warn = vWarning $ mmSingleton path (pure errMsg)
6278 unless predicate warn
6379 STGt n -> do
6480 let
6581 nlen = withKnownNat n $ natVal n
66− predicate = nlen > (fromIntegral $ T.length t)
67− errMsg = "length of " <> path <> " should be > " <> T.pack (show nlen)
82+ predicate = nlen < (fromIntegral $ T.length t)
83+ errMsg = "length should be > " <> T.pack (show nlen)
84+ warn = vWarning $ mmSingleton path (pure errMsg)
85+ unless predicate warn
86+ STGe n -> do
87+ let
88+ nlen = withKnownNat n $ natVal n
89+ predicate = nlen <= (fromIntegral $ T.length t)
90+ errMsg = "length should be >= " <> T.pack (show nlen)
6891 warn = vWarning $ mmSingleton path (pure errMsg)
6992 unless predicate warn
7093 STRegex r -> do
7194 let
72− regex = withKnownSymbol r $ symbolVal r
73− predicate = maybe False (const True) $ matchRegex (mkRegex regex) (T.unpack t)
74− errMsg = path <> " must match " <> T.pack (show regex)
95+ regex = withKnownSymbol r $ fromSing r
96+ predicate = matchTest (makeRegex (T.unpack regex) :: Regex) (T.unpack t)
97+ errMsg = "must match " <> regex
7598 warn = vWarning $ mmSingleton path (pure errMsg)
7699 unless predicate warn
77100 STEnum ss -> do
@@ -79,55 +102,97 @@ validateTextConstraint (JSONPath path) t = \case
79102 matching :: Sing (s :: [Symbol]) -> Bool
80103 matching SNil = False
81104 matching (SCons s@SSym fs) = T.pack (symbolVal s) == t || matching fs
82− errMsg = path <> " must be one of " <> T.pack (show (fromSing ss))
105+ errMsg = "must be one of " <> T.pack (show (fromSing ss))
83106 warn = vWarning $ mmSingleton path (pure errMsg)
84107 unless (matching ss) warn
85108
86109validateNumberConstraint
87− :: JSONPath
110+ :: JSONPathText
88111 -> Scientific
89112 -> Sing (tcs :: NumberConstraint)
90113 -> Validation ()
91−validateNumberConstraint (JSONPath path) num = \case
114+validateNumberConstraint (JSONPathText path) num = \case
92115 SNEq n -> do
93116 let
94117 nlen = withKnownNat n $ natVal n
95118 predicate = fromIntegral nlen == num
96− errMsg = path <> " should be == " <> T.pack (show nlen)
119+ errMsg = "should be == " <> T.pack (show nlen)
97120 warn = vWarning $ mmSingleton path (pure errMsg)
98121 unless predicate warn
99122 SNGt n -> do
100123 let
101124 nlen = withKnownNat n $ natVal n
102125 predicate = num > fromIntegral nlen
103− errMsg = path <> " should be > " <> T.pack (show nlen)
126+ errMsg = "should be > " <> T.pack (show nlen)
127+ warn = vWarning $ mmSingleton path (pure errMsg)
128+ unless predicate warn
129+ SNGe n -> do
130+ let
131+ nlen = withKnownNat n $ natVal n
132+ predicate = num >= fromIntegral nlen
133+ errMsg = "should be >= " <> T.pack (show nlen)
134+ warn = vWarning $ mmSingleton path (pure errMsg)
135+ unless predicate warn
136+ SNLt n -> do
137+ let
138+ nlen = withKnownNat n $ natVal n
139+ predicate = num < fromIntegral nlen
140+ errMsg = "should be < " <> T.pack (show nlen)
104141 warn = vWarning $ mmSingleton path (pure errMsg)
105142 unless predicate warn
106143 SNLe n -> do
107144 let
108145 nlen = withKnownNat n $ natVal n
109− predicate = fromIntegral nlen <= num
110− errMsg = path <> " should be <= " <> T.pack (show nlen)
146+ predicate = num <= fromIntegral nlen
147+ errMsg = "should be <= " <> T.pack (show nlen)
111148 warn = vWarning $ mmSingleton path (pure errMsg)
112149 unless predicate warn
113150
114151validateArrayConstraint
115− :: JSONPath
152+ :: JSONPathText
116153 -> V.Vector a
117154 -> Sing (tcs :: ArrayConstraint)
118155 -> Validation ()
119−validateArrayConstraint (JSONPath path) v = \case
156+validateArrayConstraint (JSONPathText path) v = \case
120157 SAEq n -> do
121158 let
122159 nlen = withKnownNat n $ natVal n
123160 predicate = nlen == fromIntegral (V.length v)
124− errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)
161+ errMsg = "length should be == " <> T.pack (show nlen)
162+ warn = vWarning $ mmSingleton path (pure errMsg)
163+ unless predicate warn
164+ SAGt n -> do
165+ let
166+ nlen = withKnownNat n $ natVal n
167+ predicate = fromIntegral (V.length v) > nlen
168+ errMsg = "length should be > " <> T.pack (show nlen)
169+ warn = vWarning $ mmSingleton path (pure errMsg)
170+ unless predicate warn
171+ SAGe n -> do
172+ let
173+ nlen = withKnownNat n $ natVal n
174+ predicate = fromIntegral (V.length v) >= nlen
175+ errMsg = "length should be >= " <> T.pack (show nlen)
176+ warn = vWarning $ mmSingleton path (pure errMsg)
177+ unless predicate warn
178+ SALt n -> do
179+ let
180+ nlen = withKnownNat n $ natVal n
181+ predicate = fromIntegral (V.length v) < nlen
182+ errMsg = "length should be < " <> T.pack (show nlen)
183+ warn = vWarning $ mmSingleton path (pure errMsg)
184+ unless predicate warn
185+ SALe n -> do
186+ let
187+ nlen = withKnownNat n $ natVal n
188+ predicate = fromIntegral (V.length v) <= nlen
189+ errMsg = "length should be <= " <> T.pack (show nlen)
125190 warn = vWarning $ mmSingleton path (pure errMsg)
126191 unless predicate warn
127192
128193validateJsonRepr
129194 :: Sing schema
130− -> [DemotedPathSegment]
195+ -> JSONPath
131196 -> JsonRepr schema
132197 -> Validation ()
133198validateJsonRepr sschema dpath jr = case jr of
@@ -150,6 +215,7 @@ validateJsonRepr sschema dpath jr = case jr of
150215 process cs
151216 process scs
152217 ReprNull -> pure ()
218+ ReprBoolean _ -> pure ()
153219 ReprArray v -> case sschema of
154220 SSchemaArray acs s -> do
155221 let
@@ -160,7 +226,7 @@ validateJsonRepr sschema dpath jr = case jr of
160226 process cs
161227 process acs
162228 for_ (V.indexed v) $ \(ix, jr') -> do
163− let newPath = dpath <> pure (DIx $ fromIntegral ix)
229+ let newPath = dpath <> pure (Index $ fromIntegral ix)
164230 validateJsonRepr s newPath jr'
165231 ReprOptional d -> case sschema of
166232 SSchemaOptional ss -> case d of
@@ -169,9 +235,72 @@ validateJsonRepr sschema dpath jr = case jr of
169235 ReprObject fs -> case sschema of
170236 SSchemaObject _ -> go fs
171237 where
172− go :: Rec FieldRepr (ts :: [ (Symbol, Schema) ] ) -> Validation ()
238+ go :: Rec FieldRepr (ts :: [(Symbol, Schema)] ) -> Validation ()
173239 go RNil = pure ()
174240 go (f@(FieldRepr d) :& ftl) = do
175− let newPath = dpath <> [DKey (knownFieldName f)]
241+ let newPath = dpath <> [Key (knownFieldName f)]
176242 validateJsonRepr (knownFieldSchema f) newPath d
177243 go ftl
244+ ReprUnion _ -> pure () -- FIXME
245+ -- case sschema of
246+ -- SSchemaUnion ss -> case ss of
247+ -- SCons s stl -> case umatch' s u of
248+ -- Nothing -> case urestrict u of
249+ -- Nothing ->
250+ -- fail "impossible to produce subUnion, please report this as a bug"
251+ -- Just x -> do
252+ -- let
253+ -- JSONPathText path = demotedPathToText dpath
254+ -- case stl of
255+ -- SNil -> void $ vWarning $ mmSingleton path
256+ -- $ pure "union handling error, please report this as bug"
257+ -- SCons s' stl' ->
258+ -- validateJsonRepr (SSchemaUnion (SCons s' stl')) dpath
259+ -- $ toUnion (SCons s' stl') x
260+ -- Just x -> validateJsonRepr s dpath x
261+
262+-- subUnion
263+-- :: Sing (s ': stl)
264+-- -> ( USubset stl (s ': stl) (RImage stl (s ': stl))
265+-- => Union f (s ': stl)
266+-- -> Maybe (Union f stl) )
267+-- subUnion (SCons s stl) = urestrict
268+
269+-- withUSubset
270+-- :: Sing (s ': stl)
271+-- -> (USubset stl (s ': stl) (RImage stl (s ': stl)) => Maybe (Union f stl))
272+-- -> Maybe (Union f stl)
273+-- withUSubset (SCons s stl) r = r
274+
275+toUnion
276+ :: USubset s' (s ': ss) (RImage s' (s ': ss))
277+ => Sing (s ': ss)
278+ -> Union JsonRepr s'
279+ -> JsonRepr ('SchemaUnion (s ': ss))
280+toUnion _ = ReprUnion . urelax
281+
282+umatch' :: UElem a as i => Sing a -> Union f as -> Maybe (f a)
283+umatch' _ u = umatch u
284+
285+parseAndValidateJson
286+ :: forall schema
287+ . (FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
288+ => Value
289+ -> ParseResult (JsonRepr schema)
290+parseAndValidateJson v =
291+ case parseEither parseJSON v of
292+ Left s -> DecodingError $ T.pack s
293+ Right jsonRepr ->
294+ let
295+ validate = validateJsonRepr (sing :: Sing schema) [] jsonRepr
296+ res = runIdentity . runValidationTEither $ validate
297+ in case res of
298+ Left em -> ValidationError em
299+ Right () -> Valid jsonRepr
300+
301+parseAndValidateJsonBy
302+ :: (FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
303+ => proxy schema
304+ -> Value
305+ -> ParseResult (JsonRepr schema)
306+parseAndValidateJsonBy _ = parseAndValidateJson
src/Data/Schematic/Verifier.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.21.yamlnew file+7
@@ -0,0 +1,7 @@
1+resolver: lts-13.21
2+extra-deps:
3+ - hjsonpointer-1.4.0@rev:0
4+ - hjsonschema-1.9.0@rev:0
5+ - validationt-0.3.0
6+nix:
7+ packages: [pcre, pkg-config, zlib]
stack.yaml+5−52
@@ -1,53 +1,6 @@
1−resolver: lts-9.01
2−
3−# User packages to be built.
4−# Various formats can be used as shown in the example below.
5−#
6−# packages:
7−# - some-directory
8−# - https://example.com/foo/bar/baz-0.0.2.tar.gz
9−# - location:
10−# git: https://github.com/commercialhaskell/stack.git
11−# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
12−# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
13−# extra-dep: true
14−# subdirs:
15−# - auto-update
16−# - wai
17−#
18−# A package marked 'extra-dep: true' will only be built if demanded by a
19−# non-dependency (i.e. a user package), and its test suites and benchmarks
20−# will not be run. This is useful for tweaking upstream packages.
21−packages:
22−#- location:
23− #git: https://github.com/typeable/validationt.git
24− #commit: 24578c9fd408179358c641ee1fff0eb182591f4b
25−- '.'
26−
1+resolver: lts-14.22
272extra-deps:
28−- validationt-0.2.0.0
29−- smallcheck-series-0.6
30−
31−# Override default flag values for local packages and extra-deps
32−flags: {}
33−
34−# Extra package databases containing global packages
35−extra-package-dbs: []
36−
37−# Control whether we use the GHC we find on the path
38−# system-ghc: true
39−#
40−# Require a specific version of stack, using version ranges
41−# require-stack-version: -any # Default
42−# require-stack-version: ">=1.4"
43−#
44−# Override the architecture used by stack, especially useful on Windows
45−# arch: i386
46−# arch: x86_64
47−#
48−# Extra directories used by stack for building
49−# extra-include-dirs: [/path/to/dir]
50−# extra-lib-dirs: [/path/to/dir]
51−#
52−# Allow a newer minor version of GHC than the snapshot specifies
53−# compiler-check: newer-minor
3+- hjsonpointer-1.4.0@rev:0
4+- hjsonschema-1.9.0@rev:0
5+- git: https://github.com/typeable/validationt.git
6+ commit: 97fea97c4015ab5e99f3efb2c73e1fef4b8857d8
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.hs+280−14
@@ -1,21 +1,23 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE TypeApplications #-}
3+{-# LANGUAGE OverloadedLists #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+
16module LensSpec (spec, main) where
27
38import Control.Lens
4−import Data.Kind
59import Data.Proxy
610import Data.Schematic
711import Data.Vinyl
812import Test.Hspec
913
1014
11−type ArraySchema = 'SchemaArray '[AEq 1] ('SchemaNumber '[NGt 10])
15+type ArraySchema = 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10])
1216
1317type ArrayField = '("foo", ArraySchema)
1418
1519type FieldsSchema =
16− '[ ArrayField, '("bar", 'SchemaOptional ('SchemaText '[TEnum '["foo", "bar"]]))]
17−
18−type SchemaExample = 'SchemaObject FieldsSchema
20+ '[ '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]])), ArrayField]
1921
2022arrayData :: JsonRepr ArraySchema
2123arrayData = ReprArray [ReprNumber 13]
@@ -24,12 +26,276 @@ arrayField :: FieldRepr ArrayField
2426arrayField = FieldRepr arrayData
2527
2628objectData :: Rec FieldRepr FieldsSchema
27−objectData = FieldRepr arrayData
28− :& FieldRepr (ReprOptional (Just (ReprText "foo")))
29+objectData = FieldRepr (ReprOptional (Just (ReprText "foo")))
30+ :& FieldRepr arrayData
2931 :& RNil
3032
31−exampleData :: JsonRepr SchemaExample
32−exampleData = ReprObject objectData
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
33299
34300spec :: Spec
35301spec = do
@@ -37,16 +303,16 @@ spec = do
37303 newFooVal = FieldRepr $ ReprArray [ReprNumber 15]
38304 fooProxy = Proxy @"foo"
39305 it "gets the field from an object" $ do
40− fget fooProxy objectData == arrayField
306+ fget @"foo" objectData `shouldBe` arrayField
41307 it "sets the object field" $ do
42− fget fooProxy (fput newFooVal objectData) == newFooVal
308+ fget @"foo" (fput newFooVal objectData) `shouldBe` newFooVal
43309
44310 describe "(using lens library) " $ do
45311 it "get the field from an object" $ do
46− objectData ^. flens (Proxy @"foo") == arrayField
312+ objectData ^. flens @"foo" `shouldBe` arrayField
47313 it "sets the object field" $ do
48− set (flens (Proxy @"foo")) newFooVal objectData ^. flens (Proxy @"foo")
49− == newFooVal
314+ set (flens @"foo") newFooVal objectData ^. flens @"foo"
315+ `shouldBe` newFooVal
50316
51317main :: IO ()
52318main = hspec spec
test/SchemaSpec.hs+78−55
@@ -1,47 +1,78 @@
11{-# OPTIONS_GHC -fprint-potential-instances #-}
22
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE OverloadedLists #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeApplications #-}
11+
312module SchemaSpec (spec, main) where
413
5−import Control.Monad
6−import Data.ByteString.Lazy
14+import Control.Lens
715import Data.Aeson
16+import Data.ByteString.Lazy
17+import Data.Functor.Identity
818import Data.Proxy
919import Data.Schematic
20+import Data.Schematic.Generator
1021import Data.Singletons
11−import Data.Singletons.Prelude
22+import Data.Tagged
1223import Data.Vinyl
1324import Test.Hspec
1425import Test.Hspec.SmallCheck
15−import Test.SmallCheck
16−import Test.SmallCheck.Series.Instances
17−
18−
19−type SchemaExample
20− = 'SchemaObject
21− '[ '("foo", 'SchemaArray '[AEq 1] ('SchemaNumber '[NGt 10]))
22− , '("bar", 'SchemaOptional ('SchemaText '[TEnum '["foo", "bar"]]))]
26+import Test.SmallCheck as SC
27+import Test.SmallCheck.Drivers as SC
28+import Test.SmallCheck.Series as SC
2329
24−type TestMigration =
25− 'Migration "test_revision"
26− '[ 'Diff '[ 'PKey "bar" ] ('Update ('SchemaText '[]))
27− , 'Diff '[ 'PKey "foo" ] ('Update ('SchemaNumber '[])) ]
30+import Debug.Trace
2831
29−type VS = 'Versioned SchemaExample '[ TestMigration ]
32+type SchemaExample = 'SchemaObject
33+ '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]))
34+ , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]
3035
31−exampleTest :: JsonRepr (SchemaOptional (SchemaText '[TEq 3]))
32−exampleTest = ReprOptional (Just (ReprText "lil"))
33−
34−exampleNumber :: JsonRepr (SchemaNumber '[NGt 10])
35−exampleNumber = ReprNumber 12
36−
37−exampleArray :: JsonRepr (SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))
38−exampleArray = ReprArray [exampleNumber]
36+type SchemaExample2 = 'SchemaObject
37+ '[ '("foo", 'SchemaArray '[ 'AEq 2] ('SchemaText '[ 'TGt 10]))
38+ , '("bar", 'SchemaOptional ('SchemaText '[ 'TRegex "[0-9]+"]))]
3939
4040jsonExample :: JsonRepr SchemaExample
41−jsonExample = ReprObject $
42− FieldRepr (ReprArray [ReprNumber 12])
43− :& FieldRepr (ReprOptional (Just (ReprText "bar")))
44− :& RNil
41+jsonExample = withRepr @SchemaExample
42+ $ field @"bar" (Just "bar")
43+ :& field @"foo" [12]
44+ :& RNil
45+
46+type AddQuuz =
47+ 'Migration "add_field_quuz"
48+ '[ 'Diff '[] ('AddKey "quuz" (SchemaNumber '[])) ]
49+
50+type DeleteQuuz =
51+ 'Migration "remove_field_quuz"
52+ '[ 'Diff '[] ( 'DeleteKey "quuz") ]
53+
54+type SwapFields =
55+ 'Migration "swap_fields"
56+ '[ 'Diff '[ 'PKey "bar" ] ('Update
57+ ('SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10])))
58+ , 'Diff '[ 'PKey "foo" ] ('Update
59+ ('SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))) ]
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)
74+ -- :& RNil))
75+ :&& MNil
4576
4677schemaJson :: ByteString
4778schemaJson = "{\"foo\": [13], \"bar\": null}"
@@ -49,26 +80,11 @@ schemaJson = "{\"foo\": [13], \"bar\": null}"
4980schemaJson2 :: ByteString
5081schemaJson2 = "{\"foo\": [3], \"bar\": null}"
5182
52−schemaJsonTopVersion :: ByteString
53−schemaJsonTopVersion = "{ \"foo\": 42, \"bar\": \"bar\" }"
54−
55−topObject
56− :: JsonRepr
57− ('SchemaObject
58− '[ '("foo", 'SchemaNumber '[])
59− , '("bar", 'SchemaText '[])])
60−topObject = ReprObject $
61− FieldRepr (ReprNumber 42)
62− :& FieldRepr (ReprText "test")
63− :& RNil
64−
65−instance
66− MigrateSchema
67− SchemaExample
68− ('SchemaObject
69− '[ '("foo", 'SchemaNumber '[]), '("bar", 'SchemaText '[])])
70− where
71− migrate = const topObject
83+schemaJsonSeries :: Monad m => SC.Series m (JsonRepr SchemaExample)
84+schemaJsonSeries = series
85+
86+schemaJsonSeries2 :: Monad m => SC.Series m (JsonRepr SchemaExample2)
87+schemaJsonSeries2 = series
7288
7389spec :: Spec
7490spec = do
@@ -85,15 +101,22 @@ spec = do
85101 it "validates incorrect representation" $
86102 ((decodeAndValidateJson schemaJson2) :: ParseResult (JsonRepr SchemaExample))
87103 `shouldSatisfy` isValidationError
88− it "validates versioned json" $ do
89− decodeAndValidateVersionedJson (Proxy @VS) schemaJson
90− `shouldSatisfy` isValid
91− it "validates with Migration List" $ do
92− decodeAndValidateVersionedWithMList
93− (Proxy @VS)
94− ((:&&) (Proxy @(SchemaByRevision "test_revision" VS)) (const topObject) MNil)
104+ -- it "validates versioned json" $ do
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
95111 schemaJson
96112 `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+
97120
98121main :: IO ()
99122main = hspec spec