master..81dfa91 · typeable/schematic

git.iko.soy/typeable/schematic

on 81dfa91 help sign in

.travis.yml+2−2

since splitsnapshots

unifiedsplit

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

1−sudo: required

1+sudo: false

3language: c

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

23cache:

24 directories:

25− - $HOME/.stack

25+ - $HOME/.stack

ChangeLog.md−61

@@ -1,66 +1,5 @@

1# Revision history for schematic

3−## 0.6.0.0 -- 2021-01-15

4−

5−Added compatability with aeson-1.4.3.0. Since version 1.4.3 the module `Data.Aeson` started exporting `JSONPath`, which was conflicting with our own `JSONPath`. Furthermore, started using `JSONPathElement` from `aeson` instead of `DemotedPathSegment`.

6−

7−## 0.5.1.0 -- 2021-01-15

8−

9−Fix the generation of json schema for numbers.

10−Add array constraints.

11−Fix the generation of text and number constraints.

12−Remove jsonpath from the error message.

13−

14−## 0.5.0.0 -- 2019-02-20

15−

16−GHC 8.6, json generation by schema definition, validation bug fixes, better

17−parsing error messages.

18−

19−## 0.4.3.0 -- 2018-07-12

20−

21−GHC 8.4 support, dropping support for older GHC versions

22−

23−## 0.4.2.0

24−

25−Support ghc-8.4 and drop support for older versions

26−

27−## 0.4.1.0 -- 2017-11-05

28−

29−Convenience isomorphisms: txt, num, opt, bln etc

30−

31−## 0.4.1.0 -- 2017-11-01

32−

33−flens and fget now use type application syntax

34−

35−## 0.4.0.0 -- 2017-10-17

36−

37−Object building DSL, more convenience helpers, MCons simplified with Tagged

38−

39−## 0.3.2.0 -- 2017-10-02

40−

41−Fixed FIndex bug, added bunch of convenience isomorphism, re-exports.

42−

43−## 0.3.1.0 -- 2017-09-28

44−

45−Add UUID and ISO8601 helpers, json schema constraint export, fsubset lens

46−combinator.

47−

48−## 0.3.0.0 -- 2017-09-28

49−

50−Updated to GHC 8.2.1 and singletons 2.3.1

51−

52−## 0.2.1.0 -- 2017-09-26

53−

54−Add decodeAndValidateVersionedWithPureMList, fix tests

55−

56−## 0.2.0.0 -- 2017-09-26

57−

58−Migratable is deprecated, migrations are now possible in an arbitrary monad.

59−

60−## 0.1.5.0 -- 2017-08-22

61−

62−Lens compatibility for typed json objects.

63−

64## 0.1.0.0 -- YYYY-mm-dd

3## 0.1.0.0 -- YYYY-mm-dd

66* First version. Released on an unsuspecting world.

5* First version. Released on an unsuspecting world.

README.md+33−175

@@ -1,16 +1,23 @@

1# schematic

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

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

5## Goal

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

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

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 a roundtrip property by an implementation.

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

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

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

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−* Schematic schemas can be exported to [json-schema](http://json-schema.org)

13+

14+## TODO

15+

16+* Making a migration system more usable. It should allow it to be used as a json safecopy solution minus the boilerplate.

17+* Describing versioned http endpoints

18+* Schema pretty-printing

19+* More validators

20+* Overall user friendliness

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

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

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

22$ stack install schematic

29$ stack install schematic

23```

30```

25−## GHC Extensions

26−

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

28−either to a module or a cabal file:

29−

30−```

31−DataKinds

32−OverloadedLists

33−OverloadedStrings

34−TypeApplications

35−```

36−

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

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

39−

40−## GHC Options

41−

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

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

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

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

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

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

48−the same reason.

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

50−

51## Basic Examples

32## Basic Examples

53−```haskell

34+```

54type SchemaExample

35type SchemaExample

55 = SchemaObject

36 = SchemaObject

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

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

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

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

58```

39```

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

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

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

42+ * field "foo" contains an of numeric values

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

43+ * field "bar" contains an optional textual value

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

44+* It also allows you to validate the JSON:

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

45+ * an array in "foo" must contain exactly one element

65 * that element must be strictly greater than 10

46 * that element must be strictly greater than 10

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

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

69This one is valid for example

50This one is valid for example

71−```haskell

52+```

72schemaJson :: ByteString

53schemaJson :: ByteString

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

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

74```

55```

76Also valid

57Also valid

78−```haskell

59+```

79schemaJson :: ByteString

60schemaJson :: ByteString

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

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

81```

62```

83it can be parsed and validated like this:

64it can be parsed and validated like this:

85−```haskell

66+```

86decodeAndValidateJson schemaJson :: ParseResult (JsonRepr SchemaExample)

67decodeAndValidateJson schemaJson :: ParseResult (JsonRepr SchemaExample)

87```

68```

89`ParseResult` type encodes three possible situations:

70`ParseResult` type encodes three possible situations:

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

71+* json is structurally consistent with schema and runtime validations passed

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

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

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

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

93− overall

94−

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

96−and transformed to whatever internal types user has.

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

99−```haskell

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

100−jsonExample :: JsonRepr SchemaExample

101−jsonExample = withRepr @SchemaExample

102− $ field @"foo" [12]

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

104− :& RNil

105−```

106

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

108

109```

78```

110−jsonExample' :: JsonRepr SchemaExample

79+jsonExample :: JsonRepr SchemaExample

111−jsonExample' = ReprObject $

80+jsonExample = ReprObject $

112 FieldRepr (ReprArray [ReprNumber 12])

81 FieldRepr (ReprArray [ReprNumber 12])

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

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

114 :& RNil

83 :& RNil

115```

84```

116

117−## Lens-compatibility

118−

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

120−

121−```haskell

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

123−

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

125−

126−type FieldsSchema =

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

128−

129−type SchemaExample = 'SchemaObject FieldsSchema

130−

131−```

132−

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

134−

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

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

137−

138## Migrations

86## Migrations

139

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

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

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,

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

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

92+```

153type SchemaExample

93type SchemaExample

154 = SchemaObject

94 = SchemaObject

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

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

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

157

158type TestMigration =

98type TestMigration =

159 'Migration "test_revision"

99 'Migration "test_revision"

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

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

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

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

162

102

163type VS = 'Versioned SchemaExample '[ TestMigration ]

103type VS = 'Versioned SchemaExample '[ TestMigration ]

164

104

@@ -171,85 +111,3 @@ It's possible to decode the latest version like this:

171```

111```

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

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

173```

113```

174−

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

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

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

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

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

180−

181−```haskell

182−type SchemaExample = 'SchemaObject

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

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

185−

186−jsonExample :: JsonRepr SchemaExample

187−jsonExample = withRepr @SchemaExample

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

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

190− :& RNil

191−

192−type AddQuuz =

193− 'Migration "add_field_quuz"

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

195−

196−type DeleteQuuz =

197− 'Migration "remove_field_quuz"

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

199−

200−type Migrations = '[ AddQuuz

201− , DeleteQuuz ]

202−

203−type VersionedJson = 'Versioned SchemaExample Migrations

204−

205−migrationList :: MigrationList Identity VersionedJson

206−migrationList

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

208− :&& shrinkObject

209− :&& MNil

210−

211−```

212−

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

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

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

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

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

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

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

220−appropriate by a user.

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

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

223−

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

225−

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

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

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

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

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

231−look like this:

232−

233−```haskell

234−type SchemaExample = 'SchemaObject

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

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

237−

238−jsonExample = withRepr @SchemaExample

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

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

241− :& RNil

242−```

243−

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

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

246−makes it syntactically more terse.

247−

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

249−

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

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

252−example.

253−

254−

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

releasedeleted−43

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

1−#!/bin/bash

2−

3−set -o xtrace

4−

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

6−

7−rootdir=`pwd`

8−

9−cabalfile=`ls *.cabal`

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

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

12−

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

14−stack test 2> /dev/null

15−

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

17−cabal sdist

18−

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

20−stack haddock 2> /dev/null

21−

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

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

24− read -p "Hackage username: " username

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

26− echo ""

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

28−

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

30−

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

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

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

34− cd $docdir

35− cd ..

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

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

38− cd $rootdir

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

40− exit $?

41−else

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

43−fi

release.nixdeleted−32

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

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

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

3−}:

4−

5−let

6− _nixpkgs = import <nixpkgs> {};

7− inherit (_nixpkgs) pkgs lib;

8−

9− stackageOverlayPath = pkgs.fetchFromGitHub {

10− owner = "typeable";

11− repo = "nixpkgs-stackage";

12− rev = "abe0a03ba2bde609b0707ce45301ec836cb3ed29";

13− sha256 = "0ksdk83zbsgvs30izwsfyjh4xxwz8dsn9a5igrs3pjap4whpzqfv";

14− };

15−

16− nixpkgsArgs = {

17− overlays = [ (import stackageOverlayPath) ];

18− };

19−

20− release = import <nixpkgs/pkgs/top-level/release-lib.nix> { inherit nixpkgsArgs supportedSystems; };

21−

22− mkStackage = system:

23− let

24− nixpkgs = release.pkgsFor system;

25− stackage = nixpkgs.haskell.packages.stackage.lib.callStackage2nix "schematic" schematicSrc { inherit nixpkgs; };

26− in

27− stackage;

28−

29−in

30− lib.genAttrs supportedSystems (system: {

31− inherit (mkStackage system) schematic;

32− })

schematic.cabal+46−45

@@ -1,43 +1,35 @@

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

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

1name: schematic

4name: schematic

2−version: 0.6.0.0

5+version: 0.1.3.0

3synopsis: JSON-biased spec and validation tool

6synopsis: JSON-biased spec and validation tool

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

7+-- description:

5license: BSD3

8license: BSD3

6license-file: LICENSE

9license-file: LICENSE

7author: Denis Redozubov

10author: Denis Redozubov

8maintainer: denis.redozubov@gmail.com

11maintainer: denis.redozubov@gmail.com

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

12+-- copyright:

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

11category: Data

13category: Data

12build-type: Simple

14build-type: Simple

13−extra-source-files: ChangeLog.md, README.md

15+extra-source-files: ChangeLog.md

14cabal-version: >=1.10

16cabal-version: >=1.10

16library

18library

17 exposed-modules: Data.Schematic

19 exposed-modules: Data.Schematic

18− , Data.Schematic.DSL

19− , Data.Schematic.Generator

20− , Data.Schematic.Generator.Regex

21 , Data.Schematic.Instances

20 , Data.Schematic.Instances

22− , Data.Schematic.JsonSchema

23− , Data.Schematic.Helpers

24− , Data.Schematic.Lens

25 , Data.Schematic.Migration

21 , Data.Schematic.Migration

26 , Data.Schematic.Path

22 , Data.Schematic.Path

27 , Data.Schematic.Schema

23 , Data.Schematic.Schema

28 , Data.Schematic.Validation

24 , Data.Schematic.Validation

29− , Data.Schematic.Verifier

25+ , Data.Schematic.Utils

30− , Data.Schematic.Verifier.Array

31− , Data.Schematic.Verifier.Common

32− , Data.Schematic.Verifier.Number

33− , Data.Schematic.Verifier.Text

34 ghc-options: -Wall

26 ghc-options: -Wall

27+ -- other-modules:

35 default-extensions: ConstraintKinds

28 default-extensions: ConstraintKinds

36 , DataKinds

29 , DataKinds

37 , DefaultSignatures

30 , DefaultSignatures

38 , DeriveFunctor

31 , DeriveFunctor

39 , DeriveFoldable

32 , DeriveFoldable

40− , DeriveTraversable

41 , DeriveGeneric

33 , DeriveGeneric

42 , DeriveDataTypeable

34 , DeriveDataTypeable

43 , FlexibleContexts

35 , FlexibleContexts

@@ -60,29 +52,22 @@ library

60 , TemplateHaskell

52 , TemplateHaskell

61 , TypeApplications

53 , TypeApplications

62 , TypeFamilies

54 , TypeFamilies

63− , TypeFamilyDependencies

64 , TypeInType

55 , TypeInType

65 , TypeOperators

56 , TypeOperators

66 , TypeSynonymInstances

57 , TypeSynonymInstances

67 , UndecidableInstances

58 , UndecidableInstances

68− build-depends: base >=4.11 && <5

59+ build-depends: base >=4.9 && <4.10

69 , bytestring

60 , bytestring

70− , aeson >= 1.4.3.0 && < 1.6

61+ , aeson >= 1

71− , containers

72− , hjsonschema

73− , mtl

74− , profunctors

75− , regex-tdfa

62+ , regex-compat

76− , regex-tdfa-text

77 , scientific

63 , scientific

78− , singletons >= 2.4

64+ , singletons

79 , smallcheck

65 , smallcheck

66+ , smallcheck-series

80 , tagged

67 , tagged

81− , template-haskell

82 , text

68 , text

83− , union

84 , unordered-containers

69 , unordered-containers

85− , validationt >= 0.2.1.0

70+ , validationt >= 0.1.0.1

86 , vector

71 , vector

87 , vinyl

72 , vinyl

88 hs-source-dirs: src

73 hs-source-dirs: src

@@ -93,32 +78,48 @@ test-suite spec

93 hs-source-dirs: test

78 hs-source-dirs: test

94 main-is: Spec.hs

79 main-is: Spec.hs

95 default-language: Haskell2010

80 default-language: Haskell2010

81+ default-extensions: ConstraintKinds

82+ , DataKinds

83+ , DeriveFunctor

84+ , DeriveFoldable

85+ , DeriveGeneric

86+ , DeriveDataTypeable

87+ , FlexibleContexts

88+ , FlexibleInstances

89+ , FunctionalDependencies

90+ , GADTs

91+ , KindSignatures

92+ , InstanceSigs

93+ , MultiParamTypeClasses

94+ , OverloadedLists

95+ , OverloadedStrings

96+ , PolyKinds

97+ , QuasiQuotes

98+ , PartialTypeSignatures

99+ , RecordWildCards

100+ , ScopedTypeVariables

101+ , TemplateHaskell

102+ , TypeApplications

103+ , TypeFamilies

104+ , TypeInType

105+ , TypeOperators

106+ , TypeSynonymInstances

96 build-depends: HUnit

107 build-depends: HUnit

97 , aeson >= 1

108 , aeson >= 1

98− , base >=4.11 && <4.13

109+ , base >=4.9 && <4.10

99 , bytestring

110 , bytestring

100− , containers

101− , hjsonschema

102 , hspec >= 2.2.0

111 , hspec >= 2.2.0

103 , hspec-core

112 , hspec-core

104 , hspec-discover

113 , hspec-discover

105 , hspec-smallcheck

114 , hspec-smallcheck

106− , lens

107− , regex-tdfa

115+ , regex-compat

108− , regex-tdfa-text

109 , schematic

116 , schematic

110 , smallcheck

117 , smallcheck

118+ , smallcheck-series

111 , singletons

119 , singletons

112 , tagged

120 , tagged

113 , text

121 , text

114 , unordered-containers

122 , unordered-containers

115− , validationt >= 0.2.1.0

123+ , validationt >= 0.1.0.1

116 , vinyl

124 , vinyl

117− other-modules: SchemaSpec

125+ other-modules: SchemaSpec

118− , HelpersSpec

119− , LensSpec

120− , JsonSchemaSpec

121−

122−source-repository head

123− type: git

124− location: https://github.com/typeable/schematic

src/Data/Schematic.hs+82−40

@@ -2,43 +2,60 @@

2{-# LANGUAGE AllowAmbiguousTypes #-}

4module Data.Schematic

5− ( module Data.Schematic.JsonSchema

5+ ( module Data.Schematic.Schema

6− , module Data.Schematic.Helpers

7− , module Data.Schematic.Lens

8 , module Data.Schematic.Migration

6 , module Data.Schematic.Migration

9− , module Data.Schematic.Schema

7+ , module Data.Schematic.Utils

10 , decodeAndValidateJson

8 , decodeAndValidateJson

11 , parseAndValidateJson

9 , parseAndValidateJson

12 , parseAndValidateJsonBy

10 , parseAndValidateJsonBy

11+ , parseAndValidateVersionedJson

13 , parseAndValidateTopVersionJson

12 , parseAndValidateTopVersionJson

13+ , decodeAndValidateVersionedJson

14 , parseAndValidateWithMList

15 , decodeAndValidateVersionedWithMList

16− , decodeAndValidateVersionedWithPureMList

17 , isValid

16 , isValid

18 , isDecodingError

17 , isDecodingError

19 , isValidationError

18 , isValidationError

20 , ParseResult(..)

19 , ParseResult(..)

21− , withRepr

20+ , Migratable

22− , field

23 ) where

21 ) where

25import Control.Monad.Validation

23import Control.Monad.Validation

26import Data.Aeson as J

24import Data.Aeson as J

27import Data.Aeson.Types as J

25import Data.Aeson.Types as J

28import Data.ByteString.Lazy as BL

26import Data.ByteString.Lazy as BL

29−import Data.Functor.Identity as F

27+import Data.Functor.Identity

30−import Data.Schematic.DSL

31−import Data.Schematic.Helpers

32−import Data.Schematic.JsonSchema

33−import Data.Schematic.Lens

34import Data.Schematic.Migration

28import Data.Schematic.Migration

35import Data.Schematic.Schema

29import Data.Schematic.Schema

30+import Data.Schematic.Utils

36import Data.Schematic.Validation

31import Data.Schematic.Validation

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

32+import Data.Singletons.Prelude

38−import Data.Tagged

39import Data.Text as T

33import Data.Text as T

36+parseAndValidateJson

37+ :: forall schema

38+ . (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)

39+ => J.Value

40+ -> ParseResult (JsonRepr schema)

41+parseAndValidateJson v =

42+ case parseEither parseJSON v of

43+ Left s -> DecodingError $ T.pack s

44+ Right jsonRepr ->

45+ let

46+ validate = validateJsonRepr (sing :: Sing schema) [] jsonRepr

47+ res = runIdentity . runValidationTEither $ validate

48+ in case res of

49+ Left em -> ValidationError em

50+ Right () -> Valid jsonRepr

51+

52+parseAndValidateJsonBy

53+ :: (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)

54+ => proxy schema

55+ -> J.Value

56+ -> ParseResult (JsonRepr schema)

57+parseAndValidateJsonBy _ = parseAndValidateJson

58+

42parseAndValidateTopVersionJson

59parseAndValidateTopVersionJson

43 :: forall proxy (v :: Versioned)

60 :: forall proxy (v :: Versioned)

44 . (SingI (TopVersion (AllVersions v)))

61 . (SingI (TopVersion (AllVersions v)))

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

57 Left em -> ValidationError em

74 Left em -> ValidationError em

58 Right () -> Valid jsonRepr

75 Right () -> Valid jsonRepr

77+class Migratable (revisions :: [(Revision, Schema)]) where

78+ mparse

79+ :: Sing revisions

80+ -> J.Value

81+ -> ParseResult (JsonRepr (Snd (Head revisions)))

82+

83+instance

84+ {-# OVERLAPPING #-}

85+ ( TopLevel (Snd rev), SingI (Snd rev) )

86+ => Migratable '[rev] where

87+ mparse _ = parseAndValidateJson

88+

89+instance {-# OVERLAPPABLE #-}

90+ ( Migratable (Tail revisions)

91+ , MigrateSchema (Snd (Head (Tail revisions))) (Snd (Head revisions))

92+ , SingI (Snd (Head revisions)))

93+ => Migratable revisions where

94+ mparse s v = case parseEither parseJSON v of

95+ Left _ ->

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

97+ Right x -> Valid x

98+

99+parseAndValidateVersionedJson

100+ :: forall proxy v. (SingI (AllVersions v), Migratable (AllVersions v))

101+ => proxy v

102+ -> J.Value

103+ -> ParseResult (JsonRepr (Snd (Head (AllVersions v))))

104+parseAndValidateVersionedJson _ v = mparse (sing :: Sing (AllVersions v)) v

105+

60parseAndValidateWithMList

106parseAndValidateWithMList

61− :: Monad m

62− => MList m revisions

107+ :: MList revisions

63 -> J.Value

108 -> J.Value

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

109+ -> ParseResult (JsonRepr (Head revisions))

65−parseAndValidateWithMList MNil v = pure $ parseAndValidateJson v

110+parseAndValidateWithMList MNil v = parseAndValidateJson v

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

67− case parseAndValidateJsonBy Proxy v of

111+parseAndValidateWithMList ((:&&) p f tl) v = case parseAndValidateJsonBy p v of

68− Valid a -> pure $ Valid a

112+ Valid a -> Valid a

69− DecodingError _ -> do

113+ DecodingError _ -> f <$> parseAndValidateWithMList tl v

70− pr <- parseAndValidateWithMList tl v

71− let pr' = f <$> pr

72− sequence pr'

73− ValidationError _ -> do

114+ ValidationError _ -> f <$> parseAndValidateWithMList tl v

74− pr <- parseAndValidateWithMList tl v

75− let pr' = f <$> pr

76− sequence pr'

115

78decodeAndValidateJson

116decodeAndValidateJson

79 :: forall schema

117 :: forall schema

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

84 Nothing -> DecodingError "malformed json"

122 Nothing -> DecodingError "malformed json"

85 Just x -> parseAndValidateJson x

123 Just x -> parseAndValidateJson x

124

87−decodeAndValidateVersionedWithMList

125+decodeAndValidateVersionedJson

88− :: Monad m

126+ :: (Migratable (AllVersions versioned), SingI (AllVersions versioned))

89 => proxy versioned

127 => proxy versioned

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

91 -> BL.ByteString

128 -> BL.ByteString

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

129+ -> ParseResult (JsonRepr (Snd (Head (AllVersions versioned))))

93−decodeAndValidateVersionedWithMList _ mlist bs = case decode bs of

130+decodeAndValidateVersionedJson vp bs = case decode bs of

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

131+ Nothing -> DecodingError "malformed json"

95− Just x -> parseAndValidateWithMList mlist x

132+ Just x -> parseAndValidateVersionedJson vp x

133

97−decodeAndValidateVersionedWithPureMList

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

135+ MapSnd '[] = '[]

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

137+

138+decodeAndValidateVersionedWithMList

98 :: proxy versioned

139 :: proxy versioned

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

140+ -> MList (MapSnd (AllVersions versioned))

100 -> BL.ByteString

141 -> BL.ByteString

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

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

102−decodeAndValidateVersionedWithPureMList a b c =

103− runIdentity $ decodeAndValidateVersionedWithMList a b c

143+decodeAndValidateVersionedWithMList _ mlist bs = case decode bs of

144+ Nothing -> DecodingError "malformed json"

145+ Just x -> parseAndValidateWithMList mlist x

src/Data/Schematic/DSL.hsdeleted−92

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

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE CPP #-}

3−

4−module Data.Schematic.DSL where

5−

6−import Data.Kind

7−import Data.Schematic.Lens

8−import Data.Schematic.Schema

9−import Data.Scientific

10−import Data.Singletons

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

12−import Data.Singletons.TypeLits

13−import Data.Tagged

14−import Data.Text as T

15−import Data.Union

16−import qualified Data.Vector as V

17−import Data.Vinyl

18−import Data.Vinyl.Functor

19−

20−

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

22−type Constructor a

23− = forall fields b

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

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

26− -> JsonRepr ('SchemaObject fields)

27−#else

28−type Constructor a

29− = forall fields b

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

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

32− -> JsonRepr ('SchemaObject fields)

33−#endif

34−withRepr :: Constructor a

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

36−

37−class Representable s where

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

39−

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

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

42−

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

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

45−

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

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

48−

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

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

51−

52−instance Representable 'SchemaBoolean where

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

54−

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

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

57−

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

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

60−

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

62−construct s r = case s of

63− SSchemaObject _ -> ReprObject r

64− SSchemaArray _ _ -> ReprArray r

65− SSchemaText _ -> ReprText r

66− SSchemaNumber _ -> ReprNumber r

67− SSchemaBoolean -> ReprBoolean r

68− SSchemaOptional _ -> ReprOptional r

69− SSchemaNull -> ReprNull

70− SSchemaUnion ss -> case ss of

71− SNil -> error "unconstructable union"

72− SCons _ _ -> ReprUnion r

73−

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

75− FieldsOf ('SchemaObject fs) = fs

76−

77−type FieldConstructor fn =

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

79− => Repr byField

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

81−

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

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

84−

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

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

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

88− Repr ('SchemaText cs) = Text

89− Repr ('SchemaNumber cs) = Scientific

90− Repr 'SchemaBoolean = Bool

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

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

src/Data/Schematic/Generator.hsdeleted−91

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

1−module Data.Schematic.Generator where

2−

3−import Data.Maybe

4−import Data.Schematic.Generator.Regex

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

6−import Data.Schematic.Verifier

7−import Data.Scientific

8−import Data.Text (Text, pack)

9−import qualified Data.Vector as V

10−import Test.SmallCheck.Series

11−

12−maxHigh :: Int

13−maxHigh = 30

14−

15−minLow :: Int

16−minLow = 2

17−

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

19−textLengthSeries =

20− \case

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

22− [VTBounds ml mh] -> do

23− let

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

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

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

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

28− _ -> pure "error"

29−

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

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

32−

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

34−textSeries cs = do

35− let mvcs = verifyTextConstraints cs

36− case mvcs of

37− Just vcs -> do

38− n <- textSeries' vcs

39− pure n

40− Nothing -> pure "error"

41−

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

43−textSeries' [] = pure "sample"

44−textSeries' vcs = do

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

46− case enums of

47− Just e -> textEnumSeries e

48− Nothing -> do

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

50− case regexps of

51− Just e -> regexSeries e

52− Nothing -> textLengthSeries vcs

53−

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

55−numberSeries cs = do

56− let mvcs = verifyNumberConstraints cs

57− case mvcs of

58− Just vcs -> do

59− n <- numberSeries' vcs

60− pure $ n

61− Nothing -> pure 0

62−

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

64−numberSeries' =

65− \case

66− VNEq eq -> pure $ fromIntegral eq

67− VNBounds ml mh -> do

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

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

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

71− pure $ fromIntegral n

72−

73−arraySeries

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

75− => [DemotedArrayConstraint]

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

77−arraySeries cs = do

78− let mvcs = verifyArrayConstraint cs

79− case mvcs of

80− Just vcs -> arraySeries' vcs

81− Nothing -> pure V.empty

82−

83−arraySeries'

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

85− => Maybe VerifiedArrayConstraint

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

87−arraySeries' ml = do

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

89− pure $ objs

90− where

91− f (VAEq l) = fromIntegral l

src/Data/Schematic/Generator/Regex.hsdeleted−76

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

1−module Data.Schematic.Generator.Regex where

2−

3−import Control.Monad

4−import Data.List

5−import Data.Maybe

6−import qualified Data.Set as S

7−import Data.Text (Text, unpack)

8−import Data.Text.Lazy (toStrict)

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

10−import Test.SmallCheck.Series

11−import Text.Regex.TDFA.Pattern

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

13−

14−

15−minRepeat :: Int

16−minRepeat = 2

17−

18−maxRepeat :: Int

19−maxRepeat = 10

20−

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

22−regexSeries regexp =

23− case parseRegex . unpack $ regexp of

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

25− Left _ -> pure ""

26−

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

28−regexSeries' pt =

29− case pt of

30− PEmpty -> pure mempty

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

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

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

34− pure $ singleton x

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

36− x <-

37− generate $ \depth ->

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

39− pure $ singleton x

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

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

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

43− PBound low mhigh p -> do

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

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

46− decDepth $ do

47− ps <- replicateM n $ regexSeries' p

48− pure $ mconcat ps

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

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

51− PDot _ -> do

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

53− pure $ singleton x

54− PEscape {..} -> do

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

56− pure $ singleton x

57− PCarat _ -> pure mempty

58− PDollar _ -> pure mempty

59− _ -> pure mempty

60− where

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

62− expandEscape ch =

63− case ch of

64− 'n' -> "\n"

65− 't' -> "\t"

66− 'r' -> "\r"

67− 'f' -> "\f"

68− 'a' -> "\a"

69− 'e' -> "\ESC"

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

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

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

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

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

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

76− ch' -> [ch']

src/Data/Schematic/Helpers.hsdeleted−59

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

1−module Data.Schematic.Helpers where

2−

3−import Data.Schematic.Schema

4−import GHC.TypeLits

5−

6−

7−type UUIDRegex =

8− 'TRegex "[0-9a-f]{8}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{12}"

9−

10−type IsUUID = '[UUIDRegex]

11−

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

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

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

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

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

17−-- ]

18−

19−-- components

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

21−

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

23−

24−type ISO8601DateTime =

25− AppendSymbol

26− ISO8601Date

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

28−

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

30−

31−type ISO8601DateTimeUTC =

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

33−

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

35−

36−type ISO8601DateTimeZoned =

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

38−

39−-- regexes

40−type ISO8601DateRegex = 'TRegex ISO8601Date

41−

42−type ISO8601TimeRegex = 'TRegex ISO8601Time

43−

44−type ISO8601DateTimeRegex = 'TRegex ISO8601DateTime

45−

46−type ISO8601DateTimeRegexUTC = 'TRegex ISO8601DateTimeUTC

47−

48−type ISO8601DateTimeRegexZoned = 'TRegex ISO8601DateTimeZoned

49−

50−-- constraints

51−type IsDate = '[ISO8601DateRegex]

52−

53−type IsTime = '[ISO8601TimeRegex]

54−

55−type IsDateTime = '[ISO8601DateTimeRegex]

56−

57−type IsZonedDateTime = '[ISO8601DateTimeRegexZoned]

58−

59−type IsUTCDateTime = '[ISO8601DateTimeRegexUTC]

src/Data/Schematic/Instances.hs−4

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

4module Data.Schematic.Instances where

6import Data.Scientific

7−import Data.Text (Text, pack)

8import Data.Vector as V

7import Data.Vector as V

9import Data.Vinyl

8import Data.Vinyl

10import Test.SmallCheck.Series

9import Test.SmallCheck.Series

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

23instance Monad m => Serial m Scientific where

22instance Monad m => Serial m Scientific where

24 series = scientific <$> series <*> series

23 series = scientific <$> series <*> series

25−

26−instance Monad m => Serial m Text where

27− series = pack <$> series

src/Data/Schematic/JsonSchema.hsdeleted−124

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

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE RecordWildCards #-}

3−{-# LANGUAGE OverloadedLabels #-}

4−{-# LANGUAGE TemplateHaskell #-}

5−

6−module Data.Schematic.JsonSchema

7− ( toJsonSchema

8− , toJsonSchema'

9− ) where

10−

11−import Control.Monad.State.Strict

12−import Data.Aeson as J

13−import Data.Foldable as F

14−import Data.HashMap.Strict as H

15−import Data.List as L

16−import Data.List.NonEmpty as NE

17−import Data.Schematic.Schema as S

18−import Data.Set as Set

19−import Data.Singletons

20−import Data.Text

21−import Data.Traversable

22−import JSONSchema.Draft4.Schema as D4

23−import JSONSchema.Validator.Draft4 as D4

24−

25−

26−draft4 :: Text

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

28−

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

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

31− { _schemaMinLength = pure $ fromIntegral n

32− , _schemaMaxLength = pure $ fromIntegral n }

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

34− { _schemaMaxLength = pure . fromIntegral $ n }

35−textConstraint (DTLt n) =

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

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

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

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

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

41− { _schemaMinLength = pure . fromIntegral $ n }

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

43−textConstraint (DTEnum ss) =

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

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

46−

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

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

49− { _schemaMaximum = pure . fromIntegral $ n }

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

51− { _schemaMaximum = pure . fromIntegral $ n

52− , _schemaExclusiveMaximum = pure True }

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

54− { _schemaMinimum = pure . fromIntegral $ n

55− , _schemaExclusiveMinimum = pure True }

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

57− { _schemaMinimum = pure . fromIntegral $ n }

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

59− { _schemaMinimum = pure $ fromIntegral n

60− , _schemaMaximum = pure $ fromIntegral n }

61−

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

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

64− { _schemaMaxItems = pure . fromIntegral $ n }

65−arrayConstraint (DALt n) =

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

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

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

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

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

71− { _schemaMinItems = pure . fromIntegral $ n }

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

73− { _schemaMinItems = pure $ fromIntegral n

74− , _schemaMaxItems = pure $ fromIntegral n }

75−

76−toJsonSchema

77− :: forall proxy schema

78− . SingI schema

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

80− -> Maybe D4.Schema

81−toJsonSchema _ = do

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

83− pure $ js { _schemaVersion = pure draft4 }

84−

85−toJsonSchema'

86− :: DemotedSchema

87− -> Maybe D4.Schema

88−toJsonSchema' = \case

89− DSchemaText tcs ->

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

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

92− DSchemaNumber ncs ->

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

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

95− DSchemaBoolean -> pure $ emptySchema

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

97− DSchemaObject objs -> do

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

99− s' <- toJsonSchema' s

100− pure (n, s')

101− let

102− nonOpt = \case

103− (_, DSchemaOptional _) -> False

104− _ -> True

105− pure $ emptySchema

106− { _schemaType = pure $ TypeValidatorString D4.SchemaObject

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

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

109− DSchemaArray acs sch -> do

110− res <- toJsonSchema' sch

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

112− { _schemaType = pure $ TypeValidatorString D4.SchemaArray

113− , _schemaItems = pure $ ItemsObject res }

114− DSchemaNull -> pure $ emptySchema

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

116− DSchemaOptional sch -> do

117− snull <- toJsonSchema' DSchemaNull

118− sres <- toJsonSchema' sch

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

120− DSchemaUnion sch -> do

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

122− [] -> Nothing

123− x -> Just x

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

src/Data/Schematic/Lens.hsdeleted−207

@@ -1,207 +0,0 @@

1−{-# LANGUAGE UndecidableSuperClasses #-}

2−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3−{-# LANGUAGE AllowAmbiguousTypes #-}

4−{-# LANGUAGE InstanceSigs #-}

5−

6−module Data.Schematic.Lens

7− ( FIndex

8− , FElem(..)

9− , FImage

10− , FSubset(..)

11− , obj

12− , arr

13− , uni

14− , txt

15− , num

16− , opt

17− , bln

18− , textRepr

19− , numberRepr

20− , boolRepr

21− , arrayRepr

22− , objectRepr

23− , optionalRepr

24− ) where

25−

26−import Data.Profunctor

27−import Data.Schematic.Schema

28−import Data.Scientific

29−import Data.Singletons

30−import Data.Text

31−import Data.Union

32−import Data.Vector as V

33−import Data.Vinyl

34−import Data.Vinyl.Functor

35−import Data.Vinyl.TypeLevel (Nat(..))

36−import GHC.TypeLits (Symbol, KnownSymbol)

37−

38−

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

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

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

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

43−

44−type Flens fn f g rs i

45− = Functor g

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

47− -> Rec f rs

48− -> g (Rec f rs)

49−

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

51−

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

53− type ByField fn rs i :: Schema

54− flens :: Flens fn f g rs i

55−

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

57− fget :: FGetter fn f rs i

58−

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

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

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

62− fput

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

64− -> Rec f rs

65− -> Rec f rs

66−

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

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

69−

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

71− {-# INLINE flens #-}

72−

73− fget = getConst . flens Const

74− {-# INLINE fget #-}

75−

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

77− {-# INLINE fput #-}

78−

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

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

81−

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

83− {-# INLINE flens #-}

84−

85− fget = getConst . flens Const

86− {-# INLINE fget #-}

87−

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

89− {-# INLINE fput #-}

90−

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

92−lens

93− :: Functor f

94− => (t -> s)

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

96− -> (s -> f a)

97− -> t

98− -> f b

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

100−{-# INLINE lens #-}

101−

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

103−

104−type Iso' s a = Iso s s a a

105−

106−iso

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

108− -> Iso s t a b

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

110−{-# INLINE iso #-}

111−

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

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

114− FImage '[] ss = '[]

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

116−

117−class is ~ FImage rs ss

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

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

120− --

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

122− fsubset

123− :: Functor g

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

125− -> Rec f ss

126− -> g (Rec f ss)

127−

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

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

130− fcast

131− :: Rec f ss

132− -> Rec f rs

133− fcast = getConst . fsubset Const

134− {-# INLINE fcast #-}

135−

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

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

138− freplace

139− :: Rec f rs

140− -> Rec f ss

141− -> Rec f ss

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

143− {-# INLINE freplace #-}

144−

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

146− fsubset = lens (const RNil) const

147−

148−instance

149− ( ByField fn ss i ~ s

150− , FElem fn ss i

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

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

153− where

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

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

156−

157−-- A bunch of @Iso@morphisms

158−textRepr

159− :: (KnownSymbol fn, SingI cs)

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

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

162−

163−numberRepr

164− :: (KnownSymbol fn, SingI cs)

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

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

167−

168−boolRepr

169− :: (KnownSymbol fn)

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

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

172−

173−arrayRepr

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

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

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

177−

178−objectRepr

179− :: (KnownSymbol fn, SingI fields)

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

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

182−

183−optionalRepr

184− :: (KnownSymbol fn, SingI schema)

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

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

187−

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

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

190−

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

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

193−

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

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

196−

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

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

199−

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

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

202−

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

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

205−

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

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

src/Data/Schematic/Migration.hs+27−56

@@ -1,19 +1,14 @@

1{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE CPP #-}

3−{-# LANGUAGE TemplateHaskell #-}

2+{-# LANGUAGE TemplateHaskell #-}

5module Data.Schematic.Migration where

4module Data.Schematic.Migration where

7import Data.Kind

6import Data.Kind

8−import Data.Schematic.DSL

9−import Data.Schematic.Lens

10import Data.Schematic.Path

7import Data.Schematic.Path

11import Data.Schematic.Schema

8import Data.Schematic.Schema

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

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

13import Data.Singletons.TypeLits

10import Data.Singletons.TypeLits

14−import Data.Tagged

15−import Data.Vinyl

11+-- import Data.Vinyl hiding (Dict)

16−import Data.Vinyl.Functor

19data Path

14data Path

@@ -21,7 +16,7 @@ data Path

21 | PTraverse -- traverse into the array

16 | PTraverse -- traverse into the array

23data instance Sing (p :: Path) where

18data instance Sing (p :: Path) where

24− SPKey :: Sing s -> Sing ('PKey s)

19+ SPKey :: KnownSymbol s => Sing s -> Sing ('PKey s)

25 SPTraverse :: Sing 'PTraverse

20 SPTraverse :: Sing 'PTraverse

27instance KnownSymbol s => SingI ('PKey s) where

22instance KnownSymbol s => SingI ('PKey s) where

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

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

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

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

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

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

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

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

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

49type family UpdateKey

44type family UpdateKey

50 (fn :: Symbol)

45 (fn :: Symbol)

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

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

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

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

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

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

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

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

102 AllVersions' acc '[] = acc

96 AllVersions' acc '[] = acc

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

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

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

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

@@ -106,15 +100,19 @@ type family AllVersions' (acc :: [(Revision, Schema)]) (ms :: [Migration])

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

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

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

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

108

102

103+class MigrateSchema (a :: Schema) (b :: Schema) where

104+ migrate :: JsonRepr a -> JsonRepr b

105+

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

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

110

107

111data instance Sing (a :: Action) where

108data instance Sing (a :: Action) where

112 SAddKey

109 SAddKey

110+ :: (SingI n, SingI s)

113− :: Sing n

111+ => Sing n

114 -> Sing s

112 -> Sing s

115 -> Sing ('AddKey n s)

113 -> Sing ('AddKey n s)

116− SUpdate :: Sing s -> Sing ('Update s)

114+ SUpdate :: (SingI s) => Sing s -> Sing ('Update s)

117− SDeleteKey :: Sing s -> Sing ('DeleteKey s)

115+ SDeleteKey :: KnownSymbol s => Sing s -> Sing ('DeleteKey s)

118

116

119-- | User-supplied atomic difference between schemas.

117-- | User-supplied atomic difference between schemas.

120-- Migrations can consists of many differences.

118-- Migrations can consists of many differences.

@@ -122,7 +120,8 @@ data Diff = Diff [Path] Action

122

120

123data instance Sing (diff :: Diff) where

121data instance Sing (diff :: Diff) where

124 SDiff

122 SDiff

123+ :: (SingI jp, SingI a)

125− :: Sing (jp :: [Path])

124+ => Sing (jp :: [Path])

126 -> Sing (a :: Action)

125 -> Sing (a :: Action)

127 -> Sing ('Diff jp a)

126 -> Sing ('Diff jp a)

128

127

@@ -133,7 +132,8 @@ data Migration = Migration Revision [Diff]

133

132

134data instance Sing (m :: Migration) where

133data instance Sing (m :: Migration) where

135 SMigration

134 SMigration

135+ :: (KnownSymbol r, SingI ds)

136− :: Sing r

136+ => Sing r

137 -> Sing ds

138 -> Sing ('Migration r ds)

139

@@ -141,47 +141,18 @@ data Versioned = Versioned Schema [Migration]

141

142data instance Sing (v :: Versioned) where

143 SVersioned

144+ :: (SingI s, SingI ms)

144− :: Sing (s :: Schema) -- base version

145+ => Sing (s :: Schema) -- base version

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

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

146 -> Sing ('Versioned s ms)

147 -> Sing ('Versioned s ms)

147

148

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

149−

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

149+data MList :: [Schema] -> Type where

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

150+ MNil :: (SingI s, TopLevel s) => MList '[s]

152 (:&&)

151 (:&&)

153− :: (TopLevel s, SingI s)

152+ :: (SingI s, TopLevel s)

154− => DataMigration s m h

153+ => proxy s

154+ -> (JsonRepr h -> JsonRepr s)

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

155+ -> MList (h ': tl)

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

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

157

158infixr 7 :&&

159−

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

161−migrateObject

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

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

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

165−#else

166−migrateObject

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

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

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

170−#endif

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

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

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

174−

175−shrinkObject

176− :: forall rs ss m

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

178− => Tagged

179− ('SchemaObject rs)

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

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

182−

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

184− MapSnd '[] = '[]

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

186−

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

src/Data/Schematic/Path.hs+32−18

@@ -1,36 +1,50 @@

1module Data.Schematic.Path where

3import Data.Foldable as F

4+import Data.Monoid

5+import Data.Schematic.Utils

6+import Data.Singletons

4import Data.Singletons.Prelude

7import Data.Singletons.Prelude

5import Data.Singletons.TypeLits

8import Data.Singletons.TypeLits

6import Data.Text as T

9import Data.Text as T

7−import Data.Aeson.Internal

10−newtype JSONPathText = JSONPathText Text

11− deriving (Show)

12−

13−data PathSegment = PathKey Symbol | PathIx Nat

12+data PathSegment = Key Symbol | Ix Nat

15data instance Sing (jp :: PathSegment) where

14data instance Sing (jp :: PathSegment) where

16− SKey :: (SingI k) => Sing (k :: Symbol) -> Sing ('PathKey k)

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

17− SIx :: (SingI n) => Sing (n :: Nat) -> Sing ('PathIx n)

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

17+

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

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

20+ known = SKey known

21+

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

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

24+ known = SIx known

25+

26+data DemotedPathSegment = DKey Text | DIx Integer

27+ deriving (Show)

28+

29+-- | Textual representation of json path.

30+newtype JSONPath = JSONPath Text

31+ deriving (Show)

19−demotePath :: Sing (ps :: [PathSegment]) -> JSONPath

33+demotePath :: Sing (ps :: [PathSegment]) -> [DemotedPathSegment]

20demotePath = go []

34demotePath = go []

21 where

35 where

22− go :: JSONPath -> Sing (ps :: [PathSegment]) -> JSONPath

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

23 go acc SNil = acc

37 go acc SNil = acc

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

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

25− demotePathSeg :: Sing (ps :: PathSegment) -> JSONPathElement

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

26− demotePathSeg (SKey s) = Key $ T.pack $ withKnownSymbol s $ symbolVal s

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

27− demotePathSeg (SIx n) = Index $ withKnownNat n $ fromIntegral $ natVal n

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

29−demotedPathToText :: JSONPath -> JSONPathText

43+demotedPathToText :: [DemotedPathSegment] -> JSONPath

30−demotedPathToText = JSONPathText . F.foldl' renderPathSegment ""

44+demotedPathToText = JSONPath . F.foldl' renderPathSegment ""

31 where

45 where

32− renderPathSegment acc (Key t) = acc <> "." <> t

46+ renderPathSegment acc (DKey t) = acc <> "." <> t

33− renderPathSegment acc (Index n) = acc <> "[" <> T.pack (show n) <> "]"

47+ renderPathSegment acc (DIx n) = acc <> "[" <> T.pack (show n) <> "]"

35−pathToText :: Sing (ps :: [PathSegment]) -> JSONPathText

49+pathToText :: Sing (ps :: [PathSegment]) -> JSONPath

36pathToText = demotedPathToText . demotePath

50pathToText = demotedPathToText . demotePath

src/Data/Schematic/Schema.hs+87−382

@@ -1,36 +1,35 @@

1{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE CPP #-}

3−{-# LANGUAGE OverloadedLists #-}

2+{-# LANGUAGE OverloadedLists #-}

4−{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE OverloadedStrings #-}

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

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

7module Data.Schematic.Schema where

6module Data.Schematic.Schema where

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

8+import Control.Applicative

10−import Control.Monad

9+import Control.Monad

11−import Data.Aeson as J

10+import Data.Aeson as J

12−import Data.Aeson.Types as J

11+import Data.Aeson.Types as J

13−import Data.HashMap.Strict as H

12+import Data.HashMap.Strict as H

14−import Data.Kind

13+import Data.Kind

15−import Data.Maybe

14+import Data.Maybe

16−import Data.Schematic.Generator

17−import Data.Schematic.Instances ()

15+import Data.Schematic.Instances ()

16+

18−import Data.Scientific

17+import Data.Scientific

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

18+import Data.Singletons.Prelude.List hiding (All)

20−import Data.Singletons.TH

19+import Data.Singletons.TH

21−import Data.Singletons.TypeLits

20+import Data.Singletons.TypeLits

22−import Data.Text as T

21+import Data.Text as T

23−import Data.Union

24−import Data.Vector as V

22+import Data.Vector as V

25−import Data.Vinyl hiding (Dict)

23+import Data.Vinyl hiding (Dict)

26−import qualified Data.Vinyl.TypeLevel as V

24+import Data.Vinyl.TypeLevel hiding (Nat)

27−import GHC.Exts

28−import GHC.Generics (Generic)

25+import GHC.Generics (Generic)

29−import GHC.TypeLits

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

31−import Prelude as P

26+import Prelude as P

32−import Test.SmallCheck.Series

27+import Test.SmallCheck.Series

33−

28+

29+

30+type family All (c :: k -> Constraint) (s :: [k]) :: Constraint where

31+ All c '[] = ()

32+ All c (a ': as) = (c a, All c as)

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

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

36 CRepr ('SchemaText cs) = TextConstraint

35 CRepr ('SchemaText cs) = TextConstraint

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

41data TextConstraint

40data TextConstraint

42 = TEq Nat

41 = TEq Nat

43− | TLt Nat

44 | TLe Nat

42 | TLe Nat

45 | TGt Nat

43 | TGt Nat

46− | TGe Nat

47 | TRegex Symbol

44 | TRegex Symbol

48 | TEnum [Symbol]

45 | TEnum [Symbol]

49 deriving (Generic)

46 deriving (Generic)

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−

96data instance Sing (tc :: TextConstraint) where

48data instance Sing (tc :: TextConstraint) where

97− STEq :: Sing n -> Sing ('TEq n)

49+ STEq :: (KnownNat n) => Sing n -> Sing ('TEq n)

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

99− STLe :: Sing n -> Sing ('TLe n)

50+ STLe :: (KnownNat n) => Sing n -> Sing ('TLe n)

100− STGt :: Sing n -> Sing ('TGt n)

51+ STGt :: (KnownNat n) => Sing n -> Sing ('TGt n)

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

102− STRegex :: Sing s -> Sing ('TRegex s)

52+ STRegex :: (KnownSymbol s, SingI s) => Sing s -> Sing ('TRegex s)

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

53+ STEnum :: (All KnownSymbol ss, SingI ss) => Sing ss -> Sing ('TEnum ss)

104

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

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

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

56instance (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

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

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

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

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

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

59+instance (All KnownSymbol ss, SingI ss) => SingI ('TEnum ss) where sing = STEnum sing

112

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

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

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

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

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

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

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

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

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

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

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

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

120

121data NumberConstraint

67data NumberConstraint

122 = NLe Nat

68 = NLe Nat

123− | NLt Nat

124 | NGt Nat

69 | NGt Nat

125− | NGe Nat

126 | NEq Nat

70 | NEq Nat

127 deriving (Generic)

71 deriving (Generic)

128

129−data DemotedNumberConstraint

130− = DNLe Integer

131− | DNLt Integer

132− | DNGt Integer

133− | DNGe Integer

134− | DNEq Integer

135− deriving (Generic, Eq, Show)

136−

137data instance Sing (nc :: NumberConstraint) where

73data instance Sing (nc :: NumberConstraint) where

138− SNEq :: Sing n -> Sing ('NEq n)

74+ SNEq :: KnownNat n => Sing n -> Sing ('NEq n)

139− SNGt :: Sing n -> Sing ('NGt n)

75+ SNGt :: KnownNat n => Sing n -> Sing ('NGt n)

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

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

142− SNLe :: Sing n -> Sing ('NLe n)

76+ SNLe :: KnownNat n => Sing n -> Sing ('NLe n)

143

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

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

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

79instance 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

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

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

149

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

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

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

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

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

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

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

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

155−

156−instance SingKind NumberConstraint where

157− type Demote NumberConstraint = DemotedNumberConstraint

158− fromSing = \case

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

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

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

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

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

164− toSing = \case

165− DNEq n -> case someNatVal n of

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

167− Nothing -> error "Negative singleton nat"

168− DNGt n -> case someNatVal n of

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

170− Nothing -> error "Negative singleton nat"

171− DNGe n -> case someNatVal n of

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

173− Nothing -> error "Negative singleton nat"

174− DNLt n -> case someNatVal n of

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

176− Nothing -> error "Negative singleton nat"

177− DNLe n -> case someNatVal n of

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

179− Nothing -> error "Negative singleton nat"

180

181data ArrayConstraint

86data ArrayConstraint

182 = AEq Nat

87 = AEq Nat

183− | AGt Nat

184− | AGe Nat

185− | ALt Nat

186− | ALe Nat

187 deriving (Generic)

88 deriving (Generic)

188

189−data DemotedArrayConstraint

190− = DAEq Integer

191− | DAGt Integer

192− | DAGe Integer

193− | DALt Integer

194− | DALe Integer

195− deriving (Generic, Eq, Show)

196−

197data instance Sing (ac :: ArrayConstraint) where

90data instance Sing (ac :: ArrayConstraint) where

198− SAEq :: Sing n -> Sing ('AEq n)

91+ SAEq :: KnownNat n => Sing n -> Sing ('AEq n)

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

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

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

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

203

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

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

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

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

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

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

209

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

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

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

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

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

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

215−

216−instance SingKind ArrayConstraint where

217− type Demote ArrayConstraint = DemotedArrayConstraint

218− fromSing = \case

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

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

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

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

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

224− toSing = \case

225− DAEq n -> case someNatVal n of

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

227− Nothing -> error "Negative singleton nat"

228− DAGt n -> case someNatVal n of

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

230− Nothing -> error "Negative singleton nat"

231− DAGe n -> case someNatVal n of

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

233− Nothing -> error "Negative singleton nat"

234− DALt n -> case someNatVal n of

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

236− Nothing -> error "Negative singleton nat"

237− DALe n -> case someNatVal n of

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

239− Nothing -> error "Negative singleton nat"

240

241data Schema

97data Schema

242 = SchemaText [TextConstraint]

98 = SchemaText [TextConstraint]

243− | SchemaBoolean

244 | SchemaNumber [NumberConstraint]

99 | SchemaNumber [NumberConstraint]

245 | SchemaObject [(Symbol, Schema)]

100 | SchemaObject [(Symbol, Schema)]

246 | SchemaArray [ArrayConstraint] Schema

101 | SchemaArray [ArrayConstraint] Schema

247 | SchemaNull

102 | SchemaNull

248 | SchemaOptional Schema

103 | SchemaOptional Schema

249− | SchemaUnion [Schema]

250 deriving (Generic)

104 deriving (Generic)

251

105

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−

263data instance Sing (schema :: Schema) where

106data instance Sing (schema :: Schema) where

264− SSchemaText :: Sing tcs -> Sing ('SchemaText tcs)

107+ SSchemaText :: SingI tcs => Sing tcs -> Sing ('SchemaText tcs)

265− SSchemaNumber :: Sing ncs -> Sing ('SchemaNumber ncs)

108+ SSchemaNumber :: SingI ncs => Sing ncs -> Sing ('SchemaNumber ncs)

266− SSchemaBoolean :: Sing 'SchemaBoolean

267− SSchemaArray :: Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)

109+ SSchemaArray :: (SingI acs, SingI schema) => Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)

268− SSchemaObject :: Sing fields -> Sing ('SchemaObject fields)

110+ SSchemaObject :: SingI fields => Sing fields -> Sing ('SchemaObject fields)

269− SSchemaOptional :: Sing s -> Sing ('SchemaOptional s)

111+ SSchemaOptional :: SingI s => Sing s -> Sing ('SchemaOptional s)

270 SSchemaNull :: Sing 'SchemaNull

112 SSchemaNull :: Sing 'SchemaNull

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

272

113

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

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

274 sing = SSchemaText sing

115 sing = SSchemaText sing

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

276 sing = SSchemaNumber sing

117 sing = SSchemaNumber sing

277instance SingI 'SchemaNull where

118instance SingI 'SchemaNull where

278 sing = SSchemaNull

119 sing = SSchemaNull

279−instance SingI 'SchemaBoolean where

280− sing = SSchemaBoolean

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

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

282 sing = SSchemaArray sing sing

121 sing = SSchemaArray sing sing

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

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

284 sing = SSchemaObject sing

123 sing = SSchemaObject sing

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

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

286 sing = SSchemaOptional sing

125 sing = SSchemaOptional sing

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

288− sing = SSchemaUnion sing

289

126

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

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

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

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

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

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

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

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

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

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

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

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

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

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

298−

299−instance SingKind Schema where

300− type Demote Schema = DemotedSchema

301− fromSing = \case

302− SSchemaText cs -> DSchemaText $ fromSing cs

303− SSchemaNumber cs -> DSchemaNumber $ fromSing cs

304− SSchemaBoolean -> DSchemaBoolean

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

306− SSchemaOptional s -> DSchemaOptional $ fromSing s

307− SSchemaNull -> DSchemaNull

308− SSchemaObject cs -> DSchemaObject $ fromSing cs

309− SSchemaUnion ss -> DSchemaUnion $ fromSing ss

310− toSing = \case

311− DSchemaText cs -> case toSing cs of

312− SomeSing scs -> SomeSing $ SSchemaText scs

313− DSchemaNumber cs -> case toSing cs of

314− SomeSing scs -> SomeSing $ SSchemaNumber scs

315− DSchemaBoolean -> SomeSing $ SSchemaBoolean

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

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

318− DSchemaOptional sch -> case toSing sch of

319− SomeSing ssch -> SomeSing $ SSchemaOptional ssch

320− DSchemaNull -> SomeSing SSchemaNull

321− DSchemaObject cs -> case toSing cs of

322− SomeSing scs -> SomeSing $ SSchemaObject scs

323− DSchemaUnion ss -> case toSing ss of

324− SomeSing sss -> SomeSing $ SSchemaUnion sss

325

133

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

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

327 FieldRepr

135 FieldRepr

@@ -329,10 +137,6 @@ data FieldRepr :: (Symbol, Schema) -> Type where

329 => JsonRepr schema

137 => JsonRepr schema

330 -> FieldRepr '(name, schema)

138 -> FieldRepr '(name, schema)

331

139

332−-- | Forgetful Functor Ufr

333−toJsonRepr :: FieldRepr '(fn, sch) -> JsonRepr sch

334−toJsonRepr (FieldRepr x) = x

335−

336knownFieldName

140knownFieldName

337 :: forall proxy (fieldName :: Symbol) schema

141 :: forall proxy (fieldName :: Symbol) schema

338 . KnownSymbol fieldName

142 . KnownSymbol fieldName

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

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

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

360 series = FieldRepr <$> series

164 series = FieldRepr <$> series

361

165

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−

366data JsonRepr :: Schema -> Type where

166data JsonRepr :: Schema -> Type where

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

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

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

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

369− ReprBoolean :: Bool -> JsonRepr 'SchemaBoolean

370 ReprNull :: JsonRepr 'SchemaNull

169 ReprNull :: JsonRepr 'SchemaNull

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

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

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

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

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

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

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

375−

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

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

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

379−

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

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

382− series = decDepth $ fmap ReprNumber

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

384−

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

386− series = cons0 ReprNull

387−

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

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

390− series = decDepth $ fmap ReprArray

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

392

173

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

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

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

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

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

404

176

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

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

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

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

407

179

408−instance Show (JsonRepr 'SchemaBoolean) where

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

410−

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

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

412

181

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

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

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

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

415

184

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

185+instance RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where

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

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

422−#else

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

424− show (ReprObject fs) = "ReprObject " P.++ show fs

425−#endif

426

187

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

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

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

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

429

190

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

191+instance (Monad m, Serial m Text)

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

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

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

193+ series = cons1 ReprText

194+

195+instance (Monad m, Serial m Scientific)

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

197+ series = cons1 ReprNumber

198+

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

200+ series = cons0 ReprNull

201+

202+instance (Serial m (V.Vector (JsonRepr s)))

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

204+ series = cons1 ReprArray

205+

206+instance (Serial m (JsonRepr s))

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

208+ series = cons1 ReprOptional

209+

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

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

212+ series = cons1 ReprObject

433

213

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

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

435 ReprObject a == ReprObject b = a == b

215 ReprObject a == ReprObject b = a == b

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

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

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

441 ReprNumber a == ReprNumber b = a == b

221 ReprNumber a == ReprNumber b = a == b

442

222

443−instance Eq (JsonRepr 'SchemaBoolean) where

444− ReprBoolean a == ReprBoolean b = a == b

445−

446instance Eq (JsonRepr 'SchemaNull) where

223instance Eq (JsonRepr 'SchemaNull) where

447 ReprNull == ReprNull = True

224 ReprNull == ReprNull = True

448

225

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

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

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

453 ReprOptional a == ReprOptional b = a == b

230 ReprOptional a == ReprOptional b = a == b

454

231

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−

500fromOptional

232fromOptional

501 :: SingI s

233 :: SingI s

502 => Sing ('SchemaOptional s)

234 => Sing ('SchemaOptional s)

@@ -504,75 +236,49 @@ fromOptional

504 -> Parser (Maybe (JsonRepr s))

236 -> Parser (Maybe (JsonRepr s))

505fromOptional _ = parseJSON

237fromOptional _ = parseJSON

506

238

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−

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

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

526 parseJSON value = case sing :: Sing schema of

240 parseJSON value = case sing :: Sing schema of

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

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

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

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

529− SSchemaBoolean -> ReprBoolean <$> parseJSON value

530− SSchemaNull -> case value of

243+ SSchemaNull -> case value of

531 J.Null -> pure ReprNull

244 J.Null -> pure ReprNull

532 _ -> typeMismatch "Null" value

245 _ -> typeMismatch "Null" value

533− so@(SSchemaOptional s) -> withSingI s $ ReprOptional <$> fromOptional so value

246+ so@(SSchemaOptional _) -> ReprOptional <$> fromOptional so value

534− SSchemaArray sa sb -> withSingI sa $ withSingI sb

535− $ withArray "Array" (fmap ReprArray . traverse parseJSON) value

247+ SSchemaArray _ _ -> withArray "Array" (fmap ReprArray . traverse parseJSON) value

536− SSchemaObject fs -> do

248+ SSchemaObject fs -> do

537 let

249 let

538 demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (Rec FieldRepr s)

250 demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (Rec FieldRepr s)

539 demoteFields SNil _ = pure RNil

251 demoteFields SNil _ = pure RNil

540 demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do

252 demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do

541 let fieldName = T.pack $ symbolVal (Proxy @fn)

253 let fieldName = T.pack $ symbolVal (Proxy @fn)

542 fieldRepr <- case s of

254 fieldRepr <- case s of

543− SSchemaText so -> case H.lookup fieldName h of

544− Just v -> withSingI so $ FieldRepr <$> parseJSON v

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

546− SSchemaNumber so -> case H.lookup fieldName h of

547− Just v -> withSingI so $ FieldRepr <$> parseJSON v

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

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

255+ SSchemaText _ -> case H.lookup fieldName h of

550 Just v -> FieldRepr <$> parseJSON v

256 Just v -> FieldRepr <$> parseJSON v

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

257+ Nothing -> fail "schematext"

258+ SSchemaNumber _ -> case H.lookup fieldName h of

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

260+ Nothing -> fail "schemanumber"

552 SSchemaNull -> case H.lookup fieldName h of

261 SSchemaNull -> case H.lookup fieldName h of

553 Just v -> FieldRepr <$> parseJSON v

262 Just v -> FieldRepr <$> parseJSON v

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

263+ Nothing -> fail "schemanull"

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

264+ SSchemaArray _ _ -> case H.lookup fieldName h of

556− Just v -> withSingI sa $ withSingI sb $ FieldRepr <$> parseJSON v

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

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

266+ Nothing -> fail "schemaarray"

558− SSchemaObject so -> case H.lookup fieldName h of

267+ SSchemaObject _ -> case H.lookup fieldName h of

559− Just v -> withSingI so $ FieldRepr <$> parseJSON v

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

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

269+ Nothing -> fail "schemaobject"

561− SSchemaOptional so -> case H.lookup fieldName h of

270+ SSchemaOptional _ -> case H.lookup fieldName h of

562− Just v -> withSingI so $ FieldRepr <$> parseJSON v

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

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

272+ Nothing -> fail "schemaoptional"

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

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

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

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

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

567− SSchemaUnion ss -> parseUnion ss value

568

275

569instance J.ToJSON (JsonRepr a) where

276instance J.ToJSON (JsonRepr a) where

570 toJSON ReprNull = J.Null

277 toJSON ReprNull = J.Null

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

572 toJSON (ReprText t) = J.String t

278 toJSON (ReprText t) = J.String t

573 toJSON (ReprNumber n) = J.Number n

279 toJSON (ReprNumber n) = J.Number n

574 toJSON (ReprOptional s) = case s of

280 toJSON (ReprOptional s) = case s of

575− Just v -> toJSON v

281+ Just v -> toJSON v

576 Nothing -> J.Null

282 Nothing -> J.Null

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

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

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

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

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

585 fold = \case

291 fold = \case

586 RNil -> []

292 RNil -> []

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

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

588− toJSON (ReprUnion u) = toJSON u

589

294

590class FalseConstraint a

295class FalseConstraint a

591

296

src/Data/Schematic/Schema.hs-bootdeleted−95

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

1−module Data.Schematic.Schema where

2−

3−import Data.Kind

4−import Data.Maybe

5−import Data.Schematic.Instances ()

6−import Data.Scientific

7−import Data.Singletons.TH

8−import Data.Singletons.TypeLits

9−import Data.Text as T

10−import Data.Union

11−import Data.Vector as V

12−import Data.Vinyl hiding (Dict)

13−import Prelude as P

14−

15−data TextConstraint

16− = TEq Nat

17− | TLt Nat

18− | TLe Nat

19− | TGt Nat

20− | TGe Nat

21− | TRegex Symbol

22− | TEnum [Symbol]

23−

24−data DemotedTextConstraint

25− = DTEq Integer

26− | DTLt Integer

27− | DTLe Integer

28− | DTGt Integer

29− | DTGe Integer

30− | DTRegex Text

31− | DTEnum [Text]

32−

33−data NumberConstraint

34− = NLe Nat

35− | NLt Nat

36− | NGt Nat

37− | NGe Nat

38− | NEq Nat

39−

40−data DemotedNumberConstraint

41− = DNLe Integer

42− | DNLt Integer

43− | DNGt Integer

44− | DNGe Integer

45− | DNEq Integer

46−

47−data ArrayConstraint

48− = AEq Nat

49− | AGt Nat

50− | AGe Nat

51− | ALt Nat

52− | ALe Nat

53−

54−data DemotedArrayConstraint

55− = DAEq Integer

56− | DAGt Integer

57− | DAGe Integer

58− | DALt Integer

59− | DALe Integer

60−

61−data Schema

62− = SchemaText [TextConstraint]

63− | SchemaBoolean

64− | SchemaNumber [NumberConstraint]

65− | SchemaObject [(Symbol, Schema)]

66− | SchemaArray [ArrayConstraint] Schema

67− | SchemaNull

68− | SchemaOptional Schema

69− | SchemaUnion [Schema]

70−

71−data DemotedSchema

72− = DSchemaText [DemotedTextConstraint]

73− | DSchemaNumber [DemotedNumberConstraint]

74− | DSchemaBoolean

75− | DSchemaObject [(Text, DemotedSchema)]

76− | DSchemaArray [DemotedArrayConstraint] DemotedSchema

77− | DSchemaNull

78− | DSchemaOptional DemotedSchema

79− | DSchemaUnion [DemotedSchema]

80−

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

82− FieldRepr

83− :: (SingI schema, KnownSymbol name)

84− => JsonRepr schema

85− -> FieldRepr '(name, schema)

86−

87−data JsonRepr :: Schema -> Type where

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

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

90− ReprBoolean :: Bool -> JsonRepr 'SchemaBoolean

91− ReprNull :: JsonRepr 'SchemaNull

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

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

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

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

src/Data/Schematic/Utils.hsnew file+42

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

1+{-# LANGUAGE AllowAmbiguousTypes #-}

3+module Data.Schematic.Utils where

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+34−163

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

3import Control.Monad

4import Control.Monad.Validation

5−import Data.Aeson

6−import Data.Aeson.Internal

7−import Data.Aeson.Types

8import Data.Foldable

5import Data.Foldable

9import Data.Functor.Identity

6import Data.Functor.Identity

10import Data.Monoid

7import Data.Monoid

11import Data.Schematic.Path

8import Data.Schematic.Path

12import Data.Schematic.Schema

9import Data.Schematic.Schema

10+import Data.Schematic.Utils ()

13import Data.Scientific

11import Data.Scientific

14import Data.Singletons.Prelude

12import Data.Singletons.Prelude

15import Data.Singletons.TypeLits

13import Data.Singletons.TypeLits

16import Data.Text as T

14import Data.Text as T

17−import Data.Traversable

18−import Data.Union

19import Data.Vector as V

15import Data.Vector as V

20import Data.Vinyl

16import Data.Vinyl

21−import Data.Vinyl.TypeLevel

22import Prelude as P

17import Prelude as P

23−import Text.Regex.TDFA

18+import Text.Regex

26type Validation a = ValidationT ErrorMap Identity a

21type Validation a = ValidationT ErrorMap Identity a

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

31 = Valid a

26 = Valid a

32 | DecodingError Text -- static

27 | DecodingError Text -- static

33 | ValidationError ErrorMap -- runtime

28 | ValidationError ErrorMap -- runtime

34− deriving (Show, Eq, Functor, Foldable, Traversable)

29+ deriving (Show, Eq, Functor)

35−

36−instance (TopLevel a, SingI a, FromJSON (JsonRepr a))

37− => FromJSON (ParseResult (JsonRepr a)) where

38− parseJSON = pure . parseAndValidateJson @a

40isValid :: ParseResult a -> Bool

31isValid :: ParseResult a -> Bool

41isValid (Valid _) = True

32isValid (Valid _) = True

@@ -50,51 +41,37 @@ isValidationError (ValidationError _) = True

50isValidationError _ = False

41isValidationError _ = False

52validateTextConstraint

43validateTextConstraint

53− :: JSONPathText

44+ :: JSONPath

54 -> Text

45 -> Text

55 -> Sing (tcs :: TextConstraint)

46 -> Sing (tcs :: TextConstraint)

56 -> Validation ()

47 -> Validation ()

57−validateTextConstraint (JSONPathText path) t = \case

48+validateTextConstraint (JSONPath path) t = \case

58 STEq n -> do

49 STEq n -> do

59 let

50 let

60− nlen = withKnownNat n $ natVal n

51+ nlen = natVal n

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

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

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

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

63− warn = vWarning $ mmSingleton path (pure errMsg)

64− unless predicate warn

65− STLt n -> do

66− let

67− nlen = withKnownNat n $ natVal n

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

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

70 warn = vWarning $ mmSingleton path (pure errMsg)

54 warn = vWarning $ mmSingleton path (pure errMsg)

71 unless predicate warn

55 unless predicate warn

72 STLe n -> do

56 STLe n -> do

73 let

57 let

74− nlen = withKnownNat n $ natVal n

58+ nlen = natVal n

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

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

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

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

77 warn = vWarning $ mmSingleton path (pure errMsg)

61 warn = vWarning $ mmSingleton path (pure errMsg)

78 unless predicate warn

62 unless predicate warn

79 STGt n -> do

63 STGt n -> do

80 let

64 let

81− nlen = withKnownNat n $ natVal n

65+ nlen = natVal n

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

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

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

84− warn = vWarning $ mmSingleton path (pure errMsg)

85− unless predicate warn

86− STGe n -> do

87− let

88− nlen = withKnownNat n $ natVal n

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

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

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

91 warn = vWarning $ mmSingleton path (pure errMsg)

68 warn = vWarning $ mmSingleton path (pure errMsg)

92 unless predicate warn

69 unless predicate warn

93 STRegex r -> do

70 STRegex r -> do

94 let

71 let

95− regex = withKnownSymbol r $ fromSing r

72+ regex = symbolVal r

96− predicate = matchTest (makeRegex (T.unpack regex) :: Regex) (T.unpack t)

73+ predicate = maybe False (const True) $ matchRegex (mkRegex regex) (T.unpack t)

97− errMsg = "must match " <> regex

74+ errMsg = path <> " must match " <> T.pack (show regex)

98 warn = vWarning $ mmSingleton path (pure errMsg)

75 warn = vWarning $ mmSingleton path (pure errMsg)

99 unless predicate warn

76 unless predicate warn

100 STEnum ss -> do

77 STEnum ss -> do

@@ -102,97 +79,55 @@ validateTextConstraint (JSONPathText path) t = \case

102 matching :: Sing (s :: [Symbol]) -> Bool

79 matching :: Sing (s :: [Symbol]) -> Bool

103 matching SNil = False

80 matching SNil = False

104 matching (SCons s@SSym fs) = T.pack (symbolVal s) == t || matching fs

81 matching (SCons s@SSym fs) = T.pack (symbolVal s) == t || matching fs

105− errMsg = "must be one of " <> T.pack (show (fromSing ss))

82+ errMsg = path <> " must be one of " <> T.pack (show (fromSing ss))

106 warn = vWarning $ mmSingleton path (pure errMsg)

83 warn = vWarning $ mmSingleton path (pure errMsg)

107 unless (matching ss) warn

84 unless (matching ss) warn

108

109validateNumberConstraint

86validateNumberConstraint

110− :: JSONPathText

87+ :: JSONPath

111 -> Scientific

88 -> Scientific

112 -> Sing (tcs :: NumberConstraint)

89 -> Sing (tcs :: NumberConstraint)

113 -> Validation ()

90 -> Validation ()

114−validateNumberConstraint (JSONPathText path) num = \case

91+validateNumberConstraint (JSONPath path) num = \case

115 SNEq n -> do

92 SNEq n -> do

116 let

93 let

117− nlen = withKnownNat n $ natVal n

94+ nlen = natVal n

118 predicate = fromIntegral nlen == num

95 predicate = fromIntegral nlen == num

119− errMsg = "should be == " <> T.pack (show nlen)

96+ errMsg = path <> " should be == " <> T.pack (show nlen)

120 warn = vWarning $ mmSingleton path (pure errMsg)

97 warn = vWarning $ mmSingleton path (pure errMsg)

121 unless predicate warn

98 unless predicate warn

122 SNGt n -> do

99 SNGt n -> do

123 let

100 let

124− nlen = withKnownNat n $ natVal n

101+ nlen = natVal n

125 predicate = num > fromIntegral nlen

102 predicate = num > fromIntegral nlen

126− errMsg = "should be > " <> T.pack (show nlen)

103+ errMsg = path <> " should be > " <> T.pack (show nlen)

127− warn = vWarning $ mmSingleton path (pure errMsg)

128− unless predicate warn

129− SNGe n -> do

130− let

131− nlen = withKnownNat n $ natVal n

132− predicate = num >= fromIntegral nlen

133− errMsg = "should be >= " <> T.pack (show nlen)

134− warn = vWarning $ mmSingleton path (pure errMsg)

135− unless predicate warn

136− SNLt n -> do

137− let

138− nlen = withKnownNat n $ natVal n

139− predicate = num < fromIntegral nlen

140− errMsg = "should be < " <> T.pack (show nlen)

141 warn = vWarning $ mmSingleton path (pure errMsg)

104 warn = vWarning $ mmSingleton path (pure errMsg)

142 unless predicate warn

105 unless predicate warn

143 SNLe n -> do

106 SNLe n -> do

144 let

107 let

145− nlen = withKnownNat n $ natVal n

108+ nlen = natVal n

146− predicate = num <= fromIntegral nlen

109+ predicate = fromIntegral nlen <= num

147− errMsg = "should be <= " <> T.pack (show nlen)

110+ errMsg = path <> " should be <= " <> T.pack (show nlen)

148 warn = vWarning $ mmSingleton path (pure errMsg)

111 warn = vWarning $ mmSingleton path (pure errMsg)

149 unless predicate warn

112 unless predicate warn

150

113

151validateArrayConstraint

114validateArrayConstraint

152− :: JSONPathText

115+ :: JSONPath

153 -> V.Vector a

116 -> V.Vector a

154 -> Sing (tcs :: ArrayConstraint)

117 -> Sing (tcs :: ArrayConstraint)

155 -> Validation ()

118 -> Validation ()

156−validateArrayConstraint (JSONPathText path) v = \case

119+validateArrayConstraint (JSONPath path) v = \case

157 SAEq n -> do

120 SAEq n -> do

158 let

121 let

159− nlen = withKnownNat n $ natVal n

122+ nlen = natVal n

160 predicate = nlen == fromIntegral (V.length v)

123 predicate = nlen == fromIntegral (V.length v)

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

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

162− warn = vWarning $ mmSingleton path (pure errMsg)

163− unless predicate warn

164− SAGt n -> do

165− let

166− nlen = withKnownNat n $ natVal n

167− predicate = fromIntegral (V.length v) > nlen

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

169− warn = vWarning $ mmSingleton path (pure errMsg)

170− unless predicate warn

171− SAGe n -> do

172− let

173− nlen = withKnownNat n $ natVal n

174− predicate = fromIntegral (V.length v) >= nlen

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

176− warn = vWarning $ mmSingleton path (pure errMsg)

177− unless predicate warn

178− SALt n -> do

179− let

180− nlen = withKnownNat n $ natVal n

181− predicate = fromIntegral (V.length v) < nlen

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

183− warn = vWarning $ mmSingleton path (pure errMsg)

184− unless predicate warn

185− SALe n -> do

186− let

187− nlen = withKnownNat n $ natVal n

188− predicate = fromIntegral (V.length v) <= nlen

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

190 warn = vWarning $ mmSingleton path (pure errMsg)

125 warn = vWarning $ mmSingleton path (pure errMsg)

191 unless predicate warn

126 unless predicate warn

192

127

193validateJsonRepr

128validateJsonRepr

194 :: Sing schema

129 :: Sing schema

195− -> JSONPath

130+ -> [DemotedPathSegment]

196 -> JsonRepr schema

131 -> JsonRepr schema

197 -> Validation ()

132 -> Validation ()

198validateJsonRepr sschema dpath jr = case jr of

133validateJsonRepr sschema dpath jr = case jr of

@@ -215,7 +150,6 @@ validateJsonRepr sschema dpath jr = case jr of

215 process cs

150 process cs

216 process scs

151 process scs

217 ReprNull -> pure ()

152 ReprNull -> pure ()

218− ReprBoolean _ -> pure ()

219 ReprArray v -> case sschema of

153 ReprArray v -> case sschema of

220 SSchemaArray acs s -> do

154 SSchemaArray acs s -> do

221 let

155 let

@@ -226,7 +160,7 @@ validateJsonRepr sschema dpath jr = case jr of

226 process cs

160 process cs

227 process acs

161 process acs

228 for_ (V.indexed v) $ \(ix, jr') -> do

162 for_ (V.indexed v) $ \(ix, jr') -> do

229− let newPath = dpath <> pure (Index $ fromIntegral ix)

163+ let newPath = dpath <> pure (DIx $ fromIntegral ix)

230 validateJsonRepr s newPath jr'

164 validateJsonRepr s newPath jr'

231 ReprOptional d -> case sschema of

165 ReprOptional d -> case sschema of

232 SSchemaOptional ss -> case d of

166 SSchemaOptional ss -> case d of

@@ -235,72 +169,9 @@ validateJsonRepr sschema dpath jr = case jr of

235 ReprObject fs -> case sschema of

169 ReprObject fs -> case sschema of

236 SSchemaObject _ -> go fs

170 SSchemaObject _ -> go fs

237 where

171 where

238− go :: Rec FieldRepr (ts :: [(Symbol, Schema)] ) -> Validation ()

172+ go :: Rec FieldRepr (ts :: [ (Symbol, Schema) ] ) -> Validation ()

239 go RNil = pure ()

173 go RNil = pure ()

240 go (f@(FieldRepr d) :& ftl) = do

174 go (f@(FieldRepr d) :& ftl) = do

241− let newPath = dpath <> [Key (knownFieldName f)]

175+ let newPath = dpath <> [DKey (knownFieldName f)]

242 validateJsonRepr (knownFieldSchema f) newPath d

176 validateJsonRepr (knownFieldSchema f) newPath d

243 go ftl

177 go ftl

244− ReprUnion _ -> pure () -- FIXME

245− -- case sschema of

246− -- SSchemaUnion ss -> case ss of

247− -- SCons s stl -> case umatch' s u of

248− -- Nothing -> case urestrict u of

249− -- Nothing ->

250− -- fail "impossible to produce subUnion, please report this as a bug"

251− -- Just x -> do

252− -- let

253− -- JSONPathText path = demotedPathToText dpath

254− -- case stl of

255− -- SNil -> void $ vWarning $ mmSingleton path

256− -- $ pure "union handling error, please report this as bug"

257− -- SCons s' stl' ->

258− -- validateJsonRepr (SSchemaUnion (SCons s' stl')) dpath

259− -- $ toUnion (SCons s' stl') x

260− -- Just x -> validateJsonRepr s dpath x

261−

262−-- subUnion

263−-- :: Sing (s ': stl)

264−-- -> ( USubset stl (s ': stl) (RImage stl (s ': stl))

265−-- => Union f (s ': stl)

266−-- -> Maybe (Union f stl) )

267−-- subUnion (SCons s stl) = urestrict

268−

269−-- withUSubset

270−-- :: Sing (s ': stl)

271−-- -> (USubset stl (s ': stl) (RImage stl (s ': stl)) => Maybe (Union f stl))

272−-- -> Maybe (Union f stl)

273−-- withUSubset (SCons s stl) r = r

274−

275−toUnion

276− :: USubset s' (s ': ss) (RImage s' (s ': ss))

277− => Sing (s ': ss)

278− -> Union JsonRepr s'

279− -> JsonRepr ('SchemaUnion (s ': ss))

280−toUnion _ = ReprUnion . urelax

281−

282−umatch' :: UElem a as i => Sing a -> Union f as -> Maybe (f a)

283−umatch' _ u = umatch u

284−

285−parseAndValidateJson

286− :: forall schema

287− . (FromJSON (JsonRepr schema), TopLevel schema, SingI schema)

288− => Value

289− -> ParseResult (JsonRepr schema)

290−parseAndValidateJson v =

291− case parseEither parseJSON v of

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

293− Right jsonRepr ->

294− let

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

296− res = runIdentity . runValidationTEither $ validate

297− in case res of

298− Left em -> ValidationError em

299− Right () -> Valid jsonRepr

300−

301−parseAndValidateJsonBy

302− :: (FromJSON (JsonRepr schema), TopLevel schema, SingI schema)

303− => proxy schema

304− -> Value

305− -> ParseResult (JsonRepr schema)

306−parseAndValidateJsonBy _ = parseAndValidateJson

src/Data/Schematic/Verifier.hsdeleted−5

@@ -1,5 +0,0 @@

1−module Data.Schematic.Verifier (module X) where

2−

3−import Data.Schematic.Verifier.Array as X

4−import Data.Schematic.Verifier.Number as X

5−import Data.Schematic.Verifier.Text as X

src/Data/Schematic/Verifier/Array.hsdeleted−14

@@ -1,14 +0,0 @@

1−module Data.Schematic.Verifier.Array where

2−

3−import {-# SOURCE #-} Data.Schematic.Schema

4−import Data.Schematic.Verifier.Common

5−

6−data VerifiedArrayConstraint =

7− VAEq Integer

8− deriving (Show)

9−

10−verifyArrayConstraint ::

11− [DemotedArrayConstraint] -> Maybe (Maybe VerifiedArrayConstraint)

12−verifyArrayConstraint cs = do

13− x <- verifyDNEq [x | DAEq x <- cs]

14− pure $ VAEq <$> x

src/Data/Schematic/Verifier/Common.hsdeleted−43

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

1−module Data.Schematic.Verifier.Common where

2−

3−import Data.List (nub)

4−

5−simplifyNumberConstraint :: ([Integer] -> Integer) -> [Integer] -> Maybe Integer

6−simplifyNumberConstraint f =

7− \case

8− [] -> Nothing

9− x -> Just $ f x

10−

11−simplifyDNLs :: [Integer] -> Maybe Integer

12−simplifyDNLs = simplifyNumberConstraint minimum

13−

14−simplifyDNGs :: [Integer] -> Maybe Integer

15−simplifyDNGs = simplifyNumberConstraint maximum

16−

17−verifyDNEq :: [Integer] -> Maybe (Maybe Integer)

18−verifyDNEq x =

19− case nub x of

20− [] -> Just Nothing

21− [y] -> Just $ Just y

22− (_:_:_) -> Nothing

23−

24−verify3 :: Maybe Integer -> Maybe Integer -> Maybe Integer -> Maybe ()

25−verify3 (Just x) (Just y) (Just z) =

26− if x < y && y < z

27− then Just ()

28− else Nothing

29−verify3 _ _ _ = Just ()

30−

31−verify2 :: Maybe Integer -> Maybe Integer -> Maybe ()

32−verify2 (Just x) (Just y) =

33− if x < y

34− then Just ()

35− else Nothing

36−verify2 _ _ = Just ()

37−

38−verifyEquations :: Maybe Integer -> Maybe Integer -> Maybe Integer -> Maybe ()

39−verifyEquations mgt meq mlt = do

40− verify3 mgt meq mlt

41− verify2 mgt meq

42− verify2 meq mlt

43− verify2 mgt mlt

src/Data/Schematic/Verifier/Number.hsdeleted−31

@@ -1,31 +0,0 @@

1−module Data.Schematic.Verifier.Number where

2−

3−import {-# SOURCE #-} Data.Schematic.Schema

4−import Data.Schematic.Verifier.Common

5−

6−toStrictNumber :: [DemotedNumberConstraint] -> [DemotedNumberConstraint]

7−toStrictNumber = map f

8− where

9− f (DNLe x) = DNLt (x + 1)

10− f (DNGe x) = DNGt (x - 1)

11− f x = x

12−

13−data VerifiedNumberConstraint

14− = VNEq Integer

15− | VNBounds (Maybe Integer) (Maybe Integer)

16− deriving (Show)

17−

18−verifyNumberConstraints

19− :: [DemotedNumberConstraint]

20− -> Maybe VerifiedNumberConstraint

21−verifyNumberConstraints cs' = do

22− let

23− cs = toStrictNumber cs'

24− mlt = simplifyDNLs [x | DNLt x <- cs]

25− mgt = simplifyDNGs [x | DNGt x <- cs]

26− meq <- verifyDNEq [x | DNEq x <- cs]

27− verifyEquations mgt meq mlt

28− Just $

29− case meq of

30− Just eq -> VNEq eq

31− Nothing -> VNBounds mgt mlt

src/Data/Schematic/Verifier/Text.hsdeleted−121

@@ -1,121 +0,0 @@

1−module Data.Schematic.Verifier.Text where

2−

3−import Control.Monad

4−import Data.Maybe

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

6−import Data.Schematic.Verifier.Common

7−import Data.Text (Text, unpack)

8−import Text.Regex.TDFA.Pattern

9−import Text.Regex.TDFA.ReadRegex (parseRegex)

10−

11−toStrictTextLength :: [DemotedTextConstraint] -> [DemotedTextConstraint]

12−toStrictTextLength = map f

13− where

14− f (DTLe x) = DTLt (x + 1)

15− f (DTGe x) = DTGt (x - 1)

16− f x = x

17−

18−data VerifiedTextConstraint

19− = VTEq Integer

20− | VTBounds (Maybe Integer) (Maybe Integer)

21− | VTRegex Text Integer (Maybe Integer)

22− | VTEnum [Text]

23− deriving (Show)

24−

25−verifyTextLengthConstraints

26− :: [DemotedTextConstraint]

27− -> Maybe (Maybe VerifiedTextConstraint)

28−verifyTextLengthConstraints cs' = do

29− let

30− cs = toStrictTextLength cs'

31− mlt = simplifyDNLs [x | DTLt x <- cs]

32− mgt = simplifyDNGs [x | DTGt x <- cs]

33− meq <- verifyDNEq [x | DTEq x <- cs]

34− verifyEquations mgt meq mlt

35− case all isNothing ([mgt, meq, mlt] :: [Maybe Integer]) of

36− True -> Just Nothing

37− _ ->

38− Just $

39− Just $

40− case meq of

41− Just eq -> VTEq eq

42− Nothing -> VTBounds mgt mlt

43−

44−regexLength :: Text -> Maybe (Int, Maybe Int)

45−regexLength regexp =

46− case parseRegex . unpack $ regexp of

47− Right (p, _) -> Just (minRegexLength p, maxRegexLength p)

48− Left _ -> Nothing

49−

50−minRegexLength :: Pattern -> Int

51−minRegexLength p =

52− case p of

53− PEmpty -> 0

54− PChar {..} -> 1

55− PAny {..} -> 1

56− PAnyNot {..} -> 1

57− PQuest _ -> 0

58− PPlus sch -> minRegexLength $ PBound 1 Nothing sch

59− PStar _ sch -> minRegexLength $ PBound 0 Nothing sch

60− PBound low _ sch -> low * minRegexLength sch

61− PConcat ps -> sum $ fmap minRegexLength ps

62− POr xs -> minimum $ fmap minRegexLength xs

63− PDot _ -> 1

64− PEscape {..} -> 1

65− PCarat _ -> 0

66− PDollar _ -> 0

67− _ -> 0

68−

69−maxRegexLength :: Pattern -> Maybe Int

70−maxRegexLength p =

71− case p of

72− PEmpty -> Just 0

73− PChar _ _ -> Just 1

74− PAny _ _ -> Just 1

75− PAnyNot _ _ -> Just 1

76− PQuest _ -> Just 0

77− PPlus _ -> Nothing

78− PStar _ _ -> Nothing

79− PBound _ mhigh sch -> (*) <$> mhigh <*> maxRegexLength sch

80− PConcat ps -> sum <$> mapM maxRegexLength ps

81− POr xs -> maximum <$> mapM maxRegexLength xs

82− PDot _ -> Just 1

83− PEscape _ _ -> Just 1

84− PCarat _ -> Just 0

85− PDollar _ -> Just 0

86− _ -> Just 0

87−

88−verifyTextRegexConstraint

89− :: [DemotedTextConstraint]

90− -> Maybe (Maybe VerifiedTextConstraint)

91−verifyTextRegexConstraint cs = do

92− let regexps = [x | DTRegex x <- cs]

93− case regexps of

94− [] -> Just Nothing

95− [x] -> do

96− (l, mh) <- regexLength x

97− Just $ Just $ VTRegex x (fromIntegral l) (fromIntegral <$> mh)

98− _ -> Nothing

99−

100−verifyTextEnumConstraint

101− :: [DemotedTextConstraint]

102− -> Maybe (Maybe VerifiedTextConstraint)

103−verifyTextEnumConstraint cs = do

104− let enums = concat [x | DTEnum x <- cs]

105− case enums of

106− [] -> Just Nothing

107− x -> Just $ Just $ VTEnum x

108−

109−verifyTextConstraints

110− :: [DemotedTextConstraint]

111− -> Maybe [VerifiedTextConstraint]

112−verifyTextConstraints cs = do

113− regexp <- verifyTextRegexConstraint cs

114− void $

115− case regexp of

116− Just (VTRegex _ l mh) ->

117− verifyTextLengthConstraints (DTGe l : cs ++ maybeToList (DTLe <$> mh))

118− _ -> pure Nothing

119− lengths <- verifyTextLengthConstraints cs

120− enums <- verifyTextEnumConstraint cs

121− return $ catMaybes [lengths, enums, regexp]

stack-13.21.yamldeleted−7

@@ -1,7 +0,0 @@

1−resolver: lts-13.21

2−extra-deps:

3− - hjsonpointer-1.4.0@rev:0

4− - hjsonschema-1.9.0@rev:0

5− - validationt-0.3.0

6−nix:

7− packages: [pcre, pkg-config, zlib]

stack.yaml+53−5

@@ -1,6 +1,54 @@

1−resolver: lts-14.22

1+resolver: lts-8.12

2+#resolver: ghc-8.0.2

4+# User packages to be built.

5+# Various formats can be used as shown in the example below.

6+#

7+# packages:

8+# - some-directory

9+# - https://example.com/foo/bar/baz-0.0.2.tar.gz

10+# - location:

11+# git: https://github.com/commercialhaskell/stack.git

12+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

13+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a

14+# extra-dep: true

15+# subdirs:

16+# - auto-update

17+# - wai

18+#

19+# A package marked 'extra-dep: true' will only be built if demanded by a

20+# non-dependency (i.e. a user package), and its test suites and benchmarks

21+# will not be run. This is useful for tweaking upstream packages.

22+packages:

23+#- location:

24+ #git: https://github.com/typeable/validationt.git

25+ #commit: 24578c9fd408179358c641ee1fff0eb182591f4b

26+- '.'

27+

2extra-deps:

28extra-deps:

3−- hjsonpointer-1.4.0@rev:0

4−- hjsonschema-1.9.0@rev:0

5−- git: https://github.com/typeable/validationt.git

29+- validationt-0.2.0.0

6− commit: 97fea97c4015ab5e99f3efb2c73e1fef4b8857d8

30+- smallcheck-series-0.6

31+

32+# Override default flag values for local packages and extra-deps

33+flags: {}

34+

35+# Extra package databases containing global packages

36+extra-package-dbs: []

37+

38+# Control whether we use the GHC we find on the path

39+# system-ghc: true

40+#

41+# Require a specific version of stack, using version ranges

42+# require-stack-version: -any # Default

43+# require-stack-version: ">=1.4"

44+#

45+# Override the architecture used by stack, especially useful on Windows

46+# arch: i386

47+# arch: x86_64

48+#

49+# Extra directories used by stack for building

50+# extra-include-dirs: [/path/to/dir]

51+# extra-lib-dirs: [/path/to/dir]

52+#

53+# Allow a newer minor version of GHC than the snapshot specifies

54+# compiler-check: newer-minor

test/HelpersSpec.hsdeleted−124

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

1−{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}

2−

3−{-# LANGUAGE LambdaCase #-}

4−

5−{-# LANGUAGE DataKinds #-}

6−{-# LANGUAGE TypeApplications #-}

7−{-# LANGUAGE OverloadedStrings #-}

8−

9−module HelpersSpec (spec, main) where

10−

11−import Control.Lens

12−import Data.ByteString.Lazy.Lens

13−import Data.Foldable

14−import Data.Monoid

15−import Data.Schematic

16−import Data.Text as T

17−import Data.Text.Lens

18−import Test.Hspec

19−

20−

21−type UUIDSchema = 'SchemaObject '[ '("uuid", 'SchemaText IsUUID) ]

22−

23−-- | Taken from UUID RFC 4122

24−uuid :: Text

25−uuid = "f81d4fae-7dec-11d0-a765-00a0c91e6bf6"

26−

27−type ISO8601DateSchema = 'SchemaObject '[ '("date", 'SchemaText IsDate) ]

28−

29−iso8601dates :: [Text]

30−iso8601dates = [ "1985-04-12" ]

31−

32−invalidIso8601dates :: [Text]

33−invalidIso8601dates = [ "1999-13-12" ]

34−

35−type ISO8601TimeSchema = 'SchemaObject '[ '("time", 'SchemaText IsTime) ]

36−

37−iso8601times :: [Text]

38−iso8601times =

39− [ "19:23:00"

40− , "00:00:00"

41− , "23:47:12" ]

42−

43−invalidIso8601times :: [Text]

44−invalidIso8601times =

45− [ "00:60:00"

46− , "24:01:02" ]

47−

48−type ISO8601DateTimeSchema = 'SchemaObject '[ '("datetime", 'SchemaText IsDateTime) ]

49−

50−-- | Taken from ISO8601 RFC 3339

51−iso8601datetimes :: [Text]

52−iso8601datetimes =

53− iso8601dates <>

54− [ "1985-04-12T23:20:50.52Z"

55− , "1996-12-19T16:39:57-08:00"

56− , "1990-12-31T23:59:60Z"

57− , "1990-12-31T15:59:60-08:00"

58− , "1937-01-01T12:00:27.87+00:20"

59− ]

60−

61−invalidIso8601datetimes :: [Text]

62−invalidIso8601datetimes =

63− [ "1996-13-129T16:39:57-08:00"

64− , "1990-2-31T23:59:60Z"

65− , "1990-12-32T15:59:70"

66− , "1937-01-1T12::27.87+24:20"

67− ]

68−

69−spec :: Spec

70−spec = do

71− describe "UUID: " $ do

72− it "validates correct UUID" $ do

73− let

74− uuidJson = "{\"uuid\": \"" <> (uuid ^. unpacked . packedChars) <> "\" }"

75− (decodeAndValidateJson uuidJson :: ParseResult (JsonRepr UUIDSchema))

76− `shouldSatisfy` isValid

77−

78− it "fails to validate incorrect UUID" $ do

79− let

80− incorrectJson = "{\"uuid\": \"incorrect\" }"

81− (decodeAndValidateJson incorrectJson :: ParseResult (JsonRepr UUIDSchema))

82− `shouldSatisfy` isValidationError

83−

84− describe "ISO8601 date: " $ do

85− for_ iso8601dates $ \dt -> do

86− it ("validates correct date - " <> dt ^. unpacked) $ do

87− let json = "{\"date\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"

88− (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601DateSchema))

89− `shouldSatisfy` isValid

90−

91− for_ invalidIso8601dates $ \dt -> do

92− it ("fails to validate incorrect date - " <> dt ^. unpacked) $ do

93− let json = "{\"date\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"

94− (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601DateSchema))

95− `shouldSatisfy` isValidationError

96−

97− describe "ISO8601 time: " $ do

98− for_ iso8601times $ \dt -> do

99− it ("validates correct time - " <> dt ^. unpacked) $ do

100− let json = "{\"time\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"

101− (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601TimeSchema))

102− `shouldSatisfy` isValid

103−

104− for_ invalidIso8601times $ \dt -> do

105− it ("fails to validate incorrect time - " <> dt ^. unpacked) $ do

106− let json = "{\"time\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"

107− (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601TimeSchema))

108− `shouldSatisfy` isValidationError

109−

110− describe "ISO8601 datetime: " $ do

111− for_ iso8601datetimes $ \dt -> do

112− it ("validates correct datetime - " <> dt ^. unpacked) $ do

113− let json = "{\"datetime\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"

114− (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601DateTimeSchema))

115− `shouldSatisfy` isValid

116−

117− for_ invalidIso8601datetimes $ \dt -> do

118− it ("fails to validate incorrect datetime - " <> dt ^. unpacked) $ do

119− let json = "{\"datetime\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"

120− (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601DateTimeSchema))

121− `shouldSatisfy` isValidationError

122−

123−main :: IO ()

124−main = hspec spec

test/JsonSchemaSpec.hsdeleted−101

@@ -1,101 +0,0 @@

1−{-# LANGUAGE LambdaCase #-}

2−

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE TypeApplications #-}

5−{-# LANGUAGE OverloadedLists #-}

6−{-# LANGUAGE OverloadedStrings #-}

7−

8−module JsonSchemaSpec (spec, main) where

9−

10−import Data.Aeson as J

11−import Data.Maybe

12−import Data.Proxy

13−import Data.ByteString.Lazy as B

14−import Data.Schematic

15−import Data.Vinyl

16−import JSONSchema.Draft4 as D4

17−import Test.Hspec

18−

19−

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

21−

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

23−

24−type FieldsSchema =

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

26−

27−type SchemaExample = 'SchemaObject FieldsSchema

28−

29−exampleData :: JsonRepr SchemaExample

30−exampleData = withRepr @SchemaExample $

31− field @"foo" [ReprNumber 13]

32− :& field @"bar" (pure (ReprText "foo"))

33− :& RNil

34−

35−type SchemaArrayExample = 'SchemaObject

36− '[ '("a1", 'SchemaArray '[ 'AGt 1 ] ('SchemaNumber '[]))

37− , '("a2", 'SchemaArray '[ 'AGe 1 ] ('SchemaNumber '[]))

38− , '("a3", 'SchemaArray '[ 'ALt 1 ] ('SchemaNumber '[]))

39− , '("a4", 'SchemaArray '[ 'ALe 1 ] ('SchemaNumber '[]))

40− ]

41−

42−type SchemaNumberExample = 'SchemaObject

43− '[ '("n1", 'SchemaNumber '[ 'NGt 1 ])

44− , '("n2", 'SchemaNumber '[ 'NGe 1 ])

45− , '("n3", 'SchemaNumber '[ 'NLt 1 ])

46− , '("n4", 'SchemaNumber '[ 'NLe 1 ])

47− ]

48−

49−type SchemaTextExample = 'SchemaObject

50− '[ '("t1", 'SchemaText '[ 'TGt 1 ])

51− , '("t2", 'SchemaText '[ 'TGe 1 ])

52− , '("t3", 'SchemaText '[ 'TLt 1 ])

53− , '("t4", 'SchemaText '[ 'TLe 1 ])

54− ]

55−

56−spec :: Spec

57−spec = do

58− it "validates simple schema" $ do

59− let schema = D4.SchemaWithURI (fromJust $ toJsonSchema (Proxy @SchemaExample)) Nothing

60− fetchHTTPAndValidate schema (toJSON exampleData) >>= \case

61− Left _ -> fail "failed to validate test example"

62− Right _ -> pure ()

63− it "validates schema with arrays" $ do

64− let

65− schema = D4.SchemaWithURI (fromJust $ toJsonSchema (Proxy @SchemaArrayExample)) Nothing

66− obj = withRepr @SchemaArrayExample $

67− field @"a1" [ReprNumber 13, ReprNumber 13]

68− :& field @"a2" [ReprNumber 13]

69− :& field @"a3" []

70− :& field @"a4" [ReprNumber 13]

71− :& RNil

72− fetchHTTPAndValidate schema (toJSON obj) >>= \case

73− Left e -> fail "failed to validate test example"

74− Right _ -> pure ()

75− it "validates schema with numbers" $ do

76− let

77− schema = D4.SchemaWithURI (fromJust $ toJsonSchema (Proxy @SchemaNumberExample)) Nothing

78− obj = withRepr @SchemaNumberExample $

79− field @"n1" 1.1

80− :& field @"n2" 1

81− :& field @"n3" 0.9

82− :& field @"n4" 1.0

83− :& RNil

84− fetchHTTPAndValidate schema (toJSON obj) >>= \case

85− Left e -> fail "failed to validate test example"

86− Right _ -> pure ()

87− it "validates schema with strings" $ do

88− let

89− schema = D4.SchemaWithURI (fromJust $ toJsonSchema (Proxy @SchemaTextExample)) Nothing

90− obj = withRepr @SchemaTextExample $

91− field @"t1" "11"

92− :& field @"t2" "1"

93− :& field @"t3" ""

94− :& field @"t4" "1"

95− :& RNil

96− fetchHTTPAndValidate schema (toJSON obj) >>= \case

97− Left e -> fail "failed to validate test example"

98− Right _ -> pure ()

99−

100−main :: IO ()

101−main = hspec spec

test/LensSpec.hsdeleted−318

@@ -1,318 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE TypeApplications #-}

3−{-# LANGUAGE OverloadedLists #-}

4−{-# LANGUAGE OverloadedStrings #-}

5−

6−module LensSpec (spec, main) where

7−

8−import Control.Lens

9−import Data.Proxy

10−import Data.Schematic

11−import Data.Vinyl

12−import Test.Hspec

13−

14−

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

16−

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

18−

19−type FieldsSchema =

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

21−

22−arrayData :: JsonRepr ArraySchema

23−arrayData = ReprArray [ReprNumber 13]

24−

25−arrayField :: FieldRepr ArrayField

26−arrayField = FieldRepr arrayData

27−

28−objectData :: Rec FieldRepr FieldsSchema

29−objectData = FieldRepr (ReprOptional (Just (ReprText "foo")))

30− :& FieldRepr arrayData

31− :& RNil

32−

33−type BigRecord = Rec FieldRepr

34− '[ '("f1", 'SchemaNumber '[])

35− , '("f2", 'SchemaNumber '[])

36− , '("f3", 'SchemaNumber '[])

37− , '("f4", 'SchemaNumber '[])

38− , '("f5", 'SchemaNumber '[])

39− , '("f6", 'SchemaNumber '[])

40− , '("f7", 'SchemaNumber '[])

41− , '("f8", 'SchemaNumber '[])

42− , '("f9", 'SchemaNumber '[])

43− , '("f10", 'SchemaNumber '[])

44− , '("f11", 'SchemaNumber '[])

45− , '("f12", 'SchemaNumber '[])

46− , '("f13", 'SchemaNumber '[])

47− , '("f14", 'SchemaNumber '[])

48− , '("f15", 'SchemaNumber '[])

49− , '("f16", 'SchemaNumber '[])

50− , '("f17", 'SchemaNumber '[])

51− , '("f18", 'SchemaNumber '[])

52− , '("f19", 'SchemaNumber '[])

53− , '("f20", 'SchemaNumber '[])

54− , '("f21", 'SchemaNumber '[])

55− , '("f22", 'SchemaNumber '[])

56− , '("f23", 'SchemaNumber '[])

57− , '("f24", 'SchemaNumber '[])

58− , '("f25", 'SchemaNumber '[])

59− , '("f26", 'SchemaNumber '[])

60− , '("f27", 'SchemaNumber '[])

61− , '("f28", 'SchemaNumber '[])

62− , '("f29", 'SchemaNumber '[])

63− , '("f30", 'SchemaNumber '[])

64− , '("f31", 'SchemaNumber '[])

65− , '("f32", 'SchemaNumber '[])

66− , '("f33", 'SchemaNumber '[])

67− , '("f34", 'SchemaNumber '[])

68− , '("f35", 'SchemaNumber '[])

69− , '("f36", 'SchemaNumber '[])

70− , '("f37", 'SchemaNumber '[])

71− , '("f38", 'SchemaNumber '[])

72− , '("f39", 'SchemaNumber '[])

73− , '("f40", 'SchemaNumber '[])

74− , '("f41", 'SchemaNumber '[])

75− , '("f42", 'SchemaNumber '[])

76− , '("f43", 'SchemaNumber '[])

77− , '("f44", 'SchemaNumber '[])

78− , '("f45", 'SchemaNumber '[])

79− , '("f46", 'SchemaNumber '[])

80− , '("f47", 'SchemaNumber '[])

81− , '("f48", 'SchemaNumber '[])

82− , '("f49", 'SchemaNumber '[])

83− , '("f50", 'SchemaNumber '[])

84− , '("f51", 'SchemaNumber '[])

85− , '("f52", 'SchemaNumber '[])

86− , '("f53", 'SchemaNumber '[])

87− , '("f54", 'SchemaNumber '[])

88− , '("f55", 'SchemaNumber '[])

89− , '("f56", 'SchemaNumber '[])

90− , '("f57", 'SchemaNumber '[])

91− , '("f58", 'SchemaNumber '[])

92− , '("f59", 'SchemaNumber '[])

93− , '("f60", 'SchemaNumber '[])

94− , '("f61", 'SchemaNumber '[])

95− , '("f62", 'SchemaNumber '[])

96− , '("f63", 'SchemaNumber '[])

97− , '("f64", 'SchemaNumber '[])

98− , '("f65", 'SchemaNumber '[])

99− , '("f66", 'SchemaNumber '[])

100− , '("f67", 'SchemaNumber '[])

101− , '("f68", 'SchemaNumber '[])

102− , '("f69", 'SchemaNumber '[])

103− , '("f70", 'SchemaNumber '[])

104− , '("f71", 'SchemaNumber '[])

105− , '("f72", 'SchemaNumber '[])

106− , '("f73", 'SchemaNumber '[])

107− , '("f74", 'SchemaNumber '[])

108− , '("f75", 'SchemaNumber '[])

109− , '("f76", 'SchemaNumber '[])

110− , '("f77", 'SchemaNumber '[])

111− , '("f78", 'SchemaNumber '[])

112− , '("f79", 'SchemaNumber '[])

113− , '("f80", 'SchemaNumber '[])

114− , '("f81", 'SchemaNumber '[])

115− , '("f82", 'SchemaNumber '[])

116− , '("f83", 'SchemaNumber '[])

117− , '("f84", 'SchemaNumber '[])

118− , '("f85", 'SchemaNumber '[])

119− , '("f86", 'SchemaNumber '[])

120− , '("f87", 'SchemaNumber '[])

121− , '("f88", 'SchemaNumber '[])

122− , '("f89", 'SchemaNumber '[])

123− , '("f90", 'SchemaNumber '[])

124− , '("f91", 'SchemaNumber '[])

125− , '("f92", 'SchemaNumber '[])

126− , '("f93", 'SchemaNumber '[])

127− , '("f94", 'SchemaNumber '[])

128− , '("f95", 'SchemaNumber '[])

129− , '("f96", 'SchemaNumber '[])

130− , '("f97", 'SchemaNumber '[])

131− , '("f98", 'SchemaNumber '[])

132− , '("f99", 'SchemaNumber '[])

133− , '("f100", 'SchemaNumber '[])

134− , '("f101", 'SchemaNumber '[])

135− , '("f102", 'SchemaNumber '[])

136− , '("f103", 'SchemaNumber '[])

137− , '("f104", 'SchemaNumber '[])

138− , '("f105", 'SchemaNumber '[])

139− , '("f106", 'SchemaNumber '[])

140− , '("f107", 'SchemaNumber '[])

141− , '("f108", 'SchemaNumber '[])

142− , '("f109", 'SchemaNumber '[])

143− , '("f110", 'SchemaNumber '[])

144− , '("f111", 'SchemaNumber '[])

145− , '("f112", 'SchemaNumber '[])

146− , '("f113", 'SchemaNumber '[])

147− , '("f114", 'SchemaNumber '[])

148− , '("f115", 'SchemaNumber '[])

149− , '("f116", 'SchemaNumber '[])

150− , '("f117", 'SchemaNumber '[])

151− , '("f118", 'SchemaNumber '[])

152− , '("f119", 'SchemaNumber '[])

153− , '("f120", 'SchemaNumber '[])

154− , '("f121", 'SchemaNumber '[])

155− , '("f122", 'SchemaNumber '[])

156− , '("f123", 'SchemaNumber '[])

157− , '("f124", 'SchemaNumber '[])

158− , '("f125", 'SchemaNumber '[])

159− , '("f126", 'SchemaNumber '[])

160− , '("f127", 'SchemaNumber '[])

161− , '("f128", 'SchemaNumber '[])

162− , '("f129", 'SchemaNumber '[])

163− , '("f130", 'SchemaNumber '[])

164− ]

165−

166−_bigRecord :: BigRecord

167−_bigRecord =

168− FieldRepr (ReprNumber 1)

169− :& FieldRepr (ReprNumber 2)

170− :& FieldRepr (ReprNumber 3)

171− :& FieldRepr (ReprNumber 4)

172− :& FieldRepr (ReprNumber 5)

173− :& FieldRepr (ReprNumber 6)

174− :& FieldRepr (ReprNumber 7)

175− :& FieldRepr (ReprNumber 8)

176− :& FieldRepr (ReprNumber 9)

177− :& FieldRepr (ReprNumber 10)

178− :& FieldRepr (ReprNumber 11)

179− :& FieldRepr (ReprNumber 12)

180− :& FieldRepr (ReprNumber 13)

181− :& FieldRepr (ReprNumber 14)

182− :& FieldRepr (ReprNumber 15)

183− :& FieldRepr (ReprNumber 16)

184− :& FieldRepr (ReprNumber 17)

185− :& FieldRepr (ReprNumber 18)

186− :& FieldRepr (ReprNumber 19)

187− :& FieldRepr (ReprNumber 20)

188− :& FieldRepr (ReprNumber 21)

189− :& FieldRepr (ReprNumber 22)

190− :& FieldRepr (ReprNumber 23)

191− :& FieldRepr (ReprNumber 24)

192− :& FieldRepr (ReprNumber 25)

193− :& FieldRepr (ReprNumber 26)

194− :& FieldRepr (ReprNumber 27)

195− :& FieldRepr (ReprNumber 28)

196− :& FieldRepr (ReprNumber 29)

197− :& FieldRepr (ReprNumber 30)

198− :& FieldRepr (ReprNumber 31)

199− :& FieldRepr (ReprNumber 32)

200− :& FieldRepr (ReprNumber 33)

201− :& FieldRepr (ReprNumber 34)

202− :& FieldRepr (ReprNumber 35)

203− :& FieldRepr (ReprNumber 36)

204− :& FieldRepr (ReprNumber 37)

205− :& FieldRepr (ReprNumber 38)

206− :& FieldRepr (ReprNumber 39)

207− :& FieldRepr (ReprNumber 40)

208− :& FieldRepr (ReprNumber 41)

209− :& FieldRepr (ReprNumber 42)

210− :& FieldRepr (ReprNumber 43)

211− :& FieldRepr (ReprNumber 44)

212− :& FieldRepr (ReprNumber 45)

213− :& FieldRepr (ReprNumber 46)

214− :& FieldRepr (ReprNumber 47)

215− :& FieldRepr (ReprNumber 48)

216− :& FieldRepr (ReprNumber 49)

217− :& FieldRepr (ReprNumber 50)

218− :& FieldRepr (ReprNumber 51)

219− :& FieldRepr (ReprNumber 52)

220− :& FieldRepr (ReprNumber 53)

221− :& FieldRepr (ReprNumber 54)

222− :& FieldRepr (ReprNumber 55)

223− :& FieldRepr (ReprNumber 56)

224− :& FieldRepr (ReprNumber 57)

225− :& FieldRepr (ReprNumber 58)

226− :& FieldRepr (ReprNumber 59)

227− :& FieldRepr (ReprNumber 60)

228− :& FieldRepr (ReprNumber 61)

229− :& FieldRepr (ReprNumber 62)

230− :& FieldRepr (ReprNumber 63)

231− :& FieldRepr (ReprNumber 64)

232− :& FieldRepr (ReprNumber 65)

233− :& FieldRepr (ReprNumber 66)

234− :& FieldRepr (ReprNumber 67)

235− :& FieldRepr (ReprNumber 68)

236− :& FieldRepr (ReprNumber 69)

237− :& FieldRepr (ReprNumber 70)

238− :& FieldRepr (ReprNumber 71)

239− :& FieldRepr (ReprNumber 72)

240− :& FieldRepr (ReprNumber 73)

241− :& FieldRepr (ReprNumber 74)

242− :& FieldRepr (ReprNumber 75)

243− :& FieldRepr (ReprNumber 76)

244− :& FieldRepr (ReprNumber 77)

245− :& FieldRepr (ReprNumber 78)

246− :& FieldRepr (ReprNumber 79)

247− :& FieldRepr (ReprNumber 80)

248− :& FieldRepr (ReprNumber 81)

249− :& FieldRepr (ReprNumber 82)

250− :& FieldRepr (ReprNumber 83)

251− :& FieldRepr (ReprNumber 84)

252− :& FieldRepr (ReprNumber 85)

253− :& FieldRepr (ReprNumber 86)

254− :& FieldRepr (ReprNumber 87)

255− :& FieldRepr (ReprNumber 88)

256− :& FieldRepr (ReprNumber 89)

257− :& FieldRepr (ReprNumber 90)

258− :& FieldRepr (ReprNumber 91)

259− :& FieldRepr (ReprNumber 92)

260− :& FieldRepr (ReprNumber 93)

261− :& FieldRepr (ReprNumber 94)

262− :& FieldRepr (ReprNumber 95)

263− :& FieldRepr (ReprNumber 96)

264− :& FieldRepr (ReprNumber 97)

265− :& FieldRepr (ReprNumber 98)

266− :& FieldRepr (ReprNumber 99)

267− :& FieldRepr (ReprNumber 100)

268− :& FieldRepr (ReprNumber 101)

269− :& FieldRepr (ReprNumber 102)

270− :& FieldRepr (ReprNumber 103)

271− :& FieldRepr (ReprNumber 104)

272− :& FieldRepr (ReprNumber 105)

273− :& FieldRepr (ReprNumber 106)

274− :& FieldRepr (ReprNumber 107)

275− :& FieldRepr (ReprNumber 108)

276− :& FieldRepr (ReprNumber 109)

277− :& FieldRepr (ReprNumber 110)

278− :& FieldRepr (ReprNumber 111)

279− :& FieldRepr (ReprNumber 112)

280− :& FieldRepr (ReprNumber 113)

281− :& FieldRepr (ReprNumber 114)

282− :& FieldRepr (ReprNumber 115)

283− :& FieldRepr (ReprNumber 116)

284− :& FieldRepr (ReprNumber 117)

285− :& FieldRepr (ReprNumber 118)

286− :& FieldRepr (ReprNumber 119)

287− :& FieldRepr (ReprNumber 120)

288− :& FieldRepr (ReprNumber 121)

289− :& FieldRepr (ReprNumber 122)

290− :& FieldRepr (ReprNumber 123)

291− :& FieldRepr (ReprNumber 124)

292− :& FieldRepr (ReprNumber 125)

293− :& FieldRepr (ReprNumber 126)

294− :& FieldRepr (ReprNumber 127)

295− :& FieldRepr (ReprNumber 128)

296− :& FieldRepr (ReprNumber 129)

297− :& FieldRepr (ReprNumber 130)

298− :& RNil

299−

300−spec :: Spec

301−spec = do

302− let

303− newFooVal = FieldRepr $ ReprArray [ReprNumber 15]

304− fooProxy = Proxy @"foo"

305− it "gets the field from an object" $ do

306− fget @"foo" objectData `shouldBe` arrayField

307− it "sets the object field" $ do

308− fget @"foo" (fput newFooVal objectData) `shouldBe` newFooVal

309−

310− describe "(using lens library) " $ do

311− it "get the field from an object" $ do

312− objectData ^. flens @"foo" `shouldBe` arrayField

313− it "sets the object field" $ do

314− set (flens @"foo") newFooVal objectData ^. flens @"foo"

315− `shouldBe` newFooVal

316−

317−main :: IO ()

318−main = hspec spec

test/SchemaSpec.hs+55−78

@@ -1,78 +1,47 @@

1{-# 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−

12module SchemaSpec (spec, main) where

3module SchemaSpec (spec, main) where

14−import Control.Lens

5+import Control.Monad

15−import Data.Aeson

16import Data.ByteString.Lazy

6import Data.ByteString.Lazy

17−import Data.Functor.Identity

7+import Data.Aeson

18import Data.Proxy

8import Data.Proxy

19import Data.Schematic

9import Data.Schematic

20−import Data.Schematic.Generator

21import Data.Singletons

10import Data.Singletons

22−import Data.Tagged

11+import Data.Singletons.Prelude

23import Data.Vinyl

12import Data.Vinyl

24import Test.Hspec

13import Test.Hspec

25import Test.Hspec.SmallCheck

14import Test.Hspec.SmallCheck

26−import Test.SmallCheck as SC

15+import Test.SmallCheck

27−import Test.SmallCheck.Drivers as SC

28−import Test.SmallCheck.Series as SC

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"]]))]

30−import Debug.Trace

24+type TestMigration =

25+ 'Migration "test_revision"

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

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

32−type SchemaExample = 'SchemaObject

29+type VS = 'Versioned SchemaExample '[ TestMigration ]

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

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

36−type SchemaExample2 = 'SchemaObject

31+exampleTest :: JsonRepr (SchemaOptional (SchemaText '[TEq 3]))

37− '[ '("foo", 'SchemaArray '[ 'AEq 2] ('SchemaText '[ 'TGt 10]))

32+exampleTest = ReprOptional (Just (ReprText "lil"))

38− , '("bar", 'SchemaOptional ('SchemaText '[ 'TRegex "[0-9]+"]))]

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]

40jsonExample :: JsonRepr SchemaExample

41−jsonExample = withRepr @SchemaExample

41+jsonExample = ReprObject $

42− $ field @"bar" (Just "bar")

42+ FieldRepr (ReprArray [ReprNumber 12])

43− :& field @"foo" [12]

43+ :& FieldRepr (ReprOptional (Just (ReprText "bar")))

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))

44+ :& RNil

75− :&& MNil

77schemaJson :: ByteString

46schemaJson :: ByteString

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

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

@@ -80,11 +49,26 @@ schemaJson = "{\"foo\": [13], \"bar\": null}"

80schemaJson2 :: ByteString

49schemaJson2 :: ByteString

81schemaJson2 = "{\"foo\": [3], \"bar\": null}"

50schemaJson2 = "{\"foo\": [3], \"bar\": null}"

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

83−schemaJsonSeries :: Monad m => SC.Series m (JsonRepr SchemaExample)

67+ SchemaExample

84−schemaJsonSeries = series

68+ ('SchemaObject

85−

69+ '[ '("foo", 'SchemaNumber '[]), '("bar", 'SchemaText '[])])

86−schemaJsonSeries2 :: Monad m => SC.Series m (JsonRepr SchemaExample2)

70+ where

87−schemaJsonSeries2 = series

71+ migrate = const topObject

89spec :: Spec

73spec :: Spec

90spec = do

74spec = do

@@ -101,22 +85,15 @@ spec = do

101 it "validates incorrect representation" $

85 it "validates incorrect representation" $

102 ((decodeAndValidateJson schemaJson2) :: ParseResult (JsonRepr SchemaExample))

86 ((decodeAndValidateJson schemaJson2) :: ParseResult (JsonRepr SchemaExample))

103 `shouldSatisfy` isValidationError

87 `shouldSatisfy` isValidationError

104− -- it "validates versioned json" $ do

88+ it "validates versioned json" $ do

105− -- decodeAndValidateVersionedJson (Proxy @VS) schemaJson

89+ decodeAndValidateVersionedJson (Proxy @VS) schemaJson

106− -- `shouldSatisfy` isValid

90+ `shouldSatisfy` isValid

107− it "validates versioned json with a migration list" $ do

91+ it "validates with Migration List" $ do

108− decodeAndValidateVersionedWithPureMList

92+ decodeAndValidateVersionedWithMList

109− (Proxy @VersionedJson)

93+ (Proxy @VS)

110− migrationList

94+ ((:&&) (Proxy @(SchemaByRevision "test_revision" VS)) (const topObject) MNil)

111 schemaJson

95 schemaJson

112 `shouldSatisfy` isValid

96 `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−

120

121main :: IO ()

98main :: IO ()

122main = hspec spec

99main = hspec spec