git.iko.soy/typeable/schematic
on a6ec669 help sign in
7db0b46
swap
0 ahead, 161 behind
.travis.ymldeleted−25
since splitsnapshots
unifiedsplit
@@ -1,25 +0,0 @@
1−sudo: required
2−
3−language: c
4−
5−addons:
6− apt:
7− packages:
8− - libgmp-dev
9−
10−env:
11− - STACK_YAML=stack.yaml
12−
13−install:
14− - mkdir -p ~/.local/bin
15− - export PATH=$HOME/.local/bin:$PATH
16− - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
17− - stack --version
18− - stack setup --no-terminal
19−
20−script:
21− - stack test --ghc-options=-Werror --no-terminal
22−
23−cache:
24− directories:
25− - $HOME/.stack
ChangeLog.mddeleted−66
@@ -1,66 +0,0 @@
1−# Revision history for schematic
2−
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.
59−
60−## 0.1.5.0 -- 2017-08-22
61−
62−Lens compatibility for typed json objects.
63−
64−## 0.1.0.0 -- YYYY-mm-dd
65−
66−* First version. Released on an unsuspecting world.
README.mddeleted−255
@@ -1,255 +0,0 @@
1−# schematic
2−
3−[![Build Status](https://travis-ci.org/typeable/schematic.svg?branch=master)](https://travis-ci.org/typeable/schematic)
4−
5−## Goal
6−
7−The goal of the library is to provide a type-safe transport layer for serializing and validating JSON. It can be thought of as a subset of [json-schema](http://json-schema.org), which is basically a specification of a JSON document. The other goal is getting as much as possible from this specification for free. Right now the following bits are prototyped:
8−
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.
11−* Runtime value validators are generated from the schema. Validation errors are reported as a pairs of a json-path to the element and an error message.
12−* There are migrations. It's possible to describe a series of migrations to the schema and have all the 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)
14−
15−Be aware that library is experimental and subject to change a lot. The current state can be viewed as a prototype.
16−
17−## Installation
18−
19−* Install [Stack](https://github.com/commercialhaskell/stack)
20−
21−```
22−$ stack install schematic
23−```
24−
25−## GHC Extensions
26−
27−To use this library without any hassle you should add a few GHC extension
28−either to a module or a cabal file:
29−
30−```
31−DataKinds
32−OverloadedLists
33−OverloadedStrings
34−TypeApplications
35−```
36−
37−`Overloaded`-extensions are being used only by `field` combinator,
38−so if you don't use it - feel free to disable it.
39−
40−## GHC Options
41−
42−I recommend using `{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}`
43−pragma in modules which declare schemas and schema migrations, because `schematic`
44−heavily uses promoted types which should be prefixed with "`" signs and they can
45−be dropped with this option, making it less noisy visually.
46−It's entirely optional and totally opinionated, so feel free to ignore this.
47−Through the documentation, the code is written without any explicit ticks for
48−the same reason.
49−Notice that they're still needed for type-level lists and tuples in schematic code.
50−
51−## Basic Examples
52−
53−```haskell
54−type SchemaExample
55− = SchemaObject
56− '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))
57− , '("bar", SchemaOptional (SchemaText '[TEnum '["foo", "bar"]]))]
58−```
59−
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
65− * that element must be strictly greater than 10
66− * value of "bar" field must be either "foo" or "bar" if presented
67−
68−
69−This one is valid for example
70−
71−```haskell
72−schemaJson :: ByteString
73−schemaJson = "{\"foo\": [13], \"bar\": null}"
74−```
75−
76−Also valid
77−
78−```haskell
79−schemaJson :: ByteString
80−schemaJson = "{\"foo\": [13], \"bar\": \"bar\"}"
81−```
82−
83−it can be parsed and validated like this:
84−
85−```haskell
86−decodeAndValidateJson schemaJson :: ParseResult (JsonRepr SchemaExample)
87−```
88−
89−`ParseResult` type encodes three possible situations:
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
94−
95−It implies a transport layer representation of that data that can be traversed
96−and transformed to whatever internal types user has.
97−It's called `JsonRepr`. Type parameter is the schema itself.
98−
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:
108−
109−```
110−jsonExample' :: JsonRepr SchemaExample
111−jsonExample' = ReprObject $
112− FieldRepr (ReprArray [ReprNumber 12])
113− :& FieldRepr (ReprOptional (Just (ReprText "bar")))
114− :& RNil
115−```
116−
117−## Lens-compatibility
118−
119−It's possible to use `flens` to construct a field lens for a typed object in schematic. Let's suppose you have a schema like this:
120−
121−```haskell
122−type ArraySchema = SchemaArray '[AEq 1] (SchemaNumber '[NGt 10])
123−
124−type ArrayField = '("foo", ArraySchema)
125−
126−type FieldsSchema =
127− '[ ArrayField, '("bar", SchemaOptional (SchemaText '[TEnum '["foo", "bar"]]))]
128−
129−type SchemaExample = 'SchemaObject FieldsSchema
130−
131−```
132−
133−There are two ways of working with named fields in the objects:
134−
135−* Using the `fget` and `fset` functions: `fget @"foo" (fput newFooVal objectData) == newFooVal`
136−* Using the lens library: `set (flens @"foo") newFooVal objectData ^. flens @"foo" == newFooVal`
137−
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
153−type SchemaExample
154− = SchemaObject
155− '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))
156− , '("bar", SchemaOptional (SchemaText '[TEnum '["foo", "bar"]]))]
157−
158−type TestMigration =
159− 'Migration "test_revision"
160− '[ Diff '[ PKey "bar" ] (Update (SchemaText '[]))
161− , Diff '[ PKey "foo" ] (Update (SchemaNumber '[])) ]
162−
163−type VS = 'Versioned SchemaExample '[ TestMigration ]
164−
165−schemaJsonTopVersion :: ByteString
166−schemaJsonTopVersion = "{ \"foo\": 42, \"bar\": \"bar\" }"
167−```
168−
169−It's possible to decode the latest version like this:
170−
171−```
172−decodeAndValidateJson schemaJsonTopVersion :: ParseResult (JsonRepr (TopVersion (AllVersions VS)))
173−```
174−
175−It's important to differentiate between schema migrations and data migrations.
176−Schema migration is a change of a schema acceptable by a JSON consumer. It transforms one schema to another.
177−Data migrations on the other hand are functions on the data itself. They transform values
178−acceptable by one schema to values acceptable by another.
179−Let's look at the situation when we have to add a field to a JSON Object of a current schema:
180−
181−```haskell
182−type SchemaExample = 'SchemaObject
183− '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]))
184− , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]
185−
186−jsonExample :: JsonRepr SchemaExample
187−jsonExample = withRepr @SchemaExample
188− $ field @"bar" (Just "bar")
189− :& field @"foo" [12]
190− :& RNil
191−
192−type AddQuuz =
193− 'Migration "add_field_quuz"
194− '[ 'Diff '[] ('AddKey "quuz" (SchemaNumber '[])) ]
195−
196−type DeleteQuuz =
197− 'Migration "remove_field_quuz"
198− '[ 'Diff '[] ( 'DeleteKey "quuz") ]
199−
200−type Migrations = '[ AddQuuz
201− , DeleteQuuz ]
202−
203−type VersionedJson = 'Versioned SchemaExample Migrations
204−
205−migrationList :: MigrationList Identity VersionedJson
206−migrationList
207− = (migrateObject (\r -> Identity $ field @"quuz" 42 :& r))
208− :&& shrinkObject
209− :&& MNil
210−
211−```
212−
213−In this instance `Migrations` is a list of schema migrations and
214−`MigrationList Identity VersionedJson` is a list of data migrations corresponding
215−to the list of schema migrations: `migrateObject (\r -> Identity $ field @"quuz" 42 :& r))`
216−will be used at runtime to transform `JsonRepr SchemaExample` to
217−`JsonRepr (SchemaByRevision "add_quuz" VersionedJson). `Identity` in the type of
218−`MigrationList` is a monad we choose to run our migrations in. If there's need to
219−do database queries or something like that, it can be changed to something more
220−appropriate by a user.
221−`migrateObject` takes a function transforming old fields into new ones, `shrinkObject`
222−allows to shrink the JSON object in case migration only removed fields.
223−
224−## How do I construct a value of `JsonRepr schema`?
225−
226−`JsonRepr schema` is a primary representation of a value serializable/deserializable
227−to JSON, but with a twist. It's guaranteed to correspond a type-level schema,
228−it's a type parameter of a same name.
229−It makes constructing it a little bit more involved, but luckily `schematic`
230−provides a DSL for doing so in a more straightforward fashion. An example would
231−look like this:
232−
233−```haskell
234−type SchemaExample = 'SchemaObject
235− '[ '("foo", SchemaArray '[ AEq 1] (SchemaNumber '[NGt 10]))
236− , '("bar", SchemaOptional (SchemaText '[TEnum '["foo", "bar"]]))]
237−
238−jsonExample = withRepr @SchemaExample
239− $ field @"bar" (Just "bar")
240− :& field @"foo" [12]
241− :& RNil
242−```
243−
244−`@foo` syntax is an explicit type application, which is a feature of GHC 8+, it
245−makes type inference possible without relying on a bunch of `Proxy`s, which
246−makes it syntactically more terse.
247−
248−[GHC Type Applications](https://ghc.haskell.org/trac/ghc/wiki/TypeApplication)
249−
250−`schematic` provides instances for `OverloadedLists` and `OverloadedStrings`
251−GHC extensions to make use of string and list literals for values in a previous
252−example.
253−
254−
255−## Export to json-schema (draft 4)
releasedeleted−43
@@ -1,43 +0,0 @@
1−#!/bin/bash
2−
3−set -o xtrace
4−
5−dist=`stack path --dist-dir --stack-yaml ./stack.yaml 2> /dev/null`
6−
7−rootdir=`pwd`
8−
9−cabalfile=`ls *.cabal`
10−packagename="${cabalfile%%.*}"
11−version=`grep '^version:' schematic.cabal | rev | cut -d" " -f1 | rev`
12−
13−echo -e "\033[1;36mTesting library...\033[0m"
14−stack test 2> /dev/null
15−
16−echo -e "\033[1;36mRunning sdist...\033[0m"
17−cabal sdist
18−
19−echo -e "\033[1;36mGenerating documentation...\033[0m"
20−stack haddock 2> /dev/null
21−
22−if [ "$?" -eq "0" ]; then
23− echo -e "\033[1;32mUploading package to Hackage...\033[0m"
24− read -p "Hackage username: " username
25− read -p "Hackage password: " -s password
26− echo ""
27− cabal upload -u $username -p $password dist/$packagename-$version.tar.gz
28−
29− docdir=`find .stack-work -name "$packagename-$version-docs"`
30−
31− echo -e "Compressing documentation from \033[1;34m$docdir\033[0m for \033[1;35m$packagename\033[0m-\033[1;33m$version\033[1;30m"
32− tar -c -v -z --format=ustar -f $docdir.tar.gz $docdir
33− echo -e "\033[1;32mUploading documentation to Hackage...\033[0m"
34− cd $docdir
35− cd ..
36− curl -X PUT -H 'Content-Type: application/x-tar' -H 'Content-Encoding: gzip' --data-binary "$packagename-$version-docs.tar.gz" "https://$username:$password@hackage.haskell.org/package/$packagename-$version/candidate/docs"
37− open "https://hackage.haskell.org/package/$packagename-$version/candidate/"
38− cd $rootdir
39− echo "To publish the candidate, use 'cabal upload --publish'."
40− exit $?
41−else
42− echo -e "\033[1;31mNot in a stack-powered project\033[0m"
43−fi
release.nixdeleted−32
@@ -1,32 +0,0 @@
1−{ schematicSrc ? { outPath = ./.; revCount = 0; gitTag = "dirty"; }
2−, supportedSystems ? [ "x86_64-linux" ]
3−}:
4−
5−let
6− _nixpkgs = import <nixpkgs> {};
7− inherit (_nixpkgs) pkgs lib;
8−
9− stackageOverlayPath = pkgs.fetchFromGitHub {
10− owner = "typeable";
11− repo = "nixpkgs-stackage";
12− rev = "abe0a03ba2bde609b0707ce45301ec836cb3ed29";
13− sha256 = "0ksdk83zbsgvs30izwsfyjh4xxwz8dsn9a5igrs3pjap4whpzqfv";
14− };
15−
16− nixpkgsArgs = {
17− overlays = [ (import stackageOverlayPath) ];
18− };
19−
20− release = import <nixpkgs/pkgs/top-level/release-lib.nix> { inherit nixpkgsArgs supportedSystems; };
21−
22− mkStackage = system:
23− let
24− nixpkgs = release.pkgsFor system;
25− stackage = nixpkgs.haskell.packages.stackage.lib.callStackage2nix "schematic" schematicSrc { inherit nixpkgs; };
26− in
27− stackage;
28−
29−in
30− lib.genAttrs supportedSystems (system: {
31− inherit (mkStackage system) schematic;
32− })
schematic.cabal+48−59
@@ -1,44 +1,32 @@
1+-- Initial schematic.cabal generated by cabal init. For further
2+-- documentation, see http://haskell.org/cabal/users-guide/
3+
1name: schematic
4name: schematic
2−version: 0.6.0.0
5+version: 0.1.0.0
3synopsis: JSON-biased spec and validation tool
6synopsis: JSON-biased spec and validation tool
4−description: JSON-biased spec and validation tool. Makes possible to have a schema as a haskell type and derive json instances, validation actions, JSON generation for property-test generically. Built-in lens support.
7+-- description:
5license: BSD3
8license: BSD3
6license-file: LICENSE
9license-file: LICENSE
7author: Denis Redozubov
10author: Denis Redozubov
8maintainer: denis.redozubov@gmail.com
11maintainer: denis.redozubov@gmail.com
9−homepage: http://github.com/typeable/schematic
12+-- copyright:
10−Bug-reports: http://github.com/typeable/schematic/issues/
11category: Data
13category: Data
12build-type: Simple
14build-type: Simple
13−extra-source-files: ChangeLog.md, README.md
15+extra-source-files: ChangeLog.md
14cabal-version: >=1.10
16cabal-version: >=1.10
15
17
16library
18library
17− exposed-modules: Data.Schematic
19+ exposed-modules: Data.Aeson.Validation
18− , Data.Schematic.DSL
19− , Data.Schematic.Generator
20− , Data.Schematic.Generator.Regex
21− , Data.Schematic.Instances
22− , Data.Schematic.JsonSchema
23− , Data.Schematic.Helpers
20+ , Data.Schematic
24− , Data.Schematic.Lens
25− , Data.Schematic.Migration
26− , Data.Schematic.Path
27 , Data.Schematic.Schema
21 , Data.Schematic.Schema
28 , Data.Schematic.Validation
22 , Data.Schematic.Validation
29− , Data.Schematic.Verifier
30− , Data.Schematic.Verifier.Array
31− , Data.Schematic.Verifier.Common
32− , Data.Schematic.Verifier.Number
33− , Data.Schematic.Verifier.Text
34− ghc-options: -Wall
23+ -- ghc-options:
24+ -- other-modules:
35 default-extensions: ConstraintKinds
25 default-extensions: ConstraintKinds
36 , DataKinds
26 , DataKinds
37 , DefaultSignatures
27 , DefaultSignatures
38 , DeriveFunctor
28 , DeriveFunctor
39 , DeriveFoldable
29 , DeriveFoldable
40− , DeriveTraversable
41− , DeriveGeneric
42 , DeriveDataTypeable
30 , DeriveDataTypeable
43 , FlexibleContexts
31 , FlexibleContexts
44 , FlexibleInstances
32 , FlexibleInstances
@@ -60,29 +48,20 @@ library
60 , TemplateHaskell
48 , TemplateHaskell
61 , TypeApplications
49 , TypeApplications
62 , TypeFamilies
50 , TypeFamilies
63− , TypeFamilyDependencies
64 , TypeInType
51 , TypeInType
65 , TypeOperators
52 , TypeOperators
66 , TypeSynonymInstances
53 , TypeSynonymInstances
67 , UndecidableInstances
54 , UndecidableInstances
68− build-depends: base >=4.11 && <5
55+ build-depends: base >=4.9 && <4.10
69− , bytestring
70− , aeson >= 1.4.3.0 && < 1.6
56+ , aeson >= 1
71− , containers
57+ , deriving-compat
72− , hjsonschema
58+ , recursion-schemes
73− , mtl
74− , profunctors
75− , regex-tdfa
76− , regex-tdfa-text
59+ , regex-compat
77 , scientific
60 , scientific
78− , singletons >= 2.4
61+ , singletons
79− , smallcheck
80− , tagged
81− , template-haskell
82 , text
62 , text
83− , union
84 , unordered-containers
63 , unordered-containers
85− , validationt >= 0.2.1.0
64+ , validationt >= 0.1.0.1
86 , vector
65 , vector
87 , vinyl
66 , vinyl
88 hs-source-dirs: src
67 hs-source-dirs: src
@@ -93,32 +72,42 @@ test-suite spec
93 hs-source-dirs: test
72 hs-source-dirs: test
94 main-is: Spec.hs
73 main-is: Spec.hs
95 default-language: Haskell2010
74 default-language: Haskell2010
75+ default-extensions: ConstraintKinds
76+ , DataKinds
77+ , DeriveFunctor
78+ , DeriveFoldable
79+ , DeriveDataTypeable
80+ , FlexibleContexts
81+ , FlexibleInstances
82+ , FunctionalDependencies
83+ , GADTs
84+ , KindSignatures
85+ , InstanceSigs
86+ , MultiParamTypeClasses
87+ , OverloadedLists
88+ , OverloadedStrings
89+ , PolyKinds
90+ , QuasiQuotes
91+ , PartialTypeSignatures
92+ , RecordWildCards
93+ , ScopedTypeVariables
94+ , TemplateHaskell
95+ , TypeApplications
96+ , TypeFamilies
97+ , TypeInType
98+ , TypeOperators
99+ , TypeSynonymInstances
96 build-depends: HUnit
100 build-depends: HUnit
97 , aeson >= 1
101 , aeson >= 1
98− , base >=4.11 && <4.13
102+ , base >=4.9 && <4.10
99− , bytestring
100− , containers
101− , hjsonschema
102 , hspec >= 2.2.0
103 , hspec >= 2.2.0
103 , hspec-core
104 , hspec-core
104 , hspec-discover
105 , hspec-discover
105− , hspec-smallcheck
106+ , recursion-schemes
106− , lens
107− , regex-tdfa
107+ , regex-compat
108− , regex-tdfa-text
109 , schematic
108 , schematic
110− , smallcheck
111− , singletons
112− , tagged
113 , text
109 , text
114 , unordered-containers
110 , unordered-containers
115− , validationt >= 0.2.1.0
111+ , validationt >= 0.1.0.1
116 , vinyl
112 , vinyl
117− other-modules: SchemaSpec
113+ other-modules: SchemaSpec
118− , HelpersSpec
119− , LensSpec
120− , JsonSchemaSpec
121−
122−source-repository head
123− type: git
124− location: https://github.com/typeable/schematic
src/Data/Aeson/Validation.hsnew file+84
@@ -0,0 +1,84 @@
1+module Data.Aeson.Validation where
2+
3+
4+import Control.Applicative
5+import Control.Monad
6+import Data.Aeson.Types as J
7+import Data.Foldable as F
8+import Data.Functor.Foldable
9+import Data.HashMap.Strict as H
10+import Data.Maybe
11+import Data.Proxy
12+import Data.Schematic.Validation
13+import Data.Singletons
14+import Data.Singletons.Decide
15+import Data.Text as T
16+import Data.Traversable
17+
18+
19+(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool
20+(<&&>) = liftA2 (&&)
21+
22+infixl 3 <&&>
23+
24+-- validateConstraint
25+-- :: TopLevel spec
26+-- => Sing spec
27+-- -> CRepr spec
28+-- -> Value
29+-- -> Maybe Bool
30+-- validateConstraint s c = \case
31+-- J.String t -> case s %~ SJText of
32+-- Proved Refl -> pure $ case fromSing c of
33+-- TEq n -> (== n) . fromIntegral . T.length $ t
34+-- TLe n -> (<= n) . fromIntegral . T.length $ t
35+-- TGt n -> (> n) . fromIntegral . T.length $ t
36+-- Disproved _ -> mzero
37+-- J.Number i -> case s %~ SJNumber of
38+-- Proved Refl -> pure $ case fromSing c of
39+-- NEq n -> i == fromIntegral n
40+-- NLe n -> i <= fromIntegral n
41+-- NGt n -> i > fromIntegral n
42+-- Disproved _ -> mzero
43+-- J.Array v -> case s %~ SJArray of
44+-- Proved Refl -> case fromSing c of
45+-- AEq n -> pure . (== fromIntegral n) . F.length $ v
46+-- Disproved _ -> Nothing
47+-- J.Null -> Just True
48+-- _ -> Just False
49+
50+-- validateConstraints
51+-- :: SDecide JType
52+-- => Sing jtype
53+-- -> [CRepr jtype]
54+-- -> Value
55+-- -> Maybe Bool
56+-- validateConstraints s cs v = and <$> traverse alg cs
57+-- where
58+-- alg c = validateConstraint s c v
59+
60+-- validateJson
61+-- :: (SDecide JType, TopLevel spec)
62+-- => Sing spec
63+-- -> Value
64+-- -> Maybe Bool
65+-- validateJson = validateBySchema . fromSing
66+
67+-- validateBySchema
68+-- :: SDecide JType
69+-- => Schema
70+-- -> Value
71+-- -> Maybe Bool
72+-- validateBySchema s v = case (unfix s, v) of
73+-- (SchemaArray cs ss, jv@(J.Array v)) -> do
74+-- itself <- validateConstraints SJArray cs jv
75+-- content <- traverse (validateBySchema ss) v
76+-- pure $ itself && and content
77+-- (SchemaObject ocs, J.Object o) -> do
78+-- fmap and $ for ocs $ \(fieldName, s) -> do
79+-- val <- H.lookup (T.pack fieldName) o
80+-- validateBySchema s val
81+-- (SchemaText cs, js@(J.String _)) -> validateConstraints SJText cs js
82+-- (SchemaNumber cs, jn@(J.Number _)) -> validateConstraints SJNumber cs jn
83+-- (SchemaNull, J.Null) -> Just True
84+-- _ -> Nothing
src/Data/Schematic.hs+1−103
@@ -1,103 +1 @@
1−{-# OPTIONS -fprint-explicit-kinds #-}
2−{-# LANGUAGE AllowAmbiguousTypes #-}
3−
4−module Data.Schematic
1+module Data.Schematic where
5− ( module Data.Schematic.JsonSchema
6− , module Data.Schematic.Helpers
7− , module Data.Schematic.Lens
8− , module Data.Schematic.Migration
9− , module Data.Schematic.Schema
10− , decodeAndValidateJson
11− , parseAndValidateJson
12− , parseAndValidateJsonBy
13− , parseAndValidateTopVersionJson
14− , parseAndValidateWithMList
15− , decodeAndValidateVersionedWithMList
16− , decodeAndValidateVersionedWithPureMList
17− , isValid
18− , isDecodingError
19− , isValidationError
20− , ParseResult(..)
21− , withRepr
22− , field
23− ) where
24−
25−import Control.Monad.Validation
26−import Data.Aeson as J
27−import Data.Aeson.Types as J
28−import Data.ByteString.Lazy as BL
29−import Data.Functor.Identity as F
30−import Data.Schematic.DSL
31−import Data.Schematic.Helpers
32−import Data.Schematic.JsonSchema
33−import Data.Schematic.Lens
34−import Data.Schematic.Migration
35−import Data.Schematic.Schema
36−import Data.Schematic.Validation
37−import Data.Singletons.Prelude hiding ((:.))
38−import Data.Tagged
39−import Data.Text as T
40−
41−
42−parseAndValidateTopVersionJson
43− :: forall proxy (v :: Versioned)
44− . (SingI (TopVersion (AllVersions v)))
45− => proxy v
46− -> J.Value
47− -> ParseResult (JsonRepr (TopVersion (AllVersions v)))
48−parseAndValidateTopVersionJson _ v =
49− case parseEither parseJSON v of
50− Left s -> DecodingError $ T.pack s
51− Right jsonRepr ->
52− let
53− validate =
54− validateJsonRepr (sing :: Sing (TopVersion (AllVersions v))) [] jsonRepr
55− res = runIdentity . runValidationTEither $ validate
56− in case res of
57− Left em -> ValidationError em
58− Right () -> Valid jsonRepr
59−
60−parseAndValidateWithMList
61− :: Monad m
62− => MList m revisions
63− -> J.Value
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'
77−
78−decodeAndValidateJson
79− :: forall schema
80− . (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
81− => BL.ByteString
82− -> ParseResult (JsonRepr schema)
83−decodeAndValidateJson bs = case decode bs of
84− Nothing -> DecodingError "malformed json"
85− Just x -> parseAndValidateJson x
86−
87−decodeAndValidateVersionedWithMList
88− :: Monad m
89− => proxy versioned
90− -> MList m (MapSnd (AllVersions versioned))
91− -> BL.ByteString
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
96−
97−decodeAndValidateVersionedWithPureMList
98− :: proxy versioned
99− -> MList F.Identity (MapSnd (AllVersions versioned))
100− -> BL.ByteString
101− -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))
102−decodeAndValidateVersionedWithPureMList a b c =
103− runIdentity $ decodeAndValidateVersionedWithMList a b c
src/Data/Schematic/DSL.hsdeleted−92
@@ -1,92 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
3−
4−module Data.Schematic.DSL where
5−
6−import Data.Kind
7−import Data.Schematic.Lens
8−import Data.Schematic.Schema
9−import Data.Scientific
10−import Data.Singletons
11−import Data.Singletons.Prelude hiding ((:.))
12−import Data.Singletons.TypeLits
13−import Data.Tagged
14−import Data.Text as T
15−import Data.Union
16−import qualified Data.Vector as V
17−import Data.Vinyl
18−import Data.Vinyl.Functor
19−
20−
21−#if MIN_VERSION_base(4,12,0)
22−type Constructor a
23− = forall fields b
24− . (fields ~ FieldsOf a, FSubset fields b (FImage fields b), RMap fields)
25− => Rec (Tagged fields :. FieldRepr) b
26− -> JsonRepr ('SchemaObject fields)
27−#else
28−type Constructor a
29− = forall fields b
30− . (fields ~ FieldsOf a, FSubset fields b (FImage fields b))
31− => Rec (Tagged fields :. FieldRepr) b
32− -> JsonRepr ('SchemaObject fields)
33−#endif
34−withRepr :: Constructor a
35−withRepr = ReprObject . rmap (unTagged . getCompose) . fcast
36−
37−class Representable s where
38− constructField :: Sing fn -> Proxy s -> Repr s -> FieldRepr '(fn, s)
39−
40−instance SingI so => Representable ('SchemaObject so) where
41− constructField sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprObject o
42−
43−instance (SingI cs, SingI sa) => Representable ('SchemaArray cs sa) where
44− constructField sfn _ a = withKnownSymbol sfn $ FieldRepr $ ReprArray a
45−
46−instance SingI cs => Representable ('SchemaText cs) where
47− constructField sfn _ t = withKnownSymbol sfn $ FieldRepr $ ReprText t
48−
49−instance SingI cs => Representable ('SchemaNumber cs) where
50− constructField sfn _ n = withKnownSymbol sfn $ FieldRepr $ ReprNumber n
51−
52−instance Representable 'SchemaBoolean where
53− constructField sfn _ b = withKnownSymbol sfn $ FieldRepr $ ReprBoolean b
54−
55−instance SingI so => Representable ('SchemaOptional so) where
56− constructField sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprOptional o
57−
58−instance SingI (h ': tl) => Representable ('SchemaUnion (h ': tl)) where
59− constructField sfn _ u = withKnownSymbol sfn $ FieldRepr $ ReprUnion u
60−
61−construct :: Sing s -> Repr s -> JsonRepr s
62−construct s r = case s of
63− SSchemaObject _ -> ReprObject r
64− SSchemaArray _ _ -> ReprArray r
65− SSchemaText _ -> ReprText r
66− SSchemaNumber _ -> ReprNumber r
67− SSchemaBoolean -> ReprBoolean r
68− SSchemaOptional _ -> ReprOptional r
69− SSchemaNull -> ReprNull
70− SSchemaUnion ss -> case ss of
71− SNil -> error "unconstructable union"
72− SCons _ _ -> ReprUnion r
73−
74−type family FieldsOf (s :: Schema) :: [(Symbol, Schema)] where
75− FieldsOf ('SchemaObject fs) = fs
76−
77−type FieldConstructor fn =
78− forall byField fs. (byField ~ ByField fn fs (FIndex fn fs), Representable byField)
79− => Repr byField
80− -> (Tagged fs :. FieldRepr) '(fn, byField)
81−
82−field :: forall fn. KnownSymbol fn => FieldConstructor fn
83−field = Compose . Tagged . constructField (sing :: Sing fn) Proxy
84−
85−type family Repr (s :: Schema) = (ty :: Type) where
86− Repr ('SchemaObject so) = Rec FieldRepr so
87− Repr ('SchemaArray cs sa) = V.Vector (JsonRepr sa)
88− Repr ('SchemaText cs) = Text
89− Repr ('SchemaNumber cs) = Scientific
90− Repr 'SchemaBoolean = Bool
91− Repr ('SchemaOptional so) = Maybe (JsonRepr so)
92− Repr ('SchemaUnion (h ': tl)) = Union JsonRepr (h ': tl)
src/Data/Schematic/Generator.hsdeleted−91
@@ -1,91 +0,0 @@
1−module Data.Schematic.Generator where
2−
3−import Data.Maybe
4−import Data.Schematic.Generator.Regex
5−import {-# SOURCE #-} Data.Schematic.Schema
6−import Data.Schematic.Verifier
7−import Data.Scientific
8−import Data.Text (Text, pack)
9−import qualified Data.Vector as V
10−import Test.SmallCheck.Series
11−
12−maxHigh :: Int
13−maxHigh = 30
14−
15−minLow :: Int
16−minLow = 2
17−
18−textLengthSeries :: Monad m => [VerifiedTextConstraint] -> Series m Text
19−textLengthSeries =
20− \case
21− [VTEq eq] -> pure $ pack $ take (fromIntegral eq) $ cycle "sample"
22− [VTBounds ml mh] -> do
23− let
24− l = fromMaybe minLow (fromIntegral <$> ml) + 1
25− h = fromMaybe maxHigh (fromIntegral <$> mh) - 1
26− n <- generate $ \depth -> take depth [l .. h]
27− pure $ pack $ take (fromIntegral n) $ cycle "sample"
28− _ -> pure "error"
29−
30−textEnumSeries :: Monad m => [Text] -> Series m Text
31−textEnumSeries enum = generate $ \depth -> take depth enum
32−
33−textSeries :: Monad m => [DemotedTextConstraint] -> Series m Text
34−textSeries cs = do
35− let mvcs = verifyTextConstraints cs
36− case mvcs of
37− Just vcs -> do
38− n <- textSeries' vcs
39− pure n
40− Nothing -> pure "error"
41−
42−textSeries' :: Monad m => [VerifiedTextConstraint] -> Series m Text
43−textSeries' [] = pure "sample"
44−textSeries' vcs = do
45− let enums = listToMaybe [x | VTEnum x <- vcs]
46− case enums of
47− Just e -> textEnumSeries e
48− Nothing -> do
49− let regexps = listToMaybe [x | VTRegex x _ _ <- vcs]
50− case regexps of
51− Just e -> regexSeries e
52− Nothing -> textLengthSeries vcs
53−
54−numberSeries :: Monad m => [DemotedNumberConstraint] -> Series m Scientific
55−numberSeries cs = do
56− let mvcs = verifyNumberConstraints cs
57− case mvcs of
58− Just vcs -> do
59− n <- numberSeries' vcs
60− pure $ n
61− Nothing -> pure 0
62−
63−numberSeries' :: Monad m => VerifiedNumberConstraint -> Series m Scientific
64−numberSeries' =
65− \case
66− VNEq eq -> pure $ fromIntegral eq
67− VNBounds ml mh -> do
68− let l = fromMaybe minLow (fromIntegral <$> ml) + 1
69− h = fromMaybe maxHigh (fromIntegral <$> mh) - 1
70− n <- generate $ \depth -> take depth [l .. h]
71− pure $ fromIntegral n
72−
73−arraySeries
74− :: (Monad m, Serial m (JsonRepr s))
75− => [DemotedArrayConstraint]
76− -> Series m (V.Vector (JsonRepr s))
77−arraySeries cs = do
78− let mvcs = verifyArrayConstraint cs
79− case mvcs of
80− Just vcs -> arraySeries' vcs
81− Nothing -> pure V.empty
82−
83−arraySeries'
84− :: forall m s. (Monad m, Serial m (JsonRepr s))
85− => Maybe VerifiedArrayConstraint
86− -> Series m (V.Vector (JsonRepr s))
87−arraySeries' ml = do
88− objs <- V.replicateM (maybe minRepeat f ml) (series :: Series m (JsonRepr s))
89− pure $ objs
90− where
91− f (VAEq l) = fromIntegral l
src/Data/Schematic/Generator/Regex.hsdeleted−76
@@ -1,76 +0,0 @@
1−module Data.Schematic.Generator.Regex where
2−
3−import Control.Monad
4−import Data.List
5−import Data.Maybe
6−import qualified Data.Set as S
7−import Data.Text (Text, unpack)
8−import Data.Text.Lazy (toStrict)
9−import Data.Text.Lazy.Builder (Builder, singleton, toLazyText)
10−import Test.SmallCheck.Series
11−import Text.Regex.TDFA.Pattern
12−import Text.Regex.TDFA.ReadRegex (parseRegex)
13−
14−
15−minRepeat :: Int
16−minRepeat = 2
17−
18−maxRepeat :: Int
19−maxRepeat = 10
20−
21−regexSeries :: (Monad m) => Text -> Series m Text
22−regexSeries regexp =
23− case parseRegex . unpack $ regexp of
24− Right (p, _) -> toStrict . toLazyText <$> regexSeries' p
25− Left _ -> pure ""
26−
27−regexSeries' :: (Monad m) => Pattern -> Series m Builder
28−regexSeries' pt =
29− case pt of
30− PEmpty -> pure mempty
31− PChar {..} -> pure $ singleton getPatternChar
32− PAny {getPatternSet = PatternSet (Just cset) _ _ _} -> do
33− x <- generate $ \depth -> take depth $ S.toList cset
34− pure $ singleton x
35− PAnyNot {getPatternSet = PatternSet (Just cset) _ _ _} -> do
36− x <-
37− generate $ \depth ->
38− take depth $ notChars $ concatMap expandEscape $ S.toList cset
39− pure $ singleton x
40− PQuest p -> regexSeries' p \/ pure mempty
41− PPlus p -> regexSeries' $ PBound 1 Nothing p
42− PStar _ p -> regexSeries' $ PBound 0 Nothing p
43− PBound low mhigh p -> do
44− let high = fromMaybe (low + maxRepeat) mhigh
45− n <- generate $ \depth -> take depth [low .. high]
46− decDepth $ do
47− ps <- replicateM n $ regexSeries' p
48− pure $ mconcat ps
49− PConcat ps -> mconcat <$> mapM regexSeries' ps
50− POr xs -> regexSeries' =<< (generate $ \depth -> take depth xs)
51− PDot _ -> do
52− x <- generate $ \depth -> take depth $ notChars []
53− pure $ singleton x
54− PEscape {..} -> do
55− x <- generate $ \depth -> take depth $ expandEscape getPatternChar
56− pure $ singleton x
57− PCarat _ -> pure mempty
58− PDollar _ -> pure mempty
59− _ -> pure mempty
60− where
61− notChars = ([' ' .. '~'] \\)
62− expandEscape ch =
63− case ch of
64− 'n' -> "\n"
65− 't' -> "\t"
66− 'r' -> "\r"
67− 'f' -> "\f"
68− 'a' -> "\a"
69− 'e' -> "\ESC"
70− 'd' -> ['0' .. '9']
71− 'w' -> ['0' .. '9'] ++ '_' : ['a' .. 'z'] ++ ['A' .. 'Z']
72− 's' -> "\9\32"
73− 'D' -> notChars $ ['0' .. '9']
74− 'W' -> notChars $ ['0' .. '9'] ++ '_' : ['a' .. 'z'] ++ ['A' .. 'Z']
75− 'S' -> notChars "\9\32"
76− ch' -> [ch']
src/Data/Schematic/Helpers.hsdeleted−59
@@ -1,59 +0,0 @@
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.hsdeleted−27
@@ -1,27 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# OPTIONS_GHC -fno-warn-orphans #-}
3−
4−module Data.Schematic.Instances where
5−
6−import Data.Scientific
7−import Data.Text (Text, pack)
8−import Data.Vector as V
9−import Data.Vinyl
10−import Test.SmallCheck.Series
11−
12−
13−instance Monad m => Serial m (Rec f '[]) where
14− series = cons0 RNil
15−
16−instance (Serial m (f a), Serial m (Rec f as), Monad m)
17− => Serial m (Rec f (a ': as)) where
18− series = cons2 (:&)
19−
20−instance Serial m a => Serial m (V.Vector a) where
21− series = V.fromList <$> series
22−
23−instance Monad m => Serial m Scientific where
24− series = scientific <$> series <*> series
25−
26−instance Monad m => Serial m Text where
27− series = pack <$> series
src/Data/Schematic/JsonSchema.hsdeleted−124
@@ -1,124 +0,0 @@
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.hsdeleted−207
@@ -1,207 +0,0 @@
1−{-# LANGUAGE UndecidableSuperClasses #-}
2−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3−{-# LANGUAGE AllowAmbiguousTypes #-}
4−{-# LANGUAGE InstanceSigs #-}
5−
6−module Data.Schematic.Lens
7− ( FIndex
8− , FElem(..)
9− , FImage
10− , FSubset(..)
11− , obj
12− , arr
13− , uni
14− , txt
15− , num
16− , opt
17− , bln
18− , textRepr
19− , numberRepr
20− , boolRepr
21− , arrayRepr
22− , objectRepr
23− , optionalRepr
24− ) where
25−
26−import Data.Profunctor
27−import Data.Schematic.Schema
28−import Data.Scientific
29−import Data.Singletons
30−import Data.Text
31−import Data.Union
32−import Data.Vector as V
33−import Data.Vinyl
34−import Data.Vinyl.Functor
35−import Data.Vinyl.TypeLevel (Nat(..))
36−import GHC.TypeLits (Symbol, KnownSymbol)
37−
38−
39−-- | A partial relation that gives the index of a value in a list.
40−type family FIndex (r :: Symbol) (rs :: [(Symbol, Schema)]) :: Nat where
41− FIndex r ( '(r, s) ': rs) = 'Z
42− FIndex r ( s ': rs) = 'S (FIndex r rs)
43−
44−type Flens fn f g rs i
45− = Functor g
46− => (f '(fn, (ByField fn rs i)) -> g (f '(fn, (ByField fn rs i))))
47− -> Rec f rs
48− -> g (Rec f rs)
49−
50−type FGetter fn f rs i = Rec f rs -> f '(fn, (ByField fn rs i))
51−
52−class i ~ FIndex fn rs => FElem (fn :: Symbol) (rs :: [(Symbol, Schema)]) (i :: Nat) where
53− type ByField fn rs i :: Schema
54− flens :: Flens fn f g rs i
55−
56− -- | For Vinyl users who are not using the @lens@ package, we provide a getter.
57− fget :: FGetter fn f rs i
58−
59− -- | For Vinyl users who are not using the @lens@ package, we also provide a
60− -- setter. In general, it will be unambiguous what field is being written to,
61− -- and so we do not take a proxy argument here.
62− fput
63− :: f '(fn, ByField fn rs i)
64− -> Rec f rs
65− -> Rec f rs
66−
67−instance FElem fn ('(fn, r) ': rs) 'Z where
68− type ByField fn ('(fn, r) ': rs) 'Z = r
69−
70− flens f (x :& xs) = fmap (:& xs) (f x)
71− {-# INLINE flens #-}
72−
73− fget = getConst . flens Const
74− {-# INLINE fget #-}
75−
76− fput y = getIdentity . flens (\_ -> Identity y)
77− {-# INLINE fput #-}
78−
79−instance (FIndex r (s ': rs) ~ 'S i, FElem r rs i) => FElem r (s ': rs) ('S i) where
80− type ByField r (s ': rs) ('S i) = ByField r rs i
81−
82− flens f (x :& xs) = fmap (x :&) (flens f xs)
83− {-# INLINE flens #-}
84−
85− fget = getConst . flens Const
86− {-# INLINE fget #-}
87−
88− fput y = getIdentity . flens (\_ -> Identity y)
89− {-# INLINE fput #-}
90−
91−-- This is an internal convenience helpers stolen from the @lens@ library.
92−lens
93− :: Functor f
94− => (t -> s)
95− -> (t -> a -> b)
96− -> (s -> f a)
97− -> t
98− -> f b
99−lens sa sbt afb s = fmap (sbt s) $ afb (sa s)
100−{-# INLINE lens #-}
101−
102−type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
103−
104−type Iso' s a = Iso s s a a
105−
106−iso
107− :: (s -> a) -> (b -> t)
108− -> Iso s t a b
109−iso sa bt = dimap sa (fmap bt)
110−{-# INLINE iso #-}
111−
112−-- | A partial relation that gives the indices of a sublist in a larger list.
113−type family FImage (rs :: [(Symbol, Schema)]) (ss :: [(Symbol, Schema)]) :: [Nat] where
114− FImage '[] ss = '[]
115− FImage ('(fn,s) ': rs) ss = FIndex fn ss ': FImage rs ss
116−
117−class is ~ FImage rs ss
118− => FSubset (rs :: [(Symbol, Schema)]) (ss :: [(Symbol, Schema)]) is where
119− -- | This is a lens into a slice of the larger record. Morally, we have:
120− --
121− -- > fsubset :: Lens' (Rec FieldRepr ss) (Rec FieldRepr rs)
122− fsubset
123− :: Functor g
124− => (Rec f rs -> g (Rec f rs))
125− -> Rec f ss
126− -> g (Rec f ss)
127−
128− -- | The getter of the 'fsubset' lens is 'fcast', which takes a larger record
129− -- to a smaller one by forgetting fields.
130− fcast
131− :: Rec f ss
132− -> Rec f rs
133− fcast = getConst . fsubset Const
134− {-# INLINE fcast #-}
135−
136− -- | The setter of the 'fsubset' lens is 'freplace', which allows a slice of
137− -- a record to be replaced with different values.
138− freplace
139− :: Rec f rs
140− -> Rec f ss
141− -> Rec f ss
142− freplace rs = getIdentity . fsubset (\_ -> Identity rs)
143− {-# INLINE freplace #-}
144−
145−instance FSubset '[] ss '[] where
146− fsubset = lens (const RNil) const
147−
148−instance
149− ( ByField fn ss i ~ s
150− , FElem fn ss i
151− , FSubset rs ss is) => FSubset ( '(fn,s) ': rs) ss (i ': is) where
152− fsubset = lens (\ss -> fget @fn ss :& fcast ss) set
153− where
154− set :: Rec f ss -> Rec f ( '(fn,s) ': rs) -> Rec f ss
155− set ss (r :& rs) = fput r $ freplace rs ss
156−
157−-- A bunch of @Iso@morphisms
158−textRepr
159− :: (KnownSymbol fn, SingI cs)
160− => Iso' (FieldRepr '(fn, ('SchemaText cs))) Text
161−textRepr = iso (\(FieldRepr (ReprText t)) -> t) (FieldRepr . ReprText)
162−
163−numberRepr
164− :: (KnownSymbol fn, SingI cs)
165− => Iso' (FieldRepr '(fn, ('SchemaNumber cs))) Scientific
166−numberRepr = iso (\(FieldRepr (ReprNumber n)) -> n) (FieldRepr . ReprNumber)
167−
168−boolRepr
169− :: (KnownSymbol fn)
170− => Iso' (FieldRepr '(fn, 'SchemaBoolean)) Bool
171−boolRepr = iso (\(FieldRepr (ReprBoolean b)) -> b) (FieldRepr . ReprBoolean)
172−
173−arrayRepr
174− :: (KnownSymbol fn, SingI cs, SingI schema)
175− => Iso' (FieldRepr '(fn, ('SchemaArray cs schema))) (V.Vector (JsonRepr schema))
176−arrayRepr = iso (\(FieldRepr (ReprArray a)) -> a) (FieldRepr . ReprArray)
177−
178−objectRepr
179− :: (KnownSymbol fn, SingI fields)
180− => Iso' (FieldRepr '(fn, ('SchemaObject fields))) (Rec FieldRepr fields)
181−objectRepr = iso (\(FieldRepr (ReprObject o)) -> o) (FieldRepr . ReprObject)
182−
183−optionalRepr
184− :: (KnownSymbol fn, SingI schema)
185− => Iso' (FieldRepr '(fn, ('SchemaOptional schema))) (Maybe (JsonRepr schema))
186−optionalRepr = iso (\(FieldRepr (ReprOptional r)) -> r) (FieldRepr . ReprOptional)
187−
188−obj :: Iso' (JsonRepr ('SchemaObject fields)) (Rec FieldRepr fields)
189−obj = iso (\(ReprObject r) -> r) ReprObject
190−
191−arr :: Iso' (JsonRepr ('SchemaArray cs schema)) (V.Vector (JsonRepr schema))
192−arr = iso (\(ReprArray r) -> r) ReprArray
193−
194−uni :: Iso' (JsonRepr ('SchemaUnion (h ': tl))) (Union JsonRepr (h ': tl))
195−uni = iso (\(ReprUnion u) -> u) ReprUnion
196−
197−txt :: Iso' (JsonRepr ('SchemaText cs)) Text
198−txt = iso (\(ReprText t) -> t) ReprText
199−
200−num :: Iso' (JsonRepr ('SchemaNumber cs)) Scientific
201−num = iso (\(ReprNumber t) -> t) ReprNumber
202−
203−bln :: Iso' (JsonRepr 'SchemaBoolean) Bool
204−bln = iso (\(ReprBoolean b) -> b) ReprBoolean
205−
206−opt :: Iso' (JsonRepr ('SchemaOptional schema)) (Maybe (JsonRepr schema))
207−opt = iso (\(ReprOptional o) -> o) ReprOptional
src/Data/Schematic/Migration.hsdeleted−187
@@ -1,187 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE TemplateHaskell #-}
4−
5−module Data.Schematic.Migration where
6−
7−import Data.Kind
8−import Data.Schematic.DSL
9−import Data.Schematic.Lens
10−import Data.Schematic.Path
11−import Data.Schematic.Schema
12−import Data.Singletons.Prelude hiding ((:.), All)
13−import Data.Singletons.TypeLits
14−import Data.Tagged
15−import Data.Vinyl
16−import Data.Vinyl.Functor
17−
18−
19−data Path
20− = PKey Symbol -- traverse into the object by key
21− | PTraverse -- traverse into the array
22−
23−data instance Sing (p :: Path) where
24− SPKey :: Sing s -> Sing ('PKey s)
25− SPTraverse :: Sing 'PTraverse
26−
27−instance KnownSymbol s => SingI ('PKey s) where
28− sing = SPKey sing
29−
30−instance SingI 'PTraverse where
31− sing = SPTraverse
32−
33−-- Result type blueprint
34−data Builder
35− = BKey Schema Symbol Builder -- field schema
36− | BTraverse Schema Builder -- array schema
37− | BScalar Schema
38−
39−-- Working with keys
40−
41−type family SchemaByKey (fs :: [(Symbol, Schema)]) (s :: Symbol) :: Schema where
42− SchemaByKey ( '(fn,s) ': tl) fn = s
43− SchemaByKey ( '(a, s) ': tl) fn = SchemaByKey tl fn
44−
45−type family DeleteKey (acc :: [(Symbol, Schema)]) (fn :: Symbol) (fs :: [(Symbol, Schema)]) :: [(Symbol, Schema)] where
46− DeleteKey acc fn ('(fn, a) ': tl) = acc ++ tl
47− DeleteKey acc fn (fna ': tl) = acc ++ (fna ': tl)
48−
49−type family UpdateKey
50− (fn :: Symbol)
51− (fs :: [(Symbol, Schema)])
52− (s :: Schema) = (r :: [(Symbol, Schema)]) where
53− UpdateKey fn ( '(fn, a) ': tl ) s = ( '(fn, s) ': tl )
54− UpdateKey fn ( '(fs, a) ': tl ) s = ( '(fs, a) ': UpdateKey fn tl s)
55−
56−-- schema updates
57−
58−type family Build (b :: Builder) :: Schema where
59− Build ('BKey ('SchemaObject fs) fn z) = 'SchemaObject (UpdateKey fn fs (Build z))
60− Build ('BTraverse ('SchemaArray acs s) z) = 'SchemaArray acs (Build z)
61− Build ('BScalar s) = s
62−
63−type family MakeBuilder (s :: Schema) (d :: Diff) :: Builder where
64− MakeBuilder s ('Diff '[] a) = 'BScalar (ApplyAction a s)
65− MakeBuilder ('SchemaObject fs) ('Diff ('PKey fn ': tl) a) =
66− 'BKey ('SchemaObject fs) fn (MakeBuilder (SchemaByKey fs fn) ('Diff tl a))
67− MakeBuilder ('SchemaArray acs s) ('Diff ('PTraverse ': tl) a) =
68− 'BTraverse ('SchemaArray acs s) (MakeBuilder s ('Diff tl a))
69−
70−type family ApplyAction (a :: Action) (s :: Schema) :: Schema where
71− ApplyAction ('AddKey fn s) ('SchemaObject fs) = 'SchemaObject ('(fn,s) ': fs)
72− ApplyAction ('DeleteKey fn) ('SchemaObject fs) = 'SchemaObject (DeleteKey '[] fn fs)
73− ApplyAction ('Update s) t = s
74−
75−type family ApplyMigration (m :: Migration) (s :: Schema) :: (Revision, Schema) where
76− ApplyMigration ('Migration r '[]) s = '(r, s)
77− ApplyMigration ('Migration r (d ': ds)) s =
78− '(r, Snd (ApplyMigration ('Migration r ds) (Build (MakeBuilder s d))))
79−
80−-- working with revisions
81−
82−type family SchemaByRevision (r :: Revision) (vd :: Versioned) :: Schema where
83− SchemaByRevision r ('Versioned s (('Migration r ds) ': ms)) =
84− Snd (ApplyMigration ('Migration r ds) s)
85− SchemaByRevision r ('Versioned s (m ': ms)) =
86− SchemaByRevision r ('Versioned (Snd (ApplyMigration m s)) ms)
87−
88−type family InitialSchema (v :: Versioned) = (s :: Schema) where
89− InitialSchema ('Versioned s ms) = s
90−
91−type family ElemOf (e :: k) (l :: [(a,k)]) :: Constraint where
92− ElemOf e '[] = 'True ~ 'False
93− ElemOf e ( '(a, e) ': es) = ()
94− ElemOf e (n ': es) = ElemOf e es
95−
96−-- | Extracts revision/schema pairs from @Versioned@ in reverse order.
97−type family AllVersions (vd :: Versioned) :: [(Revision, Schema)] where
98− AllVersions ('Versioned s ms) = Reverse (AllVersions' '[ '("initial", s) ] ms)
99−
100−type family AllVersions' (acc :: [(Revision, Schema)]) (ms :: [Migration])
101− = (r :: [(Revision, Schema)]) where
102− AllVersions' acc '[] = acc
103− AllVersions' ( '(rh, sh) ': tl ) (m ': ms) =
104− AllVersions' ( '(rh, sh) ': ApplyMigration m sh ': tl ) ms
105−
106−type family TopVersion (rs :: [(Revision, Schema)]) :: Schema where
107− TopVersion ( '(rh, sh) ': tl) = sh
108−
109−data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol
110−
111−data instance Sing (a :: Action) where
112− SAddKey
113− :: Sing n
114− -> Sing s
115− -> Sing ('AddKey n s)
116− SUpdate :: Sing s -> Sing ('Update s)
117− SDeleteKey :: Sing s -> Sing ('DeleteKey s)
118−
119−-- | User-supplied atomic difference between schemas.
120−-- Migrations can consists of many differences.
121−data Diff = Diff [Path] Action
122−
123−data instance Sing (diff :: Diff) where
124− SDiff
125− :: Sing (jp :: [Path])
126− -> Sing (a :: Action)
127− -> Sing ('Diff jp a)
128−
129−-- | User-provided name of the revision.
130−type Revision = Symbol
131−
132−data Migration = Migration Revision [Diff]
133−
134−data instance Sing (m :: Migration) where
135− SMigration
136− :: Sing r
137− -> Sing ds
138− -> Sing ('Migration r ds)
139−
140−data Versioned = Versioned Schema [Migration]
141−
142−data instance Sing (v :: Versioned) where
143− SVersioned
144− :: Sing (s :: Schema) -- base version
145− -> Sing (ms :: [Migration]) -- a bunch of migrations
146− -> Sing ('Versioned s ms)
147−
148−type DataMigration s m h = Tagged s (JsonRepr h -> m (JsonRepr s))
149−
150−data MList :: (Type -> Type) -> [Schema] -> Type where
151− MNil :: (Monad m, SingI s, TopLevel s) => MList m '[s]
152− (:&&)
153− :: (TopLevel s, SingI s)
154− => DataMigration s m h
155− -> MList m (h ': tl)
156− -> MList m (s ': h ': tl)
157−
158−infixr 7 :&&
159−
160−#if MIN_VERSION_base(4,12,0)
161−migrateObject
162− :: forall m fs fh. (FSubset fs fs (FImage fs fs), Monad m, RMap fh, RMap fs)
163− => (Rec (Tagged fs :. FieldRepr) fh -> m (Rec (Tagged fs :. FieldRepr) fs))
164− -> Tagged ('SchemaObject fs) (JsonRepr ('SchemaObject fh) -> m (JsonRepr ('SchemaObject fs)))
165−#else
166−migrateObject
167− :: forall m fs fh. (FSubset fs fs (FImage fs fs), Monad m)
168− => (Rec (Tagged fs :. FieldRepr) fh -> m (Rec (Tagged fs :. FieldRepr) fs))
169− -> Tagged ('SchemaObject fs) (JsonRepr ('SchemaObject fh) -> m (JsonRepr ('SchemaObject fs)))
170−#endif
171−migrateObject f = Tagged $ \(ReprObject r) -> do
172− res <- f $ rmap (Compose . Tagged) r
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/OldSchema.hsnew file+76
@@ -0,0 +1,76 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+
3+module Data.Schematic.Schema where
4+
5+import Data.Maybe
6+import Data.Proxy
7+import GHC.TypeLits
8+import Text.Regex
9+
10+
11+-- JSON types
12+data JText
13+data JNumber
14+data JArray
15+data JObject
16+data JNull
17+
18+type family Repr (ty :: k1) :: k2 where
19+ Repr JText = String -- because of matchRegex
20+ Repr JNumber = Double
21+
22+class Schema schema where
23+ type Term subschema
24+ predicate :: Repr (Term ty) -> Bool
25+
26+data Regexp (s :: Symbol) = Regexp
27+
28+instance KnownSymbol reg => Schema (Regexp reg) subschema where
29+ type Term (Regexp reg) subschema = Term ((), subschema)
30+ predicate = isJust . matchRegex (mkRegex $ symbolVal (Proxy :: Proxy reg))
31+
32+data LengthEqNat (n :: Nat)
33+data LengthGtNat (n :: Nat)
34+data LengthGeNat (n :: Nat)
35+data LengthLtNat (n :: Nat)
36+data LengthLeNat (n :: Nat)
37+
38+instance KnownNat n => Schema (LengthEqNat n) subschema where
39+ type Term (LengthEqNat n) s = Term s
40+ predicate s = natVal (Proxy :: Proxy n) == fromIntegral (length s)
41+ && predicate
42+
43+instance KnownNat n => Schema (LengthGtNat n) rest where
44+ type Term (LengthGtNat n) = JNumber
45+ predicate s = natVal (Proxy :: Proxy n) > fromIntegral (length s)
46+
47+instance KnownNat n => Schema (LengthGeNat n) rest where
48+ type Term (LengthGeNat n) = JNumber
49+ predicate s = natVal (Proxy :: Proxy n) >= fromIntegral (length s)
50+
51+instance KnownNat n => Schema (LengthLtNat n) rest where
52+ type Term (LengthLtNat n) = JNumber
53+ predicate s = natVal (Proxy :: Proxy n) < fromIntegral (length s)
54+
55+instance KnownNat n => Schema (LengthLeNat n) rest where
56+ type Term (LengthLeNat n) = JNumber
57+ predicate s = natVal (Proxy :: Proxy n) <= fromIntegral (length s)
58+
59+-- | Corresponds to [] or {} json values.
60+data EmptyObj = EmptyObj
61+
62+data ConsObj (s :: Symbol) jsval = ConsObj
63+
64+-- data Schema a where
65+-- (:*:) :: KnownSymbol label => label -> Schema l -> Schema r -> Schema a
66+-- (:%:) :: Schema c a => Schema a -> c a -> Schema a
67+-- Nil :: Schema a
68+
69+data (s :: Symbol) :+: obj = (:+:) a b
70+
71+infixl 6 :+:
72+infixl 6 :*:
73+infixl 9 :%:
74+
75+schema :: Schema ()
76+schema = "foo" :%: (Regexp "foo") :*: Nil
src/Data/Schematic/Path.hsdeleted−36
@@ -1,36 +0,0 @@
1−module Data.Schematic.Path where
2−
3−import Data.Foldable as F
4−import Data.Singletons.Prelude
5−import Data.Singletons.TypeLits
6−import Data.Text as T
7−import Data.Aeson.Internal
8−
9−
10−newtype JSONPathText = JSONPathText Text
11− deriving (Show)
12−
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)
18−
19−demotePath :: Sing (ps :: [PathSegment]) -> JSONPath
20−demotePath = go []
21− where
22− go :: JSONPath -> Sing (ps :: [PathSegment]) -> JSONPath
23− go acc SNil = acc
24− go acc (SCons p ps) = go (acc ++ [demotePathSeg p]) ps
25− demotePathSeg :: Sing (ps :: PathSegment) -> JSONPathElement
26− demotePathSeg (SKey s) = Key $ T.pack $ withKnownSymbol s $ symbolVal s
27− demotePathSeg (SIx n) = Index $ withKnownNat n $ fromIntegral $ natVal n
28−
29−demotedPathToText :: JSONPath -> JSONPathText
30−demotedPathToText = JSONPathText . F.foldl' renderPathSegment ""
31− where
32− renderPathSegment acc (Key t) = acc <> "." <> t
33− renderPathSegment acc (Index n) = acc <> "[" <> T.pack (show n) <> "]"
34−
35−pathToText :: Sing (ps :: [PathSegment]) -> JSONPathText
36−pathToText = demotedPathToText . demotePath
src/Data/Schematic/Schema.hs+141−585
@@ -1,595 +1,151 @@
1{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE OverloadedLists #-}
3+{-# LANGUAGE InstanceSigs #-}
4−{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE UndecidableInstances #-}
5{-# OPTIONS_GHC -fprint-explicit-kinds #-}
5{-# OPTIONS_GHC -fprint-explicit-kinds #-}
6
6
7module Data.Schematic.Schema where
7module Data.Schematic.Schema where
8
8
9−import Control.Applicative ((<|>))
9+import Data.Functor.Foldable
10−import Control.Monad
11−import Data.Aeson as J
12−import Data.Aeson.Types as J
13−import Data.HashMap.Strict as H
14−import Data.Kind
10+import Data.Kind hiding (Type)
15−import Data.Maybe
16−import Data.Schematic.Generator
17−import Data.Schematic.Instances ()
18−import Data.Scientific
19−import Data.Singletons.Prelude.List hiding (All, Union)
20−import Data.Singletons.TH
11+import Data.Proxy
21−import Data.Singletons.TypeLits
12+import Data.Schematic.Validation
22−import Data.Text as T
13+import Data.Text (Text)
23−import Data.Union
24−import Data.Vector as V
25−import Data.Vinyl hiding (Dict)
26−import qualified Data.Vinyl.TypeLevel as V
27−import GHC.Exts
28−import GHC.Generics (Generic)
14+import GHC.Generics
29−import GHC.TypeLits
15+import GHC.TypeLits (KnownNat, natVal, KnownSymbol, symbolVal, Symbol, Nat)
30− (SomeNat(..), SomeSymbol(..), someNatVal, someSymbolVal)
16+
31−import Prelude as P
17+
32−import Test.SmallCheck.Series
33−
34−
35−type family CRepr (s :: Schema) :: Type where
18+type family JT (s :: k) :: JType where
36− CRepr ('SchemaText cs) = TextConstraint
19+ JT (SNumber cs) = 'JNumber
37− CRepr ('SchemaNumber cs) = NumberConstraint
20+ JT (SText cs) = 'JText
38− CRepr ('SchemaObject fs) = (String, Schema)
21+ JT (SObject els) = 'JObject
39− CRepr ('SchemaArray ar s) = ArrayConstraint
22+ JT (SArray cs s) = 'JArray
40−
23+ JT (Field field ty cs) = JT ty
41−data TextConstraint
24+
42− = TEq Nat
25+class Constrained (ty :: JType) c where
43− | TLt Nat
26+ cRep :: Proxy ty -> Proxy c -> CRepr ty
44− | TLe Nat
27+
45− | TGt Nat
28+-- Validators
46− | TGe Nat
29+
47− | TRegex Symbol
30+data LengthEqNat nat
48− | TEnum [Symbol]
31+
49− deriving (Generic)
32+instance KnownNat nat => Constrained 'JText (LengthEqNat nat) where
50−
33+ cRep _ _ = LengthEq $ natVal (Proxy @nat)
51−instance SingKind TextConstraint where
34+
52− type Demote TextConstraint = DemotedTextConstraint
35+data Gt nat
53− fromSing = \case
36+
54− STEq n -> withKnownNat n (DTEq . fromIntegral $ natVal n)
37+instance KnownNat nat => Constrained 'JNumber (Gt nat) where
55− STLt n -> withKnownNat n (DTLt . fromIntegral $ natVal n)
38+ cRep _ _ = Gt $ natVal (Proxy @nat)
56− STLe n -> withKnownNat n (DTLe . fromIntegral $ natVal n)
39+
57− STGt n -> withKnownNat n (DTGt . fromIntegral $ natVal n)
40+instance KnownNat nat => Constrained 'JArray (LengthEqNat nat) where
58− STGe n -> withKnownNat n (DTGe . fromIntegral $ natVal n)
41+ cRep _ _ = LengthArrEq $ natVal (Proxy @nat)
59− STRegex s -> withKnownSymbol s (DTRegex $ T.pack $ symbolVal s)
42+
60− STEnum s -> let
43+-- /Validators
61− d :: Sing (s :: [Symbol]) -> [Text]
44+
62− d SNil = []
45+data Field field ty schema
63− d (SCons ss@SSym fs) = T.pack (symbolVal ss) : d fs
46+
64− in DTEnum $ d s
47+data Empty
65− toSing = \case
48+
66− DTEq n -> case someNatVal n of
49+class Verifiable ty cs where
67− Just (SomeNat (_ :: Proxy n)) -> SomeSing (STEq (SNat :: Sing n))
50+ schema :: Proxy ty -> Proxy cs -> [CRepr ty]
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−
96−data instance Sing (tc :: TextConstraint) where
97− STEq :: Sing n -> Sing ('TEq n)
98− STLt :: Sing n -> Sing ('TLt n)
99− STLe :: Sing n -> Sing ('TLe n)
100− STGt :: Sing n -> Sing ('TGt n)
101− STGe :: Sing n -> Sing ('TGe n)
102− STRegex :: Sing s -> Sing ('TRegex s)
103− STEnum :: Sing ss -> Sing ('TEnum ss)
104−
105−instance (KnownNat n) => SingI ('TEq n) where sing = STEq sing
106−instance (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
109−instance (KnownNat n) => SingI ('TLe n) where sing = STLe sing
110−instance (KnownSymbol s, SingI s) => SingI ('TRegex s) where sing = STRegex sing
111−instance (SingI ss) => SingI ('TEnum ss) where sing = STEnum sing
112−
113−instance Eq (Sing ('TEq n)) where _ == _ = True
114−instance Eq (Sing ('TLt n)) where _ == _ = True
115−instance Eq (Sing ('TLe n)) where _ == _ = True
116−instance Eq (Sing ('TGt n)) where _ == _ = True
117−instance Eq (Sing ('TGe n)) where _ == _ = True
118−instance Eq (Sing ('TRegex t)) where _ == _ = True
119−instance Eq (Sing ('TEnum ss)) where _ == _ = True
120−
121−data NumberConstraint
122− = NLe Nat
123− | NLt Nat
124− | NGt Nat
125− | NGe Nat
126− | NEq Nat
127− deriving (Generic)
128−
129−data DemotedNumberConstraint
130− = DNLe Integer
131− | DNLt Integer
132− | DNGt Integer
133− | DNGe Integer
134− | DNEq Integer
135− deriving (Generic, Eq, Show)
136−
137−data instance Sing (nc :: NumberConstraint) where
138− SNEq :: Sing n -> Sing ('NEq n)
139− SNGt :: Sing n -> Sing ('NGt n)
140− SNGe :: Sing n -> Sing ('NGe n)
141− SNLt :: Sing n -> Sing ('NLt n)
142− SNLe :: Sing n -> Sing ('NLe n)
143−
144−instance KnownNat n => SingI ('NEq n) where sing = SNEq sing
145−instance 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
148−instance KnownNat n => SingI ('NLe n) where sing = SNLe sing
149−
150−instance Eq (Sing ('NEq n)) where _ == _ = True
151−instance Eq (Sing ('NLt n)) where _ == _ = True
152−instance Eq (Sing ('NLe n)) where _ == _ = True
153−instance 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"
180−
181−data ArrayConstraint
182− = AEq Nat
183− | AGt Nat
184− | AGe Nat
185− | ALt Nat
186− | ALe Nat
187− deriving (Generic)
188−
189−data DemotedArrayConstraint
190− = DAEq Integer
191− | DAGt Integer
192− | DAGe Integer
193− | DALt Integer
194− | DALe Integer
195− deriving (Generic, Eq, Show)
196−
197−data instance Sing (ac :: ArrayConstraint) where
198− SAEq :: Sing n -> Sing ('AEq n)
199− SAGt :: Sing n -> Sing ('AGt n)
200− SAGe :: Sing n -> Sing ('AGe n)
201− SALt :: Sing n -> Sing ('ALt n)
202− SALe :: Sing n -> Sing ('ALe n)
203−
204−instance 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
209−
210−instance 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"
240−
241−data Schema
242− = SchemaText [TextConstraint]
243− | SchemaBoolean
244− | SchemaNumber [NumberConstraint]
245− | SchemaObject [(Symbol, Schema)]
246− | SchemaArray [ArrayConstraint] Schema
247− | SchemaNull
248− | SchemaOptional Schema
249− | SchemaUnion [Schema]
250− deriving (Generic)
251−
252−data DemotedSchema
253− = DSchemaText [DemotedTextConstraint]
254− | DSchemaNumber [DemotedNumberConstraint]
255− | DSchemaBoolean
256− | DSchemaObject [(Text, DemotedSchema)]
257− | DSchemaArray [DemotedArrayConstraint] DemotedSchema
258− | DSchemaNull
259− | DSchemaOptional DemotedSchema
260− | DSchemaUnion [DemotedSchema]
261− deriving (Generic, Eq, Show)
262−
263−data instance Sing (schema :: Schema) where
264− SSchemaText :: Sing tcs -> Sing ('SchemaText tcs)
265− SSchemaNumber :: Sing ncs -> Sing ('SchemaNumber ncs)
266− SSchemaBoolean :: Sing 'SchemaBoolean
267− SSchemaArray :: Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)
268− SSchemaObject :: Sing fields -> Sing ('SchemaObject fields)
269− SSchemaOptional :: Sing s -> Sing ('SchemaOptional s)
270− SSchemaNull :: Sing 'SchemaNull
271− SSchemaUnion :: Sing ss -> Sing ('SchemaUnion ss)
272−
273−instance SingI sl => SingI ('SchemaText sl) where
274− sing = SSchemaText sing
275−instance SingI sl => SingI ('SchemaNumber sl) where
276− sing = SSchemaNumber sing
277−instance SingI 'SchemaNull where
278− sing = SSchemaNull
279−instance SingI 'SchemaBoolean where
280− sing = SSchemaBoolean
281−instance (SingI ac, SingI s) => SingI ('SchemaArray ac s) where
282− sing = SSchemaArray sing sing
283−instance SingI stl => SingI ('SchemaObject stl) where
284− sing = SSchemaObject sing
285−instance SingI s => SingI ('SchemaOptional s) where
286− sing = SSchemaOptional sing
287−instance SingI s => SingI ('SchemaUnion s) where
288− sing = SSchemaUnion sing
289−
290−instance Eq (Sing ('SchemaText cs)) where _ == _ = True
291−instance Eq (Sing ('SchemaNumber cs)) where _ == _ = True
292−instance Eq (Sing 'SchemaNull) where _ == _ = True
293−instance Eq (Sing 'SchemaBoolean) where _ == _ = True
294−instance Eq (Sing ('SchemaArray as s)) where _ == _ = True
295−instance Eq (Sing ('SchemaObject cs)) where _ == _ = True
296−instance 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
325−
326−data FieldRepr :: (Symbol, Schema) -> Type where
327− FieldRepr
328− :: (SingI schema, KnownSymbol name)
329− => JsonRepr schema
330− -> FieldRepr '(name, schema)
331−
332−-- | Forgetful Functor Ufr
333−toJsonRepr :: FieldRepr '(fn, sch) -> JsonRepr sch
334−toJsonRepr (FieldRepr x) = x
335−
336−knownFieldName
337− :: forall proxy (fieldName :: Symbol) schema
338− . KnownSymbol fieldName
339− => proxy '(fieldName, schema)
340− -> Text
341−knownFieldName _ = T.pack $ symbolVal (Proxy @fieldName)
342−
343−knownFieldSchema
344− :: forall proxy fieldName schema
345− . SingI schema
346− => proxy '(fieldName, schema)
347− -> Sing schema
348−knownFieldSchema _ = sing
349−
350−deriving instance Show (JsonRepr schema) => Show (FieldRepr '(name, schema))
351−
352−instance Eq (JsonRepr schema) => Eq (FieldRepr '(name, schema)) where
353− FieldRepr a == FieldRepr b = a == b
354
51
355instance
52instance
356− ( KnownSymbol name
53+ ( Constrained 'JText c
357− , SingI schema
54+ , Verifiable 'JText cs )
358− , Serial m (JsonRepr schema) )
55+ => Verifiable 'JText (c ': cs) where
359− => Serial m (FieldRepr '(name, schema)) where
56+ schema _ _ = cRep (Proxy @'JText) (Proxy @c)
360− series = FieldRepr <$> series
57+ : schema (Proxy @'JText) (Proxy @cs)
361−
58+
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−
366−data JsonRepr :: Schema -> Type where
367− ReprText :: Text -> JsonRepr ('SchemaText cs)
368− ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)
369− ReprBoolean :: Bool -> JsonRepr 'SchemaBoolean
370− ReprNull :: JsonRepr 'SchemaNull
371− ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)
372− ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)
373− 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)
392−
393−instance (Serial m (JsonRepr s))
394− => Serial m (JsonRepr ('SchemaOptional s)) where
395− series = cons1 ReprOptional
396−
397−instance (Monad m, Serial m (Rec FieldRepr fs))
398− => Serial m (JsonRepr ('SchemaObject fs)) where
399− series = cons1 ReprObject
400−
401−-- | Move to the union package
402−instance Show (JsonRepr ('SchemaText cs)) where
403− show (ReprText t) = "ReprText " P.++ show t
404−
405−instance Show (JsonRepr ('SchemaNumber cs)) where
406− show (ReprNumber n) = "ReprNumber " P.++ show n
407−
408−instance Show (JsonRepr 'SchemaBoolean) where
409− show (ReprBoolean n) = "ReprBoolean " P.++ show n
410−
411−instance Show (JsonRepr 'SchemaNull) where show _ = "ReprNull"
412−
413−instance Show (JsonRepr s) => Show (JsonRepr ('SchemaArray acs s)) where
414− show (ReprArray v) = "ReprArray " P.++ show v
415−
416−#if MIN_VERSION_base(4,12,0)
417instance
59instance
418− ( V.RecAll FieldRepr fs Show, RMap fs, ReifyConstraint Show FieldRepr fs
60+ ( Constrained 'JNumber c
419− , RecordToList fs )
61+ , Verifiable 'JNumber cs )
420− => Show (JsonRepr ('SchemaObject fs)) where
62+ => Verifiable 'JNumber (c ': cs) where
421− show (ReprObject fs) = "ReprObject " P.++ show fs
63+ schema _ _ = cRep (Proxy @'JNumber) (Proxy @c)
422−#else
64+ : schema (Proxy @'JNumber) (Proxy @cs)
423−instance V.RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where
424− show (ReprObject fs) = "ReprObject " P.++ show fs
425−#endif
426
65
427−instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where
66+instance Verifiable jty '[] where
428− show (ReprOptional s) = "ReprOptional " P.++ show s
67+ schema _ _ = []
429−
68+
430−instance Show (Union JsonRepr (h ': tl))
69+instance
431− => Show (JsonRepr ('SchemaUnion (h ': tl))) where
70+ ( Constrained 'JArray c
432− show (ReprUnion s) = "ReprUnion " P.++ show s
71+ , Verifiable 'JArray cs )
433−
72+ => Verifiable 'JArray (c ': cs) where
434−instance Eq (Rec FieldRepr fs) => Eq (JsonRepr ('SchemaObject fs)) where
73+ schema _ _ = cRep (Proxy @'JArray) (Proxy @c)
435− ReprObject a == ReprObject b = a == b
74+ : schema (Proxy @'JArray) (Proxy @cs)
436−
75+
437−instance Eq (JsonRepr ('SchemaText cs)) where
76+instance
438− ReprText a == ReprText b = a == b
77+ ( SchemaConstructor jty
439−
78+ , Verifiable 'JObject fs
440−instance Eq (JsonRepr ('SchemaNumber cs)) where
79+ , KnownSymbol field
441− ReprNumber a == ReprNumber b = a == b
80+ , Verifiable jty cs )
442−
81+ => Verifiable 'JObject ((Field field jty cs) ': fs) where
443−instance Eq (JsonRepr 'SchemaBoolean) where
82+ schema _ _ = (fieldName, fieldSchema) : schema (Proxy @'JObject) (Proxy @fs)
444− ReprBoolean a == ReprBoolean b = a == b
445−
446−instance Eq (JsonRepr 'SchemaNull) where
447− ReprNull == ReprNull = True
448−
449−instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaArray as s)) where
450− ReprArray a == ReprArray b = a == b
451−
452−instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaOptional s)) where
453− ReprOptional a == ReprOptional b = a == b
454−
455−instance Eq (Union JsonRepr (h ': tl))
456− => Eq (JsonRepr ('SchemaUnion (h ': tl))) where
457− ReprUnion a == ReprUnion b = a == b
458−
459−instance Ord (Rec FieldRepr fs) => Ord (JsonRepr ('SchemaObject fs)) where
460− ReprObject a `compare` ReprObject b = a `compare` b
461−
462−instance Ord (JsonRepr ('SchemaText cs)) where
463− ReprText a `compare` ReprText b = a `compare` b
464−
465−instance Ord (JsonRepr ('SchemaNumber cs)) where
466− ReprNumber a `compare` ReprNumber b = a `compare` b
467−
468−instance Ord (JsonRepr 'SchemaBoolean) where
469− ReprBoolean a `compare` ReprBoolean b = a `compare` b
470−
471−instance Ord (JsonRepr 'SchemaNull) where
472− compare _ _ = EQ
473−
474−instance Ord (JsonRepr s) => Ord (JsonRepr ('SchemaArray as s)) where
475− ReprArray a `compare` ReprArray b = a `compare` b
476−
477−instance Ord (JsonRepr s) => Ord (JsonRepr ('SchemaOptional s)) where
478− ReprOptional a `compare` ReprOptional b = a `compare` b
479−
480−instance Ord (Union JsonRepr (h ': tl))
481− => Ord (JsonRepr ('SchemaUnion (h ': tl))) where
482− ReprUnion a `compare` ReprUnion b = a `compare` b
483−
484−instance IsList (JsonRepr ('SchemaArray cs s)) where
485− type Item (JsonRepr ('SchemaArray cs s)) = JsonRepr s
486− fromList = ReprArray . GHC.Exts.fromList
487− toList (ReprArray v) = GHC.Exts.toList v
488−
489−instance Num (JsonRepr ('SchemaNumber cs)) where
490− ReprNumber a + ReprNumber b = ReprNumber $ a + b
491− ReprNumber a - ReprNumber b = ReprNumber $ a - b
492− ReprNumber a * ReprNumber b = ReprNumber $ a * b
493− abs (ReprNumber a) = ReprNumber $ abs a
494− signum (ReprNumber a) = ReprNumber $ signum a
495− fromInteger = ReprNumber . fromIntegral
496−
497−instance IsString (JsonRepr ('SchemaText cs)) where
498− fromString = ReprText . fromString
499−
500−fromOptional
501− :: SingI s
502− => Sing ('SchemaOptional s)
503− -> J.Value
504− -> Parser (Maybe (JsonRepr s))
505−fromOptional _ = parseJSON
506−
507−parseUnion
508− :: FromJSON (JsonRepr ('SchemaUnion ss))
509− => sing (ss :: [Schema])
510− -> Value
511− -> Parser (JsonRepr ('SchemaUnion ss))
512−parseUnion _ val = parseJSON val
513−
514−instance FromJSON (Union JsonRepr '[]) where
515− parseJSON = fail "empty union"
516−
517−instance (SingI a, FromJSON (Union JsonRepr as)) => FromJSON (Union JsonRepr (a ': as)) where
518− parseJSON val = (This <$> parseJSON val)
519− <|> (That <$> (parseJSON val :: Parser (Union JsonRepr as)))
520−
521−instance ToJSON (Union JsonRepr as) where
522− toJSON (This fa) = toJSON fa
523− toJSON (That u) = toJSON u
524−
525−instance SingI schema => J.FromJSON (JsonRepr schema) where
526− parseJSON value = case sing :: Sing schema of
527− SSchemaText _ -> withText "String" (pure . ReprText) value
528− SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value
529− SSchemaBoolean -> ReprBoolean <$> parseJSON value
530− SSchemaNull -> case value of
531− J.Null -> pure ReprNull
532− _ -> typeMismatch "Null" value
533− so@(SSchemaOptional s) -> withSingI s $ ReprOptional <$> fromOptional so value
534− SSchemaArray sa sb -> withSingI sa $ withSingI sb
535− $ withArray "Array" (fmap ReprArray . traverse parseJSON) value
536− SSchemaObject fs -> do
537− let
538− demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (Rec FieldRepr s)
539− demoteFields SNil _ = pure RNil
540− demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do
541− let fieldName = T.pack $ symbolVal (Proxy @fn)
542− fieldRepr <- case s of
543− SSchemaText so -> case H.lookup fieldName h of
544− Just v -> withSingI so $ FieldRepr <$> parseJSON v
545− Nothing -> fail $ "No text field: " P.++ show fieldName
546− SSchemaNumber so -> case H.lookup fieldName h of
547− Just v -> withSingI so $ FieldRepr <$> parseJSON v
548− Nothing -> fail $ "No number field: " P.++ show fieldName
549− SSchemaBoolean -> case H.lookup fieldName h of
550− Just v -> FieldRepr <$> parseJSON v
551− Nothing -> fail $ "No boolean field: " P.++ show fieldName
552− SSchemaNull -> case H.lookup fieldName h of
553− Just v -> FieldRepr <$> parseJSON v
554− Nothing -> fail $ "No null field: " P.++ show fieldName
555− SSchemaArray sa sb -> case H.lookup fieldName h of
556− Just v -> withSingI sa $ withSingI sb $ FieldRepr <$> parseJSON v
557− Nothing -> fail $ "No array field: " P.++ show fieldName
558− SSchemaObject so -> case H.lookup fieldName h of
559− Just v -> withSingI so $ FieldRepr <$> parseJSON v
560− Nothing -> fail $ "No object field" P.++ show fieldName
561− SSchemaOptional so -> case H.lookup fieldName h of
562− Just v -> withSingI so $ FieldRepr <$> parseJSON v
563− Nothing -> withSingI so $ pure $ FieldRepr $ ReprOptional Nothing
564− SSchemaUnion ss -> withSingI ss $ FieldRepr <$> parseUnion ss value
565− (fieldRepr :&) <$> demoteFields tl h
566− ReprObject <$> withObject "Object" (demoteFields fs) value
567− SSchemaUnion ss -> parseUnion ss value
568−
569−instance J.ToJSON (JsonRepr a) where
570− toJSON ReprNull = J.Null
571− toJSON (ReprBoolean b) = J.Bool b
572− toJSON (ReprText t) = J.String t
573− toJSON (ReprNumber n) = J.Number n
574− toJSON (ReprOptional s) = case s of
575− Just v -> toJSON v
576− Nothing -> J.Null
577− toJSON (ReprArray v) = J.Array $ toJSON <$> v
578− toJSON (ReprObject r) = J.Object . H.fromList . fold $ r
579 where
83 where
580− extract :: forall name s . (KnownSymbol name)
84+ fieldName = symbolVal (Proxy @field)
581− => FieldRepr '(name, s)
85+ fieldSchema = constructor (Proxy @jty) $ schema (Proxy @jty) (Proxy @cs)
582− -> (Text, Value)
86+
583− extract (FieldRepr s) = (T.pack $ symbolVal $ Proxy @name, toJSON s)
87+class SchemaConstructor jty where
584− fold :: Rec FieldRepr fs -> [(Text, J.Value)]
88+ constructor :: Proxy jty -> [CRepr jty] -> Schema
585− fold = \case
89+
586− RNil -> []
90+instance SchemaConstructor 'JText where
587− fr@(FieldRepr _) :& tl -> (extract fr) : fold tl
91+ constructor _ = Fix . SchemaText
588− toJSON (ReprUnion u) = toJSON u
92+
589−
93+instance SchemaConstructor 'JNumber where
590−class FalseConstraint a
94+ constructor _ = Fix . SchemaNumber
591−
95+
592−type family TopLevel (schema :: Schema) :: Constraint where
96+instance SchemaConstructor 'JObject where
593− TopLevel ('SchemaArray acs s) = ()
594− TopLevel ('SchemaObject o) = ()
97+ constructor _ = Fix . SchemaObject
595− TopLevel spec = 'True ~ 'False
98+
99+class Schematic ty where
100+ build :: Proxy ty -> Schema
101+
102+data SText cs
103+
104+instance (Verifiable 'JText cs) => Schematic (SText cs) where
105+ build _ = constructor (Proxy @(JT (SText cs))) $ schema (Proxy @JText) (Proxy @cs)
106+
107+data SNumber cs
108+
109+instance (Verifiable 'JNumber cs) => Schematic (SNumber cs) where
110+ build _ = constructor (Proxy @(JT (SNumber cs)))
111+ $ schema (Proxy @'JNumber) (Proxy @cs)
112+
113+instance
114+ ( Verifiable (JT ty) cs
115+ , SchemaConstructor (JT ty))
116+ => Schematic (Field field ty cs) where
117+ build _ = constructor (Proxy @(JT (Field field ty cs)))
118+ $ schema (Proxy @(JT (Field field ty cs))) (Proxy @cs)
119+
120+data SObject els
121+
122+instance
123+ ( Verifiable 'JObject els )
124+ => Schematic (SObject els) where
125+ build _ =
126+ constructor (Proxy @'JObject) $ schema (Proxy @(JT (SObject els))) (Proxy @els)
127+
128+data SArray cs s
129+
130+instance
131+ ( Schematic s
132+ , Verifiable 'JArray cs )
133+ => Schematic (SArray cs s) where
134+ build _ =
135+ Fix $ SchemaArray
136+ (schema (Proxy @'JArray) (Proxy @cs))
137+ (build (Proxy @s))
138+
139+-- | Shows it's top-level definition according to the json-schema
140+class Schematic spec => TopLevel spec
141+
142+instance (Schematic (SObject els)) => TopLevel (SObject els)
143+
144+instance Schematic (SArray cs s) => TopLevel (SArray cs s)
145+
146+-- | TODO: abstract over objects and arrays
147+toSchema
148+ :: forall spec. TopLevel spec
149+ => Proxy spec
150+ -> Schema
151+toSchema = build
src/Data/Schematic/Schema.hs-bootdeleted−95
@@ -1,95 +0,0 @@
1−module Data.Schematic.Schema where
2−
3−import Data.Kind
4−import Data.Maybe
5−import Data.Schematic.Instances ()
6−import Data.Scientific
7−import Data.Singletons.TH
8−import Data.Singletons.TypeLits
9−import Data.Text as T
10−import Data.Union
11−import Data.Vector as V
12−import Data.Vinyl hiding (Dict)
13−import Prelude as P
14−
15−data TextConstraint
16− = TEq Nat
17− | TLt Nat
18− | TLe Nat
19− | TGt Nat
20− | TGe Nat
21− | TRegex Symbol
22− | TEnum [Symbol]
23−
24−data DemotedTextConstraint
25− = DTEq Integer
26− | DTLt Integer
27− | DTLe Integer
28− | DTGt Integer
29− | DTGe Integer
30− | DTRegex Text
31− | DTEnum [Text]
32−
33−data NumberConstraint
34− = NLe Nat
35− | NLt Nat
36− | NGt Nat
37− | NGe Nat
38− | NEq Nat
39−
40−data DemotedNumberConstraint
41− = DNLe Integer
42− | DNLt Integer
43− | DNGt Integer
44− | DNGe Integer
45− | DNEq Integer
46−
47−data ArrayConstraint
48− = AEq Nat
49− | AGt Nat
50− | AGe Nat
51− | ALt Nat
52− | ALe Nat
53−
54−data DemotedArrayConstraint
55− = DAEq Integer
56− | DAGt Integer
57− | DAGe Integer
58− | DALt Integer
59− | DALe Integer
60−
61−data Schema
62− = SchemaText [TextConstraint]
63− | SchemaBoolean
64− | SchemaNumber [NumberConstraint]
65− | SchemaObject [(Symbol, Schema)]
66− | SchemaArray [ArrayConstraint] Schema
67− | SchemaNull
68− | SchemaOptional Schema
69− | SchemaUnion [Schema]
70−
71−data DemotedSchema
72− = DSchemaText [DemotedTextConstraint]
73− | DSchemaNumber [DemotedNumberConstraint]
74− | DSchemaBoolean
75− | DSchemaObject [(Text, DemotedSchema)]
76− | DSchemaArray [DemotedArrayConstraint] DemotedSchema
77− | DSchemaNull
78− | DSchemaOptional DemotedSchema
79− | DSchemaUnion [DemotedSchema]
80−
81−data FieldRepr :: (Symbol, Schema) -> Type where
82− FieldRepr
83− :: (SingI schema, KnownSymbol name)
84− => JsonRepr schema
85− -> FieldRepr '(name, schema)
86−
87−data JsonRepr :: Schema -> Type where
88− ReprText :: Text -> JsonRepr ('SchemaText cs)
89− ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)
90− ReprBoolean :: Bool -> JsonRepr 'SchemaBoolean
91− ReprNull :: JsonRepr 'SchemaNull
92− ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)
93− ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)
94− ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)
95− ReprUnion :: Union JsonRepr (h ': tl) -> JsonRepr ('SchemaUnion (h ': tl))
src/Data/Schematic/Validatable.hsnew file+5
@@ -0,0 +1,5 @@
1+module Data.Schematic.Validatable where
2+
3+
4+class Validatable spec where
5+ type Schema a
src/Data/Schematic/Validation.hs+180−298
@@ -1,306 +1,188 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE OverloadedLists #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# OPTIONS_GHC -fprint-explicit-kinds #-}
5+
1module Data.Schematic.Validation where
6module Data.Schematic.Validation where
2
7
8+import Control.Applicative
9+import Control.Category ((<<<), (>>>))
3import Control.Monad
10import Control.Monad
4−import Control.Monad.Validation
5−import Data.Aeson
11+import Data.Aeson as J
6−import Data.Aeson.Internal
7−import Data.Aeson.Types
12+import Data.Aeson.Types as J
8−import Data.Foldable
13+import Data.Eq.Deriving (deriveEq1)
14+import Data.Foldable as F
9−import Data.Functor.Identity
15+import Data.Functor.Classes
10−import Data.Monoid
16+import Data.Functor.Foldable
11−import Data.Schematic.Path
17+import Data.HashMap.Strict as H
12−import Data.Schematic.Schema
18+import Data.Kind
19+import Data.Maybe
13import Data.Scientific
20import Data.Scientific
14−import Data.Singletons.Prelude
21+import Data.Singletons.Decide
22+import Data.Singletons.Prelude.List
23+import Data.Singletons.TH
15import Data.Singletons.TypeLits
24import Data.Singletons.TypeLits
16import Data.Text as T
25import Data.Text as T
17−import Data.Traversable
18−import Data.Union
19import Data.Vector as V
26import Data.Vector as V
20−import Data.Vinyl
27+import Data.Vinyl hiding (Dict)
21−import Data.Vinyl.TypeLevel
28+import Data.Vinyl.Functor
22−import Prelude as P
29+import Text.Show.Deriving (deriveShow1)
23−import Text.Regex.TDFA
30+
24−
31+
25−
32+-- -- | Type Tags
26−type Validation a = ValidationT ErrorMap Identity a
33+data JType
27−
34+ = JText
28−type ErrorMap = MonoidMap Text [Text]
35+ | JNumber
29−
36+ | JArray
30−data ParseResult a
37+ | JObject
31− = Valid a
38+ | JNull
32− | DecodingError Text -- static
33− | ValidationError ErrorMap -- runtime
34− deriving (Show, Eq, Functor, Foldable, Traversable)
39+ deriving (Show, Eq)
35−
40+
36−instance (TopLevel a, SingI a, FromJSON (JsonRepr a))
41+genSingletons [ ''JType ]
37− => FromJSON (ParseResult (JsonRepr a)) where
42+
38− parseJSON = pure . parseAndValidateJson @a
43+-- instance Show (Sing JText) where showsPrec 4 _ = showString "SJText"
39−
44+-- instance Show (Sing JNumber) where showsPrec 4 _ = showString "SJNumber"
40−isValid :: ParseResult a -> Bool
45+-- instance Show (Sing JArray) where showsPrec 4 _ = showString "SJArray"
41−isValid (Valid _) = True
46+-- instance Show (Sing JObject) where showsPrec 4 _ = showString "SJObject"
42−isValid _ = False
47+-- instance Show (Sing JNull) where showsPrec 4 _ = showString "SJNull"
43−
48+
44−isDecodingError :: ParseResult a -> Bool
49+-- instance Eq (Sing JText) where (==) _ _ = True
45−isDecodingError (DecodingError _) = True
50+-- instance Eq (Sing JNumber) where (==) _ _ = True
46−isDecodingError _ = False
51+-- instance Eq (Sing JArray) where (==) _ _ = True
47−
52+-- instance Eq (Sing JObject) where (==) _ _ = True
48−isValidationError :: ParseResult a -> Bool
53+-- instance Eq (Sing JNull) where (==) _ _ = True
49−isValidationError (ValidationError _) = True
54+
50−isValidationError _ = False
55+type family CRepr (jty :: Schema) :: Type where
51−
56+ CRepr (SchemaText cs) = TextConstraint
52−validateTextConstraint
57+ CRepr (SchemaNumber cs) = NumberConstraint
53− :: JSONPathText
58+ CRepr (SchemaObject fs) = (String, Schema)
54− -> Text
59+ CRepr (SchemaArray ar s) = ArrayConstraint
55− -> Sing (tcs :: TextConstraint)
60+
56− -> Validation ()
61+data TextConstraint
57−validateTextConstraint (JSONPathText path) t = \case
62+ = TEq Nat
58− STEq n -> do
63+ | TLe Nat
59− let
64+ | TGt Nat
60− nlen = withKnownNat n $ natVal n
65+ | Regex Symbol
61− predicate = nlen == (fromIntegral $ T.length t)
66+
62− errMsg = "length should be == " <> T.pack (show nlen)
67+data instance Sing (tc :: TextConstraint) where
63− warn = vWarning $ mmSingleton path (pure errMsg)
68+ STextLengthEq :: Sing n -> Sing (TEq n)
64− unless predicate warn
69+ STextLengthLe :: Sing n -> Sing (TLe n)
65− STLt n -> do
70+ STextLengthGt :: Sing n -> Sing (TGt n)
66− let
71+
67− nlen = withKnownNat n $ natVal n
72+data NumberConstraint
68− predicate = nlen > (fromIntegral $ T.length t)
73+ = NLe Nat
69− errMsg = "length should be < " <> T.pack (show nlen)
74+ | NGt Nat
70− warn = vWarning $ mmSingleton path (pure errMsg)
75+ | NEq Nat
71− unless predicate warn
76+
72− STLe n -> do
77+data instance Sing (nc :: NumberConstraint) where
73− let
78+ SNumberEq :: Sing n -> Sing (NEq n)
74− nlen = withKnownNat n $ natVal n
79+ SNumberGt :: Sing n -> Sing (NGt n)
75− predicate = nlen >= (fromIntegral $ T.length t)
80+ SNumberLe :: Sing n -> Sing (NLe n)
76− errMsg = "length should be <= " <> T.pack (show nlen)
81+
77− warn = vWarning $ mmSingleton path (pure errMsg)
82+data ArrayConstraint
78− unless predicate warn
83+ = AEq Nat
79− STGt n -> do
84+
80− let
85+data instance Sing (ac :: ArrayConstraint) where
81− nlen = withKnownNat n $ natVal n
86+ SArrayEq :: Sing n -> Sing (AEq n)
82− predicate = nlen < (fromIntegral $ T.length t)
87+
83− errMsg = "length should be > " <> T.pack (show nlen)
88+data Schema
84− warn = vWarning $ mmSingleton path (pure errMsg)
89+ = SchemaText [TextConstraint]
85− unless predicate warn
90+ | SchemaNumber [NumberConstraint]
86− STGe n -> do
91+ | SchemaObject [(Symbol, Schema)]
87− let
92+ | SchemaArray [ArrayConstraint] Schema
88− nlen = withKnownNat n $ natVal n
93+ | SchemaNull
89− predicate = nlen <= (fromIntegral $ T.length t)
94+
90− errMsg = "length should be >= " <> T.pack (show nlen)
95+data instance Sing (schema :: Schema) where
91− warn = vWarning $ mmSingleton path (pure errMsg)
96+ SSchemaText :: Sing tcs -> Sing (SchemaText tcs)
92− unless predicate warn
97+ SSchemaNumber :: Sing ncs -> Sing (SchemaNumber ncs)
93− STRegex r -> do
98+ SSchemaArray :: Sing acs -> Sing schema -> Sing (SchemaArray acs schema)
94− let
99+ SSchemaObject :: Sing fields -> Sing (SchemaObject fields)
95− regex = withKnownSymbol r $ fromSing r
100+ SSchemaNull :: Sing SchemaNull
96− predicate = matchTest (makeRegex (T.unpack regex) :: Regex) (T.unpack t)
101+
97− errMsg = "must match " <> regex
102+data FieldRepr :: (Symbol, Schema) -> Type where
98− warn = vWarning $ mmSingleton path (pure errMsg)
103+ FieldRepr :: KnownSymbol name => JsonRepr schema -> FieldRepr '(name, schema)
99− unless predicate warn
104+
100− STEnum ss -> do
105+data JsonRepr :: Schema -> Type where
101− let
106+ ReprText :: Text -> JsonRepr (SchemaText cs)
102− matching :: Sing (s :: [Symbol]) -> Bool
107+ ReprNumber :: Scientific -> JsonRepr (SchemaNumber cs)
103− matching SNil = False
108+ ReprNull :: JsonRepr SchemaNull
104− matching (SCons s@SSym fs) = T.pack (symbolVal s) == t || matching fs
109+ ReprArray :: V.Vector (JsonRepr s) -> JsonRepr (SchemaArray cs s)
105− errMsg = "must be one of " <> T.pack (show (fromSing ss))
110+ ReprObject :: Rec FieldRepr fs -> JsonRepr (SchemaObject fs)
106− warn = vWarning $ mmSingleton path (pure errMsg)
111+
107− unless (matching ss) warn
112+instance (SingI schema) => J.FromJSON (JsonRepr schema) where
108−
113+ parseJSON value = case sing :: Sing schema of
109−validateNumberConstraint
114+ SSchemaText _ -> withText "String" (pure . ReprText) value
110− :: JSONPathText
115+ SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value
111− -> Scientific
116+ SSchemaNull -> pure ReprNull
112− -> Sing (tcs :: NumberConstraint)
117+ SSchemaArray c s -> withArray "Array" f value
113− -> Validation ()
114−validateNumberConstraint (JSONPathText path) num = \case
115− SNEq n -> do
116− let
117− nlen = withKnownNat n $ natVal n
118− predicate = fromIntegral nlen == num
119− errMsg = "should be == " <> T.pack (show nlen)
120− warn = vWarning $ mmSingleton path (pure errMsg)
121− unless predicate warn
122− SNGt n -> do
123− let
124− nlen = withKnownNat n $ natVal n
125− predicate = num > fromIntegral 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)
141− warn = vWarning $ mmSingleton path (pure errMsg)
142− unless predicate warn
143− SNLe n -> do
144− let
145− nlen = withKnownNat n $ natVal n
146− predicate = num <= fromIntegral nlen
147− errMsg = "should be <= " <> T.pack (show nlen)
148− warn = vWarning $ mmSingleton path (pure errMsg)
149− unless predicate warn
150−
151−validateArrayConstraint
152− :: JSONPathText
153− -> V.Vector a
154− -> Sing (tcs :: ArrayConstraint)
155− -> Validation ()
156−validateArrayConstraint (JSONPathText path) v = \case
157− SAEq n -> do
158− let
159− nlen = withKnownNat n $ natVal n
160− predicate = nlen == fromIntegral (V.length v)
161− errMsg = "length should be == " <> T.pack (show nlen)
162− warn = vWarning $ mmSingleton path (pure errMsg)
163− unless predicate warn
164− SAGt n -> do
165− let
166− nlen = withKnownNat n $ natVal n
167− predicate = fromIntegral (V.length v) > nlen
168− errMsg = "length should be > " <> T.pack (show nlen)
169− warn = vWarning $ mmSingleton path (pure errMsg)
170− unless predicate warn
171− SAGe n -> do
172− let
173− nlen = withKnownNat n $ natVal n
174− predicate = fromIntegral (V.length v) >= nlen
175− errMsg = "length should be >= " <> T.pack (show nlen)
176− warn = vWarning $ mmSingleton path (pure errMsg)
177− unless predicate warn
178− SALt n -> do
179− let
180− nlen = withKnownNat n $ natVal n
181− predicate = fromIntegral (V.length v) < nlen
182− errMsg = "length should be < " <> T.pack (show nlen)
183− warn = vWarning $ mmSingleton path (pure errMsg)
184− unless predicate warn
185− SALe n -> do
186− let
187− nlen = withKnownNat n $ natVal n
188− predicate = fromIntegral (V.length v) <= nlen
189− errMsg = "length should be <= " <> T.pack (show nlen)
190− warn = vWarning $ mmSingleton path (pure errMsg)
191− unless predicate warn
192−
193−validateJsonRepr
194− :: Sing schema
195− -> JSONPath
196− -> JsonRepr schema
197− -> Validation ()
198−validateJsonRepr sschema dpath jr = case jr of
199− ReprText t -> case sschema of
200− SSchemaText scs -> do
201− let
202− process :: Sing (cs :: [TextConstraint]) -> Validation ()
203− process SNil = pure ()
204− process (SCons c cs) = do
205− validateTextConstraint (demotedPathToText dpath) t c
206− process cs
207− process scs
208− ReprNumber n -> case sschema of
209− SSchemaNumber scs -> do
210− let
211− process :: Sing (cs :: [NumberConstraint]) -> Validation ()
212− process SNil = pure ()
213− process (SCons c cs) = do
214− validateNumberConstraint (demotedPathToText dpath) n c
215− process cs
216− process scs
217− ReprNull -> pure ()
218− ReprBoolean _ -> pure ()
219− ReprArray v -> case sschema of
220− SSchemaArray acs s -> do
221− let
222− process :: Sing (cs :: [ArrayConstraint]) -> Validation ()
223− process SNil = pure ()
224− process (SCons c cs) = do
225− validateArrayConstraint (demotedPathToText dpath) v c
226− process cs
227− process acs
228− for_ (V.indexed v) $ \(ix, jr') -> do
229− let newPath = dpath <> pure (Index $ fromIntegral ix)
230− validateJsonRepr s newPath jr'
231− ReprOptional d -> case sschema of
232− SSchemaOptional ss -> case d of
233− Just x -> validateJsonRepr ss dpath x
234− Nothing -> pure ()
235− ReprObject fs -> case sschema of
236− SSchemaObject _ -> go fs
237 where
118 where
238− go :: Rec FieldRepr (ts :: [(Symbol, Schema)] ) -> Validation ()
119+ f v = do
239− go RNil = pure ()
120+ values <- withSingI s $ traverse parseJSON v
240− go (f@(FieldRepr d) :& ftl) = do
121+ pure $ ReprArray values
241− let newPath = dpath <> [Key (knownFieldName f)]
122+ SSchemaObject fs -> ReprObject <$> withObject "Object" (demoteFields fs) value
242− validateJsonRepr (knownFieldSchema f) newPath d
123+
243− go ftl
124+demoteFields
244− ReprUnion _ -> pure () -- FIXME
125+ :: SList s
245− -- case sschema of
126+ -> H.HashMap Text J.Value
246− -- SSchemaUnion ss -> case ss of
127+ -> Parser (Rec FieldRepr s)
247− -- SCons s stl -> case umatch' s u of
128+demoteFields SNil h
248− -- Nothing -> case urestrict u of
129+ | H.null h = pure RNil
249− -- Nothing ->
130+ | otherwise = mzero
250− -- fail "impossible to produce subUnion, please report this as a bug"
131+demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do
251− -- Just x -> do
132+ let fieldName = T.pack $ symbolVal (Proxy @fn)
252− -- let
133+ fieldRepr <- case H.lookup fieldName h of
253− -- JSONPathText path = demotedPathToText dpath
134+ Just v -> FieldRepr <$> (withSingI s $ parseJSON v)
254− -- case stl of
135+ Nothing -> mzero
255− -- SNil -> void $ vWarning $ mmSingleton path
136+ (fieldRepr :&) <$> demoteFields tl h
256− -- $ pure "union handling error, please report this as bug"
137+
257− -- SCons s' stl' ->
138+instance J.ToJSON (JsonRepr a) where
258− -- validateJsonRepr (SSchemaUnion (SCons s' stl')) dpath
139+ toJSON ReprNull = J.Null
259− -- $ toUnion (SCons s' stl') x
140+ toJSON (ReprText t) = J.String t
260− -- Just x -> validateJsonRepr s dpath x
141+ toJSON (ReprNumber n) = J.Number n
261−
142+ toJSON (ReprArray v) = J.Array $ toJSON <$> v
262−-- subUnion
143+ toJSON (ReprObject r) = J.Object . H.fromList . fold $ r
263−-- :: Sing (s ': stl)
144+ where
264−-- -> ( USubset stl (s ': stl) (RImage stl (s ': stl))
145+ extract
265−-- => Union f (s ': stl)
146+ :: forall name s
266−-- -> Maybe (Union f stl) )
147+ . (KnownSymbol name)
267−-- subUnion (SCons s stl) = urestrict
148+ => FieldRepr '(name, s)
268−
149+ -> (Text, Value)
269−-- withUSubset
150+ extract (FieldRepr s) = (T.pack $ symbolVal $ Proxy @name, toJSON s)
270−-- :: Sing (s ': stl)
151+ fold :: Rec FieldRepr fs -> [(Text, J.Value)]
271−-- -> (USubset stl (s ': stl) (RImage stl (s ': stl)) => Maybe (Union f stl))
152+ fold = \case
272−-- -> Maybe (Union f stl)
153+ RNil -> []
273−-- withUSubset (SCons s stl) r = r
154+ fr@(FieldRepr s) :& tl -> (extract fr) : fold tl
274−
155+
275−toUnion
156+type Spec
276− :: USubset s' (s ': ss) (RImage s' (s ': ss))
157+ = SchemaObject
277− => Sing (s ': ss)
158+ '[ '("foo", SchemaArray '[AEq 3] (SchemaNumber '[NGt 10]))
278− -> Union JsonRepr s'
159+ , '("bar", SchemaText '[Regex "\\w+"])]
279− -> JsonRepr ('SchemaUnion (s ': ss))
160+
280−toUnion _ = ReprUnion . urelax
161+spec :: (SingKind Schema, SingI Spec) => DemoteRep Schema
281−
162+spec = fromSing (sing :: Sing Spec)
282−umatch' :: UElem a as i => Sing a -> Union f as -> Maybe (f a)
163+
283−umatch' _ u = umatch u
164+exampleTest :: JsonRepr (SchemaText '[TEq 3])
284−
165+exampleTest = ReprText "ololo"
285−parseAndValidateJson
166+
286− :: forall schema
167+exampleNumber :: JsonRepr (SchemaNumber '[NEq 3])
287− . (FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
168+exampleNumber = ReprNumber 3
288− => Value
169+
289− -> ParseResult (JsonRepr schema)
170+exampleArray :: JsonRepr (SchemaArray '[AEq 1] (SchemaNumber '[NEq 3]))
290−parseAndValidateJson v =
171+exampleArray = ReprArray [exampleNumber]
291− case parseEither parseJSON v of
172+
292− Left s -> DecodingError $ T.pack s
173+exampleObject
293− Right jsonRepr ->
174+ :: JsonRepr (SchemaObject '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NEq 3]))] )
294− let
175+exampleObject = ReprObject $ FieldRepr exampleArray :& RNil
295− validate = validateJsonRepr (sing :: Sing schema) [] jsonRepr
176+
296− res = runIdentity . runValidationTEither $ validate
177+example :: JsonRepr Spec
297− in case res of
178+example = ReprObject $
298− Left em -> ValidationError em
179+ FieldRepr (ReprArray [ReprNumber 3])
299− Right () -> Valid jsonRepr
180+ :& FieldRepr (ReprText "test")
300−
181+ :& RNil
301−parseAndValidateJsonBy
182+
302− :: (FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
183+class FalseConstraint
303− => proxy schema
184+
304− -> Value
185+type family TopLevel (spec :: Schema) :: Constraint where
305− -> ParseResult (JsonRepr schema)
186+ TopLevel (SchemaArray a e) = ()
306−parseAndValidateJsonBy _ = parseAndValidateJson
187+ TopLevel (SchemaObject o) = ()
188+ TopLevel spec = FalseConstraint
src/Data/Schematic/Verifier.hsdeleted−5
@@ -1,5 +0,0 @@
1−module Data.Schematic.Verifier (module X) where
2−
3−import Data.Schematic.Verifier.Array as X
4−import Data.Schematic.Verifier.Number as X
5−import Data.Schematic.Verifier.Text as X
src/Data/Schematic/Verifier/Array.hsdeleted−14
@@ -1,14 +0,0 @@
1−module Data.Schematic.Verifier.Array where
2−
3−import {-# SOURCE #-} Data.Schematic.Schema
4−import Data.Schematic.Verifier.Common
5−
6−data VerifiedArrayConstraint =
7− VAEq Integer
8− deriving (Show)
9−
10−verifyArrayConstraint ::
11− [DemotedArrayConstraint] -> Maybe (Maybe VerifiedArrayConstraint)
12−verifyArrayConstraint cs = do
13− x <- verifyDNEq [x | DAEq x <- cs]
14− pure $ VAEq <$> x
src/Data/Schematic/Verifier/Common.hsdeleted−43
@@ -1,43 +0,0 @@
1−module Data.Schematic.Verifier.Common where
2−
3−import Data.List (nub)
4−
5−simplifyNumberConstraint :: ([Integer] -> Integer) -> [Integer] -> Maybe Integer
6−simplifyNumberConstraint f =
7− \case
8− [] -> Nothing
9− x -> Just $ f x
10−
11−simplifyDNLs :: [Integer] -> Maybe Integer
12−simplifyDNLs = simplifyNumberConstraint minimum
13−
14−simplifyDNGs :: [Integer] -> Maybe Integer
15−simplifyDNGs = simplifyNumberConstraint maximum
16−
17−verifyDNEq :: [Integer] -> Maybe (Maybe Integer)
18−verifyDNEq x =
19− case nub x of
20− [] -> Just Nothing
21− [y] -> Just $ Just y
22− (_:_:_) -> Nothing
23−
24−verify3 :: Maybe Integer -> Maybe Integer -> Maybe Integer -> Maybe ()
25−verify3 (Just x) (Just y) (Just z) =
26− if x < y && y < z
27− then Just ()
28− else Nothing
29−verify3 _ _ _ = Just ()
30−
31−verify2 :: Maybe Integer -> Maybe Integer -> Maybe ()
32−verify2 (Just x) (Just y) =
33− if x < y
34− then Just ()
35− else Nothing
36−verify2 _ _ = Just ()
37−
38−verifyEquations :: Maybe Integer -> Maybe Integer -> Maybe Integer -> Maybe ()
39−verifyEquations mgt meq mlt = do
40− verify3 mgt meq mlt
41− verify2 mgt meq
42− verify2 meq mlt
43− verify2 mgt mlt
src/Data/Schematic/Verifier/Number.hsdeleted−31
@@ -1,31 +0,0 @@
1−module Data.Schematic.Verifier.Number where
2−
3−import {-# SOURCE #-} Data.Schematic.Schema
4−import Data.Schematic.Verifier.Common
5−
6−toStrictNumber :: [DemotedNumberConstraint] -> [DemotedNumberConstraint]
7−toStrictNumber = map f
8− where
9− f (DNLe x) = DNLt (x + 1)
10− f (DNGe x) = DNGt (x - 1)
11− f x = x
12−
13−data VerifiedNumberConstraint
14− = VNEq Integer
15− | VNBounds (Maybe Integer) (Maybe Integer)
16− deriving (Show)
17−
18−verifyNumberConstraints
19− :: [DemotedNumberConstraint]
20− -> Maybe VerifiedNumberConstraint
21−verifyNumberConstraints cs' = do
22− let
23− cs = toStrictNumber cs'
24− mlt = simplifyDNLs [x | DNLt x <- cs]
25− mgt = simplifyDNGs [x | DNGt x <- cs]
26− meq <- verifyDNEq [x | DNEq x <- cs]
27− verifyEquations mgt meq mlt
28− Just $
29− case meq of
30− Just eq -> VNEq eq
31− Nothing -> VNBounds mgt mlt
src/Data/Schematic/Verifier/Text.hsdeleted−121
@@ -1,121 +0,0 @@
1−module Data.Schematic.Verifier.Text where
2−
3−import Control.Monad
4−import Data.Maybe
5−import {-# SOURCE #-} Data.Schematic.Schema
6−import Data.Schematic.Verifier.Common
7−import Data.Text (Text, unpack)
8−import Text.Regex.TDFA.Pattern
9−import Text.Regex.TDFA.ReadRegex (parseRegex)
10−
11−toStrictTextLength :: [DemotedTextConstraint] -> [DemotedTextConstraint]
12−toStrictTextLength = map f
13− where
14− f (DTLe x) = DTLt (x + 1)
15− f (DTGe x) = DTGt (x - 1)
16− f x = x
17−
18−data VerifiedTextConstraint
19− = VTEq Integer
20− | VTBounds (Maybe Integer) (Maybe Integer)
21− | VTRegex Text Integer (Maybe Integer)
22− | VTEnum [Text]
23− deriving (Show)
24−
25−verifyTextLengthConstraints
26− :: [DemotedTextConstraint]
27− -> Maybe (Maybe VerifiedTextConstraint)
28−verifyTextLengthConstraints cs' = do
29− let
30− cs = toStrictTextLength cs'
31− mlt = simplifyDNLs [x | DTLt x <- cs]
32− mgt = simplifyDNGs [x | DTGt x <- cs]
33− meq <- verifyDNEq [x | DTEq x <- cs]
34− verifyEquations mgt meq mlt
35− case all isNothing ([mgt, meq, mlt] :: [Maybe Integer]) of
36− True -> Just Nothing
37− _ ->
38− Just $
39− Just $
40− case meq of
41− Just eq -> VTEq eq
42− Nothing -> VTBounds mgt mlt
43−
44−regexLength :: Text -> Maybe (Int, Maybe Int)
45−regexLength regexp =
46− case parseRegex . unpack $ regexp of
47− Right (p, _) -> Just (minRegexLength p, maxRegexLength p)
48− Left _ -> Nothing
49−
50−minRegexLength :: Pattern -> Int
51−minRegexLength p =
52− case p of
53− PEmpty -> 0
54− PChar {..} -> 1
55− PAny {..} -> 1
56− PAnyNot {..} -> 1
57− PQuest _ -> 0
58− PPlus sch -> minRegexLength $ PBound 1 Nothing sch
59− PStar _ sch -> minRegexLength $ PBound 0 Nothing sch
60− PBound low _ sch -> low * minRegexLength sch
61− PConcat ps -> sum $ fmap minRegexLength ps
62− POr xs -> minimum $ fmap minRegexLength xs
63− PDot _ -> 1
64− PEscape {..} -> 1
65− PCarat _ -> 0
66− PDollar _ -> 0
67− _ -> 0
68−
69−maxRegexLength :: Pattern -> Maybe Int
70−maxRegexLength p =
71− case p of
72− PEmpty -> Just 0
73− PChar _ _ -> Just 1
74− PAny _ _ -> Just 1
75− PAnyNot _ _ -> Just 1
76− PQuest _ -> Just 0
77− PPlus _ -> Nothing
78− PStar _ _ -> Nothing
79− PBound _ mhigh sch -> (*) <$> mhigh <*> maxRegexLength sch
80− PConcat ps -> sum <$> mapM maxRegexLength ps
81− POr xs -> maximum <$> mapM maxRegexLength xs
82− PDot _ -> Just 1
83− PEscape _ _ -> Just 1
84− PCarat _ -> Just 0
85− PDollar _ -> Just 0
86− _ -> Just 0
87−
88−verifyTextRegexConstraint
89− :: [DemotedTextConstraint]
90− -> Maybe (Maybe VerifiedTextConstraint)
91−verifyTextRegexConstraint cs = do
92− let regexps = [x | DTRegex x <- cs]
93− case regexps of
94− [] -> Just Nothing
95− [x] -> do
96− (l, mh) <- regexLength x
97− Just $ Just $ VTRegex x (fromIntegral l) (fromIntegral <$> mh)
98− _ -> Nothing
99−
100−verifyTextEnumConstraint
101− :: [DemotedTextConstraint]
102− -> Maybe (Maybe VerifiedTextConstraint)
103−verifyTextEnumConstraint cs = do
104− let enums = concat [x | DTEnum x <- cs]
105− case enums of
106− [] -> Just Nothing
107− x -> Just $ Just $ VTEnum x
108−
109−verifyTextConstraints
110− :: [DemotedTextConstraint]
111− -> Maybe [VerifiedTextConstraint]
112−verifyTextConstraints cs = do
113− regexp <- verifyTextRegexConstraint cs
114− void $
115− case regexp of
116− Just (VTRegex _ l mh) ->
117− verifyTextLengthConstraints (DTGe l : cs ++ maybeToList (DTLe <$> mh))
118− _ -> pure Nothing
119− lengths <- verifyTextLengthConstraints cs
120− enums <- verifyTextEnumConstraint cs
121− return $ catMaybes [lengths, enums, regexp]
stack-13.21.yamldeleted−7
@@ -1,7 +0,0 @@
1−resolver: lts-13.21
2−extra-deps:
3− - hjsonpointer-1.4.0@rev:0
4− - hjsonschema-1.9.0@rev:0
5− - validationt-0.3.0
6−nix:
7− packages: [pcre, pkg-config, zlib]
stack.yaml+68−6
@@ -1,6 +1,68 @@
1−resolver: lts-14.22
1+# This file was automatically generated by 'stack init'
2−extra-deps:
2+#
3−- hjsonpointer-1.4.0@rev:0
3+# Some commonly used options have been documented as comments in this file.
4−- hjsonschema-1.9.0@rev:0
4+# For advanced use and comprehensive documentation of the format, please see:
5−- git: https://github.com/typeable/validationt.git
5+# http://docs.haskellstack.org/en/stable/yaml_configuration/
6− commit: 97fea97c4015ab5e99f3efb2c73e1fef4b8857d8
6+
7+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
8+# A snapshot resolver dictates the compiler version and the set of packages
9+# to be used for project dependencies. For example:
10+#
11+# resolver: lts-3.5
12+# resolver: nightly-2015-09-21
13+# resolver: ghcjs-0.1.0_ghc-7.10.2
14+# resolver:
15+# name: custom-snapshot
16+# location: "./custom-snapshot.yaml"
17+resolver: lts-8.12
18+#resolver: ghc-8.0.2
19+
20+# User packages to be built.
21+# Various formats can be used as shown in the example below.
22+#
23+# packages:
24+# - some-directory
25+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
26+# - location:
27+# git: https://github.com/commercialhaskell/stack.git
28+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
29+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
30+# extra-dep: true
31+# subdirs:
32+# - auto-update
33+# - wai
34+#
35+# A package marked 'extra-dep: true' will only be built if demanded by a
36+# non-dependency (i.e. a user package), and its test suites and benchmarks
37+# will not be run. This is useful for tweaking upstream packages.
38+packages:
39+- location:
40+ git: https://github.com/typeable/validationt.git
41+ commit: 24578c9fd408179358c641ee1fff0eb182591f4b
42+- '.'
43+
44+extra-deps: []
45+
46+# Override default flag values for local packages and extra-deps
47+flags: {}
48+
49+# Extra package databases containing global packages
50+extra-package-dbs: []
51+
52+# Control whether we use the GHC we find on the path
53+# system-ghc: true
54+#
55+# Require a specific version of stack, using version ranges
56+# require-stack-version: -any # Default
57+# require-stack-version: ">=1.4"
58+#
59+# Override the architecture used by stack, especially useful on Windows
60+# arch: i386
61+# arch: x86_64
62+#
63+# Extra directories used by stack for building
64+# extra-include-dirs: [/path/to/dir]
65+# extra-lib-dirs: [/path/to/dir]
66+#
67+# Allow a newer minor version of GHC than the snapshot specifies
68+# compiler-check: newer-minor
test/HelpersSpec.hsdeleted−124
@@ -1,124 +0,0 @@
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.hsdeleted−101
@@ -1,101 +0,0 @@
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.hsdeleted−318
@@ -1,318 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE TypeApplications #-}
3−{-# LANGUAGE OverloadedLists #-}
4−{-# LANGUAGE OverloadedStrings #-}
5−
6−module LensSpec (spec, main) where
7−
8−import Control.Lens
9−import Data.Proxy
10−import Data.Schematic
11−import Data.Vinyl
12−import Test.Hspec
13−
14−
15−type ArraySchema = 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10])
16−
17−type ArrayField = '("foo", ArraySchema)
18−
19−type FieldsSchema =
20− '[ '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]])), ArrayField]
21−
22−arrayData :: JsonRepr ArraySchema
23−arrayData = ReprArray [ReprNumber 13]
24−
25−arrayField :: FieldRepr ArrayField
26−arrayField = FieldRepr arrayData
27−
28−objectData :: Rec FieldRepr FieldsSchema
29−objectData = FieldRepr (ReprOptional (Just (ReprText "foo")))
30− :& FieldRepr arrayData
31− :& RNil
32−
33−type BigRecord = Rec FieldRepr
34− '[ '("f1", 'SchemaNumber '[])
35− , '("f2", 'SchemaNumber '[])
36− , '("f3", 'SchemaNumber '[])
37− , '("f4", 'SchemaNumber '[])
38− , '("f5", 'SchemaNumber '[])
39− , '("f6", 'SchemaNumber '[])
40− , '("f7", 'SchemaNumber '[])
41− , '("f8", 'SchemaNumber '[])
42− , '("f9", 'SchemaNumber '[])
43− , '("f10", 'SchemaNumber '[])
44− , '("f11", 'SchemaNumber '[])
45− , '("f12", 'SchemaNumber '[])
46− , '("f13", 'SchemaNumber '[])
47− , '("f14", 'SchemaNumber '[])
48− , '("f15", 'SchemaNumber '[])
49− , '("f16", 'SchemaNumber '[])
50− , '("f17", 'SchemaNumber '[])
51− , '("f18", 'SchemaNumber '[])
52− , '("f19", 'SchemaNumber '[])
53− , '("f20", 'SchemaNumber '[])
54− , '("f21", 'SchemaNumber '[])
55− , '("f22", 'SchemaNumber '[])
56− , '("f23", 'SchemaNumber '[])
57− , '("f24", 'SchemaNumber '[])
58− , '("f25", 'SchemaNumber '[])
59− , '("f26", 'SchemaNumber '[])
60− , '("f27", 'SchemaNumber '[])
61− , '("f28", 'SchemaNumber '[])
62− , '("f29", 'SchemaNumber '[])
63− , '("f30", 'SchemaNumber '[])
64− , '("f31", 'SchemaNumber '[])
65− , '("f32", 'SchemaNumber '[])
66− , '("f33", 'SchemaNumber '[])
67− , '("f34", 'SchemaNumber '[])
68− , '("f35", 'SchemaNumber '[])
69− , '("f36", 'SchemaNumber '[])
70− , '("f37", 'SchemaNumber '[])
71− , '("f38", 'SchemaNumber '[])
72− , '("f39", 'SchemaNumber '[])
73− , '("f40", 'SchemaNumber '[])
74− , '("f41", 'SchemaNumber '[])
75− , '("f42", 'SchemaNumber '[])
76− , '("f43", 'SchemaNumber '[])
77− , '("f44", 'SchemaNumber '[])
78− , '("f45", 'SchemaNumber '[])
79− , '("f46", 'SchemaNumber '[])
80− , '("f47", 'SchemaNumber '[])
81− , '("f48", 'SchemaNumber '[])
82− , '("f49", 'SchemaNumber '[])
83− , '("f50", 'SchemaNumber '[])
84− , '("f51", 'SchemaNumber '[])
85− , '("f52", 'SchemaNumber '[])
86− , '("f53", 'SchemaNumber '[])
87− , '("f54", 'SchemaNumber '[])
88− , '("f55", 'SchemaNumber '[])
89− , '("f56", 'SchemaNumber '[])
90− , '("f57", 'SchemaNumber '[])
91− , '("f58", 'SchemaNumber '[])
92− , '("f59", 'SchemaNumber '[])
93− , '("f60", 'SchemaNumber '[])
94− , '("f61", 'SchemaNumber '[])
95− , '("f62", 'SchemaNumber '[])
96− , '("f63", 'SchemaNumber '[])
97− , '("f64", 'SchemaNumber '[])
98− , '("f65", 'SchemaNumber '[])
99− , '("f66", 'SchemaNumber '[])
100− , '("f67", 'SchemaNumber '[])
101− , '("f68", 'SchemaNumber '[])
102− , '("f69", 'SchemaNumber '[])
103− , '("f70", 'SchemaNumber '[])
104− , '("f71", 'SchemaNumber '[])
105− , '("f72", 'SchemaNumber '[])
106− , '("f73", 'SchemaNumber '[])
107− , '("f74", 'SchemaNumber '[])
108− , '("f75", 'SchemaNumber '[])
109− , '("f76", 'SchemaNumber '[])
110− , '("f77", 'SchemaNumber '[])
111− , '("f78", 'SchemaNumber '[])
112− , '("f79", 'SchemaNumber '[])
113− , '("f80", 'SchemaNumber '[])
114− , '("f81", 'SchemaNumber '[])
115− , '("f82", 'SchemaNumber '[])
116− , '("f83", 'SchemaNumber '[])
117− , '("f84", 'SchemaNumber '[])
118− , '("f85", 'SchemaNumber '[])
119− , '("f86", 'SchemaNumber '[])
120− , '("f87", 'SchemaNumber '[])
121− , '("f88", 'SchemaNumber '[])
122− , '("f89", 'SchemaNumber '[])
123− , '("f90", 'SchemaNumber '[])
124− , '("f91", 'SchemaNumber '[])
125− , '("f92", 'SchemaNumber '[])
126− , '("f93", 'SchemaNumber '[])
127− , '("f94", 'SchemaNumber '[])
128− , '("f95", 'SchemaNumber '[])
129− , '("f96", 'SchemaNumber '[])
130− , '("f97", 'SchemaNumber '[])
131− , '("f98", 'SchemaNumber '[])
132− , '("f99", 'SchemaNumber '[])
133− , '("f100", 'SchemaNumber '[])
134− , '("f101", 'SchemaNumber '[])
135− , '("f102", 'SchemaNumber '[])
136− , '("f103", 'SchemaNumber '[])
137− , '("f104", 'SchemaNumber '[])
138− , '("f105", 'SchemaNumber '[])
139− , '("f106", 'SchemaNumber '[])
140− , '("f107", 'SchemaNumber '[])
141− , '("f108", 'SchemaNumber '[])
142− , '("f109", 'SchemaNumber '[])
143− , '("f110", 'SchemaNumber '[])
144− , '("f111", 'SchemaNumber '[])
145− , '("f112", 'SchemaNumber '[])
146− , '("f113", 'SchemaNumber '[])
147− , '("f114", 'SchemaNumber '[])
148− , '("f115", 'SchemaNumber '[])
149− , '("f116", 'SchemaNumber '[])
150− , '("f117", 'SchemaNumber '[])
151− , '("f118", 'SchemaNumber '[])
152− , '("f119", 'SchemaNumber '[])
153− , '("f120", 'SchemaNumber '[])
154− , '("f121", 'SchemaNumber '[])
155− , '("f122", 'SchemaNumber '[])
156− , '("f123", 'SchemaNumber '[])
157− , '("f124", 'SchemaNumber '[])
158− , '("f125", 'SchemaNumber '[])
159− , '("f126", 'SchemaNumber '[])
160− , '("f127", 'SchemaNumber '[])
161− , '("f128", 'SchemaNumber '[])
162− , '("f129", 'SchemaNumber '[])
163− , '("f130", 'SchemaNumber '[])
164− ]
165−
166−_bigRecord :: BigRecord
167−_bigRecord =
168− FieldRepr (ReprNumber 1)
169− :& FieldRepr (ReprNumber 2)
170− :& FieldRepr (ReprNumber 3)
171− :& FieldRepr (ReprNumber 4)
172− :& FieldRepr (ReprNumber 5)
173− :& FieldRepr (ReprNumber 6)
174− :& FieldRepr (ReprNumber 7)
175− :& FieldRepr (ReprNumber 8)
176− :& FieldRepr (ReprNumber 9)
177− :& FieldRepr (ReprNumber 10)
178− :& FieldRepr (ReprNumber 11)
179− :& FieldRepr (ReprNumber 12)
180− :& FieldRepr (ReprNumber 13)
181− :& FieldRepr (ReprNumber 14)
182− :& FieldRepr (ReprNumber 15)
183− :& FieldRepr (ReprNumber 16)
184− :& FieldRepr (ReprNumber 17)
185− :& FieldRepr (ReprNumber 18)
186− :& FieldRepr (ReprNumber 19)
187− :& FieldRepr (ReprNumber 20)
188− :& FieldRepr (ReprNumber 21)
189− :& FieldRepr (ReprNumber 22)
190− :& FieldRepr (ReprNumber 23)
191− :& FieldRepr (ReprNumber 24)
192− :& FieldRepr (ReprNumber 25)
193− :& FieldRepr (ReprNumber 26)
194− :& FieldRepr (ReprNumber 27)
195− :& FieldRepr (ReprNumber 28)
196− :& FieldRepr (ReprNumber 29)
197− :& FieldRepr (ReprNumber 30)
198− :& FieldRepr (ReprNumber 31)
199− :& FieldRepr (ReprNumber 32)
200− :& FieldRepr (ReprNumber 33)
201− :& FieldRepr (ReprNumber 34)
202− :& FieldRepr (ReprNumber 35)
203− :& FieldRepr (ReprNumber 36)
204− :& FieldRepr (ReprNumber 37)
205− :& FieldRepr (ReprNumber 38)
206− :& FieldRepr (ReprNumber 39)
207− :& FieldRepr (ReprNumber 40)
208− :& FieldRepr (ReprNumber 41)
209− :& FieldRepr (ReprNumber 42)
210− :& FieldRepr (ReprNumber 43)
211− :& FieldRepr (ReprNumber 44)
212− :& FieldRepr (ReprNumber 45)
213− :& FieldRepr (ReprNumber 46)
214− :& FieldRepr (ReprNumber 47)
215− :& FieldRepr (ReprNumber 48)
216− :& FieldRepr (ReprNumber 49)
217− :& FieldRepr (ReprNumber 50)
218− :& FieldRepr (ReprNumber 51)
219− :& FieldRepr (ReprNumber 52)
220− :& FieldRepr (ReprNumber 53)
221− :& FieldRepr (ReprNumber 54)
222− :& FieldRepr (ReprNumber 55)
223− :& FieldRepr (ReprNumber 56)
224− :& FieldRepr (ReprNumber 57)
225− :& FieldRepr (ReprNumber 58)
226− :& FieldRepr (ReprNumber 59)
227− :& FieldRepr (ReprNumber 60)
228− :& FieldRepr (ReprNumber 61)
229− :& FieldRepr (ReprNumber 62)
230− :& FieldRepr (ReprNumber 63)
231− :& FieldRepr (ReprNumber 64)
232− :& FieldRepr (ReprNumber 65)
233− :& FieldRepr (ReprNumber 66)
234− :& FieldRepr (ReprNumber 67)
235− :& FieldRepr (ReprNumber 68)
236− :& FieldRepr (ReprNumber 69)
237− :& FieldRepr (ReprNumber 70)
238− :& FieldRepr (ReprNumber 71)
239− :& FieldRepr (ReprNumber 72)
240− :& FieldRepr (ReprNumber 73)
241− :& FieldRepr (ReprNumber 74)
242− :& FieldRepr (ReprNumber 75)
243− :& FieldRepr (ReprNumber 76)
244− :& FieldRepr (ReprNumber 77)
245− :& FieldRepr (ReprNumber 78)
246− :& FieldRepr (ReprNumber 79)
247− :& FieldRepr (ReprNumber 80)
248− :& FieldRepr (ReprNumber 81)
249− :& FieldRepr (ReprNumber 82)
250− :& FieldRepr (ReprNumber 83)
251− :& FieldRepr (ReprNumber 84)
252− :& FieldRepr (ReprNumber 85)
253− :& FieldRepr (ReprNumber 86)
254− :& FieldRepr (ReprNumber 87)
255− :& FieldRepr (ReprNumber 88)
256− :& FieldRepr (ReprNumber 89)
257− :& FieldRepr (ReprNumber 90)
258− :& FieldRepr (ReprNumber 91)
259− :& FieldRepr (ReprNumber 92)
260− :& FieldRepr (ReprNumber 93)
261− :& FieldRepr (ReprNumber 94)
262− :& FieldRepr (ReprNumber 95)
263− :& FieldRepr (ReprNumber 96)
264− :& FieldRepr (ReprNumber 97)
265− :& FieldRepr (ReprNumber 98)
266− :& FieldRepr (ReprNumber 99)
267− :& FieldRepr (ReprNumber 100)
268− :& FieldRepr (ReprNumber 101)
269− :& FieldRepr (ReprNumber 102)
270− :& FieldRepr (ReprNumber 103)
271− :& FieldRepr (ReprNumber 104)
272− :& FieldRepr (ReprNumber 105)
273− :& FieldRepr (ReprNumber 106)
274− :& FieldRepr (ReprNumber 107)
275− :& FieldRepr (ReprNumber 108)
276− :& FieldRepr (ReprNumber 109)
277− :& FieldRepr (ReprNumber 110)
278− :& FieldRepr (ReprNumber 111)
279− :& FieldRepr (ReprNumber 112)
280− :& FieldRepr (ReprNumber 113)
281− :& FieldRepr (ReprNumber 114)
282− :& FieldRepr (ReprNumber 115)
283− :& FieldRepr (ReprNumber 116)
284− :& FieldRepr (ReprNumber 117)
285− :& FieldRepr (ReprNumber 118)
286− :& FieldRepr (ReprNumber 119)
287− :& FieldRepr (ReprNumber 120)
288− :& FieldRepr (ReprNumber 121)
289− :& FieldRepr (ReprNumber 122)
290− :& FieldRepr (ReprNumber 123)
291− :& FieldRepr (ReprNumber 124)
292− :& FieldRepr (ReprNumber 125)
293− :& FieldRepr (ReprNumber 126)
294− :& FieldRepr (ReprNumber 127)
295− :& FieldRepr (ReprNumber 128)
296− :& FieldRepr (ReprNumber 129)
297− :& FieldRepr (ReprNumber 130)
298− :& RNil
299−
300−spec :: Spec
301−spec = do
302− let
303− newFooVal = FieldRepr $ ReprArray [ReprNumber 15]
304− fooProxy = Proxy @"foo"
305− it "gets the field from an object" $ do
306− fget @"foo" objectData `shouldBe` arrayField
307− it "sets the object field" $ do
308− fget @"foo" (fput newFooVal objectData) `shouldBe` newFooVal
309−
310− describe "(using lens library) " $ do
311− it "get the field from an object" $ do
312− objectData ^. flens @"foo" `shouldBe` arrayField
313− it "sets the object field" $ do
314− set (flens @"foo") newFooVal objectData ^. flens @"foo"
315− `shouldBe` newFooVal
316−
317−main :: IO ()
318−main = hspec spec
test/SchemaSpec.hs+35−107
@@ -1,122 +1,50 @@
1−{-# OPTIONS_GHC -fprint-potential-instances #-}
2−
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE OverloadedLists #-}
7−{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE RankNTypes #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TypeApplications #-}
11−
12module SchemaSpec (spec, main) where
1module SchemaSpec (spec, main) where
13
2
14−import Control.Lens
3+import Data.Functor.Foldable
15−import Data.Aeson
16−import Data.ByteString.Lazy
17−import Data.Functor.Identity
18import Data.Proxy
4import Data.Proxy
19−import Data.Schematic
5+import Data.Schematic.Schema
20−import Data.Schematic.Generator
6+import Data.Schematic.Validation
21−import Data.Singletons
22−import Data.Tagged
23−import Data.Vinyl
24import Test.Hspec
7import Test.Hspec
25−import Test.Hspec.SmallCheck
26−import Test.SmallCheck as SC
27−import Test.SmallCheck.Drivers as SC
28−import Test.SmallCheck.Series as SC
29−
30−import Debug.Trace
31−
32−type SchemaExample = 'SchemaObject
33− '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]))
34− , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]
35−
36−type SchemaExample2 = 'SchemaObject
37− '[ '("foo", 'SchemaArray '[ 'AEq 2] ('SchemaText '[ 'TGt 10]))
38− , '("bar", 'SchemaOptional ('SchemaText '[ 'TRegex "[0-9]+"]))]
39−
40−jsonExample :: JsonRepr SchemaExample
41−jsonExample = withRepr @SchemaExample
42− $ field @"bar" (Just "bar")
43− :& field @"foo" [12]
44− :& RNil
45
8
46−type AddQuuz =
47− 'Migration "add_field_quuz"
48− '[ 'Diff '[] ('AddKey "quuz" (SchemaNumber '[])) ]
49
9
50−type DeleteQuuz =
10+type TextSchema = SText '[LengthEqNat 2]
51− 'Migration "remove_field_quuz"
52− '[ 'Diff '[] ( 'DeleteKey "quuz") ]
53
11
54−type SwapFields =
12+type NumberSchema = SNumber '[ Gt 3]
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
13
61−type Migrations = '[ AddQuuz
14+type ArraySchema = SArray '[ LengthEqNat 3 ] NumberSchema
62− , DeleteQuuz ]
63− -- , SwapFields ]
64
15
65−type VersionedJson = 'Versioned SchemaExample Migrations
16+type ObjectSchema
66−
17+ = SObject "CarrierObj"
67−migrationList :: MigrationList Identity VersionedJson
18+ '[ Field "carrier" 'JText '[LengthEqNat 2]
68−migrationList
19+ , Field "number_gt_3" 'JNumber '[Gt 3] ]
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
76−
77−schemaJson :: ByteString
78−schemaJson = "{\"foo\": [13], \"bar\": null}"
79−
80−schemaJson2 :: ByteString
81−schemaJson2 = "{\"foo\": [3], \"bar\": null}"
82−
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
88
20
89spec :: Spec
21spec :: Spec
90spec = do
22spec = do
91− -- it "show/read JsonRepr properly" $
23+ let
92− -- read (show example) == example
24+ textSchema = Fix $ SchemaText [LengthEq 2]
93− it "decode/encode JsonRepr properly" $
25+ numberSchema = Fix $ SchemaNumber [Gt 3]
94− decode (encode jsonExample) == Just jsonExample
26+ arraySchema = Fix $ SchemaArray [LengthArrEq 3]
95− it "validates correct representation" $
27+ $ Fix $ SchemaNumber [Gt 3]
96− ((decodeAndValidateJson schemaJson) :: ParseResult (JsonRepr SchemaExample))
28+ objectSchema = Fix $ SchemaObject
97− `shouldSatisfy` isValid
29+ [ ("carrier", textSchema)
98− it "returns decoding error on structurally incorrect input" $
30+ , ("number_gt_3", numberSchema)]
99− ((decodeAndValidateJson "{}") :: ParseResult (JsonRepr SchemaExample))
31+
100− `shouldSatisfy` isDecodingError
32+ describe "Schema translation: " $ do
101− it "validates incorrect representation" $
33+ it "translate string schema" $ do
102− ((decodeAndValidateJson schemaJson2) :: ParseResult (JsonRepr SchemaExample))
34+ build (Proxy @TextSchema) `shouldBe` textSchema
103− `shouldSatisfy` isValidationError
35+ it "translates number schema" $ do
104− -- it "validates versioned json" $ do
36+ build (Proxy @NumberSchema) `shouldBe` numberSchema
105− -- decodeAndValidateVersionedJson (Proxy @VS) schemaJson
37+ it "translates array schema" $ do
106− -- `shouldSatisfy` isValid
38+ build (Proxy @ArraySchema) `shouldBe` arraySchema
107− it "validates versioned json with a migration list" $ do
39+ it "translates object schema" $ do
108− decodeAndValidateVersionedWithPureMList
40+ build (Proxy @ObjectSchema) `shouldBe` objectSchema
109− (Proxy @VersionedJson)
41+ -- it "translates Generate symbols" $ do
110− migrationList
42+ -- build (Proxy @GeneratorSchema) `shouldBe` objectSchema
111− schemaJson
43+
112− `shouldSatisfy` isValid
44+ describe "Types listing: " $ do
113− it "validates json series" $ property $
45+ it "lists types"
114− SC.over schemaJsonSeries $ \x ->
46+ $ typesOf (build (Proxy @ObjectSchema))
115− isValid (parseAndValidateJson @SchemaExample (toJSON x))
47+ `shouldBe` [("Carrier", textSchema), ("Object", objectSchema)]
116− it "validates json series 2" $ property $
117− SC.over schemaJsonSeries2 $ \x ->
118− isValid (parseAndValidateJson @SchemaExample2 (toJSON x))
119−
120
48
121main :: IO ()
49main :: IO ()
122main = hspec spec
50main = hspec spec