1076b56...master · schematic

git.iko.soy/schematic

31 files changed+2404−448

since splitsnapshots

unifiedsplit

.travis.yml+2−2 ChangeLog.md+45 README.md+164−42 release+43 release.nix+32 schematic.cabal+35−44 src/Data/Schematic.hs+38−82 src/Data/Schematic/DSL.hs+92 src/Data/Schematic/Generator.hs+91 src/Data/Schematic/Generator/Regex.hs+76 src/Data/Schematic/Helpers.hs+59 src/Data/Schematic/Instances.hs+4 src/Data/Schematic/JsonSchema.hs+124 src/Data/Schematic/Lens.hs+168−27 src/Data/Schematic/Migration.hs+48−14 src/Data/Schematic/Path.hs+6−17 src/Data/Schematic/Schema.hs+330−39 src/Data/Schematic/Schema.hs-boot+95 src/Data/Schematic/Utils.hs−42 src/Data/Schematic/Validation.hs+146−18 src/Data/Schematic/Verifier.hs+5 src/Data/Schematic/Verifier/Array.hs+14 src/Data/Schematic/Verifier/Common.hs+43 src/Data/Schematic/Verifier/Number.hs+31 src/Data/Schematic/Verifier/Text.hs+121 stack-13.7.yaml+5 stack.yaml+4−52 test/HelpersSpec.hs+124 test/JsonSchemaSpec.hs+101 test/LensSpec.hs+280−14 test/SchemaSpec.hs+78−55

.travis.yml+2−2

@@ -1,4 +1,4 @@

1−sudo: false

1+sudo: required

33language: c

@@ -22,4 +22,4 @@ script:

2222

2323cache:

2424 directories:

25− - $HOME/.stack

25+ - $HOME/.stack

ChangeLog.md+45

@@ -1,5 +1,50 @@

11# Revision history for schematic

3+## 0.5.0.0 -- 2019-02-20

5+GHC 8.6, json generation by schema definition, validation bug fixes, better

6+parsing error messages.

8+## 0.4.3.0 -- 2018-07-12

10+GHC 8.4 support, dropping support for older GHC versions

11+

12+## 0.4.2.0

13+

14+Support ghc-8.4 and drop support for older versions

15+

16+## 0.4.1.0 -- 2017-11-05

17+

18+Convenience isomorphisms: txt, num, opt, bln etc

19+

20+## 0.4.1.0 -- 2017-11-01

21+

22+flens and fget now use type application syntax

23+

24+## 0.4.0.0 -- 2017-10-17

25+

26+Object building DSL, more convenience helpers, MCons simplified with Tagged

27+

28+## 0.3.2.0 -- 2017-10-02

29+

30+Fixed FIndex bug, added bunch of convenience isomorphism, re-exports.

31+

32+## 0.3.1.0 -- 2017-09-28

33+

34+Add UUID and ISO8601 helpers, json schema constraint export, fsubset lens

35+combinator.

36+

37+## 0.3.0.0 -- 2017-09-28

38+

39+Updated to GHC 8.2.1 and singletons 2.3.1

40+

41+## 0.2.1.0 -- 2017-09-26

42+

43+Add decodeAndValidateVersionedWithPureMList, fix tests

44+

45+## 0.2.0.0 -- 2017-09-26

46+

47+Migratable is deprecated, migrations are now possible in an arbitrary monad.

348

449## 0.1.5.0 -- 2017-08-22

550

README.md+164−42

@@ -1,22 +1,16 @@

11# schematic

3−[![Build Status](https://travis-ci.org/dredozubov/schematic.svg?branch=master)](https://travis-ci.org/dredozubov/schematic)

3+[![Build Status](https://travis-ci.org/typeable/schematic.svg?branch=master)](https://travis-ci.org/typeable/schematic)

55## Goal

77The goal of the library is to provide a type-safe transport layer for serializing and validating JSON. It can be thought of as a subset of [json-schema](http://json-schema.org), which is basically a specification of a JSON document. The other goal is getting as much as possible from this specification for free. Right now the following bits are prototyped:

9−* All the instantiations of transport types are structurally follow the schema provided by user

10−* Serializers are generic, so they follow from the type-level schema and the're supposed to have roundtrip property by implementation.

9+* All of the instantiations of the transport types structurally follow the schema provided by user

10+* Serializers are generic, so they follow from the type-level schema and the're supposed to have a roundtrip property by an implementation.

1111* Runtime value validators are generated from the schema. Validation errors are reported as a pairs of a json-path to the element and an error message.

12−* There are migrations. It's possible to describe a series of migrations to the schema and have all the machinery deserialize a user specified version of the schema if there's a few versions.

13−

14−## TODO

15−

16−* Describing versioned http endpoints

17−* Schema pretty-printing

18−* More validators

19−* Overall user friendliness

12+* There are migrations. It's possible to describe a series of migrations to the schema and have all the necessary machinery to deserialize a user specified version of the schema if there are multiple versions available.

13+* Schematic schemas can be exported to [json-schema](http://json-schema.org)

2014

2115Be aware that library is experimental and subject to change a lot. The current state can be viewed as a prototype.

2216

@@ -28,67 +22,134 @@ Be aware that library is experimental and subject to change a lot. The current s

2822$ stack install schematic

2923```

3024

31−## Basic Examples

25+## GHC Extensions

26+

27+To use this library without any hassle you should add a few GHC extension

28+either to a module or a cabal file:

3229

3330```

31+DataKinds

32+OverloadedLists

33+OverloadedStrings

34+TypeApplications

35+```

36+

37+`Overloaded`-extensions are being used only by `field` combinator,

38+so if you don't use it - feel free to disable it.

39+

40+## GHC Options

41+

42+I recommend using `{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}`

43+pragma in modules which declare schemas and schema migrations, because `schematic`

44+heavily uses promoted types which should be prefixed with "`" signs and they can

45+be dropped with this option, making it less noisy visually.

46+It's entirely optional and totally opinionated, so feel free to ignore this.

47+Through the documentation, the code is written without any explicit ticks for

48+the same reason.

49+Notice that they're still needed for type-level lists and tuples in schematic code.

50+

51+## Basic Examples

52+

53+```haskell

3454type SchemaExample

3555 = SchemaObject

3656 '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))

3757 , '("bar", SchemaOptional (SchemaText '[TEnum '["foo", "bar"]]))]

3858```

3959

40−* This schema says that's structurally it's a JSON object which has two field:

41− * field "foo" contains an of numeric values

42− * field "bar" contains an optional textual value

43−* It also allows you to validate the JSON:

44− * an array in "foo" must contain exactly one element

60+* This schema says that's structurally it's a JSON object which has two fields:

61+ * field "foo" contains an array of numeric values

62+ * field "bar" contains an optional text value

63+* It also allows you to validate JSON values itself:

64+ * an array in "foo" contains exactly one element

4565 * that element must be strictly greater than 10

46− * value of bar must be either "foo" or "bar" if presented

66+ * value of "bar" field must be either "foo" or "bar" if presented

4767

4868

4969This one is valid for example

5070

51−```

71+```haskell

5272schemaJson :: ByteString

5373schemaJson = "{\"foo\": [13], \"bar\": null}"

5474```

5575

5676Also valid

5777

58−```

78+```haskell

5979schemaJson :: ByteString

6080schemaJson = "{\"foo\": [13], \"bar\": \"bar\"}"

6181```

6282

6383it can be parsed and validated like this:

6484

65−```

85+```haskell

6686decodeAndValidateJson schemaJson :: ParseResult (JsonRepr SchemaExample)

6787```

6888

6989`ParseResult` type encodes three possible situations:

70−* json is structurally consistent with schema and runtime validations passed

71−* json source is malformed or doesn't correspond to schema structurally

72−* some of the runtime validations failed, but it's structurally correct

90+* json is structurally consistent with a schema and runtime validations pass

91+* json source is malformed or doesn't correspond to a schema structurally

92+* some of the runtime validations have failed, but it's structurally correct

93+ overall

7394

74−I t's build a transport layer representation of that data that can be tranversed and transformed to whatever internal types user has. Transport layer represetation looks like this. Type parameter is the schema itself.

95+It implies a transport layer representation of that data that can be traversed

96+and transformed to whatever internal types user has.

97+It's called `JsonRepr`. Type parameter is the schema itself.

7598

99+```haskell

100+jsonExample :: JsonRepr SchemaExample

101+jsonExample = withRepr @SchemaExample

102+ $ field @"foo" [12]

103+ :& field @"bar" (Just "bar")

104+ :& RNil

105+```

106+

107+The most basic and sugar-free way of constructing the same object will look like this:

76108

77109```

78−jsonExample :: JsonRepr SchemaExample

79−jsonExample = ReprObject $

110+jsonExample' :: JsonRepr SchemaExample

111+jsonExample' = ReprObject $

80112 FieldRepr (ReprArray [ReprNumber 12])

81113 :& FieldRepr (ReprOptional (Just (ReprText "bar")))

82114 :& RNil

83115```

84116

85−## Migrations

117+## Lens-compatibility

86118

87−It's possible to represent schema changes as a migration, which describes a series of json-path/change pairs. Migrations can be applied in succession.

119+It's possible to use `flens` to construct a field lens for a typed object in schematic. Let's suppose you have a schema like this:

88120

89−This piece of code will apply a migration to the schema, then decodes and validates the latest version.

121+```haskell

122+type ArraySchema = SchemaArray '[AEq 1] (SchemaNumber '[NGt 10])

123+

124+type ArrayField = '("foo", ArraySchema)

125+

126+type FieldsSchema =

127+ '[ ArrayField, '("bar", SchemaOptional (SchemaText '[TEnum '["foo", "bar"]]))]

128+

129+type SchemaExample = 'SchemaObject FieldsSchema

90130

91131```

132+

133+There are two ways of working with named fields in the objects:

134+

135+* Using the `fget` and `fset` functions: `fget @"foo" (fput newFooVal objectData) == newFooVal`

136+* Using the lens library: `set (flens @"foo") newFooVal objectData ^. flens @"foo" == newFooVal`

137+

138+## Migrations

139+

140+Usually migrations are implicit and hard to deal with, `schematic` deals with it

141+by giving tools to deal with it to a programmer, being as explicit as possible,

142+notifying the developer of a missing transition with a compile-time error.

143+It allows to build versioned HTTP APIs or migrate data from the older versions

144+when reading from the JSON storages.

145+

146+It's possible to represent schema changes as a series of migrations,

147+which describes a series of json-path/change pairs. Migrations can be applied in

148+succession.

149+

150+This piece of code will apply a migration to the schema, decode and validate the latest version.

151+

152+```haskell

92153type SchemaExample

93154 = SchemaObject

94155 '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))

@@ -96,8 +157,8 @@ type SchemaExample

96157

97158type TestMigration =

98159 'Migration "test_revision"

99− '[ 'Diff '[ 'PKey "bar" ] ('Update ('SchemaText '[]))

100− , 'Diff '[ 'PKey "foo" ] ('Update ('SchemaNumber '[])) ]

160+ '[ Diff '[ PKey "bar" ] (Update (SchemaText '[]))

161+ , Diff '[ PKey "foo" ] (Update (SchemaNumber '[])) ]

101162

102163type VS = 'Versioned SchemaExample '[ TestMigration ]

103164

@@ -111,23 +172,84 @@ It's possible to decode the latest version like this:

111172decodeAndValidateJson schemaJsonTopVersion :: ParseResult (JsonRepr (TopVersion (AllVersions VS)))

112173```

113174

114−## Lens-compatibility

175+It's important to differentiate between schema migrations and data migrations.

176+Schema migration is a change of a schema acceptable by a JSON consumer. It transforms one schema to another.

177+Data migrations on the other hand are functions on the data itself. They transform values

178+acceptable by one schema to values acceptable by another.

179+Let's look at the situation when we have to add a field to a JSON Object of a current schema:

115180

116−It's possible to use `flens` to construct a field lens for a typed object in schematic. Let's suppose you have a schema like this:

181+```haskell

182+type SchemaExample = 'SchemaObject

183+ '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]))

184+ , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]

185+

186+jsonExample :: JsonRepr SchemaExample

187+jsonExample = withRepr @SchemaExample

188+ $ field @"bar" (Just "bar")

189+ :& field @"foo" [12]

190+ :& RNil

191+

192+type AddQuuz =

193+ 'Migration "add_field_quuz"

194+ '[ 'Diff '[] ('AddKey "quuz" (SchemaNumber '[])) ]

195+

196+type DeleteQuuz =

197+ 'Migration "remove_field_quuz"

198+ '[ 'Diff '[] ( 'DeleteKey "quuz") ]

199+

200+type Migrations = '[ AddQuuz

201+ , DeleteQuuz ]

202+

203+type VersionedJson = 'Versioned SchemaExample Migrations

204+

205+migrationList :: MigrationList Identity VersionedJson

206+migrationList

207+ = (migrateObject (\r -> Identity $ field @"quuz" 42 :& r))

208+ :&& shrinkObject

209+ :&& MNil

117210

118211```

119−type ArraySchema = 'SchemaArray '[AEq 1] ('SchemaNumber '[NGt 10])

120212

121−type ArrayField = '("foo", ArraySchema)

213+In this instance `Migrations` is a list of schema migrations and

214+`MigrationList Identity VersionedJson` is a list of data migrations corresponding

215+to the list of schema migrations: `migrateObject (\r -> Identity $ field @"quuz" 42 :& r))`

216+will be used at runtime to transform `JsonRepr SchemaExample` to

217+`JsonRepr (SchemaByRevision "add_quuz" VersionedJson). `Identity` in the type of

218+`MigrationList` is a monad we choose to run our migrations in. If there's need to

219+do database queries or something like that, it can be changed to something more

220+appropriate by a user.

221+`migrateObject` takes a function transforming old fields into new ones, `shrinkObject`

222+allows to shrink the JSON object in case migration only removed fields.

122223

123−type FieldsSchema =

124− '[ ArrayField, '("bar", 'SchemaOptional ('SchemaText '[TEnum '["foo", "bar"]]))]

224+## How do I construct a value of `JsonRepr schema`?

125225

126−type SchemaExample = 'SchemaObject FieldsSchema

226+`JsonRepr schema` is a primary representation of a value serializable/deserializable

227+to JSON, but with a twist. It's guaranteed to correspond a type-level schema,

228+it's a type parameter of a same name.

229+It makes constructing it a little bit more involved, but luckily `schematic`

230+provides a DSL for doing so in a more straightforward fashion. An example would

231+look like this:

232+

233+```haskell

234+type SchemaExample = 'SchemaObject

235+ '[ '("foo", SchemaArray '[ AEq 1] (SchemaNumber '[NGt 10]))

236+ , '("bar", SchemaOptional (SchemaText '[TEnum '["foo", "bar"]]))]

127237

238+jsonExample = withRepr @SchemaExample

239+ $ field @"bar" (Just "bar")

240+ :& field @"foo" [12]

241+ :& RNil

128242```

129243

130−There are two ways of working with named fields in the objects:

244+`@foo` syntax is an explicit type application, which is a feature of GHC 8+, it

245+makes type inference possible without relying on a bunch of `Proxy`s, which

246+makes it syntactically more terse.

247+

248+[GHC Type Applications](https://ghc.haskell.org/trac/ghc/wiki/TypeApplication)

249+

250+`schematic` provides instances for `OverloadedLists` and `OverloadedStrings`

251+GHC extensions to make use of string and list literals for values in a previous

252+example.

253+

131254

132−* Using the `fget` and `fset` functions: `fget fooProxy (fput newFooVal objectData) == newFooVal`

133−* Using the lens library: `set (flens (Proxy @"foo")) newFooVal objectData ^. flens (Proxy @"foo") == newFooVal`

255+## Export to json-schema (draft 4)

releasenew file+43

@@ -0,0 +1,43 @@

1+#!/bin/bash

3+set -o xtrace

5+dist=`stack path --dist-dir --stack-yaml ./stack.yaml 2> /dev/null`

7+rootdir=`pwd`

9+cabalfile=`ls *.cabal`

10+packagename="${cabalfile%%.*}"

11+version=`grep '^version:' schematic.cabal | rev | cut -d" " -f1 | rev`

12+

13+echo -e "\033[1;36mTesting library...\033[0m"

14+stack test 2> /dev/null

15+

16+echo -e "\033[1;36mRunning sdist...\033[0m"

17+cabal sdist

18+

19+echo -e "\033[1;36mGenerating documentation...\033[0m"

20+stack haddock 2> /dev/null

21+

22+if [ "$?" -eq "0" ]; then

23+ echo -e "\033[1;32mUploading package to Hackage...\033[0m"

24+ read -p "Hackage username: " username

25+ read -p "Hackage password: " -s password

26+ echo ""

27+ cabal upload -u $username -p $password dist/$packagename-$version.tar.gz

28+

29+ docdir=`find .stack-work -name "$packagename-$version-docs"`

30+

31+ echo -e "Compressing documentation from \033[1;34m$docdir\033[0m for \033[1;35m$packagename\033[0m-\033[1;33m$version\033[1;30m"

32+ tar -c -v -z --format=ustar -f $docdir.tar.gz $docdir

33+ echo -e "\033[1;32mUploading documentation to Hackage...\033[0m"

34+ cd $docdir

35+ cd ..

36+ curl -X PUT -H 'Content-Type: application/x-tar' -H 'Content-Encoding: gzip' --data-binary "$packagename-$version-docs.tar.gz" "https://$username:$password@hackage.haskell.org/package/$packagename-$version/candidate/docs"

37+ open "https://hackage.haskell.org/package/$packagename-$version/candidate/"

38+ cd $rootdir

39+ echo "To publish the candidate, use 'cabal upload --publish'."

40+ exit $?

41+else

42+ echo -e "\033[1;31mNot in a stack-powered project\033[0m"

43+fi

release.nixnew file+32

@@ -0,0 +1,32 @@

1+{ schematicSrc ? { outPath = ./.; revCount = 0; gitTag = "dirty"; }

2+, supportedSystems ? [ "x86_64-linux" ]

3+}:

5+let

6+ _nixpkgs = import <nixpkgs> {};

7+ inherit (_nixpkgs) pkgs lib;

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+35−44

@@ -1,15 +1,13 @@

1−-- Initial schematic.cabal generated by cabal init. For further

2−-- documentation, see http://haskell.org/cabal/users-guide/

3−

41name: schematic

5−version: 0.1.4.0

2+version: 0.5.0.0

63synopsis: JSON-biased spec and validation tool

7−-- description:

4+description: JSON-biased spec and validation tool. Makes possible to have a schema as a haskell type and derive json instances, validation actions, JSON generation for property-test generically. Built-in lens support.

85license: BSD3

96license-file: LICENSE

107author: Denis Redozubov

118maintainer: denis.redozubov@gmail.com

12−-- copyright:

9+homepage: http://github.com/typeable/schematic

10+Bug-reports: http://github.com/typeable/schematic/issues/

1311category: Data

1412build-type: Simple

1513extra-source-files: ChangeLog.md

@@ -17,20 +15,29 @@ cabal-version: >=1.10

1715

1816library

1917 exposed-modules: Data.Schematic

18+ , Data.Schematic.DSL

19+ , Data.Schematic.Generator

20+ , Data.Schematic.Generator.Regex

2021 , Data.Schematic.Instances

22+ , Data.Schematic.JsonSchema

23+ , Data.Schematic.Helpers

2124 , Data.Schematic.Lens

2225 , Data.Schematic.Migration

2326 , Data.Schematic.Path

2427 , Data.Schematic.Schema

2528 , Data.Schematic.Validation

26− , Data.Schematic.Utils

29+ , Data.Schematic.Verifier

30+ , Data.Schematic.Verifier.Array

31+ , Data.Schematic.Verifier.Common

32+ , Data.Schematic.Verifier.Number

33+ , Data.Schematic.Verifier.Text

2734 ghc-options: -Wall

28− -- other-modules:

2935 default-extensions: ConstraintKinds

3036 , DataKinds

3137 , DefaultSignatures

3238 , DeriveFunctor

3339 , DeriveFoldable

40+ , DeriveTraversable

3441 , DeriveGeneric

3542 , DeriveDataTypeable

3643 , FlexibleContexts

@@ -58,18 +65,24 @@ library

5865 , TypeOperators

5966 , TypeSynonymInstances

6067 , UndecidableInstances

61− build-depends: base >=4.9 && <4.10

68+ build-depends: base >=4.11 && <4.13

6269 , bytestring

6370 , aeson >= 1

64− , regex-compat

71+ , containers

72+ , hjsonschema

73+ , mtl

74+ , profunctors

75+ , regex-tdfa

76+ , regex-tdfa-text

6577 , scientific

66− , singletons

78+ , singletons >= 2.4

6779 , smallcheck

68− , smallcheck-series

6980 , tagged

81+ , template-haskell

7082 , text

83+ , union

7184 , unordered-containers

72− , validationt >= 0.1.0.1

85+ , validationt >= 0.2.1.0

7386 , vector

7487 , vinyl

7588 hs-source-dirs: src

@@ -80,50 +93,28 @@ test-suite spec

8093 hs-source-dirs: test

8194 main-is: Spec.hs

8295 default-language: Haskell2010

83− default-extensions: ConstraintKinds

84− , DataKinds

85− , DeriveFunctor

86− , DeriveFoldable

87− , DeriveGeneric

88− , DeriveDataTypeable

89− , FlexibleContexts

90− , FlexibleInstances

91− , FunctionalDependencies

92− , GADTs

93− , KindSignatures

94− , InstanceSigs

95− , MultiParamTypeClasses

96− , OverloadedLists

97− , OverloadedStrings

98− , PolyKinds

99− , QuasiQuotes

100− , PartialTypeSignatures

101− , RecordWildCards

102− , ScopedTypeVariables

103− , TemplateHaskell

104− , TypeApplications

105− , TypeFamilies

106− , TypeInType

107− , TypeOperators

108− , TypeSynonymInstances

10996 build-depends: HUnit

11097 , aeson >= 1

111− , base >=4.9 && <4.10

98+ , base >=4.11 && <4.13

11299 , bytestring

100+ , containers

101+ , hjsonschema

113102 , hspec >= 2.2.0

114103 , hspec-core

115104 , hspec-discover

116105 , hspec-smallcheck

117106 , lens

118− , regex-compat

107+ , regex-tdfa

108+ , regex-tdfa-text

119109 , schematic

120110 , smallcheck

121− , smallcheck-series

122111 , singletons

123112 , tagged

124113 , text

125114 , unordered-containers

126− , validationt >= 0.1.0.1

115+ , validationt >= 0.2.1.0

127116 , vinyl

128117 other-modules: SchemaSpec

129− , LensSpec

118+ , HelpersSpec

119+ , LensSpec

120+ , JsonSchemaSpec

src/Data/Schematic.hs+38−82

@@ -2,62 +2,43 @@

22{-# LANGUAGE AllowAmbiguousTypes #-}

44module Data.Schematic

5− ( module Data.Schematic.Schema

5+ ( module Data.Schematic.JsonSchema

6+ , module Data.Schematic.Helpers

67 , module Data.Schematic.Lens

78 , module Data.Schematic.Migration

8− , module Data.Schematic.Utils

9+ , module Data.Schematic.Schema

910 , decodeAndValidateJson

1011 , parseAndValidateJson

1112 , parseAndValidateJsonBy

12− , parseAndValidateVersionedJson

1313 , parseAndValidateTopVersionJson

14− , decodeAndValidateVersionedJson

1514 , parseAndValidateWithMList

1615 , decodeAndValidateVersionedWithMList

16+ , decodeAndValidateVersionedWithPureMList

1717 , isValid

1818 , isDecodingError

1919 , isValidationError

2020 , ParseResult(..)

21− , Migratable

21+ , withRepr

22+ , field

2223 ) where

2324

2425import Control.Monad.Validation

2526import Data.Aeson as J

2627import Data.Aeson.Types as J

2728import Data.ByteString.Lazy as BL

28−import Data.Functor.Identity

29+import Data.Functor.Identity as F

30+import Data.Schematic.DSL

31+import Data.Schematic.Helpers

32+import Data.Schematic.JsonSchema

2933import Data.Schematic.Lens

3034import Data.Schematic.Migration

3135import Data.Schematic.Schema

32−import Data.Schematic.Utils

3336import Data.Schematic.Validation

34−import Data.Singletons.Prelude

37+import Data.Singletons.Prelude hiding ((:.))

38+import Data.Tagged

3539import Data.Text as T

3640

3741

38−parseAndValidateJson

39− :: forall schema

40− . (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)

41− => J.Value

42− -> ParseResult (JsonRepr schema)

43−parseAndValidateJson v =

44− case parseEither parseJSON v of

45− Left s -> DecodingError $ T.pack s

46− Right jsonRepr ->

47− let

48− validate = validateJsonRepr (sing :: Sing schema) [] jsonRepr

49− res = runIdentity . runValidationTEither $ validate

50− in case res of

51− Left em -> ValidationError em

52− Right () -> Valid jsonRepr

53−

54−parseAndValidateJsonBy

55− :: (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)

56− => proxy schema

57− -> J.Value

58− -> ParseResult (JsonRepr schema)

59−parseAndValidateJsonBy _ = parseAndValidateJson

60−

6142parseAndValidateTopVersionJson

6243 :: forall proxy (v :: Versioned)

6344 . (SingI (TopVersion (AllVersions v)))

@@ -76,44 +57,23 @@ parseAndValidateTopVersionJson _ v =

7657 Left em -> ValidationError em

7758 Right () -> Valid jsonRepr

7859

79−class Migratable (revisions :: [(Revision, Schema)]) where

80− mparse

81− :: Sing revisions

82− -> J.Value

83− -> ParseResult (JsonRepr (Snd (Head revisions)))

84−

85−instance

86− {-# OVERLAPPING #-}

87− ( TopLevel (Snd rev), SingI (Snd rev) )

88− => Migratable '[rev] where

89− mparse _ = parseAndValidateJson

90−

91−instance {-# OVERLAPPABLE #-}

92− ( Migratable (Tail revisions)

93− , MigrateSchema (Snd (Head (Tail revisions))) (Snd (Head revisions))

94− , SingI (Snd (Head revisions)))

95− => Migratable revisions where

96− mparse s v = case parseEither parseJSON v of

97− Left _ ->

98− migrate <$> (mparse (sTail s) v :: ParseResult (JsonRepr (Snd (Head (Tail revisions)))))

99− Right x -> Valid x

100−

101−parseAndValidateVersionedJson

102− :: forall proxy v. (SingI (AllVersions v), Migratable (AllVersions v))

103− => proxy v

104− -> J.Value

105− -> ParseResult (JsonRepr (Snd (Head (AllVersions v))))

106−parseAndValidateVersionedJson _ v = mparse (sing :: Sing (AllVersions v)) v

107−

10860parseAndValidateWithMList

109− :: MList revisions

61+ :: Monad m

62+ => MList m revisions

11063 -> J.Value

111− -> ParseResult (JsonRepr (Head revisions))

112−parseAndValidateWithMList MNil v = parseAndValidateJson v

113−parseAndValidateWithMList ((:&&) p f tl) v = case parseAndValidateJsonBy p v of

114− Valid a -> Valid a

115− DecodingError _ -> f <$> parseAndValidateWithMList tl v

116− ValidationError _ -> f <$> parseAndValidateWithMList tl v

64+ -> m (ParseResult (JsonRepr (Head revisions)))

65+parseAndValidateWithMList MNil v = pure $ parseAndValidateJson v

66+parseAndValidateWithMList (Tagged f :&& tl) v =

67+ case parseAndValidateJsonBy Proxy v of

68+ Valid a -> pure $ Valid a

69+ DecodingError _ -> do

70+ pr <- parseAndValidateWithMList tl v

71+ let pr' = f <$> pr

72+ sequence pr'

73+ ValidationError _ -> do

74+ pr <- parseAndValidateWithMList tl v

75+ let pr' = f <$> pr

76+ sequence pr'

11777

11878decodeAndValidateJson

11979 :: forall schema

@@ -124,24 +84,20 @@ decodeAndValidateJson bs = case decode bs of

12484 Nothing -> DecodingError "malformed json"

12585 Just x -> parseAndValidateJson x

12686

127−decodeAndValidateVersionedJson

128− :: (Migratable (AllVersions versioned), SingI (AllVersions versioned))

87+decodeAndValidateVersionedWithMList

88+ :: Monad m

12989 => proxy versioned

90+ -> MList m (MapSnd (AllVersions versioned))

13091 -> BL.ByteString

131− -> ParseResult (JsonRepr (Snd (Head (AllVersions versioned))))

132−decodeAndValidateVersionedJson vp bs = case decode bs of

133− Nothing -> DecodingError "malformed json"

134− Just x -> parseAndValidateVersionedJson vp x

135−

136−type family MapSnd (l :: [(a,k)]) = (r :: [k]) where

137− MapSnd '[] = '[]

138− MapSnd ( '(a, b) ': tl) = b ': MapSnd tl

92+ -> m (ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned)))))

93+decodeAndValidateVersionedWithMList _ mlist bs = case decode bs of

94+ Nothing -> pure $ DecodingError "malformed json"

95+ Just x -> parseAndValidateWithMList mlist x

13996

140−decodeAndValidateVersionedWithMList

97+decodeAndValidateVersionedWithPureMList

14198 :: proxy versioned

142− -> MList (MapSnd (AllVersions versioned))

99+ -> MList F.Identity (MapSnd (AllVersions versioned))

143100 -> BL.ByteString

144101 -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))

145−decodeAndValidateVersionedWithMList _ mlist bs = case decode bs of

146− Nothing -> DecodingError "malformed json"

147− Just x -> parseAndValidateWithMList mlist x

102+decodeAndValidateVersionedWithPureMList a b c =

103+ runIdentity $ decodeAndValidateVersionedWithMList a b c

src/Data/Schematic/DSL.hsnew file+92

@@ -0,0 +1,92 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE CPP #-}

4+module Data.Schematic.DSL where

6+import Data.Kind

7+import Data.Schematic.Lens

8+import Data.Schematic.Schema

9+import Data.Scientific

10+import Data.Singletons

11+import Data.Singletons.Prelude hiding ((:.))

12+import Data.Singletons.TypeLits

13+import Data.Tagged

14+import Data.Text as T

15+import Data.Union

16+import qualified Data.Vector as V

17+import Data.Vinyl

18+import Data.Vinyl.Functor

19+

20+

21+#if MIN_VERSION_base(4,12,0)

22+type Constructor a

23+ = forall fields b

24+ . (fields ~ FieldsOf a, FSubset fields b (FImage fields b), RMap fields)

25+ => Rec (Tagged fields :. FieldRepr) b

26+ -> JsonRepr ('SchemaObject fields)

27+#else

28+type Constructor a

29+ = forall fields b

30+ . (fields ~ FieldsOf a, FSubset fields b (FImage fields b))

31+ => Rec (Tagged fields :. FieldRepr) b

32+ -> JsonRepr ('SchemaObject fields)

33+#endif

34+withRepr :: Constructor a

35+withRepr = ReprObject . rmap (unTagged . getCompose) . fcast

36+

37+class Representable s where

38+ constructField :: Sing fn -> Proxy s -> Repr s -> FieldRepr '(fn, s)

39+

40+instance SingI so => Representable ('SchemaObject so) where

41+ constructField sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprObject o

42+

43+instance (SingI cs, SingI sa) => Representable ('SchemaArray cs sa) where

44+ constructField sfn _ a = withKnownSymbol sfn $ FieldRepr $ ReprArray a

45+

46+instance SingI cs => Representable ('SchemaText cs) where

47+ constructField sfn _ t = withKnownSymbol sfn $ FieldRepr $ ReprText t

48+

49+instance SingI cs => Representable ('SchemaNumber cs) where

50+ constructField sfn _ n = withKnownSymbol sfn $ FieldRepr $ ReprNumber n

51+

52+instance Representable 'SchemaBoolean where

53+ constructField sfn _ b = withKnownSymbol sfn $ FieldRepr $ ReprBoolean b

54+

55+instance SingI so => Representable ('SchemaOptional so) where

56+ constructField sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprOptional o

57+

58+instance SingI (h ': tl) => Representable ('SchemaUnion (h ': tl)) where

59+ constructField sfn _ u = withKnownSymbol sfn $ FieldRepr $ ReprUnion u

60+

61+construct :: Sing s -> Repr s -> JsonRepr s

62+construct s r = case s of

63+ SSchemaObject _ -> ReprObject r

64+ SSchemaArray _ _ -> ReprArray r

65+ SSchemaText _ -> ReprText r

66+ SSchemaNumber _ -> ReprNumber r

67+ SSchemaBoolean -> ReprBoolean r

68+ SSchemaOptional _ -> ReprOptional r

69+ SSchemaNull -> ReprNull

70+ SSchemaUnion ss -> case ss of

71+ SNil -> error "unconstructable union"

72+ SCons _ _ -> ReprUnion r

73+

74+type family FieldsOf (s :: Schema) :: [(Symbol, Schema)] where

75+ FieldsOf ('SchemaObject fs) = fs

76+

77+type FieldConstructor fn =

78+ forall byField fs. (byField ~ ByField fn fs (FIndex fn fs), Representable byField)

79+ => Repr byField

80+ -> (Tagged fs :. FieldRepr) '(fn, byField)

81+

82+field :: forall fn. KnownSymbol fn => FieldConstructor fn

83+field = Compose . Tagged . constructField (sing :: Sing fn) Proxy

84+

85+type family Repr (s :: Schema) = (ty :: Type) where

86+ Repr ('SchemaObject so) = Rec FieldRepr so

87+ Repr ('SchemaArray cs sa) = V.Vector (JsonRepr sa)

88+ Repr ('SchemaText cs) = Text

89+ Repr ('SchemaNumber cs) = Scientific

90+ Repr 'SchemaBoolean = Bool

91+ Repr ('SchemaOptional so) = Maybe (JsonRepr so)

92+ Repr ('SchemaUnion (h ': tl)) = Union JsonRepr (h ': tl)

src/Data/Schematic/Generator.hsnew file+91

@@ -0,0 +1,91 @@

1+module Data.Schematic.Generator where

3+import Data.Maybe

4+import Data.Schematic.Generator.Regex

5+import {-# SOURCE #-} Data.Schematic.Schema

6+import Data.Schematic.Verifier

7+import Data.Scientific

8+import Data.Text (Text, pack)

9+import qualified Data.Vector as V

10+import Test.SmallCheck.Series

11+

12+maxHigh :: Int

13+maxHigh = 30

14+

15+minLow :: Int

16+minLow = 2

17+

18+textLengthSeries :: Monad m => [VerifiedTextConstraint] -> Series m Text

19+textLengthSeries =

20+ \case

21+ [VTEq eq] -> pure $ pack $ take (fromIntegral eq) $ cycle "sample"

22+ [VTBounds ml mh] -> do

23+ let

24+ l = fromMaybe minLow (fromIntegral <$> ml) + 1

25+ h = fromMaybe maxHigh (fromIntegral <$> mh) - 1

26+ n <- generate $ \depth -> take depth [l .. h]

27+ pure $ pack $ take (fromIntegral n) $ cycle "sample"

28+ _ -> pure "error"

29+

30+textEnumSeries :: Monad m => [Text] -> Series m Text

31+textEnumSeries enum = generate $ \depth -> take depth enum

32+

33+textSeries :: Monad m => [DemotedTextConstraint] -> Series m Text

34+textSeries cs = do

35+ let mvcs = verifyTextConstraints cs

36+ case mvcs of

37+ Just vcs -> do

38+ n <- textSeries' vcs

39+ pure n

40+ Nothing -> pure "error"

41+

42+textSeries' :: Monad m => [VerifiedTextConstraint] -> Series m Text

43+textSeries' [] = pure "sample"

44+textSeries' vcs = do

45+ let enums = listToMaybe [x | VTEnum x <- vcs]

46+ case enums of

47+ Just e -> textEnumSeries e

48+ Nothing -> do

49+ let regexps = listToMaybe [x | VTRegex x _ _ <- vcs]

50+ case regexps of

51+ Just e -> regexSeries e

52+ Nothing -> textLengthSeries vcs

53+

54+numberSeries :: Monad m => [DemotedNumberConstraint] -> Series m Scientific

55+numberSeries cs = do

56+ let mvcs = verifyNumberConstraints cs

57+ case mvcs of

58+ Just vcs -> do

59+ n <- numberSeries' vcs

60+ pure $ n

61+ Nothing -> pure 0

62+

63+numberSeries' :: Monad m => VerifiedNumberConstraint -> Series m Scientific

64+numberSeries' =

65+ \case

66+ VNEq eq -> pure $ fromIntegral eq

67+ VNBounds ml mh -> do

68+ let l = fromMaybe minLow (fromIntegral <$> ml) + 1

69+ h = fromMaybe maxHigh (fromIntegral <$> mh) - 1

70+ n <- generate $ \depth -> take depth [l .. h]

71+ pure $ fromIntegral n

72+

73+arraySeries

74+ :: (Monad m, Serial m (JsonRepr s))

75+ => [DemotedArrayConstraint]

76+ -> Series m (V.Vector (JsonRepr s))

77+arraySeries cs = do

78+ let mvcs = verifyArrayConstraint cs

79+ case mvcs of

80+ Just vcs -> arraySeries' vcs

81+ Nothing -> pure V.empty

82+

83+arraySeries'

84+ :: forall m s. (Monad m, Serial m (JsonRepr s))

85+ => Maybe VerifiedArrayConstraint

86+ -> Series m (V.Vector (JsonRepr s))

87+arraySeries' ml = do

88+ objs <- V.replicateM (maybe minRepeat f ml) (series :: Series m (JsonRepr s))

89+ pure $ objs

90+ where

91+ f (VAEq l) = fromIntegral l

src/Data/Schematic/Generator/Regex.hsnew file+76

@@ -0,0 +1,76 @@

1+module Data.Schematic.Generator.Regex where

3+import Control.Monad

4+import Data.List

5+import Data.Maybe

6+import qualified Data.Set as S

7+import Data.Text (Text, unpack)

8+import Data.Text.Lazy (toStrict)

9+import Data.Text.Lazy.Builder (Builder, singleton, toLazyText)

10+import Test.SmallCheck.Series

11+import Text.Regex.TDFA.Pattern

12+import Text.Regex.TDFA.ReadRegex (parseRegex)

13+

14+

15+minRepeat :: Int

16+minRepeat = 2

17+

18+maxRepeat :: Int

19+maxRepeat = 10

20+

21+regexSeries :: (Monad m) => Text -> Series m Text

22+regexSeries regexp =

23+ case parseRegex . unpack $ regexp of

24+ Right (p, _) -> toStrict . toLazyText <$> regexSeries' p

25+ Left _ -> pure ""

26+

27+regexSeries' :: (Monad m) => Pattern -> Series m Builder

28+regexSeries' pt =

29+ case pt of

30+ PEmpty -> pure mempty

31+ PChar {..} -> pure $ singleton getPatternChar

32+ PAny {getPatternSet = PatternSet (Just cset) _ _ _} -> do

33+ x <- generate $ \depth -> take depth $ S.toList cset

34+ pure $ singleton x

35+ PAnyNot {getPatternSet = PatternSet (Just cset) _ _ _} -> do

36+ x <-

37+ generate $ \depth ->

38+ take depth $ notChars $ concatMap expandEscape $ S.toList cset

39+ pure $ singleton x

40+ PQuest p -> regexSeries' p \/ pure mempty

41+ PPlus p -> regexSeries' $ PBound 1 Nothing p

42+ PStar _ p -> regexSeries' $ PBound 0 Nothing p

43+ PBound low mhigh p -> do

44+ let high = fromMaybe (low + maxRepeat) mhigh

45+ n <- generate $ \depth -> take depth [low .. high]

46+ decDepth $ do

47+ ps <- replicateM n $ regexSeries' p

48+ pure $ mconcat ps

49+ PConcat ps -> mconcat <$> mapM regexSeries' ps

50+ POr xs -> regexSeries' =<< (generate $ \depth -> take depth xs)

51+ PDot _ -> do

52+ x <- generate $ \depth -> take depth $ notChars []

53+ pure $ singleton x

54+ PEscape {..} -> do

55+ x <- generate $ \depth -> take depth $ expandEscape getPatternChar

56+ pure $ singleton x

57+ PCarat _ -> pure mempty

58+ PDollar _ -> pure mempty

59+ _ -> pure mempty

60+ where

61+ notChars = ([' ' .. '~'] \\)

62+ expandEscape ch =

63+ case ch of

64+ 'n' -> "\n"

65+ 't' -> "\t"

66+ 'r' -> "\r"

67+ 'f' -> "\f"

68+ 'a' -> "\a"

69+ 'e' -> "\ESC"

70+ 'd' -> ['0' .. '9']

71+ 'w' -> ['0' .. '9'] ++ '_' : ['a' .. 'z'] ++ ['A' .. 'Z']

72+ 's' -> "\9\32"

73+ 'D' -> notChars $ ['0' .. '9']

74+ 'W' -> notChars $ ['0' .. '9'] ++ '_' : ['a' .. 'z'] ++ ['A' .. 'Z']

75+ 'S' -> notChars "\9\32"

76+ ch' -> [ch']

src/Data/Schematic/Helpers.hsnew file+59

@@ -0,0 +1,59 @@

1+module Data.Schematic.Helpers where

3+import Data.Schematic.Schema

4+import GHC.TypeLits

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}"

10+type IsUUID = '[UUIDRegex]

11+

12+-- [ "1985-04-12T23:20:50.52Z"

13+-- , "1996-12-19T16:39:57-08:00"

14+-- , "1990-12-31T23:59:60Z"

15+-- , "1990-12-31T15:59:60-08:00"

16+-- , "1937-01-01T12:00:27.87+00:20"

17+-- ]

18+

19+-- components

20+type ISO8601Date = "[1-9][0-9]{3}-(0[1-9]|1[0-2])-([0-2][0-9]|3[0-1])"

21+

22+type ISO8601Time = "([0-1][0-9]|2[0-3]):[0-5][0-9]:[0-5][0-9]"

23+

24+type ISO8601DateTime =

25+ AppendSymbol

26+ ISO8601Date

27+ (AppendSymbol "(T" (AppendSymbol ISO8601Time ")?"))

28+

29+type ISO8601UTC = "(Z|\\+00:00)"

30+

31+type ISO8601DateTimeUTC =

32+ AppendSymbol ISO8601Date (AppendSymbol "T" (AppendSymbol ISO8601Time ISO8601UTC))

33+

34+type ISO8601TZ = "\\+[0-1][0-9]:[0-6][0-9]"

35+

36+type ISO8601DateTimeZoned =

37+ AppendSymbol ISO8601Date (AppendSymbol "T" (AppendSymbol ISO8601Time ISO8601TZ))

38+

39+-- regexes

40+type ISO8601DateRegex = 'TRegex ISO8601Date

41+

42+type ISO8601TimeRegex = 'TRegex ISO8601Time

43+

44+type ISO8601DateTimeRegex = 'TRegex ISO8601DateTime

45+

46+type ISO8601DateTimeRegexUTC = 'TRegex ISO8601DateTimeUTC

47+

48+type ISO8601DateTimeRegexZoned = 'TRegex ISO8601DateTimeZoned

49+

50+-- constraints

51+type IsDate = '[ISO8601DateRegex]

52+

53+type IsTime = '[ISO8601TimeRegex]

54+

55+type IsDateTime = '[ISO8601DateTimeRegex]

56+

57+type IsZonedDateTime = '[ISO8601DateTimeRegexZoned]

58+

59+type IsUTCDateTime = '[ISO8601DateTimeRegexUTC]

src/Data/Schematic/Instances.hs+4

@@ -4,6 +4,7 @@

44module Data.Schematic.Instances where

66import Data.Scientific

7+import Data.Text (Text, pack)

78import Data.Vector as V

89import Data.Vinyl

910import Test.SmallCheck.Series

@@ -21,3 +22,6 @@ instance Serial m a => Serial m (V.Vector a) where

2122

2223instance Monad m => Serial m Scientific where

2324 series = scientific <$> series <*> series

25+

26+instance Monad m => Serial m Text where

27+ series = pack <$> series

src/Data/Schematic/JsonSchema.hsnew file+124

@@ -0,0 +1,124 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE RecordWildCards #-}

3+{-# LANGUAGE OverloadedLabels #-}

4+{-# LANGUAGE TemplateHaskell #-}

6+module Data.Schematic.JsonSchema

7+ ( toJsonSchema

8+ , toJsonSchema'

9+ ) where

10+

11+import Control.Monad.State.Strict

12+import Data.Aeson as J

13+import Data.Foldable as F

14+import Data.HashMap.Strict as H

15+import Data.List as L

16+import Data.List.NonEmpty as NE

17+import Data.Schematic.Schema as S

18+import Data.Set as Set

19+import Data.Singletons

20+import Data.Text

21+import Data.Traversable

22+import JSONSchema.Draft4.Schema as D4

23+import JSONSchema.Validator.Draft4 as D4

24+

25+

26+draft4 :: Text

27+draft4 = "http://json-schema.org/draft-04/schema#"

28+

29+textConstraint :: DemotedTextConstraint -> State D4.Schema ()

30+textConstraint (DTEq n) = modify $ \s -> s

31+ { _schemaMinLength = pure $ fromIntegral n

32+ , _schemaMaxLength = pure $ fromIntegral n }

33+textConstraint (DTLe n) = modify $ \s -> s

34+ { _schemaMaxLength = pure . fromIntegral $ n }

35+textConstraint (DTLt n) =

36+ let n' = if n == 0 then 0 else n - 1

37+ in modify $ \s -> s { _schemaMaxLength = pure . fromIntegral $ n' }

38+textConstraint (DTGt n) = modify $ \s -> s

39+ { _schemaMinLength = pure . fromIntegral $ n + 1 }

40+textConstraint (DTGe n) = modify $ \s -> s

41+ { _schemaMinLength = pure . fromIntegral $ n }

42+textConstraint (DTRegex r) = modify $ \s -> s { _schemaPattern = pure r }

43+textConstraint (DTEnum ss) =

44+ let ss' = if F.length ss == 0 then [] else NE.fromList $ J.String <$> ss

45+ in modify $ \s -> s { _schemaEnum = pure ss' }

46+

47+numberConstraint :: DemotedNumberConstraint -> State D4.Schema ()

48+numberConstraint (DNLe n) = modify $ \s -> s

49+ { _schemaMaximum = pure . fromIntegral $ n }

50+numberConstraint (DNLt n) = modify $ \s -> s

51+ { _schemaMaximum = pure . fromIntegral $ n

52+ , _schemaExclusiveMaximum = pure True }

53+numberConstraint (DNGt n) = modify $ \s -> s

54+ { _schemaMinimum = pure . fromIntegral $ n

55+ , _schemaExclusiveMinimum = pure True }

56+numberConstraint (DNGe n) = modify $ \s -> s

57+ { _schemaMinimum = pure . fromIntegral $ n }

58+numberConstraint (DNEq n) = modify $ \s -> s

59+ { _schemaMinimum = pure $ fromIntegral n

60+ , _schemaMaximum = pure $ fromIntegral n }

61+

62+arrayConstraint :: DemotedArrayConstraint -> State D4.Schema ()

63+arrayConstraint (DALe n) = modify $ \s -> s

64+ { _schemaMaxItems = pure . fromIntegral $ n }

65+arrayConstraint (DALt n) =

66+ let n' = if n == 0 then 0 else n - 1

67+ in modify $ \s -> s { _schemaMaxItems = pure . fromIntegral $ n' }

68+arrayConstraint (DAGt n) = modify $ \s -> s

69+ { _schemaMinItems = pure . fromIntegral $ n + 1 }

70+arrayConstraint (DAGe n) = modify $ \s -> s

71+ { _schemaMinItems = pure . fromIntegral $ n }

72+arrayConstraint (DAEq n) = modify $ \s -> s

73+ { _schemaMinItems = pure $ fromIntegral n

74+ , _schemaMaxItems = pure $ fromIntegral n }

75+

76+toJsonSchema

77+ :: forall proxy schema

78+ . SingI schema

79+ => proxy (schema :: S.Schema)

80+ -> Maybe D4.Schema

81+toJsonSchema _ = do

82+ js <- toJsonSchema' $ fromSing (sing :: Sing schema)

83+ pure $ js { _schemaVersion = pure draft4 }

84+

85+toJsonSchema'

86+ :: DemotedSchema

87+ -> Maybe D4.Schema

88+toJsonSchema' = \case

89+ DSchemaText tcs ->

90+ pure $ execState (traverse_ textConstraint tcs) $ emptySchema

91+ { _schemaType = pure $ TypeValidatorString D4.SchemaString }

92+ DSchemaNumber ncs ->

93+ pure $ execState (traverse_ numberConstraint ncs) $ emptySchema

94+ { _schemaType = pure $ TypeValidatorString D4.SchemaNumber }

95+ DSchemaBoolean -> pure $ emptySchema

96+ { _schemaType = pure $ TypeValidatorString D4.SchemaBoolean }

97+ DSchemaObject objs -> do

98+ res <- for objs $ \(n,s) -> do

99+ s' <- toJsonSchema' s

100+ pure (n, s')

101+ let

102+ nonOpt = \case

103+ (_, DSchemaOptional _) -> False

104+ _ -> True

105+ pure $ emptySchema

106+ { _schemaType = pure $ TypeValidatorString D4.SchemaObject

107+ , _schemaRequired = pure $ Set.fromList $ fst <$> L.filter nonOpt objs

108+ , _schemaProperties = pure $ H.fromList res }

109+ DSchemaArray acs sch -> do

110+ res <- toJsonSchema' sch

111+ pure $ execState (traverse_ arrayConstraint acs) $ emptySchema

112+ { _schemaType = pure $ TypeValidatorString D4.SchemaArray

113+ , _schemaItems = pure $ ItemsObject res }

114+ DSchemaNull -> pure $ emptySchema

115+ { _schemaType = pure $ TypeValidatorString D4.SchemaNull }

116+ DSchemaOptional sch -> do

117+ snull <- toJsonSchema' DSchemaNull

118+ sres <- toJsonSchema' sch

119+ pure $ emptySchema { _schemaOneOf = pure (snull :| [sres]) }

120+ DSchemaUnion sch -> do

121+ schemaUnion <- traverse toJsonSchema' sch >>= \case

122+ [] -> Nothing

123+ x -> Just x

124+ pure $ emptySchema { _schemaAnyOf = pure $ NE.fromList schemaUnion }

src/Data/Schematic/Lens.hs+168−27

@@ -3,64 +3,205 @@

33{-# LANGUAGE AllowAmbiguousTypes #-}

44{-# LANGUAGE InstanceSigs #-}

6−module Data.Schematic.Lens where

6+module Data.Schematic.Lens

7+ ( FIndex

8+ , FElem(..)

9+ , FImage

10+ , FSubset(..)

11+ , obj

12+ , arr

13+ , uni

14+ , txt

15+ , num

16+ , opt

17+ , bln

18+ , textRepr

19+ , numberRepr

20+ , boolRepr

21+ , arrayRepr

22+ , objectRepr

23+ , optionalRepr

24+ ) where

725

8−import Data.Proxy

26+import Data.Profunctor

927import Data.Schematic.Schema

28+import Data.Scientific

29+import Data.Singletons

30+import Data.Text

31+import Data.Union

32+import Data.Vector as V

1033import Data.Vinyl

1134import Data.Vinyl.Functor

1235import Data.Vinyl.TypeLevel (Nat(..))

13−import GHC.TypeLits (Symbol)

36+import GHC.TypeLits (Symbol, KnownSymbol)

1437

1538

1639-- | A partial relation that gives the index of a value in a list.

1740type family FIndex (r :: Symbol) (rs :: [(Symbol, Schema)]) :: Nat where

18− FIndex r ( '(fn, s) ': rs) = 'Z

19− FIndex r ( s ': rs) = 'S (FIndex r rs)

41+ FIndex r ( '(r, s) ': rs) = 'Z

42+ FIndex r ( s ': rs) = 'S (FIndex r rs)

43+

44+type Flens fn f g rs i

45+ = Functor g

46+ => (f '(fn, (ByField fn rs i)) -> g (f '(fn, (ByField fn rs i))))

47+ -> Rec f rs

48+ -> g (Rec f rs)

49+

50+type FGetter fn f rs i = Rec f rs -> f '(fn, (ByField fn rs i))

2051

2152class i ~ FIndex fn rs => FElem (fn :: Symbol) (rs :: [(Symbol, Schema)]) (i :: Nat) where

22− type ByRevision fn rs i :: Schema

23− flens

24− :: Functor g

25− => proxy fn

26− -> (FieldRepr '(fn, (ByRevision fn rs i)) -> g (FieldRepr '(fn, (ByRevision fn rs i))))

27− -> Rec FieldRepr rs

28− -> g (Rec FieldRepr rs)

53+ type ByField fn rs i :: Schema

54+ flens :: Flens fn f g rs i

2955

3056 -- | For Vinyl users who are not using the @lens@ package, we provide a getter.

31− fget

32− :: proxy fn

33− -> Rec FieldRepr rs

34− -> FieldRepr '(fn, (ByRevision fn rs i))

57+ fget :: FGetter fn f rs i

3558

3659 -- | For Vinyl users who are not using the @lens@ package, we also provide a

3760 -- setter. In general, it will be unambiguous what field is being written to,

3861 -- and so we do not take a proxy argument here.

3962 fput

40− :: FieldRepr '(fn, ByRevision fn rs i)

41− -> Rec FieldRepr rs

42− -> Rec FieldRepr rs

63+ :: f '(fn, ByField fn rs i)

64+ -> Rec f rs

65+ -> Rec f rs

4366

4467instance FElem fn ('(fn, r) ': rs) 'Z where

45− type ByRevision fn ('(fn, r) ': rs) 'Z = r

68+ type ByField fn ('(fn, r) ': rs) 'Z = r

4669

47− flens _ f (x :& xs) = fmap (:& xs) (f x)

70+ flens f (x :& xs) = fmap (:& xs) (f x)

4871 {-# INLINE flens #-}

4972

50− fget k = getConst . flens k Const

73+ fget = getConst . flens Const

5174 {-# INLINE fget #-}

5275

53− fput y = getIdentity . flens Proxy (\_ -> Identity y)

76+ fput y = getIdentity . flens (\_ -> Identity y)

5477 {-# INLINE fput #-}

5578

5679instance (FIndex r (s ': rs) ~ 'S i, FElem r rs i) => FElem r (s ': rs) ('S i) where

57− type ByRevision fn (s ': rs) ('S i) = ByRevision fn rs i

80+ type ByField r (s ': rs) ('S i) = ByField r rs i

5881

59− flens p f (x :& xs) = fmap (x :&) (flens p f xs)

82+ flens f (x :& xs) = fmap (x :&) (flens f xs)

6083 {-# INLINE flens #-}

6184

62− fget k = getConst . flens k Const

85+ fget = getConst . flens Const

6386 {-# INLINE fget #-}

6487

65− fput y = getIdentity . flens Proxy (\_ -> Identity y)

88+ fput y = getIdentity . flens (\_ -> Identity y)

6689 {-# INLINE fput #-}

90+

91+-- This is an internal convenience helpers stolen from the @lens@ library.

92+lens

93+ :: Functor f

94+ => (t -> s)

95+ -> (t -> a -> b)

96+ -> (s -> f a)

97+ -> t

98+ -> f b

99+lens sa sbt afb s = fmap (sbt s) $ afb (sa s)

100+{-# INLINE lens #-}

101+

102+type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)

103+

104+type Iso' s a = Iso s s a a

105+

106+iso

107+ :: (s -> a) -> (b -> t)

108+ -> Iso s t a b

109+iso sa bt = dimap sa (fmap bt)

110+{-# INLINE iso #-}

111+

112+-- | A partial relation that gives the indices of a sublist in a larger list.

113+type family FImage (rs :: [(Symbol, Schema)]) (ss :: [(Symbol, Schema)]) :: [Nat] where

114+ FImage '[] ss = '[]

115+ FImage ('(fn,s) ': rs) ss = FIndex fn ss ': FImage rs ss

116+

117+class is ~ FImage rs ss

118+ => FSubset (rs :: [(Symbol, Schema)]) (ss :: [(Symbol, Schema)]) is where

119+ -- | This is a lens into a slice of the larger record. Morally, we have:

120+ --

121+ -- > fsubset :: Lens' (Rec FieldRepr ss) (Rec FieldRepr rs)

122+ fsubset

123+ :: Functor g

124+ => (Rec f rs -> g (Rec f rs))

125+ -> Rec f ss

126+ -> g (Rec f ss)

127+

128+ -- | The getter of the 'fsubset' lens is 'fcast', which takes a larger record

129+ -- to a smaller one by forgetting fields.

130+ fcast

131+ :: Rec f ss

132+ -> Rec f rs

133+ fcast = getConst . fsubset Const

134+ {-# INLINE fcast #-}

135+

136+ -- | The setter of the 'fsubset' lens is 'freplace', which allows a slice of

137+ -- a record to be replaced with different values.

138+ freplace

139+ :: Rec f rs

140+ -> Rec f ss

141+ -> Rec f ss

142+ freplace rs = getIdentity . fsubset (\_ -> Identity rs)

143+ {-# INLINE freplace #-}

144+

145+instance FSubset '[] ss '[] where

146+ fsubset = lens (const RNil) const

147+

148+instance

149+ ( ByField fn ss i ~ s

150+ , FElem fn ss i

151+ , FSubset rs ss is) => FSubset ( '(fn,s) ': rs) ss (i ': is) where

152+ fsubset = lens (\ss -> fget @fn ss :& fcast ss) set

153+ where

154+ set :: Rec f ss -> Rec f ( '(fn,s) ': rs) -> Rec f ss

155+ set ss (r :& rs) = fput r $ freplace rs ss

156+

157+-- A bunch of @Iso@morphisms

158+textRepr

159+ :: (KnownSymbol fn, SingI cs)

160+ => Iso' (FieldRepr '(fn, ('SchemaText cs))) Text

161+textRepr = iso (\(FieldRepr (ReprText t)) -> t) (FieldRepr . ReprText)

162+

163+numberRepr

164+ :: (KnownSymbol fn, SingI cs)

165+ => Iso' (FieldRepr '(fn, ('SchemaNumber cs))) Scientific

166+numberRepr = iso (\(FieldRepr (ReprNumber n)) -> n) (FieldRepr . ReprNumber)

167+

168+boolRepr

169+ :: (KnownSymbol fn)

170+ => Iso' (FieldRepr '(fn, 'SchemaBoolean)) Bool

171+boolRepr = iso (\(FieldRepr (ReprBoolean b)) -> b) (FieldRepr . ReprBoolean)

172+

173+arrayRepr

174+ :: (KnownSymbol fn, SingI cs, SingI schema)

175+ => Iso' (FieldRepr '(fn, ('SchemaArray cs schema))) (V.Vector (JsonRepr schema))

176+arrayRepr = iso (\(FieldRepr (ReprArray a)) -> a) (FieldRepr . ReprArray)

177+

178+objectRepr

179+ :: (KnownSymbol fn, SingI fields)

180+ => Iso' (FieldRepr '(fn, ('SchemaObject fields))) (Rec FieldRepr fields)

181+objectRepr = iso (\(FieldRepr (ReprObject o)) -> o) (FieldRepr . ReprObject)

182+

183+optionalRepr

184+ :: (KnownSymbol fn, SingI schema)

185+ => Iso' (FieldRepr '(fn, ('SchemaOptional schema))) (Maybe (JsonRepr schema))

186+optionalRepr = iso (\(FieldRepr (ReprOptional r)) -> r) (FieldRepr . ReprOptional)

187+

188+obj :: Iso' (JsonRepr ('SchemaObject fields)) (Rec FieldRepr fields)

189+obj = iso (\(ReprObject r) -> r) ReprObject

190+

191+arr :: Iso' (JsonRepr ('SchemaArray cs schema)) (V.Vector (JsonRepr schema))

192+arr = iso (\(ReprArray r) -> r) ReprArray

193+

194+uni :: Iso' (JsonRepr ('SchemaUnion (h ': tl))) (Union JsonRepr (h ': tl))

195+uni = iso (\(ReprUnion u) -> u) ReprUnion

196+

197+txt :: Iso' (JsonRepr ('SchemaText cs)) Text

198+txt = iso (\(ReprText t) -> t) ReprText

199+

200+num :: Iso' (JsonRepr ('SchemaNumber cs)) Scientific

201+num = iso (\(ReprNumber t) -> t) ReprNumber

202+

203+bln :: Iso' (JsonRepr 'SchemaBoolean) Bool

204+bln = iso (\(ReprBoolean b) -> b) ReprBoolean

205+

206+opt :: Iso' (JsonRepr ('SchemaOptional schema)) (Maybe (JsonRepr schema))

207+opt = iso (\(ReprOptional o) -> o) ReprOptional

src/Data/Schematic/Migration.hs+48−14

@@ -1,13 +1,19 @@

11{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE TemplateHaskell #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE TemplateHaskell #-}

45module Data.Schematic.Migration where

67import Data.Kind

8+import Data.Schematic.DSL

9+import Data.Schematic.Lens

710import Data.Schematic.Path

811import Data.Schematic.Schema

9−import Data.Singletons.Prelude hiding (All)

12+import Data.Singletons.Prelude hiding ((:.), All)

1013import Data.Singletons.TypeLits

14+import Data.Tagged

15+import Data.Vinyl

16+import Data.Vinyl.Functor

1117

1218

1319data Path

@@ -37,8 +43,8 @@ type family SchemaByKey (fs :: [(Symbol, Schema)]) (s :: Symbol) :: Schema where

3743 SchemaByKey ( '(a, s) ': tl) fn = SchemaByKey tl fn

3844

3945type family DeleteKey (acc :: [(Symbol, Schema)]) (fn :: Symbol) (fs :: [(Symbol, Schema)]) :: [(Symbol, Schema)] where

40− DeleteKey acc fn ('(fn, a) ': tl) = acc :++ tl

41− DeleteKey acc fn (fna ': tl) = acc :++ (fna ': tl)

46+ DeleteKey acc fn ('(fn, a) ': tl) = acc ++ tl

47+ DeleteKey acc fn (fna ': tl) = acc ++ (fna ': tl)

4248

4349type family UpdateKey

4450 (fn :: Symbol)

@@ -91,7 +97,8 @@ type family ElemOf (e :: k) (l :: [(a,k)]) :: Constraint where

9197type family AllVersions (vd :: Versioned) :: [(Revision, Schema)] where

9298 AllVersions ('Versioned s ms) = Reverse (AllVersions' '[ '("initial", s) ] ms)

9399

94−type family AllVersions' (acc :: [(Revision, Schema)]) (ms :: [Migration]) = (r :: [(Revision, Schema)]) where

100+type family AllVersions' (acc :: [(Revision, Schema)]) (ms :: [Migration])

101+ = (r :: [(Revision, Schema)]) where

95102 AllVersions' acc '[] = acc

96103 AllVersions' ( '(rh, sh) ': tl ) (m ': ms) =

97104 AllVersions' ( '(rh, sh) ': ApplyMigration m sh ': tl ) ms

@@ -99,9 +106,6 @@ type family AllVersions' (acc :: [(Revision, Schema)]) (ms :: [Migration]) = (r

99106type family TopVersion (rs :: [(Revision, Schema)]) :: Schema where

100107 TopVersion ( '(rh, sh) ': tl) = sh

101108

102−class MigrateSchema (a :: Schema) (b :: Schema) where

103− migrate :: JsonRepr a -> JsonRepr b

104−

105109data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol

106110

107111data instance Sing (a :: Action) where

@@ -141,13 +145,43 @@ data instance Sing (v :: Versioned) where

141145 -> Sing (ms :: [Migration]) -- a bunch of migrations

142146 -> Sing ('Versioned s ms)

143147

144−data MList :: [Schema] -> Type where

145− MNil :: (SingI s, TopLevel s) => MList '[s]

148+type DataMigration s m h = Tagged s (JsonRepr h -> m (JsonRepr s))

149+

150+data MList :: (Type -> Type) -> [Schema] -> Type where

151+ MNil :: (Monad m, SingI s, TopLevel s) => MList m '[s]

146152 (:&&)

147153 :: (TopLevel s, SingI s)

148− => proxy s

149− -> (JsonRepr h -> JsonRepr s)

150− -> MList (h ': tl)

151− -> MList (s ': h ': tl)

154+ => DataMigration s m h

155+ -> MList m (h ': tl)

156+ -> MList m (s ': h ': tl)

152157

153158infixr 7 :&&

159+

160+#if MIN_VERSION_base(4,12,0)

161+migrateObject

162+ :: forall m fs fh. (FSubset fs fs (FImage fs fs), Monad m, RMap fh, RMap fs)

163+ => (Rec (Tagged fs :. FieldRepr) fh -> m (Rec (Tagged fs :. FieldRepr) fs))

164+ -> Tagged ('SchemaObject fs) (JsonRepr ('SchemaObject fh) -> m (JsonRepr ('SchemaObject fs)))

165+#else

166+migrateObject

167+ :: forall m fs fh. (FSubset fs fs (FImage fs fs), Monad m)

168+ => (Rec (Tagged fs :. FieldRepr) fh -> m (Rec (Tagged fs :. FieldRepr) fs))

169+ -> Tagged ('SchemaObject fs) (JsonRepr ('SchemaObject fh) -> m (JsonRepr ('SchemaObject fs)))

170+#endif

171+migrateObject f = Tagged $ \(ReprObject r) -> do

172+ res <- f $ rmap (Compose . Tagged) r

173+ pure $ withRepr @('SchemaObject fs) res

174+

175+shrinkObject

176+ :: forall rs ss m

177+ . ( Monad m, FSubset rs ss (FImage rs ss) )

178+ => Tagged

179+ ('SchemaObject rs)

180+ (JsonRepr ('SchemaObject ss) -> m (JsonRepr ('SchemaObject rs)))

181+shrinkObject = Tagged $ \(ReprObject r) -> pure $ ReprObject $ fcast r

182+

183+type family MapSnd (l :: [(a,k)]) = (r :: [k]) where

184+ MapSnd '[] = '[]

185+ MapSnd ( '(a, b) ': tl) = b ': MapSnd tl

186+

187+type MigrationList m vs = MList m (MapSnd (AllVersions vs))

src/Data/Schematic/Path.hs+6−17

@@ -1,9 +1,6 @@

11module Data.Schematic.Path where

33import Data.Foldable as F

4−import Data.Monoid

5−import Data.Schematic.Utils

6−import Data.Singletons

74import Data.Singletons.Prelude

85import Data.Singletons.TypeLits

96import Data.Text as T

@@ -12,16 +9,8 @@ import Data.Text as T

129data PathSegment = Key Symbol | Ix Nat

1310

1411data instance Sing (jp :: PathSegment) where

15− SKey :: (KnownSymbol k, Known (Sing k)) => Sing (k :: Symbol) -> Sing ('Key k)

16− SIx :: (KnownNat n, Known (Sing n)) => Sing (n :: Nat) -> Sing ('Ix n)

17−

18−instance (KnownSymbol k, Known (Sing k))

19− => Known (Sing ('Key k)) where

20− known = SKey known

21−

22−instance (KnownNat n, Known (Sing n))

23− => Known (Sing ('Ix n)) where

24− known = SIx known

12+ SKey :: (SingI k) => Sing (k :: Symbol) -> Sing ('Key k)

13+ SIx :: (SingI n) => Sing (n :: Nat) -> Sing ('Ix n)

2514

2615data DemotedPathSegment = DKey Text | DIx Integer

2716 deriving (Show)

@@ -35,10 +24,10 @@ demotePath = go []

3524 where

3625 go :: [DemotedPathSegment] -> Sing (ps :: [PathSegment]) -> [DemotedPathSegment]

3726 go acc SNil = acc

38− go acc (SCons p ps) = go (acc ++ [demote p]) ps

39− demote :: Sing (ps :: PathSegment) -> DemotedPathSegment

40− demote (SKey s) = DKey $ T.pack $ symbolVal s

41− demote (SIx n) = DIx $ natVal n

27+ go acc (SCons p ps) = go (acc ++ [demotePathSeg p]) ps

28+ demotePathSeg :: Sing (ps :: PathSegment) -> DemotedPathSegment

29+ demotePathSeg (SKey s) = DKey $ T.pack $ withKnownSymbol s $ symbolVal s

30+ demotePathSeg (SIx n) = DIx $ withKnownNat n $ fromIntegral $ natVal n

4231

4332demotedPathToText :: [DemotedPathSegment] -> JSONPath

4433demotedPathToText = JSONPath . F.foldl' renderPathSegment ""

src/Data/Schematic/Schema.hs+330−39

@@ -1,35 +1,37 @@

11{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE OverloadedLists #-}

3−{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE OverloadedLists #-}

4+{-# LANGUAGE OverloadedStrings #-}

45{-# OPTIONS_GHC -fprint-explicit-kinds #-}

67module Data.Schematic.Schema where

8−import Control.Applicative ()

9+import Control.Applicative ((<|>))

910import Control.Monad

1011import Data.Aeson as J

1112import Data.Aeson.Types as J

1213import Data.HashMap.Strict as H

1314import Data.Kind

1415import Data.Maybe

16+import Data.Schematic.Generator

1517import Data.Schematic.Instances ()

1618import Data.Scientific

17−import Data.Singletons.Prelude.List hiding (All)

19+import Data.Singletons.Prelude.List hiding (All, Union)

1820import Data.Singletons.TH

1921import Data.Singletons.TypeLits

2022import Data.Text as T

23+import Data.Union

2124import Data.Vector as V

2225import Data.Vinyl hiding (Dict)

2326import qualified Data.Vinyl.TypeLevel as V

27+import GHC.Exts

2428import GHC.Generics (Generic)

29+import GHC.TypeLits

30+ (SomeNat(..), SomeSymbol(..), someNatVal, someSymbolVal)

2531import Prelude as P

2632import Test.SmallCheck.Series

2733

2834

29−type family All (c :: k -> Constraint) (s :: [k]) :: Constraint where

30− All c '[] = ()

31− All c (a ': as) = (c a, All c as)

32−

3335type family CRepr (s :: Schema) :: Type where

3436 CRepr ('SchemaText cs) = TextConstraint

3537 CRepr ('SchemaNumber cs) = NumberConstraint

@@ -38,77 +40,235 @@ type family CRepr (s :: Schema) :: Type where

3840

3941data TextConstraint

4042 = TEq Nat

43+ | TLt Nat

4144 | TLe Nat

4245 | TGt Nat

46+ | TGe Nat

4347 | TRegex Symbol

4448 | TEnum [Symbol]

4549 deriving (Generic)

4650

51+instance SingKind TextConstraint where

52+ type Demote TextConstraint = DemotedTextConstraint

53+ fromSing = \case

54+ STEq n -> withKnownNat n (DTEq . fromIntegral $ natVal n)

55+ STLt n -> withKnownNat n (DTLt . fromIntegral $ natVal n)

56+ STLe n -> withKnownNat n (DTLe . fromIntegral $ natVal n)

57+ STGt n -> withKnownNat n (DTGt . fromIntegral $ natVal n)

58+ STGe n -> withKnownNat n (DTGe . fromIntegral $ natVal n)

59+ STRegex s -> withKnownSymbol s (DTRegex $ T.pack $ symbolVal s)

60+ STEnum s -> let

61+ d :: Sing (s :: [Symbol]) -> [Text]

62+ d SNil = []

63+ d (SCons ss@SSym fs) = T.pack (symbolVal ss) : d fs

64+ in DTEnum $ d s

65+ toSing = \case

66+ DTEq n -> case someNatVal n of

67+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (STEq (SNat :: Sing n))

68+ Nothing -> error "Negative singleton nat"

69+ DTLt n -> case someNatVal n of

70+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLt (SNat :: Sing n))

71+ Nothing -> error "Negative singleton nat"

72+ DTLe n -> case someNatVal n of

73+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLe (SNat :: Sing n))

74+ Nothing -> error "Negative singleton nat"

75+ DTGt n -> case someNatVal n of

76+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGt (SNat :: Sing n))

77+ Nothing -> error "Negative singleton nat"

78+ DTGe n -> case someNatVal n of

79+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGe (SNat :: Sing n))

80+ Nothing -> error "Negative singleton nat"

81+ DTRegex s -> case someSymbolVal (T.unpack s) of

82+ SomeSymbol (_ :: Proxy n) -> SomeSing (STRegex (SSym :: Sing n))

83+ DTEnum ss -> case toSing ss of

84+ SomeSing l -> SomeSing (STEnum l)

85+

86+data DemotedTextConstraint

87+ = DTEq Integer

88+ | DTLt Integer

89+ | DTLe Integer

90+ | DTGt Integer

91+ | DTGe Integer

92+ | DTRegex Text

93+ | DTEnum [Text]

94+ deriving (Generic, Eq, Show)

95+

4796data instance Sing (tc :: TextConstraint) where

4897 STEq :: Sing n -> Sing ('TEq n)

98+ STLt :: Sing n -> Sing ('TLt n)

4999 STLe :: Sing n -> Sing ('TLe n)

50100 STGt :: Sing n -> Sing ('TGt n)

101+ STGe :: Sing n -> Sing ('TGe n)

51102 STRegex :: Sing s -> Sing ('TRegex s)

52− STEnum :: All KnownSymbol ss => Sing ss -> Sing ('TEnum ss)

103+ STEnum :: Sing ss -> Sing ('TEnum ss)

53104

54105instance (KnownNat n) => SingI ('TEq n) where sing = STEq sing

55106instance (KnownNat n) => SingI ('TGt n) where sing = STGt sing

107+instance (KnownNat n) => SingI ('TGe n) where sing = STGe sing

108+instance (KnownNat n) => SingI ('TLt n) where sing = STLt sing

56109instance (KnownNat n) => SingI ('TLe n) where sing = STLe sing

57110instance (KnownSymbol s, SingI s) => SingI ('TRegex s) where sing = STRegex sing

58−instance (All KnownSymbol ss, SingI ss) => SingI ('TEnum ss) where sing = STEnum sing

111+instance (SingI ss) => SingI ('TEnum ss) where sing = STEnum sing

59112

60113instance Eq (Sing ('TEq n)) where _ == _ = True

114+instance Eq (Sing ('TLt n)) where _ == _ = True

61115instance Eq (Sing ('TLe n)) where _ == _ = True

62116instance Eq (Sing ('TGt n)) where _ == _ = True

117+instance Eq (Sing ('TGe n)) where _ == _ = True

63118instance Eq (Sing ('TRegex t)) where _ == _ = True

64119instance Eq (Sing ('TEnum ss)) where _ == _ = True

65120

66121data NumberConstraint

67122 = NLe Nat

123+ | NLt Nat

68124 | NGt Nat

125+ | NGe Nat

69126 | NEq Nat

70127 deriving (Generic)

71128

129+data DemotedNumberConstraint

130+ = DNLe Integer

131+ | DNLt Integer

132+ | DNGt Integer

133+ | DNGe Integer

134+ | DNEq Integer

135+ deriving (Generic, Eq, Show)

136+

72137data instance Sing (nc :: NumberConstraint) where

73138 SNEq :: Sing n -> Sing ('NEq n)

74139 SNGt :: Sing n -> Sing ('NGt n)

140+ SNGe :: Sing n -> Sing ('NGe n)

141+ SNLt :: Sing n -> Sing ('NLt n)

75142 SNLe :: Sing n -> Sing ('NLe n)

76143

77144instance KnownNat n => SingI ('NEq n) where sing = SNEq sing

78145instance KnownNat n => SingI ('NGt n) where sing = SNGt sing

146+instance KnownNat n => SingI ('NGe n) where sing = SNGe sing

147+instance KnownNat n => SingI ('NLt n) where sing = SNLt sing

79148instance KnownNat n => SingI ('NLe n) where sing = SNLe sing

80149

81150instance Eq (Sing ('NEq n)) where _ == _ = True

151+instance Eq (Sing ('NLt n)) where _ == _ = True

82152instance Eq (Sing ('NLe n)) where _ == _ = True

83153instance Eq (Sing ('NGt n)) where _ == _ = True

154+instance Eq (Sing ('NGe n)) where _ == _ = True

155+

156+instance SingKind NumberConstraint where

157+ type Demote NumberConstraint = DemotedNumberConstraint

158+ fromSing = \case

159+ SNEq n -> withKnownNat n (DNEq . fromIntegral $ natVal n)

160+ SNGt n -> withKnownNat n (DNGt . fromIntegral $ natVal n)

161+ SNGe n -> withKnownNat n (DNGe . fromIntegral $ natVal n)

162+ SNLt n -> withKnownNat n (DNLt . fromIntegral $ natVal n)

163+ SNLe n -> withKnownNat n (DNLe . fromIntegral $ natVal n)

164+ toSing = \case

165+ DNEq n -> case someNatVal n of

166+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNEq (SNat :: Sing n))

167+ Nothing -> error "Negative singleton nat"

168+ DNGt n -> case someNatVal n of

169+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGt (SNat :: Sing n))

170+ Nothing -> error "Negative singleton nat"

171+ DNGe n -> case someNatVal n of

172+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGe (SNat :: Sing n))

173+ Nothing -> error "Negative singleton nat"

174+ DNLt n -> case someNatVal n of

175+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLt (SNat :: Sing n))

176+ Nothing -> error "Negative singleton nat"

177+ DNLe n -> case someNatVal n of

178+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLe (SNat :: Sing n))

179+ Nothing -> error "Negative singleton nat"

84180

85181data ArrayConstraint

86182 = AEq Nat

183+ | AGt Nat

184+ | AGe Nat

185+ | ALt Nat

186+ | ALe Nat

87187 deriving (Generic)

88188

189+data DemotedArrayConstraint

190+ = DAEq Integer

191+ | DAGt Integer

192+ | DAGe Integer

193+ | DALt Integer

194+ | DALe Integer

195+ deriving (Generic, Eq, Show)

196+

89197data instance Sing (ac :: ArrayConstraint) where

90198 SAEq :: Sing n -> Sing ('AEq n)

199+ SAGt :: Sing n -> Sing ('AGt n)

200+ SAGe :: Sing n -> Sing ('AGe n)

201+ SALt :: Sing n -> Sing ('ALt n)

202+ SALe :: Sing n -> Sing ('ALe n)

91203

92204instance KnownNat n => SingI ('AEq n) where sing = SAEq sing

205+instance KnownNat n => SingI ('AGt n) where sing = SAGt sing

206+instance KnownNat n => SingI ('AGe n) where sing = SAGe sing

207+instance KnownNat n => SingI ('ALt n) where sing = SALt sing

208+instance KnownNat n => SingI ('ALe n) where sing = SALe sing

93209

94210instance Eq (Sing ('AEq n)) where _ == _ = True

211+instance Eq (Sing ('AGt n)) where _ == _ = True

212+instance Eq (Sing ('AGe n)) where _ == _ = True

213+instance Eq (Sing ('ALt n)) where _ == _ = True

214+instance Eq (Sing ('ALe n)) where _ == _ = True

215+

216+instance SingKind ArrayConstraint where

217+ type Demote ArrayConstraint = DemotedArrayConstraint

218+ fromSing = \case

219+ SAEq n -> withKnownNat n (DAEq . fromIntegral $ natVal n)

220+ SAGt n -> withKnownNat n (DAGt . fromIntegral $ natVal n)

221+ SAGe n -> withKnownNat n (DAGe . fromIntegral $ natVal n)

222+ SALt n -> withKnownNat n (DALt . fromIntegral $ natVal n)

223+ SALe n -> withKnownNat n (DALe . fromIntegral $ natVal n)

224+ toSing = \case

225+ DAEq n -> case someNatVal n of

226+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (SAEq (SNat :: Sing n))

227+ Nothing -> error "Negative singleton nat"

228+ DAGt n -> case someNatVal n of

229+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (SAGt (SNat :: Sing n))

230+ Nothing -> error "Negative singleton nat"

231+ DAGe n -> case someNatVal n of

232+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (SAGe (SNat :: Sing n))

233+ Nothing -> error "Negative singleton nat"

234+ DALt n -> case someNatVal n of

235+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (SALt (SNat :: Sing n))

236+ Nothing -> error "Negative singleton nat"

237+ DALe n -> case someNatVal n of

238+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (SALe (SNat :: Sing n))

239+ Nothing -> error "Negative singleton nat"

95240

96241data Schema

97242 = SchemaText [TextConstraint]

243+ | SchemaBoolean

98244 | SchemaNumber [NumberConstraint]

99245 | SchemaObject [(Symbol, Schema)]

100246 | SchemaArray [ArrayConstraint] Schema

101247 | SchemaNull

102248 | SchemaOptional Schema

249+ | SchemaUnion [Schema]

103250 deriving (Generic)

104251

252+data DemotedSchema

253+ = DSchemaText [DemotedTextConstraint]

254+ | DSchemaNumber [DemotedNumberConstraint]

255+ | DSchemaBoolean

256+ | DSchemaObject [(Text, DemotedSchema)]

257+ | DSchemaArray [DemotedArrayConstraint] DemotedSchema

258+ | DSchemaNull

259+ | DSchemaOptional DemotedSchema

260+ | DSchemaUnion [DemotedSchema]

261+ deriving (Generic, Eq, Show)

262+

105263data instance Sing (schema :: Schema) where

106264 SSchemaText :: Sing tcs -> Sing ('SchemaText tcs)

107265 SSchemaNumber :: Sing ncs -> Sing ('SchemaNumber ncs)

266+ SSchemaBoolean :: Sing 'SchemaBoolean

108267 SSchemaArray :: Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)

109268 SSchemaObject :: Sing fields -> Sing ('SchemaObject fields)

110269 SSchemaOptional :: Sing s -> Sing ('SchemaOptional s)

111270 SSchemaNull :: Sing 'SchemaNull

271+ SSchemaUnion :: Sing ss -> Sing ('SchemaUnion ss)

112272

113273instance SingI sl => SingI ('SchemaText sl) where

114274 sing = SSchemaText sing

@@ -116,19 +276,52 @@ instance SingI sl => SingI ('SchemaNumber sl) where

116276 sing = SSchemaNumber sing

117277instance SingI 'SchemaNull where

118278 sing = SSchemaNull

279+instance SingI 'SchemaBoolean where

280+ sing = SSchemaBoolean

119281instance (SingI ac, SingI s) => SingI ('SchemaArray ac s) where

120282 sing = SSchemaArray sing sing

121283instance SingI stl => SingI ('SchemaObject stl) where

122284 sing = SSchemaObject sing

123285instance SingI s => SingI ('SchemaOptional s) where

124286 sing = SSchemaOptional sing

287+instance SingI s => SingI ('SchemaUnion s) where

288+ sing = SSchemaUnion sing

125289

126290instance Eq (Sing ('SchemaText cs)) where _ == _ = True

127291instance Eq (Sing ('SchemaNumber cs)) where _ == _ = True

128292instance Eq (Sing 'SchemaNull) where _ == _ = True

293+instance Eq (Sing 'SchemaBoolean) where _ == _ = True

129294instance Eq (Sing ('SchemaArray as s)) where _ == _ = True

130295instance Eq (Sing ('SchemaObject cs)) where _ == _ = True

131296instance Eq (Sing ('SchemaOptional s)) where _ == _ = True

297+instance Eq (Sing ('SchemaUnion s)) where _ == _ = True

298+

299+instance SingKind Schema where

300+ type Demote Schema = DemotedSchema

301+ fromSing = \case

302+ SSchemaText cs -> DSchemaText $ fromSing cs

303+ SSchemaNumber cs -> DSchemaNumber $ fromSing cs

304+ SSchemaBoolean -> DSchemaBoolean

305+ SSchemaArray cs s -> DSchemaArray (fromSing cs) (fromSing s)

306+ SSchemaOptional s -> DSchemaOptional $ fromSing s

307+ SSchemaNull -> DSchemaNull

308+ SSchemaObject cs -> DSchemaObject $ fromSing cs

309+ SSchemaUnion ss -> DSchemaUnion $ fromSing ss

310+ toSing = \case

311+ DSchemaText cs -> case toSing cs of

312+ SomeSing scs -> SomeSing $ SSchemaText scs

313+ DSchemaNumber cs -> case toSing cs of

314+ SomeSing scs -> SomeSing $ SSchemaNumber scs

315+ DSchemaBoolean -> SomeSing $ SSchemaBoolean

316+ DSchemaArray cs sch -> case (toSing cs, toSing sch) of

317+ (SomeSing scs, SomeSing ssch) -> SomeSing $ SSchemaArray scs ssch

318+ DSchemaOptional sch -> case toSing sch of

319+ SomeSing ssch -> SomeSing $ SSchemaOptional ssch

320+ DSchemaNull -> SomeSing SSchemaNull

321+ DSchemaObject cs -> case toSing cs of

322+ SomeSing scs -> SomeSing $ SSchemaObject scs

323+ DSchemaUnion ss -> case toSing ss of

324+ SomeSing sss -> SomeSing $ SSchemaUnion sss

132325

133326data FieldRepr :: (Symbol, Schema) -> Type where

134327 FieldRepr

@@ -166,53 +359,77 @@ instance

166359 => Serial m (FieldRepr '(name, schema)) where

167360 series = FieldRepr <$> series

168361

362+type family USubsets (u :: [k]) :: Constraint where

363+ USubsets '[] = ()

364+ USubsets (h ': tl) = (USubset tl (h ': tl) (V.RImage tl (h ': tl)), USubsets tl)

365+

169366data JsonRepr :: Schema -> Type where

170367 ReprText :: Text -> JsonRepr ('SchemaText cs)

171368 ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)

369+ ReprBoolean :: Bool -> JsonRepr 'SchemaBoolean

172370 ReprNull :: JsonRepr 'SchemaNull

173371 ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)

174372 ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)

175373 ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)

374+ ReprUnion :: Union JsonRepr (h ': tl) -> JsonRepr ('SchemaUnion (h ': tl))

375+

376+instance (Monad m, Serial m Text, SingI cs)

377+ => Serial m (JsonRepr ('SchemaText cs)) where

378+ series = decDepth $ fmap ReprText $ textSeries $ fromSing (sing :: Sing cs)

379+

380+instance (Monad m, Serial m Scientific, SingI cs)

381+ => Serial m (JsonRepr ('SchemaNumber cs)) where

382+ series = decDepth $ fmap ReprNumber

383+ $ numberSeries $ fromSing (sing :: Sing cs)

384+

385+instance Monad m => Serial m (JsonRepr 'SchemaNull) where

386+ series = cons0 ReprNull

387+

388+instance (Serial m (JsonRepr s), Serial m (V.Vector (JsonRepr s)), SingI cs)

389+ => Serial m (JsonRepr ('SchemaArray cs s)) where

390+ series = decDepth $ fmap ReprArray

391+ $ arraySeries $ fromSing (sing :: Sing cs)

176392

393+instance (Serial m (JsonRepr s))

394+ => Serial m (JsonRepr ('SchemaOptional s)) where

395+ series = cons1 ReprOptional

396+

397+instance (Monad m, Serial m (Rec FieldRepr fs))

398+ => Serial m (JsonRepr ('SchemaObject fs)) where

399+ series = cons1 ReprObject

400+

401+-- | Move to the union package

177402instance Show (JsonRepr ('SchemaText cs)) where

178403 show (ReprText t) = "ReprText " P.++ show t

179404

180405instance Show (JsonRepr ('SchemaNumber cs)) where

181406 show (ReprNumber n) = "ReprNumber " P.++ show n

182407

408+instance Show (JsonRepr 'SchemaBoolean) where

409+ show (ReprBoolean n) = "ReprBoolean " P.++ show n

410+

183411instance Show (JsonRepr 'SchemaNull) where show _ = "ReprNull"

184412

185413instance Show (JsonRepr s) => Show (JsonRepr ('SchemaArray acs s)) where

186414 show (ReprArray v) = "ReprArray " P.++ show v

187415

416+#if MIN_VERSION_base(4,12,0)

417+instance

418+ ( V.RecAll FieldRepr fs Show, RMap fs, ReifyConstraint Show FieldRepr fs

419+ , RecordToList fs )

420+ => Show (JsonRepr ('SchemaObject fs)) where

421+ show (ReprObject fs) = "ReprObject " P.++ show fs

422+#else

188423instance V.RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where

189424 show (ReprObject fs) = "ReprObject " P.++ show fs

425+#endif

190426

191427instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where

192428 show (ReprOptional s) = "ReprOptional " P.++ show s

193429

194−instance (Monad m, Serial m Text)

195− => Serial m (JsonRepr ('SchemaText cs)) where

196− series = cons1 ReprText

197−

198−instance (Monad m, Serial m Scientific)

199− => Serial m (JsonRepr ('SchemaNumber cs)) where

200− series = cons1 ReprNumber

201−

202−instance Monad m => Serial m (JsonRepr 'SchemaNull) where

203− series = cons0 ReprNull

204−

205−instance (Serial m (V.Vector (JsonRepr s)))

206− => Serial m (JsonRepr ('SchemaArray cs s)) where

207− series = cons1 ReprArray

208−

209−instance (Serial m (JsonRepr s))

210− => Serial m (JsonRepr ('SchemaOptional s)) where

211− series = cons1 ReprOptional

212−

213−instance (Monad m, Serial m (Rec FieldRepr fs))

214− => Serial m (JsonRepr ('SchemaObject fs)) where

215− series = cons1 ReprObject

430+instance Show (Union JsonRepr (h ': tl))

431+ => Show (JsonRepr ('SchemaUnion (h ': tl))) where

432+ show (ReprUnion s) = "ReprUnion " P.++ show s

216433

217434instance Eq (Rec FieldRepr fs) => Eq (JsonRepr ('SchemaObject fs)) where

218435 ReprObject a == ReprObject b = a == b

@@ -223,6 +440,9 @@ instance Eq (JsonRepr ('SchemaText cs)) where

223440instance Eq (JsonRepr ('SchemaNumber cs)) where

224441 ReprNumber a == ReprNumber b = a == b

225442

443+instance Eq (JsonRepr 'SchemaBoolean) where

444+ ReprBoolean a == ReprBoolean b = a == b

445+

226446instance Eq (JsonRepr 'SchemaNull) where

227447 ReprNull == ReprNull = True

228448

@@ -232,6 +452,51 @@ instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaArray as s)) where

232452instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaOptional s)) where

233453 ReprOptional a == ReprOptional b = a == b

234454

455+instance Eq (Union JsonRepr (h ': tl))

456+ => Eq (JsonRepr ('SchemaUnion (h ': tl))) where

457+ ReprUnion a == ReprUnion b = a == b

458+

459+instance Ord (Rec FieldRepr fs) => Ord (JsonRepr ('SchemaObject fs)) where

460+ ReprObject a `compare` ReprObject b = a `compare` b

461+

462+instance Ord (JsonRepr ('SchemaText cs)) where

463+ ReprText a `compare` ReprText b = a `compare` b

464+

465+instance Ord (JsonRepr ('SchemaNumber cs)) where

466+ ReprNumber a `compare` ReprNumber b = a `compare` b

467+

468+instance Ord (JsonRepr 'SchemaBoolean) where

469+ ReprBoolean a `compare` ReprBoolean b = a `compare` b

470+

471+instance Ord (JsonRepr 'SchemaNull) where

472+ compare _ _ = EQ

473+

474+instance Ord (JsonRepr s) => Ord (JsonRepr ('SchemaArray as s)) where

475+ ReprArray a `compare` ReprArray b = a `compare` b

476+

477+instance Ord (JsonRepr s) => Ord (JsonRepr ('SchemaOptional s)) where

478+ ReprOptional a `compare` ReprOptional b = a `compare` b

479+

480+instance Ord (Union JsonRepr (h ': tl))

481+ => Ord (JsonRepr ('SchemaUnion (h ': tl))) where

482+ ReprUnion a `compare` ReprUnion b = a `compare` b

483+

484+instance IsList (JsonRepr ('SchemaArray cs s)) where

485+ type Item (JsonRepr ('SchemaArray cs s)) = JsonRepr s

486+ fromList = ReprArray . GHC.Exts.fromList

487+ toList (ReprArray v) = GHC.Exts.toList v

488+

489+instance Num (JsonRepr ('SchemaNumber cs)) where

490+ ReprNumber a + ReprNumber b = ReprNumber $ a + b

491+ ReprNumber a - ReprNumber b = ReprNumber $ a - b

492+ ReprNumber a * ReprNumber b = ReprNumber $ a * b

493+ abs (ReprNumber a) = ReprNumber $ abs a

494+ signum (ReprNumber a) = ReprNumber $ signum a

495+ fromInteger = ReprNumber . fromIntegral

496+

497+instance IsString (JsonRepr ('SchemaText cs)) where

498+ fromString = ReprText . fromString

499+

235500fromOptional

236501 :: SingI s

237502 => Sing ('SchemaOptional s)

@@ -239,10 +504,29 @@ fromOptional

239504 -> Parser (Maybe (JsonRepr s))

240505fromOptional _ = parseJSON

241506

507+parseUnion

508+ :: FromJSON (JsonRepr ('SchemaUnion ss))

509+ => sing (ss :: [Schema])

510+ -> Value

511+ -> Parser (JsonRepr ('SchemaUnion ss))

512+parseUnion _ val = parseJSON val

513+

514+instance FromJSON (Union JsonRepr '[]) where

515+ parseJSON = fail "empty union"

516+

517+instance (SingI a, FromJSON (Union JsonRepr as)) => FromJSON (Union JsonRepr (a ': as)) where

518+ parseJSON val = (This <$> parseJSON val)

519+ <|> (That <$> (parseJSON val :: Parser (Union JsonRepr as)))

520+

521+instance ToJSON (Union JsonRepr as) where

522+ toJSON (This fa) = toJSON fa

523+ toJSON (That u) = toJSON u

524+

242525instance SingI schema => J.FromJSON (JsonRepr schema) where

243526 parseJSON value = case sing :: Sing schema of

244527 SSchemaText _ -> withText "String" (pure . ReprText) value

245528 SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value

529+ SSchemaBoolean -> ReprBoolean <$> parseJSON value

246530 SSchemaNull -> case value of

247531 J.Null -> pure ReprNull

248532 _ -> typeMismatch "Null" value

@@ -258,31 +542,37 @@ instance SingI schema => J.FromJSON (JsonRepr schema) where

258542 fieldRepr <- case s of

259543 SSchemaText so -> case H.lookup fieldName h of

260544 Just v -> withSingI so $ FieldRepr <$> parseJSON v

261− Nothing -> fail "schematext"

545+ Nothing -> fail $ "No text field: " P.++ show fieldName

262546 SSchemaNumber so -> case H.lookup fieldName h of

263547 Just v -> withSingI so $ FieldRepr <$> parseJSON v

264− Nothing -> fail "schemanumber"

548+ Nothing -> fail $ "No number field: " P.++ show fieldName

549+ SSchemaBoolean -> case H.lookup fieldName h of

550+ Just v -> FieldRepr <$> parseJSON v

551+ Nothing -> fail $ "No boolean field: " P.++ show fieldName

265552 SSchemaNull -> case H.lookup fieldName h of

266553 Just v -> FieldRepr <$> parseJSON v

267− Nothing -> fail "schemanull"

554+ Nothing -> fail $ "No null field: " P.++ show fieldName

268555 SSchemaArray sa sb -> case H.lookup fieldName h of

269556 Just v -> withSingI sa $ withSingI sb $ FieldRepr <$> parseJSON v

270− Nothing -> fail "schemaarray"

557+ Nothing -> fail $ "No array field: " P.++ show fieldName

271558 SSchemaObject so -> case H.lookup fieldName h of

272559 Just v -> withSingI so $ FieldRepr <$> parseJSON v

273− Nothing -> fail "schemaobject"

560+ Nothing -> fail $ "No object field" P.++ show fieldName

274561 SSchemaOptional so -> case H.lookup fieldName h of

275562 Just v -> withSingI so $ FieldRepr <$> parseJSON v

276− Nothing -> fail "schemaoptional"

563+ Nothing -> withSingI so $ pure $ FieldRepr $ ReprOptional Nothing

564+ SSchemaUnion ss -> withSingI ss $ FieldRepr <$> parseUnion ss value

277565 (fieldRepr :&) <$> demoteFields tl h

278566 ReprObject <$> withObject "Object" (demoteFields fs) value

567+ SSchemaUnion ss -> parseUnion ss value

279568

280569instance J.ToJSON (JsonRepr a) where

281570 toJSON ReprNull = J.Null

571+ toJSON (ReprBoolean b) = J.Bool b

282572 toJSON (ReprText t) = J.String t

283573 toJSON (ReprNumber n) = J.Number n

284574 toJSON (ReprOptional s) = case s of

285− Just v -> toJSON v

575+ Just v -> toJSON v

286576 Nothing -> J.Null

287577 toJSON (ReprArray v) = J.Array $ toJSON <$> v

288578 toJSON (ReprObject r) = J.Object . H.fromList . fold $ r

@@ -295,6 +585,7 @@ instance J.ToJSON (JsonRepr a) where

295585 fold = \case

296586 RNil -> []

297587 fr@(FieldRepr _) :& tl -> (extract fr) : fold tl

588+ toJSON (ReprUnion u) = toJSON u

298589

299590class FalseConstraint a

300591

src/Data/Schematic/Schema.hs-bootnew file+95

@@ -0,0 +1,95 @@

1+module Data.Schematic.Schema where

3+import Data.Kind

4+import Data.Maybe

5+import Data.Schematic.Instances ()

6+import Data.Scientific

7+import Data.Singletons.TH

8+import Data.Singletons.TypeLits

9+import Data.Text as T

10+import Data.Union

11+import Data.Vector as V

12+import Data.Vinyl hiding (Dict)

13+import Prelude as P

14+

15+data TextConstraint

16+ = TEq Nat

17+ | TLt Nat

18+ | TLe Nat

19+ | TGt Nat

20+ | TGe Nat

21+ | TRegex Symbol

22+ | TEnum [Symbol]

23+

24+data DemotedTextConstraint

25+ = DTEq Integer

26+ | DTLt Integer

27+ | DTLe Integer

28+ | DTGt Integer

29+ | DTGe Integer

30+ | DTRegex Text

31+ | DTEnum [Text]

32+

33+data NumberConstraint

34+ = NLe Nat

35+ | NLt Nat

36+ | NGt Nat

37+ | NGe Nat

38+ | NEq Nat

39+

40+data DemotedNumberConstraint

41+ = DNLe Integer

42+ | DNLt Integer

43+ | DNGt Integer

44+ | DNGe Integer

45+ | DNEq Integer

46+

47+data ArrayConstraint

48+ = AEq Nat

49+ | AGt Nat

50+ | AGe Nat

51+ | ALt Nat

52+ | ALe Nat

53+

54+data DemotedArrayConstraint

55+ = DAEq Integer

56+ | DAGt Integer

57+ | DAGe Integer

58+ | DALt Integer

59+ | DALe Integer

60+

61+data Schema

62+ = SchemaText [TextConstraint]

63+ | SchemaBoolean

64+ | SchemaNumber [NumberConstraint]

65+ | SchemaObject [(Symbol, Schema)]

66+ | SchemaArray [ArrayConstraint] Schema

67+ | SchemaNull

68+ | SchemaOptional Schema

69+ | SchemaUnion [Schema]

70+

71+data DemotedSchema

72+ = DSchemaText [DemotedTextConstraint]

73+ | DSchemaNumber [DemotedNumberConstraint]

74+ | DSchemaBoolean

75+ | DSchemaObject [(Text, DemotedSchema)]

76+ | DSchemaArray [DemotedArrayConstraint] DemotedSchema

77+ | DSchemaNull

78+ | DSchemaOptional DemotedSchema

79+ | DSchemaUnion [DemotedSchema]

80+

81+data FieldRepr :: (Symbol, Schema) -> Type where

82+ FieldRepr

83+ :: (SingI schema, KnownSymbol name)

84+ => JsonRepr schema

85+ -> FieldRepr '(name, schema)

86+

87+data JsonRepr :: Schema -> Type where

88+ ReprText :: Text -> JsonRepr ('SchemaText cs)

89+ ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)

90+ ReprBoolean :: Bool -> JsonRepr 'SchemaBoolean

91+ ReprNull :: JsonRepr 'SchemaNull

92+ ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)

93+ ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)

94+ ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)

95+ ReprUnion :: Union JsonRepr (h ': tl) -> JsonRepr ('SchemaUnion (h ': tl))

src/Data/Schematic/Utils.hsdeleted−42

@@ -1,42 +0,0 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−

3−module Data.Schematic.Utils where

4−

5−import Data.Proxy

6−import Data.Singletons

7−import Data.Singletons.Prelude

8−import Data.Singletons.TypeLits

9−import Data.Vinyl hiding (Dict)

10−

11−

12−class Known a where

13− known :: a

14−

15−instance Known (Proxy a) where

16− known = Proxy

17−

18−instance KnownNat n => Known (Sing n) where

19− known = SNat

20−

21−instance KnownSymbol s => Known (Sing s) where

22− known = SSym

23−

24−instance (Known (Sing a), Known (Sing b)) => Known (Sing '(a,b)) where

25− known = STuple2 known known

26−

27−instance Known (Sing '[]) where known = SNil

28−

29−instance (Known (Sing a), Known (Sing as)) => Known (Sing (a ': as)) where

30− known = SCons known known

31−

32−instance Known (Rec Sing '[]) where

33− known = RNil

34−

35−instance (Known (Sing a), Known (Rec Sing tl)) => Known (Rec Sing (a ': tl)) where

36− known = known :& known

37−

38−data Dict c where

39− Dict :: c => Dict c

40−

41−instance c => Known (Dict c) where

42− known = Dict

src/Data/Schematic/Validation.hs+146−18

@@ -2,20 +2,24 @@ module Data.Schematic.Validation where

33import Control.Monad

44import Control.Monad.Validation

5+import Data.Aeson

6+import Data.Aeson.Types

57import Data.Foldable

68import Data.Functor.Identity

79import Data.Monoid

810import Data.Schematic.Path

911import Data.Schematic.Schema

10−import Data.Schematic.Utils ()

1112import Data.Scientific

1213import Data.Singletons.Prelude

1314import Data.Singletons.TypeLits

1415import Data.Text as T

16+import Data.Traversable

17+import Data.Union

1518import Data.Vector as V

1619import Data.Vinyl

20+import Data.Vinyl.TypeLevel

1721import Prelude as P

18−import Text.Regex

22+import Text.Regex.TDFA

1923

2024

2125type Validation a = ValidationT ErrorMap Identity a

@@ -26,7 +30,11 @@ data ParseResult a

2630 = Valid a

2731 | DecodingError Text -- static

2832 | ValidationError ErrorMap -- runtime

29− deriving (Show, Eq, Functor)

33+ deriving (Show, Eq, Functor, Foldable, Traversable)

34+

35+instance (TopLevel a, SingI a, FromJSON (JsonRepr a))

36+ => FromJSON (ParseResult (JsonRepr a)) where

37+ parseJSON = pure . parseAndValidateJson @a

3038

3139isValid :: ParseResult a -> Bool

3240isValid (Valid _) = True

@@ -50,28 +58,42 @@ validateTextConstraint (JSONPath path) t = \case

5058 let

5159 nlen = withKnownNat n $ natVal n

5260 predicate = nlen == (fromIntegral $ T.length t)

53− errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)

61+ errMsg = "length should be == " <> T.pack (show nlen)

62+ warn = vWarning $ mmSingleton path (pure errMsg)

63+ unless predicate warn

64+ STLt n -> do

65+ let

66+ nlen = withKnownNat n $ natVal n

67+ predicate = nlen > (fromIntegral $ T.length t)

68+ errMsg = "length should be < " <> T.pack (show nlen)

5469 warn = vWarning $ mmSingleton path (pure errMsg)

5570 unless predicate warn

5671 STLe n -> do

5772 let

5873 nlen = withKnownNat n $ natVal n

59− predicate = nlen <= (fromIntegral $ T.length t)

60− errMsg = "length of " <> path <> " should be <= " <> T.pack (show nlen)

74+ predicate = nlen >= (fromIntegral $ T.length t)

75+ errMsg = "length should be <= " <> T.pack (show nlen)

6176 warn = vWarning $ mmSingleton path (pure errMsg)

6277 unless predicate warn

6378 STGt n -> do

6479 let

6580 nlen = withKnownNat n $ natVal n

66− predicate = nlen > (fromIntegral $ T.length t)

67− errMsg = "length of " <> path <> " should be > " <> T.pack (show nlen)

81+ predicate = nlen < (fromIntegral $ T.length t)

82+ errMsg = "length should be > " <> T.pack (show nlen)

83+ warn = vWarning $ mmSingleton path (pure errMsg)

84+ unless predicate warn

85+ STGe n -> do

86+ let

87+ nlen = withKnownNat n $ natVal n

88+ predicate = nlen <= (fromIntegral $ T.length t)

89+ errMsg = "length should be >= " <> T.pack (show nlen)

6890 warn = vWarning $ mmSingleton path (pure errMsg)

6991 unless predicate warn

7092 STRegex r -> do

7193 let

72− regex = withKnownSymbol r $ symbolVal r

73− predicate = maybe False (const True) $ matchRegex (mkRegex regex) (T.unpack t)

74− errMsg = path <> " must match " <> T.pack (show regex)

94+ regex = withKnownSymbol r $ fromSing r

95+ predicate = matchTest (makeRegex (T.unpack regex) :: Regex) (T.unpack t)

96+ errMsg = "must match " <> regex

7597 warn = vWarning $ mmSingleton path (pure errMsg)

7698 unless predicate warn

7799 STEnum ss -> do

@@ -79,7 +101,7 @@ validateTextConstraint (JSONPath path) t = \case

79101 matching :: Sing (s :: [Symbol]) -> Bool

80102 matching SNil = False

81103 matching (SCons s@SSym fs) = T.pack (symbolVal s) == t || matching fs

82− errMsg = path <> " must be one of " <> T.pack (show (fromSing ss))

104+ errMsg = "must be one of " <> T.pack (show (fromSing ss))

83105 warn = vWarning $ mmSingleton path (pure errMsg)

84106 unless (matching ss) warn

85107

@@ -93,21 +115,35 @@ validateNumberConstraint (JSONPath path) num = \case

93115 let

94116 nlen = withKnownNat n $ natVal n

95117 predicate = fromIntegral nlen == num

96− errMsg = path <> " should be == " <> T.pack (show nlen)

118+ errMsg = "should be == " <> T.pack (show nlen)

97119 warn = vWarning $ mmSingleton path (pure errMsg)

98120 unless predicate warn

99121 SNGt n -> do

100122 let

101123 nlen = withKnownNat n $ natVal n

102124 predicate = num > fromIntegral nlen

103− errMsg = path <> " should be > " <> T.pack (show nlen)

125+ errMsg = "should be > " <> T.pack (show nlen)

126+ warn = vWarning $ mmSingleton path (pure errMsg)

127+ unless predicate warn

128+ SNGe n -> do

129+ let

130+ nlen = withKnownNat n $ natVal n

131+ predicate = num >= fromIntegral nlen

132+ errMsg = "should be >= " <> T.pack (show nlen)

133+ warn = vWarning $ mmSingleton path (pure errMsg)

134+ unless predicate warn

135+ SNLt n -> do

136+ let

137+ nlen = withKnownNat n $ natVal n

138+ predicate = num < fromIntegral nlen

139+ errMsg = "should be < " <> T.pack (show nlen)

104140 warn = vWarning $ mmSingleton path (pure errMsg)

105141 unless predicate warn

106142 SNLe n -> do

107143 let

108144 nlen = withKnownNat n $ natVal n

109− predicate = fromIntegral nlen <= num

110− errMsg = path <> " should be <= " <> T.pack (show nlen)

145+ predicate = num <= fromIntegral nlen

146+ errMsg = "should be <= " <> T.pack (show nlen)

111147 warn = vWarning $ mmSingleton path (pure errMsg)

112148 unless predicate warn

113149

@@ -121,7 +157,35 @@ validateArrayConstraint (JSONPath path) v = \case

121157 let

122158 nlen = withKnownNat n $ natVal n

123159 predicate = nlen == fromIntegral (V.length v)

124− errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)

160+ errMsg = "length should be == " <> T.pack (show nlen)

161+ warn = vWarning $ mmSingleton path (pure errMsg)

162+ unless predicate warn

163+ SAGt n -> do

164+ let

165+ nlen = withKnownNat n $ natVal n

166+ predicate = fromIntegral (V.length v) > nlen

167+ errMsg = "length should be > " <> T.pack (show nlen)

168+ warn = vWarning $ mmSingleton path (pure errMsg)

169+ unless predicate warn

170+ SAGe n -> do

171+ let

172+ nlen = withKnownNat n $ natVal n

173+ predicate = fromIntegral (V.length v) >= nlen

174+ errMsg = "length should be >= " <> T.pack (show nlen)

175+ warn = vWarning $ mmSingleton path (pure errMsg)

176+ unless predicate warn

177+ SALt n -> do

178+ let

179+ nlen = withKnownNat n $ natVal n

180+ predicate = fromIntegral (V.length v) < nlen

181+ errMsg = "length should be < " <> T.pack (show nlen)

182+ warn = vWarning $ mmSingleton path (pure errMsg)

183+ unless predicate warn

184+ SALe n -> do

185+ let

186+ nlen = withKnownNat n $ natVal n

187+ predicate = fromIntegral (V.length v) <= nlen

188+ errMsg = "length should be <= " <> T.pack (show nlen)

125189 warn = vWarning $ mmSingleton path (pure errMsg)

126190 unless predicate warn

127191

@@ -150,6 +214,7 @@ validateJsonRepr sschema dpath jr = case jr of

150214 process cs

151215 process scs

152216 ReprNull -> pure ()

217+ ReprBoolean _ -> pure ()

153218 ReprArray v -> case sschema of

154219 SSchemaArray acs s -> do

155220 let

@@ -169,9 +234,72 @@ validateJsonRepr sschema dpath jr = case jr of

169234 ReprObject fs -> case sschema of

170235 SSchemaObject _ -> go fs

171236 where

172− go :: Rec FieldRepr (ts :: [ (Symbol, Schema) ] ) -> Validation ()

237+ go :: Rec FieldRepr (ts :: [(Symbol, Schema)] ) -> Validation ()

173238 go RNil = pure ()

174239 go (f@(FieldRepr d) :& ftl) = do

175240 let newPath = dpath <> [DKey (knownFieldName f)]

176241 validateJsonRepr (knownFieldSchema f) newPath d

177242 go ftl

243+ ReprUnion _ -> pure () -- FIXME

244+ -- case sschema of

245+ -- SSchemaUnion ss -> case ss of

246+ -- SCons s stl -> case umatch' s u of

247+ -- Nothing -> case urestrict u of

248+ -- Nothing ->

249+ -- fail "impossible to produce subUnion, please report this as a bug"

250+ -- Just x -> do

251+ -- let

252+ -- JSONPath path = demotedPathToText dpath

253+ -- case stl of

254+ -- SNil -> void $ vWarning $ mmSingleton path

255+ -- $ pure "union handling error, please report this as bug"

256+ -- SCons s' stl' ->

257+ -- validateJsonRepr (SSchemaUnion (SCons s' stl')) dpath

258+ -- $ toUnion (SCons s' stl') x

259+ -- Just x -> validateJsonRepr s dpath x

260+

261+-- subUnion

262+-- :: Sing (s ': stl)

263+-- -> ( USubset stl (s ': stl) (RImage stl (s ': stl))

264+-- => Union f (s ': stl)

265+-- -> Maybe (Union f stl) )

266+-- subUnion (SCons s stl) = urestrict

267+

268+-- withUSubset

269+-- :: Sing (s ': stl)

270+-- -> (USubset stl (s ': stl) (RImage stl (s ': stl)) => Maybe (Union f stl))

271+-- -> Maybe (Union f stl)

272+-- withUSubset (SCons s stl) r = r

273+

274+toUnion

275+ :: USubset s' (s ': ss) (RImage s' (s ': ss))

276+ => Sing (s ': ss)

277+ -> Union JsonRepr s'

278+ -> JsonRepr ('SchemaUnion (s ': ss))

279+toUnion _ = ReprUnion . urelax

280+

281+umatch' :: UElem a as i => Sing a -> Union f as -> Maybe (f a)

282+umatch' _ u = umatch u

283+

284+parseAndValidateJson

285+ :: forall schema

286+ . (FromJSON (JsonRepr schema), TopLevel schema, SingI schema)

287+ => Value

288+ -> ParseResult (JsonRepr schema)

289+parseAndValidateJson v =

290+ case parseEither parseJSON v of

291+ Left s -> DecodingError $ T.pack s

292+ Right jsonRepr ->

293+ let

294+ validate = validateJsonRepr (sing :: Sing schema) [] jsonRepr

295+ res = runIdentity . runValidationTEither $ validate

296+ in case res of

297+ Left em -> ValidationError em

298+ Right () -> Valid jsonRepr

299+

300+parseAndValidateJsonBy

301+ :: (FromJSON (JsonRepr schema), TopLevel schema, SingI schema)

302+ => proxy schema

303+ -> Value

304+ -> ParseResult (JsonRepr schema)

305+parseAndValidateJsonBy _ = parseAndValidateJson

src/Data/Schematic/Verifier.hsnew file+5

@@ -0,0 +1,5 @@

1+module Data.Schematic.Verifier (module X) where

3+import Data.Schematic.Verifier.Array as X

4+import Data.Schematic.Verifier.Number as X

5+import Data.Schematic.Verifier.Text as X

src/Data/Schematic/Verifier/Array.hsnew file+14

@@ -0,0 +1,14 @@

1+module Data.Schematic.Verifier.Array where

3+import {-# SOURCE #-} Data.Schematic.Schema

4+import Data.Schematic.Verifier.Common

6+data VerifiedArrayConstraint =

7+ VAEq Integer

8+ deriving (Show)

10+verifyArrayConstraint ::

11+ [DemotedArrayConstraint] -> Maybe (Maybe VerifiedArrayConstraint)

12+verifyArrayConstraint cs = do

13+ x <- verifyDNEq [x | DAEq x <- cs]

14+ pure $ VAEq <$> x

src/Data/Schematic/Verifier/Common.hsnew file+43

@@ -0,0 +1,43 @@

1+module Data.Schematic.Verifier.Common where

3+import Data.List (nub)

5+simplifyNumberConstraint :: ([Integer] -> Integer) -> [Integer] -> Maybe Integer

6+simplifyNumberConstraint f =

7+ \case

8+ [] -> Nothing

9+ x -> Just $ f x

10+

11+simplifyDNLs :: [Integer] -> Maybe Integer

12+simplifyDNLs = simplifyNumberConstraint minimum

13+

14+simplifyDNGs :: [Integer] -> Maybe Integer

15+simplifyDNGs = simplifyNumberConstraint maximum

16+

17+verifyDNEq :: [Integer] -> Maybe (Maybe Integer)

18+verifyDNEq x =

19+ case nub x of

20+ [] -> Just Nothing

21+ [y] -> Just $ Just y

22+ (_:_:_) -> Nothing

23+

24+verify3 :: Maybe Integer -> Maybe Integer -> Maybe Integer -> Maybe ()

25+verify3 (Just x) (Just y) (Just z) =

26+ if x < y && y < z

27+ then Just ()

28+ else Nothing

29+verify3 _ _ _ = Just ()

30+

31+verify2 :: Maybe Integer -> Maybe Integer -> Maybe ()

32+verify2 (Just x) (Just y) =

33+ if x < y

34+ then Just ()

35+ else Nothing

36+verify2 _ _ = Just ()

37+

38+verifyEquations :: Maybe Integer -> Maybe Integer -> Maybe Integer -> Maybe ()

39+verifyEquations mgt meq mlt = do

40+ verify3 mgt meq mlt

41+ verify2 mgt meq

42+ verify2 meq mlt

43+ verify2 mgt mlt

src/Data/Schematic/Verifier/Number.hsnew file+31

@@ -0,0 +1,31 @@

1+module Data.Schematic.Verifier.Number where

3+import {-# SOURCE #-} Data.Schematic.Schema

4+import Data.Schematic.Verifier.Common

6+toStrictNumber :: [DemotedNumberConstraint] -> [DemotedNumberConstraint]

7+toStrictNumber = map f

8+ where

9+ f (DNLe x) = DNLt (x + 1)

10+ f (DNGe x) = DNGt (x - 1)

11+ f x = x

12+

13+data VerifiedNumberConstraint

14+ = VNEq Integer

15+ | VNBounds (Maybe Integer) (Maybe Integer)

16+ deriving (Show)

17+

18+verifyNumberConstraints

19+ :: [DemotedNumberConstraint]

20+ -> Maybe VerifiedNumberConstraint

21+verifyNumberConstraints cs' = do

22+ let

23+ cs = toStrictNumber cs'

24+ mlt = simplifyDNLs [x | DNLt x <- cs]

25+ mgt = simplifyDNGs [x | DNGt x <- cs]

26+ meq <- verifyDNEq [x | DNEq x <- cs]

27+ verifyEquations mgt meq mlt

28+ Just $

29+ case meq of

30+ Just eq -> VNEq eq

31+ Nothing -> VNBounds mgt mlt

src/Data/Schematic/Verifier/Text.hsnew file+121

@@ -0,0 +1,121 @@

1+module Data.Schematic.Verifier.Text where

3+import Control.Monad

4+import Data.Maybe

5+import {-# SOURCE #-} Data.Schematic.Schema

6+import Data.Schematic.Verifier.Common

7+import Data.Text (Text, unpack)

8+import Text.Regex.TDFA.Pattern

9+import Text.Regex.TDFA.ReadRegex (parseRegex)

10+

11+toStrictTextLength :: [DemotedTextConstraint] -> [DemotedTextConstraint]

12+toStrictTextLength = map f

13+ where

14+ f (DTLe x) = DTLt (x + 1)

15+ f (DTGe x) = DTGt (x - 1)

16+ f x = x

17+

18+data VerifiedTextConstraint

19+ = VTEq Integer

20+ | VTBounds (Maybe Integer) (Maybe Integer)

21+ | VTRegex Text Integer (Maybe Integer)

22+ | VTEnum [Text]

23+ deriving (Show)

24+

25+verifyTextLengthConstraints

26+ :: [DemotedTextConstraint]

27+ -> Maybe (Maybe VerifiedTextConstraint)

28+verifyTextLengthConstraints cs' = do

29+ let

30+ cs = toStrictTextLength cs'

31+ mlt = simplifyDNLs [x | DTLt x <- cs]

32+ mgt = simplifyDNGs [x | DTGt x <- cs]

33+ meq <- verifyDNEq [x | DTEq x <- cs]

34+ verifyEquations mgt meq mlt

35+ case all isNothing ([mgt, meq, mlt] :: [Maybe Integer]) of

36+ True -> Just Nothing

37+ _ ->

38+ Just $

39+ Just $

40+ case meq of

41+ Just eq -> VTEq eq

42+ Nothing -> VTBounds mgt mlt

43+

44+regexLength :: Text -> Maybe (Int, Maybe Int)

45+regexLength regexp =

46+ case parseRegex . unpack $ regexp of

47+ Right (p, _) -> Just (minRegexLength p, maxRegexLength p)

48+ Left _ -> Nothing

49+

50+minRegexLength :: Pattern -> Int

51+minRegexLength p =

52+ case p of

53+ PEmpty -> 0

54+ PChar {..} -> 1

55+ PAny {..} -> 1

56+ PAnyNot {..} -> 1

57+ PQuest _ -> 0

58+ PPlus sch -> minRegexLength $ PBound 1 Nothing sch

59+ PStar _ sch -> minRegexLength $ PBound 0 Nothing sch

60+ PBound low _ sch -> low * minRegexLength sch

61+ PConcat ps -> sum $ fmap minRegexLength ps

62+ POr xs -> minimum $ fmap minRegexLength xs

63+ PDot _ -> 1

64+ PEscape {..} -> 1

65+ PCarat _ -> 0

66+ PDollar _ -> 0

67+ _ -> 0

68+

69+maxRegexLength :: Pattern -> Maybe Int

70+maxRegexLength p =

71+ case p of

72+ PEmpty -> Just 0

73+ PChar _ _ -> Just 1

74+ PAny _ _ -> Just 1

75+ PAnyNot _ _ -> Just 1

76+ PQuest _ -> Just 0

77+ PPlus _ -> Nothing

78+ PStar _ _ -> Nothing

79+ PBound _ mhigh sch -> (*) <$> mhigh <*> maxRegexLength sch

80+ PConcat ps -> sum <$> mapM maxRegexLength ps

81+ POr xs -> maximum <$> mapM maxRegexLength xs

82+ PDot _ -> Just 1

83+ PEscape _ _ -> Just 1

84+ PCarat _ -> Just 0

85+ PDollar _ -> Just 0

86+ _ -> Just 0

87+

88+verifyTextRegexConstraint

89+ :: [DemotedTextConstraint]

90+ -> Maybe (Maybe VerifiedTextConstraint)

91+verifyTextRegexConstraint cs = do

92+ let regexps = [x | DTRegex x <- cs]

93+ case regexps of

94+ [] -> Just Nothing

95+ [x] -> do

96+ (l, mh) <- regexLength x

97+ Just $ Just $ VTRegex x (fromIntegral l) (fromIntegral <$> mh)

98+ _ -> Nothing

99+

100+verifyTextEnumConstraint

101+ :: [DemotedTextConstraint]

102+ -> Maybe (Maybe VerifiedTextConstraint)

103+verifyTextEnumConstraint cs = do

104+ let enums = concat [x | DTEnum x <- cs]

105+ case enums of

106+ [] -> Just Nothing

107+ x -> Just $ Just $ VTEnum x

108+

109+verifyTextConstraints

110+ :: [DemotedTextConstraint]

111+ -> Maybe [VerifiedTextConstraint]

112+verifyTextConstraints cs = do

113+ regexp <- verifyTextRegexConstraint cs

114+ void $

115+ case regexp of

116+ Just (VTRegex _ l mh) ->

117+ verifyTextLengthConstraints (DTGe l : cs ++ maybeToList (DTLe <$> mh))

118+ _ -> pure Nothing

119+ lengths <- verifyTextLengthConstraints cs

120+ enums <- verifyTextEnumConstraint cs

121+ return $ catMaybes [lengths, enums, regexp]

stack-13.7.yamlnew file+5

@@ -0,0 +1,5 @@

1+resolver: lts-13.7

2+extra-deps:

3+ - hjsonpointer-1.4.0@rev:0

4+ - hjsonschema-1.9.0@rev:0

5+ - validationt-0.2.1.0

stack.yaml+4−52

@@ -1,53 +1,5 @@

1−resolver: lts-9.01

2−

3−# User packages to be built.

4−# Various formats can be used as shown in the example below.

5−#

6−# packages:

7−# - some-directory

8−# - https://example.com/foo/bar/baz-0.0.2.tar.gz

9−# - location:

10−# git: https://github.com/commercialhaskell/stack.git

11−# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

12−# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a

13−# extra-dep: true

14−# subdirs:

15−# - auto-update

16−# - wai

17−#

18−# A package marked 'extra-dep: true' will only be built if demanded by a

19−# non-dependency (i.e. a user package), and its test suites and benchmarks

20−# will not be run. This is useful for tweaking upstream packages.

21−packages:

22−#- location:

23− #git: https://github.com/typeable/validationt.git

24− #commit: 24578c9fd408179358c641ee1fff0eb182591f4b

25−- '.'

26−

1+resolver: lts-12.0

272extra-deps:

28−- validationt-0.2.0.0

29−- smallcheck-series-0.6

30−

31−# Override default flag values for local packages and extra-deps

32−flags: {}

33−

34−# Extra package databases containing global packages

35−extra-package-dbs: []

36−

37−# Control whether we use the GHC we find on the path

38−# system-ghc: true

39−#

40−# Require a specific version of stack, using version ranges

41−# require-stack-version: -any # Default

42−# require-stack-version: ">=1.4"

43−#

44−# Override the architecture used by stack, especially useful on Windows

45−# arch: i386

46−# arch: x86_64

47−#

48−# Extra directories used by stack for building

49−# extra-include-dirs: [/path/to/dir]

50−# extra-lib-dirs: [/path/to/dir]

51−#

52−# Allow a newer minor version of GHC than the snapshot specifies

53−# compiler-check: newer-minor

3+ - hjsonpointer-1.4.0@rev:0

4+ - hjsonschema-1.9.0@rev:0

5+ - validationt-0.2.1.0

test/HelpersSpec.hsnew file+124

@@ -0,0 +1,124 @@

1+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}

3+{-# LANGUAGE LambdaCase #-}

5+{-# LANGUAGE DataKinds #-}

6+{-# LANGUAGE TypeApplications #-}

7+{-# LANGUAGE OverloadedStrings #-}

9+module HelpersSpec (spec, main) where

10+

11+import Control.Lens

12+import Data.ByteString.Lazy.Lens

13+import Data.Foldable

14+import Data.Monoid

15+import Data.Schematic

16+import Data.Text as T

17+import Data.Text.Lens

18+import Test.Hspec

19+

20+

21+type UUIDSchema = 'SchemaObject '[ '("uuid", 'SchemaText IsUUID) ]

22+

23+-- | Taken from UUID RFC 4122

24+uuid :: Text

25+uuid = "f81d4fae-7dec-11d0-a765-00a0c91e6bf6"

26+

27+type ISO8601DateSchema = 'SchemaObject '[ '("date", 'SchemaText IsDate) ]

28+

29+iso8601dates :: [Text]

30+iso8601dates = [ "1985-04-12" ]

31+

32+invalidIso8601dates :: [Text]

33+invalidIso8601dates = [ "1999-13-12" ]

34+

35+type ISO8601TimeSchema = 'SchemaObject '[ '("time", 'SchemaText IsTime) ]

36+

37+iso8601times :: [Text]

38+iso8601times =

39+ [ "19:23:00"

40+ , "00:00:00"

41+ , "23:47:12" ]

42+

43+invalidIso8601times :: [Text]

44+invalidIso8601times =

45+ [ "00:60:00"

46+ , "24:01:02" ]

47+

48+type ISO8601DateTimeSchema = 'SchemaObject '[ '("datetime", 'SchemaText IsDateTime) ]

49+

50+-- | Taken from ISO8601 RFC 3339

51+iso8601datetimes :: [Text]

52+iso8601datetimes =

53+ iso8601dates <>

54+ [ "1985-04-12T23:20:50.52Z"

55+ , "1996-12-19T16:39:57-08:00"

56+ , "1990-12-31T23:59:60Z"

57+ , "1990-12-31T15:59:60-08:00"

58+ , "1937-01-01T12:00:27.87+00:20"

59+ ]

60+

61+invalidIso8601datetimes :: [Text]

62+invalidIso8601datetimes =

63+ [ "1996-13-129T16:39:57-08:00"

64+ , "1990-2-31T23:59:60Z"

65+ , "1990-12-32T15:59:70"

66+ , "1937-01-1T12::27.87+24:20"

67+ ]

68+

69+spec :: Spec

70+spec = do

71+ describe "UUID: " $ do

72+ it "validates correct UUID" $ do

73+ let

74+ uuidJson = "{\"uuid\": \"" <> (uuid ^. unpacked . packedChars) <> "\" }"

75+ (decodeAndValidateJson uuidJson :: ParseResult (JsonRepr UUIDSchema))

76+ `shouldSatisfy` isValid

77+

78+ it "fails to validate incorrect UUID" $ do

79+ let

80+ incorrectJson = "{\"uuid\": \"incorrect\" }"

81+ (decodeAndValidateJson incorrectJson :: ParseResult (JsonRepr UUIDSchema))

82+ `shouldSatisfy` isValidationError

83+

84+ describe "ISO8601 date: " $ do

85+ for_ iso8601dates $ \dt -> do

86+ it ("validates correct date - " <> dt ^. unpacked) $ do

87+ let json = "{\"date\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"

88+ (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601DateSchema))

89+ `shouldSatisfy` isValid

90+

91+ for_ invalidIso8601dates $ \dt -> do

92+ it ("fails to validate incorrect date - " <> dt ^. unpacked) $ do

93+ let json = "{\"date\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"

94+ (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601DateSchema))

95+ `shouldSatisfy` isValidationError

96+

97+ describe "ISO8601 time: " $ do

98+ for_ iso8601times $ \dt -> do

99+ it ("validates correct time - " <> dt ^. unpacked) $ do

100+ let json = "{\"time\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"

101+ (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601TimeSchema))

102+ `shouldSatisfy` isValid

103+

104+ for_ invalidIso8601times $ \dt -> do

105+ it ("fails to validate incorrect time - " <> dt ^. unpacked) $ do

106+ let json = "{\"time\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"

107+ (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601TimeSchema))

108+ `shouldSatisfy` isValidationError

109+

110+ describe "ISO8601 datetime: " $ do

111+ for_ iso8601datetimes $ \dt -> do

112+ it ("validates correct datetime - " <> dt ^. unpacked) $ do

113+ let json = "{\"datetime\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"

114+ (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601DateTimeSchema))

115+ `shouldSatisfy` isValid

116+

117+ for_ invalidIso8601datetimes $ \dt -> do

118+ it ("fails to validate incorrect datetime - " <> dt ^. unpacked) $ do

119+ let json = "{\"datetime\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"

120+ (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601DateTimeSchema))

121+ `shouldSatisfy` isValidationError

122+

123+main :: IO ()

124+main = hspec spec

test/JsonSchemaSpec.hsnew file+101

@@ -0,0 +1,101 @@

1+{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE TypeApplications #-}

5+{-# LANGUAGE OverloadedLists #-}

6+{-# LANGUAGE OverloadedStrings #-}

8+module JsonSchemaSpec (spec, main) where

10+import Data.Aeson as J

11+import Data.Maybe

12+import Data.Proxy

13+import Data.ByteString.Lazy as B

14+import Data.Schematic

15+import Data.Vinyl

16+import JSONSchema.Draft4 as D4

17+import Test.Hspec

18+

19+

20+type ArraySchema = 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10])

21+

22+type ArrayField = '("foo", ArraySchema)

23+

24+type FieldsSchema =

25+ '[ ArrayField, '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]

26+

27+type SchemaExample = 'SchemaObject FieldsSchema

28+

29+exampleData :: JsonRepr SchemaExample

30+exampleData = withRepr @SchemaExample $

31+ field @"foo" [ReprNumber 13]

32+ :& field @"bar" (pure (ReprText "foo"))

33+ :& RNil

34+

35+type SchemaArrayExample = 'SchemaObject

36+ '[ '("a1", 'SchemaArray '[ 'AGt 1 ] ('SchemaNumber '[]))

37+ , '("a2", 'SchemaArray '[ 'AGe 1 ] ('SchemaNumber '[]))

38+ , '("a3", 'SchemaArray '[ 'ALt 1 ] ('SchemaNumber '[]))

39+ , '("a4", 'SchemaArray '[ 'ALe 1 ] ('SchemaNumber '[]))

40+ ]

41+

42+type SchemaNumberExample = 'SchemaObject

43+ '[ '("n1", 'SchemaNumber '[ 'NGt 1 ])

44+ , '("n2", 'SchemaNumber '[ 'NGe 1 ])

45+ , '("n3", 'SchemaNumber '[ 'NLt 1 ])

46+ , '("n4", 'SchemaNumber '[ 'NLe 1 ])

47+ ]

48+

49+type SchemaTextExample = 'SchemaObject

50+ '[ '("t1", 'SchemaText '[ 'TGt 1 ])

51+ , '("t2", 'SchemaText '[ 'TGe 1 ])

52+ , '("t3", 'SchemaText '[ 'TLt 1 ])

53+ , '("t4", 'SchemaText '[ 'TLe 1 ])

54+ ]

55+

56+spec :: Spec

57+spec = do

58+ it "validates simple schema" $ do

59+ let schema = D4.SchemaWithURI (fromJust $ toJsonSchema (Proxy @SchemaExample)) Nothing

60+ fetchHTTPAndValidate schema (toJSON exampleData) >>= \case

61+ Left _ -> fail "failed to validate test example"

62+ Right _ -> pure ()

63+ it "validates schema with arrays" $ do

64+ let

65+ schema = D4.SchemaWithURI (fromJust $ toJsonSchema (Proxy @SchemaArrayExample)) Nothing

66+ obj = withRepr @SchemaArrayExample $

67+ field @"a1" [ReprNumber 13, ReprNumber 13]

68+ :& field @"a2" [ReprNumber 13]

69+ :& field @"a3" []

70+ :& field @"a4" [ReprNumber 13]

71+ :& RNil

72+ fetchHTTPAndValidate schema (toJSON obj) >>= \case

73+ Left e -> fail "failed to validate test example"

74+ Right _ -> pure ()

75+ it "validates schema with numbers" $ do

76+ let

77+ schema = D4.SchemaWithURI (fromJust $ toJsonSchema (Proxy @SchemaNumberExample)) Nothing

78+ obj = withRepr @SchemaNumberExample $

79+ field @"n1" 1.1

80+ :& field @"n2" 1

81+ :& field @"n3" 0.9

82+ :& field @"n4" 1.0

83+ :& RNil

84+ fetchHTTPAndValidate schema (toJSON obj) >>= \case

85+ Left e -> fail "failed to validate test example"

86+ Right _ -> pure ()

87+ it "validates schema with strings" $ do

88+ let

89+ schema = D4.SchemaWithURI (fromJust $ toJsonSchema (Proxy @SchemaTextExample)) Nothing

90+ obj = withRepr @SchemaTextExample $

91+ field @"t1" "11"

92+ :& field @"t2" "1"

93+ :& field @"t3" ""

94+ :& field @"t4" "1"

95+ :& RNil

96+ fetchHTTPAndValidate schema (toJSON obj) >>= \case

97+ Left e -> fail "failed to validate test example"

98+ Right _ -> pure ()

99+

100+main :: IO ()

101+main = hspec spec

test/LensSpec.hs+280−14

@@ -1,21 +1,23 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE TypeApplications #-}

3+{-# LANGUAGE OverloadedLists #-}

4+{-# LANGUAGE OverloadedStrings #-}

16module LensSpec (spec, main) where

38import Control.Lens

4−import Data.Kind

59import Data.Proxy

610import Data.Schematic

711import Data.Vinyl

812import Test.Hspec

913

1014

11−type ArraySchema = 'SchemaArray '[AEq 1] ('SchemaNumber '[NGt 10])

15+type ArraySchema = 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10])

1216

1317type ArrayField = '("foo", ArraySchema)

1418

1519type FieldsSchema =

16− '[ ArrayField, '("bar", 'SchemaOptional ('SchemaText '[TEnum '["foo", "bar"]]))]

17−

18−type SchemaExample = 'SchemaObject FieldsSchema

20+ '[ '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]])), ArrayField]

1921

2022arrayData :: JsonRepr ArraySchema

2123arrayData = ReprArray [ReprNumber 13]

@@ -24,12 +26,276 @@ arrayField :: FieldRepr ArrayField

2426arrayField = FieldRepr arrayData

2527

2628objectData :: Rec FieldRepr FieldsSchema

27−objectData = FieldRepr arrayData

28− :& FieldRepr (ReprOptional (Just (ReprText "foo")))

29+objectData = FieldRepr (ReprOptional (Just (ReprText "foo")))

30+ :& FieldRepr arrayData

2931 :& RNil

3032

31−exampleData :: JsonRepr SchemaExample

32−exampleData = ReprObject objectData

33+type BigRecord = Rec FieldRepr

34+ '[ '("f1", 'SchemaNumber '[])

35+ , '("f2", 'SchemaNumber '[])

36+ , '("f3", 'SchemaNumber '[])

37+ , '("f4", 'SchemaNumber '[])

38+ , '("f5", 'SchemaNumber '[])

39+ , '("f6", 'SchemaNumber '[])

40+ , '("f7", 'SchemaNumber '[])

41+ , '("f8", 'SchemaNumber '[])

42+ , '("f9", 'SchemaNumber '[])

43+ , '("f10", 'SchemaNumber '[])

44+ , '("f11", 'SchemaNumber '[])

45+ , '("f12", 'SchemaNumber '[])

46+ , '("f13", 'SchemaNumber '[])

47+ , '("f14", 'SchemaNumber '[])

48+ , '("f15", 'SchemaNumber '[])

49+ , '("f16", 'SchemaNumber '[])

50+ , '("f17", 'SchemaNumber '[])

51+ , '("f18", 'SchemaNumber '[])

52+ , '("f19", 'SchemaNumber '[])

53+ , '("f20", 'SchemaNumber '[])

54+ , '("f21", 'SchemaNumber '[])

55+ , '("f22", 'SchemaNumber '[])

56+ , '("f23", 'SchemaNumber '[])

57+ , '("f24", 'SchemaNumber '[])

58+ , '("f25", 'SchemaNumber '[])

59+ , '("f26", 'SchemaNumber '[])

60+ , '("f27", 'SchemaNumber '[])

61+ , '("f28", 'SchemaNumber '[])

62+ , '("f29", 'SchemaNumber '[])

63+ , '("f30", 'SchemaNumber '[])

64+ , '("f31", 'SchemaNumber '[])

65+ , '("f32", 'SchemaNumber '[])

66+ , '("f33", 'SchemaNumber '[])

67+ , '("f34", 'SchemaNumber '[])

68+ , '("f35", 'SchemaNumber '[])

69+ , '("f36", 'SchemaNumber '[])

70+ , '("f37", 'SchemaNumber '[])

71+ , '("f38", 'SchemaNumber '[])

72+ , '("f39", 'SchemaNumber '[])

73+ , '("f40", 'SchemaNumber '[])

74+ , '("f41", 'SchemaNumber '[])

75+ , '("f42", 'SchemaNumber '[])

76+ , '("f43", 'SchemaNumber '[])

77+ , '("f44", 'SchemaNumber '[])

78+ , '("f45", 'SchemaNumber '[])

79+ , '("f46", 'SchemaNumber '[])

80+ , '("f47", 'SchemaNumber '[])

81+ , '("f48", 'SchemaNumber '[])

82+ , '("f49", 'SchemaNumber '[])

83+ , '("f50", 'SchemaNumber '[])

84+ , '("f51", 'SchemaNumber '[])

85+ , '("f52", 'SchemaNumber '[])

86+ , '("f53", 'SchemaNumber '[])

87+ , '("f54", 'SchemaNumber '[])

88+ , '("f55", 'SchemaNumber '[])

89+ , '("f56", 'SchemaNumber '[])

90+ , '("f57", 'SchemaNumber '[])

91+ , '("f58", 'SchemaNumber '[])

92+ , '("f59", 'SchemaNumber '[])

93+ , '("f60", 'SchemaNumber '[])

94+ , '("f61", 'SchemaNumber '[])

95+ , '("f62", 'SchemaNumber '[])

96+ , '("f63", 'SchemaNumber '[])

97+ , '("f64", 'SchemaNumber '[])

98+ , '("f65", 'SchemaNumber '[])

99+ , '("f66", 'SchemaNumber '[])

100+ , '("f67", 'SchemaNumber '[])

101+ , '("f68", 'SchemaNumber '[])

102+ , '("f69", 'SchemaNumber '[])

103+ , '("f70", 'SchemaNumber '[])

104+ , '("f71", 'SchemaNumber '[])

105+ , '("f72", 'SchemaNumber '[])

106+ , '("f73", 'SchemaNumber '[])

107+ , '("f74", 'SchemaNumber '[])

108+ , '("f75", 'SchemaNumber '[])

109+ , '("f76", 'SchemaNumber '[])

110+ , '("f77", 'SchemaNumber '[])

111+ , '("f78", 'SchemaNumber '[])

112+ , '("f79", 'SchemaNumber '[])

113+ , '("f80", 'SchemaNumber '[])

114+ , '("f81", 'SchemaNumber '[])

115+ , '("f82", 'SchemaNumber '[])

116+ , '("f83", 'SchemaNumber '[])

117+ , '("f84", 'SchemaNumber '[])

118+ , '("f85", 'SchemaNumber '[])

119+ , '("f86", 'SchemaNumber '[])

120+ , '("f87", 'SchemaNumber '[])

121+ , '("f88", 'SchemaNumber '[])

122+ , '("f89", 'SchemaNumber '[])

123+ , '("f90", 'SchemaNumber '[])

124+ , '("f91", 'SchemaNumber '[])

125+ , '("f92", 'SchemaNumber '[])

126+ , '("f93", 'SchemaNumber '[])

127+ , '("f94", 'SchemaNumber '[])

128+ , '("f95", 'SchemaNumber '[])

129+ , '("f96", 'SchemaNumber '[])

130+ , '("f97", 'SchemaNumber '[])

131+ , '("f98", 'SchemaNumber '[])

132+ , '("f99", 'SchemaNumber '[])

133+ , '("f100", 'SchemaNumber '[])

134+ , '("f101", 'SchemaNumber '[])

135+ , '("f102", 'SchemaNumber '[])

136+ , '("f103", 'SchemaNumber '[])

137+ , '("f104", 'SchemaNumber '[])

138+ , '("f105", 'SchemaNumber '[])

139+ , '("f106", 'SchemaNumber '[])

140+ , '("f107", 'SchemaNumber '[])

141+ , '("f108", 'SchemaNumber '[])

142+ , '("f109", 'SchemaNumber '[])

143+ , '("f110", 'SchemaNumber '[])

144+ , '("f111", 'SchemaNumber '[])

145+ , '("f112", 'SchemaNumber '[])

146+ , '("f113", 'SchemaNumber '[])

147+ , '("f114", 'SchemaNumber '[])

148+ , '("f115", 'SchemaNumber '[])

149+ , '("f116", 'SchemaNumber '[])

150+ , '("f117", 'SchemaNumber '[])

151+ , '("f118", 'SchemaNumber '[])

152+ , '("f119", 'SchemaNumber '[])

153+ , '("f120", 'SchemaNumber '[])

154+ , '("f121", 'SchemaNumber '[])

155+ , '("f122", 'SchemaNumber '[])

156+ , '("f123", 'SchemaNumber '[])

157+ , '("f124", 'SchemaNumber '[])

158+ , '("f125", 'SchemaNumber '[])

159+ , '("f126", 'SchemaNumber '[])

160+ , '("f127", 'SchemaNumber '[])

161+ , '("f128", 'SchemaNumber '[])

162+ , '("f129", 'SchemaNumber '[])

163+ , '("f130", 'SchemaNumber '[])

164+ ]

165+

166+_bigRecord :: BigRecord

167+_bigRecord =

168+ FieldRepr (ReprNumber 1)

169+ :& FieldRepr (ReprNumber 2)

170+ :& FieldRepr (ReprNumber 3)

171+ :& FieldRepr (ReprNumber 4)

172+ :& FieldRepr (ReprNumber 5)

173+ :& FieldRepr (ReprNumber 6)

174+ :& FieldRepr (ReprNumber 7)

175+ :& FieldRepr (ReprNumber 8)

176+ :& FieldRepr (ReprNumber 9)

177+ :& FieldRepr (ReprNumber 10)

178+ :& FieldRepr (ReprNumber 11)

179+ :& FieldRepr (ReprNumber 12)

180+ :& FieldRepr (ReprNumber 13)

181+ :& FieldRepr (ReprNumber 14)

182+ :& FieldRepr (ReprNumber 15)

183+ :& FieldRepr (ReprNumber 16)

184+ :& FieldRepr (ReprNumber 17)

185+ :& FieldRepr (ReprNumber 18)

186+ :& FieldRepr (ReprNumber 19)

187+ :& FieldRepr (ReprNumber 20)

188+ :& FieldRepr (ReprNumber 21)

189+ :& FieldRepr (ReprNumber 22)

190+ :& FieldRepr (ReprNumber 23)

191+ :& FieldRepr (ReprNumber 24)

192+ :& FieldRepr (ReprNumber 25)

193+ :& FieldRepr (ReprNumber 26)

194+ :& FieldRepr (ReprNumber 27)

195+ :& FieldRepr (ReprNumber 28)

196+ :& FieldRepr (ReprNumber 29)

197+ :& FieldRepr (ReprNumber 30)

198+ :& FieldRepr (ReprNumber 31)

199+ :& FieldRepr (ReprNumber 32)

200+ :& FieldRepr (ReprNumber 33)

201+ :& FieldRepr (ReprNumber 34)

202+ :& FieldRepr (ReprNumber 35)

203+ :& FieldRepr (ReprNumber 36)

204+ :& FieldRepr (ReprNumber 37)

205+ :& FieldRepr (ReprNumber 38)

206+ :& FieldRepr (ReprNumber 39)

207+ :& FieldRepr (ReprNumber 40)

208+ :& FieldRepr (ReprNumber 41)

209+ :& FieldRepr (ReprNumber 42)

210+ :& FieldRepr (ReprNumber 43)

211+ :& FieldRepr (ReprNumber 44)

212+ :& FieldRepr (ReprNumber 45)

213+ :& FieldRepr (ReprNumber 46)

214+ :& FieldRepr (ReprNumber 47)

215+ :& FieldRepr (ReprNumber 48)

216+ :& FieldRepr (ReprNumber 49)

217+ :& FieldRepr (ReprNumber 50)

218+ :& FieldRepr (ReprNumber 51)

219+ :& FieldRepr (ReprNumber 52)

220+ :& FieldRepr (ReprNumber 53)

221+ :& FieldRepr (ReprNumber 54)

222+ :& FieldRepr (ReprNumber 55)

223+ :& FieldRepr (ReprNumber 56)

224+ :& FieldRepr (ReprNumber 57)

225+ :& FieldRepr (ReprNumber 58)

226+ :& FieldRepr (ReprNumber 59)

227+ :& FieldRepr (ReprNumber 60)

228+ :& FieldRepr (ReprNumber 61)

229+ :& FieldRepr (ReprNumber 62)

230+ :& FieldRepr (ReprNumber 63)

231+ :& FieldRepr (ReprNumber 64)

232+ :& FieldRepr (ReprNumber 65)

233+ :& FieldRepr (ReprNumber 66)

234+ :& FieldRepr (ReprNumber 67)

235+ :& FieldRepr (ReprNumber 68)

236+ :& FieldRepr (ReprNumber 69)

237+ :& FieldRepr (ReprNumber 70)

238+ :& FieldRepr (ReprNumber 71)

239+ :& FieldRepr (ReprNumber 72)

240+ :& FieldRepr (ReprNumber 73)

241+ :& FieldRepr (ReprNumber 74)

242+ :& FieldRepr (ReprNumber 75)

243+ :& FieldRepr (ReprNumber 76)

244+ :& FieldRepr (ReprNumber 77)

245+ :& FieldRepr (ReprNumber 78)

246+ :& FieldRepr (ReprNumber 79)

247+ :& FieldRepr (ReprNumber 80)

248+ :& FieldRepr (ReprNumber 81)

249+ :& FieldRepr (ReprNumber 82)

250+ :& FieldRepr (ReprNumber 83)

251+ :& FieldRepr (ReprNumber 84)

252+ :& FieldRepr (ReprNumber 85)

253+ :& FieldRepr (ReprNumber 86)

254+ :& FieldRepr (ReprNumber 87)

255+ :& FieldRepr (ReprNumber 88)

256+ :& FieldRepr (ReprNumber 89)

257+ :& FieldRepr (ReprNumber 90)

258+ :& FieldRepr (ReprNumber 91)

259+ :& FieldRepr (ReprNumber 92)

260+ :& FieldRepr (ReprNumber 93)

261+ :& FieldRepr (ReprNumber 94)

262+ :& FieldRepr (ReprNumber 95)

263+ :& FieldRepr (ReprNumber 96)

264+ :& FieldRepr (ReprNumber 97)

265+ :& FieldRepr (ReprNumber 98)

266+ :& FieldRepr (ReprNumber 99)

267+ :& FieldRepr (ReprNumber 100)

268+ :& FieldRepr (ReprNumber 101)

269+ :& FieldRepr (ReprNumber 102)

270+ :& FieldRepr (ReprNumber 103)

271+ :& FieldRepr (ReprNumber 104)

272+ :& FieldRepr (ReprNumber 105)

273+ :& FieldRepr (ReprNumber 106)

274+ :& FieldRepr (ReprNumber 107)

275+ :& FieldRepr (ReprNumber 108)

276+ :& FieldRepr (ReprNumber 109)

277+ :& FieldRepr (ReprNumber 110)

278+ :& FieldRepr (ReprNumber 111)

279+ :& FieldRepr (ReprNumber 112)

280+ :& FieldRepr (ReprNumber 113)

281+ :& FieldRepr (ReprNumber 114)

282+ :& FieldRepr (ReprNumber 115)

283+ :& FieldRepr (ReprNumber 116)

284+ :& FieldRepr (ReprNumber 117)

285+ :& FieldRepr (ReprNumber 118)

286+ :& FieldRepr (ReprNumber 119)

287+ :& FieldRepr (ReprNumber 120)

288+ :& FieldRepr (ReprNumber 121)

289+ :& FieldRepr (ReprNumber 122)

290+ :& FieldRepr (ReprNumber 123)

291+ :& FieldRepr (ReprNumber 124)

292+ :& FieldRepr (ReprNumber 125)

293+ :& FieldRepr (ReprNumber 126)

294+ :& FieldRepr (ReprNumber 127)

295+ :& FieldRepr (ReprNumber 128)

296+ :& FieldRepr (ReprNumber 129)

297+ :& FieldRepr (ReprNumber 130)

298+ :& RNil

33299

34300spec :: Spec

35301spec = do

@@ -37,16 +303,16 @@ spec = do

37303 newFooVal = FieldRepr $ ReprArray [ReprNumber 15]

38304 fooProxy = Proxy @"foo"

39305 it "gets the field from an object" $ do

40− fget fooProxy objectData == arrayField

306+ fget @"foo" objectData `shouldBe` arrayField

41307 it "sets the object field" $ do

42− fget fooProxy (fput newFooVal objectData) == newFooVal

308+ fget @"foo" (fput newFooVal objectData) `shouldBe` newFooVal

43309

44310 describe "(using lens library) " $ do

45311 it "get the field from an object" $ do

46− objectData ^. flens (Proxy @"foo") == arrayField

312+ objectData ^. flens @"foo" `shouldBe` arrayField

47313 it "sets the object field" $ do

48− set (flens (Proxy @"foo")) newFooVal objectData ^. flens (Proxy @"foo")

49− == newFooVal

314+ set (flens @"foo") newFooVal objectData ^. flens @"foo"

315+ `shouldBe` newFooVal

50316

51317main :: IO ()

52318main = hspec spec

test/SchemaSpec.hs+78−55

@@ -1,47 +1,78 @@

11{-# OPTIONS_GHC -fprint-potential-instances #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE OverloadedLists #-}

7+{-# LANGUAGE OverloadedStrings #-}

8+{-# LANGUAGE RankNTypes #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TypeApplications #-}

11+

312module SchemaSpec (spec, main) where

413

5−import Control.Monad

6−import Data.ByteString.Lazy

14+import Control.Lens

715import Data.Aeson

16+import Data.ByteString.Lazy

17+import Data.Functor.Identity

818import Data.Proxy

919import Data.Schematic

20+import Data.Schematic.Generator

1021import Data.Singletons

11−import Data.Singletons.Prelude

22+import Data.Tagged

1223import Data.Vinyl

1324import Test.Hspec

1425import Test.Hspec.SmallCheck

15−import Test.SmallCheck

16−import Test.SmallCheck.Series.Instances

17−

18−

19−type SchemaExample

20− = 'SchemaObject

21− '[ '("foo", 'SchemaArray '[AEq 1] ('SchemaNumber '[NGt 10]))

22− , '("bar", 'SchemaOptional ('SchemaText '[TEnum '["foo", "bar"]]))]

26+import Test.SmallCheck as SC

27+import Test.SmallCheck.Drivers as SC

28+import Test.SmallCheck.Series as SC

2329

24−type TestMigration =

25− 'Migration "test_revision"

26− '[ 'Diff '[ 'PKey "bar" ] ('Update ('SchemaText '[]))

27− , 'Diff '[ 'PKey "foo" ] ('Update ('SchemaNumber '[])) ]

30+import Debug.Trace

2831

29−type VS = 'Versioned SchemaExample '[ TestMigration ]

32+type SchemaExample = 'SchemaObject

33+ '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]))

34+ , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]

3035

31−exampleTest :: JsonRepr (SchemaOptional (SchemaText '[TEq 3]))

32−exampleTest = ReprOptional (Just (ReprText "lil"))

33−

34−exampleNumber :: JsonRepr (SchemaNumber '[NGt 10])

35−exampleNumber = ReprNumber 12

36−

37−exampleArray :: JsonRepr (SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))

38−exampleArray = ReprArray [exampleNumber]

36+type SchemaExample2 = 'SchemaObject

37+ '[ '("foo", 'SchemaArray '[ 'AEq 2] ('SchemaText '[ 'TGt 10]))

38+ , '("bar", 'SchemaOptional ('SchemaText '[ 'TRegex "[0-9]+"]))]

3939

4040jsonExample :: JsonRepr SchemaExample

41−jsonExample = ReprObject $

42− FieldRepr (ReprArray [ReprNumber 12])

43− :& FieldRepr (ReprOptional (Just (ReprText "bar")))

44− :& RNil

41+jsonExample = withRepr @SchemaExample

42+ $ field @"bar" (Just "bar")

43+ :& field @"foo" [12]

44+ :& RNil

45+

46+type AddQuuz =

47+ 'Migration "add_field_quuz"

48+ '[ 'Diff '[] ('AddKey "quuz" (SchemaNumber '[])) ]

49+

50+type DeleteQuuz =

51+ 'Migration "remove_field_quuz"

52+ '[ 'Diff '[] ( 'DeleteKey "quuz") ]

53+

54+type SwapFields =

55+ 'Migration "swap_fields"

56+ '[ 'Diff '[ 'PKey "bar" ] ('Update

57+ ('SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10])))

58+ , 'Diff '[ 'PKey "foo" ] ('Update

59+ ('SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))) ]

60+

61+type Migrations = '[ AddQuuz

62+ , DeleteQuuz ]

63+ -- , SwapFields ]

64+

65+type VersionedJson = 'Versioned SchemaExample Migrations

66+

67+migrationList :: MigrationList Identity VersionedJson

68+migrationList

69+ = (migrateObject (\r -> Identity $ field @"quuz" 42 :& r))

70+ :&& shrinkObject

71+ -- :&& (migrateObject (\r -> Identity

72+ -- $ field @"foo" (r ^. flens (Proxy @"bar") . _Just . optionalRepr)

73+ -- :& field @"bar" (r ^. flens (Proxy @"foo") . arrayRepr)

74+ -- :& RNil))

75+ :&& MNil

4576

4677schemaJson :: ByteString

4778schemaJson = "{\"foo\": [13], \"bar\": null}"

@@ -49,26 +80,11 @@ schemaJson = "{\"foo\": [13], \"bar\": null}"

4980schemaJson2 :: ByteString

5081schemaJson2 = "{\"foo\": [3], \"bar\": null}"

5182

52−schemaJsonTopVersion :: ByteString

53−schemaJsonTopVersion = "{ \"foo\": 42, \"bar\": \"bar\" }"

54−

55−topObject

56− :: JsonRepr

57− ('SchemaObject

58− '[ '("foo", 'SchemaNumber '[])

59− , '("bar", 'SchemaText '[])])

60−topObject = ReprObject $

61− FieldRepr (ReprNumber 42)

62− :& FieldRepr (ReprText "test")

63− :& RNil

64−

65−instance

66− MigrateSchema

67− SchemaExample

68− ('SchemaObject

69− '[ '("foo", 'SchemaNumber '[]), '("bar", 'SchemaText '[])])

70− where

71− migrate = const topObject

83+schemaJsonSeries :: Monad m => SC.Series m (JsonRepr SchemaExample)

84+schemaJsonSeries = series

85+

86+schemaJsonSeries2 :: Monad m => SC.Series m (JsonRepr SchemaExample2)

87+schemaJsonSeries2 = series

7288

7389spec :: Spec

7490spec = do

@@ -85,15 +101,22 @@ spec = do

85101 it "validates incorrect representation" $

86102 ((decodeAndValidateJson schemaJson2) :: ParseResult (JsonRepr SchemaExample))

87103 `shouldSatisfy` isValidationError

88− it "validates versioned json" $ do

89− decodeAndValidateVersionedJson (Proxy @VS) schemaJson

90− `shouldSatisfy` isValid

91− it "validates with Migration List" $ do

92− decodeAndValidateVersionedWithMList

93− (Proxy @VS)

94− ((:&&) (Proxy @(SchemaByRevision "test_revision" VS)) (const topObject) MNil)

104+ -- it "validates versioned json" $ do

105+ -- decodeAndValidateVersionedJson (Proxy @VS) schemaJson

106+ -- `shouldSatisfy` isValid

107+ it "validates versioned json with a migration list" $ do

108+ decodeAndValidateVersionedWithPureMList

109+ (Proxy @VersionedJson)

110+ migrationList

95111 schemaJson

96112 `shouldSatisfy` isValid

113+ it "validates json series" $ property $

114+ SC.over schemaJsonSeries $ \x ->

115+ isValid (parseAndValidateJson @SchemaExample (toJSON x))

116+ it "validates json series 2" $ property $

117+ SC.over schemaJsonSeries2 $ \x ->

118+ isValid (parseAndValidateJson @SchemaExample2 (toJSON x))

119+

97120

98121main :: IO ()

99122main = hspec spec