85c3137...master · typeable/schematic

git.iko.soy/typeable/schematic

28 files changed+1044−264

since splitsnapshots

unifiedsplit

.travis.yml+2−2 ChangeLog.md+32 README.md+5−5 release+16−8 release.nix+32 schematic.cabal+21−9 src/Data/Schematic.hs−23 src/Data/Schematic/DSL.hs+16−7 src/Data/Schematic/Generator.hs+91 src/Data/Schematic/Generator/Regex.hs+76 src/Data/Schematic/Instances.hs+4 src/Data/Schematic/JsonSchema.hs+29−10 src/Data/Schematic/Lens.hs+46−28 src/Data/Schematic/Migration.hs+14−6 src/Data/Schematic/Path.hs+18−23 src/Data/Schematic/Schema.hs+148−60 src/Data/Schematic/Schema.hs-boot+95 src/Data/Schematic/Validation.hs+87−29 src/Data/Schematic/Verifier.hs+5 src/Data/Schematic/Verifier/Array.hs+14 src/Data/Schematic/Verifier/Common.hs+43 src/Data/Schematic/Verifier/Number.hs+31 src/Data/Schematic/Verifier/Text.hs+121 stack-13.21.yaml+7 stack.yaml+5−50 test/JsonSchemaSpec.hs+58 test/LensSpec.hs+4−4 test/SchemaSpec.hs+24

.travis.yml+2−2

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

1−sudo: false

1+sudo: required

33language: c

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

2222

2323cache:

2424 directories:

25− - $HOME/.stack

25+ - $HOME/.stack

ChangeLog.md+32

@@ -1,5 +1,37 @@

11# Revision history for schematic

3+## 0.6.0.0 -- 2021-01-15

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`.

7+## 0.5.1.0 -- 2021-01-15

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+

335## 0.4.0.0 -- 2017-10-17

436

537Object building DSL, more convenience helpers, MCons simplified with Tagged

README.md+5−5

@@ -24,7 +24,7 @@ $ stack install schematic

2424

2525## GHC Extensions

2626

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

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

2828either to a module or a cabal file:

2929

3030```

@@ -35,7 +35,7 @@ TypeApplications

3535```

3636

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

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

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

3939

4040## GHC Options

4141

@@ -132,8 +132,8 @@ type SchemaExample = 'SchemaObject FieldsSchema

132132

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

134134

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

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

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`

137137

138138## Migrations

139139

@@ -178,7 +178,7 @@ Data migrations on the other hand are functions on the data itself. They transfo

178178acceptable by one schema to values acceptable by another.

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

180180

181−```

181+```haskell

182182type SchemaExample = 'SchemaObject

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

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

release+16−8

@@ -4,6 +4,12 @@ set -o xtrace

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

7+rootdir=`pwd`

9+cabalfile=`ls *.cabal`

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

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

12+

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

814stack test 2> /dev/null

915

@@ -18,17 +24,19 @@ if [ "$?" -eq "0" ]; then

1824 read -p "Hackage username: " username

1925 read -p "Hackage password: " -s password

2026 echo ""

21− cabal upload -u $username -p $password dist/$1-$2.tar.gz

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

2228

23− docdir=$dist/doc/html

24− cd $docdir

25− doc=$1-$2-docs

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

2630

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

28− cp -r $1 $doc

29− tar -c -v -z --format=ustar -f $doc.tar.gz $doc

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

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

31− curl -X PUT -H 'Content-Type: application/x-tar' -H 'Content-Encoding: gzip' --data-binary "@$doc.tar.gz" "https://$username:$password@hackage.haskell.org/package/$1-$2/docs"

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'."

3240 exit $?

3341else

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

release.nixnew file+32

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

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

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

3+}:

5+let

6+ _nixpkgs = import <nixpkgs> {};

7+ inherit (_nixpkgs) pkgs lib;

9+ stackageOverlayPath = pkgs.fetchFromGitHub {

10+ owner = "typeable";

11+ repo = "nixpkgs-stackage";

12+ rev = "abe0a03ba2bde609b0707ce45301ec836cb3ed29";

13+ sha256 = "0ksdk83zbsgvs30izwsfyjh4xxwz8dsn9a5igrs3pjap4whpzqfv";

14+ };

15+

16+ nixpkgsArgs = {

17+ overlays = [ (import stackageOverlayPath) ];

18+ };

19+

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

21+

22+ mkStackage = system:

23+ let

24+ nixpkgs = release.pkgsFor system;

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

26+ in

27+ stackage;

28+

29+in

30+ lib.genAttrs supportedSystems (system: {

31+ inherit (mkStackage system) schematic;

32+ })

schematic.cabal+21−9

@@ -1,6 +1,7 @@

11name: schematic

2−version: 0.4.0.0

2+version: 0.6.0.0

33synopsis: 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.

45license: BSD3

56license-file: LICENSE

67author: Denis Redozubov

@@ -9,12 +10,14 @@ homepage: http://github.com/typeable/schematic

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

1011category: Data

1112build-type: Simple

12−extra-source-files: ChangeLog.md

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

1314cabal-version: >=1.10

1415

1516library

1617 exposed-modules: Data.Schematic

1718 , Data.Schematic.DSL

19+ , Data.Schematic.Generator

20+ , Data.Schematic.Generator.Regex

1821 , Data.Schematic.Instances

1922 , Data.Schematic.JsonSchema

2023 , Data.Schematic.Helpers

@@ -23,6 +26,11 @@ library

2326 , Data.Schematic.Path

2427 , Data.Schematic.Schema

2528 , Data.Schematic.Validation

29+ , Data.Schematic.Verifier

30+ , Data.Schematic.Verifier.Array

31+ , Data.Schematic.Verifier.Common

32+ , Data.Schematic.Verifier.Number

33+ , Data.Schematic.Verifier.Text

2634 ghc-options: -Wall

2735 default-extensions: ConstraintKinds

2836 , DataKinds

@@ -57,9 +65,9 @@ library

5765 , TypeOperators

5866 , TypeSynonymInstances

5967 , UndecidableInstances

60− build-depends: base >=4.9 && <4.11

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

6169 , bytestring

62− , aeson >= 1

70+ , aeson >= 1.4.3.0 && < 1.6

6371 , containers

6472 , hjsonschema

6573 , mtl

@@ -67,14 +75,14 @@ library

6775 , regex-tdfa

6876 , regex-tdfa-text

6977 , scientific

70− , singletons >= 2.2

78+ , singletons >= 2.4

7179 , smallcheck

7280 , tagged

7381 , template-haskell

7482 , text

7583 , union

7684 , unordered-containers

77− , validationt >= 0.1.0.1

85+ , validationt >= 0.2.1.0

7886 , vector

7987 , vinyl

8088 hs-source-dirs: src

@@ -87,7 +95,7 @@ test-suite spec

8795 default-language: Haskell2010

8896 build-depends: HUnit

8997 , aeson >= 1

90− , base >=4.9 && <4.11

98+ , base >=4.11 && <4.13

9199 , bytestring

92100 , containers

93101 , hjsonschema

@@ -104,9 +112,13 @@ test-suite spec

104112 , tagged

105113 , text

106114 , unordered-containers

107− , validationt >= 0.1.0.1

115+ , validationt >= 0.2.1.0

108116 , vinyl

109117 other-modules: SchemaSpec

110118 , HelpersSpec

111119 , LensSpec

112− , JsonSchemaSpec

120+ , JsonSchemaSpec

121+

122+source-repository head

123+ type: git

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

src/Data/Schematic.hs−23

@@ -39,29 +39,6 @@ import Data.Tagged

3939import Data.Text as T

4040

4141

42−parseAndValidateJson

43− :: forall schema

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

45− => J.Value

46− -> ParseResult (JsonRepr schema)

47−parseAndValidateJson v =

48− case parseEither parseJSON v of

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

50− Right jsonRepr ->

51− let

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

53− res = runIdentity . runValidationTEither $ validate

54− in case res of

55− Left em -> ValidationError em

56− Right () -> Valid jsonRepr

57−

58−parseAndValidateJsonBy

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

60− => proxy schema

61− -> J.Value

62− -> ParseResult (JsonRepr schema)

63−parseAndValidateJsonBy _ = parseAndValidateJson

64−

6542parseAndValidateTopVersionJson

6643 :: forall proxy (v :: Versioned)

6744 . (SingI (TopVersion (AllVersions v)))

src/Data/Schematic/DSL.hs+16−7

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

11{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE CPP #-}

34module Data.Schematic.DSL where

@@ -17,11 +18,19 @@ import Data.Vinyl

1718import Data.Vinyl.Functor

1819

1920

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

2022type Constructor a

21− = forall b. FSubset (FieldsOf a) b (FImage (FieldsOf a) b)

22− => Rec (Tagged (FieldsOf a) :. FieldRepr) b

23− -> JsonRepr ('SchemaObject (FieldsOf a))

24−

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

2534withRepr :: Constructor a

2635withRepr = ReprObject . rmap (unTagged . getCompose) . fcast

2736

@@ -66,9 +75,9 @@ type family FieldsOf (s :: Schema) :: [(Symbol, Schema)] where

6675 FieldsOf ('SchemaObject fs) = fs

6776

6877type FieldConstructor fn =

69− forall fs. (Representable (ByField fn fs (FIndex fn fs)))

70− => Repr (ByField fn fs (FIndex fn fs))

71− -> (Tagged fs :. FieldRepr) '(fn, (ByField fn fs (FIndex fn fs)))

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

79+ => Repr byField

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

7281

7382field :: forall fn. KnownSymbol fn => FieldConstructor fn

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

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

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

1+module Data.Schematic.Generator where

3+import Data.Maybe

4+import Data.Schematic.Generator.Regex

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

6+import Data.Schematic.Verifier

7+import Data.Scientific

8+import Data.Text (Text, pack)

9+import qualified Data.Vector as V

10+import Test.SmallCheck.Series

11+

12+maxHigh :: Int

13+maxHigh = 30

14+

15+minLow :: Int

16+minLow = 2

17+

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

19+textLengthSeries =

20+ \case

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

22+ [VTBounds ml mh] -> do

23+ let

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

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

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

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

28+ _ -> pure "error"

29+

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

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

32+

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

34+textSeries cs = do

35+ let mvcs = verifyTextConstraints cs

36+ case mvcs of

37+ Just vcs -> do

38+ n <- textSeries' vcs

39+ pure n

40+ Nothing -> pure "error"

41+

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

43+textSeries' [] = pure "sample"

44+textSeries' vcs = do

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

46+ case enums of

47+ Just e -> textEnumSeries e

48+ Nothing -> do

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

50+ case regexps of

51+ Just e -> regexSeries e

52+ Nothing -> textLengthSeries vcs

53+

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

55+numberSeries cs = do

56+ let mvcs = verifyNumberConstraints cs

57+ case mvcs of

58+ Just vcs -> do

59+ n <- numberSeries' vcs

60+ pure $ n

61+ Nothing -> pure 0

62+

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

64+numberSeries' =

65+ \case

66+ VNEq eq -> pure $ fromIntegral eq

67+ VNBounds ml mh -> do

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

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

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

71+ pure $ fromIntegral n

72+

73+arraySeries

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

75+ => [DemotedArrayConstraint]

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

77+arraySeries cs = do

78+ let mvcs = verifyArrayConstraint cs

79+ case mvcs of

80+ Just vcs -> arraySeries' vcs

81+ Nothing -> pure V.empty

82+

83+arraySeries'

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

85+ => Maybe VerifiedArrayConstraint

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

87+arraySeries' ml = do

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

89+ pure $ objs

90+ where

91+ f (VAEq l) = fromIntegral l

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

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

1+module Data.Schematic.Generator.Regex where

3+import Control.Monad

4+import Data.List

5+import Data.Maybe

6+import qualified Data.Set as S

7+import Data.Text (Text, unpack)

8+import Data.Text.Lazy (toStrict)

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

10+import Test.SmallCheck.Series

11+import Text.Regex.TDFA.Pattern

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

13+

14+

15+minRepeat :: Int

16+minRepeat = 2

17+

18+maxRepeat :: Int

19+maxRepeat = 10

20+

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

22+regexSeries regexp =

23+ case parseRegex . unpack $ regexp of

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

25+ Left _ -> pure ""

26+

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

28+regexSeries' pt =

29+ case pt of

30+ PEmpty -> pure mempty

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

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

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

34+ pure $ singleton x

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

36+ x <-

37+ generate $ \depth ->

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

39+ pure $ singleton x

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

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

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

43+ PBound low mhigh p -> do

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

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

46+ decDepth $ do

47+ ps <- replicateM n $ regexSeries' p

48+ pure $ mconcat ps

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

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

51+ PDot _ -> do

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

53+ pure $ singleton x

54+ PEscape {..} -> do

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

56+ pure $ singleton x

57+ PCarat _ -> pure mempty

58+ PDollar _ -> pure mempty

59+ _ -> pure mempty

60+ where

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

62+ expandEscape ch =

63+ case ch of

64+ 'n' -> "\n"

65+ 't' -> "\t"

66+ 'r' -> "\r"

67+ 'f' -> "\f"

68+ 'a' -> "\a"

69+ 'e' -> "\ESC"

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

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

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

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

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

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

76+ ch' -> [ch']

src/Data/Schematic/Instances.hs+4

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

44module Data.Schematic.Instances where

66import Data.Scientific

7+import Data.Text (Text, pack)

78import Data.Vector as V

89import Data.Vinyl

910import Test.SmallCheck.Series

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

2122

2223instance Monad m => Serial m Scientific where

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

25+

26+instance Monad m => Serial m Text where

27+ series = pack <$> series

src/Data/Schematic/JsonSchema.hs+29−10

@@ -12,8 +12,10 @@ import Control.Monad.State.Strict

1212import Data.Aeson as J

1313import Data.Foldable as F

1414import Data.HashMap.Strict as H

15+import Data.List as L

1516import Data.List.NonEmpty as NE

1617import Data.Schematic.Schema as S

18+import Data.Set as Set

1719import Data.Singletons

1820import Data.Text

1921import Data.Traversable

@@ -28,13 +30,13 @@ textConstraint :: DemotedTextConstraint -> State D4.Schema ()

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

2931 { _schemaMinLength = pure $ fromIntegral n

3032 , _schemaMaxLength = pure $ fromIntegral n }

31−textConstraint (DTLt n) = modify $ \s -> s

32− { _schemaMaxLength = pure . fromIntegral $ n + 1 }

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

3434 { _schemaMaxLength = pure . fromIntegral $ n }

35−textConstraint (DTGt n) =

35+textConstraint (DTLt n) =

3636 let n' = if n == 0 then 0 else n - 1

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

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

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

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

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

3941 { _schemaMinLength = pure . fromIntegral $ n }

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

@@ -46,18 +48,30 @@ numberConstraint :: DemotedNumberConstraint -> State D4.Schema ()

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

4749 { _schemaMaximum = pure . fromIntegral $ n }

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

49− { _schemaMaximum = pure . fromIntegral $ n + 1 }

51+ { _schemaMaximum = pure . fromIntegral $ n

52+ , _schemaExclusiveMaximum = pure True }

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

54+ { _schemaMinimum = pure . fromIntegral $ n

55+ , _schemaExclusiveMinimum = pure True }

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

5157 { _schemaMinimum = pure . fromIntegral $ n }

52−numberConstraint (DNGe n) =

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

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

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

5659 { _schemaMinimum = pure $ fromIntegral n

5760 , _schemaMaximum = pure $ fromIntegral n }

5861

5962arrayConstraint :: DemotedArrayConstraint -> State D4.Schema ()

60−arrayConstraint (DAEq _) = pure ()

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 }

6175

6276toJsonSchema

6377 :: forall proxy schema

@@ -84,14 +98,19 @@ toJsonSchema' = \case

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

8599 s' <- toJsonSchema' s

86100 pure (n, s')

101+ let

102+ nonOpt = \case

103+ (_, DSchemaOptional _) -> False

104+ _ -> True

87105 pure $ emptySchema

88106 { _schemaType = pure $ TypeValidatorString D4.SchemaObject

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

89108 , _schemaProperties = pure $ H.fromList res }

90109 DSchemaArray acs sch -> do

91110 res <- toJsonSchema' sch

92111 pure $ execState (traverse_ arrayConstraint acs) $ emptySchema

93112 { _schemaType = pure $ TypeValidatorString D4.SchemaArray

94− , _schemaItems = pure $ ItemsArray [res] }

113+ , _schemaItems = pure $ ItemsObject res }

95114 DSchemaNull -> pure $ emptySchema

96115 { _schemaType = pure $ TypeValidatorString D4.SchemaNull }

97116 DSchemaOptional sch -> do

src/Data/Schematic/Lens.hs+46−28

@@ -10,6 +10,11 @@ module Data.Schematic.Lens

1010 , FSubset(..)

1111 , obj

1212 , arr

13+ , uni

14+ , txt

15+ , num

16+ , opt

17+ , bln

1318 , textRepr

1419 , numberRepr

1520 , boolRepr

@@ -19,11 +24,11 @@ module Data.Schematic.Lens

1924 ) where

2025

2126import Data.Profunctor

22−import Data.Proxy

2327import Data.Schematic.Schema

2428import Data.Scientific

2529import Data.Singletons

2630import Data.Text

31+import Data.Union

2732import Data.Vector as V

2833import Data.Vinyl

2934import Data.Vinyl.Functor

@@ -36,20 +41,20 @@ type family FIndex (r :: Symbol) (rs :: [(Symbol, Schema)]) :: Nat where

3641 FIndex r ( '(r, s) ': rs) = 'Z

3742 FIndex r ( s ': rs) = 'S (FIndex r rs)

3843

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+

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

4053 type ByField fn rs i :: Schema

41− flens

42− :: Functor g

43− => proxy fn

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

45− -> Rec f rs

46− -> g (Rec f rs)

54+ flens :: Flens fn f g rs i

4755

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

49− fget

50− :: proxy fn

51− -> Rec f rs

52− -> f '(fn, (ByField fn rs i))

57+ fget :: FGetter fn f rs i

5358

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

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

@@ -62,25 +67,25 @@ class i ~ FIndex fn rs => FElem (fn :: Symbol) (rs :: [(Symbol, Schema)]) (i ::

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

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

6469

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

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

6671 {-# INLINE flens #-}

6772

68− fget k = getConst . flens k Const

73+ fget = getConst . flens Const

6974 {-# INLINE fget #-}

7075

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

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

7277 {-# INLINE fput #-}

7378

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

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

7681

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

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

7883 {-# INLINE flens #-}

7984

80− fget k = getConst . flens k Const

85+ fget = getConst . flens Const

8186 {-# INLINE fget #-}

8287

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

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

8489 {-# INLINE fput #-}

8590

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

@@ -144,46 +149,59 @@ instance

144149 ( ByField fn ss i ~ s

145150 , FElem fn ss i

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

147− fsubset = lens (\ss -> fget Proxy ss :& fcast ss) set

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

148153 where

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

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

151156

152157-- A bunch of @Iso@morphisms

153158textRepr

154− :: (KnownSymbol fn, SingI fn, SingI cs)

159+ :: (KnownSymbol fn, SingI cs)

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

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

157162

158163numberRepr

159− :: (KnownSymbol fn, SingI fn, SingI cs)

164+ :: (KnownSymbol fn, SingI cs)

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

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

162167

163168boolRepr

164− :: (KnownSymbol fn, SingI fn, SingI cs)

169+ :: (KnownSymbol fn)

165170 => Iso' (FieldRepr '(fn, 'SchemaBoolean)) Bool

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

167172

168173arrayRepr

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

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

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

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

172177

173178objectRepr

174− :: (KnownSymbol fn, SingI fn, SingI fields)

179+ :: (KnownSymbol fn, SingI fields)

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

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

177182

178183optionalRepr

179− :: (KnownSymbol fn, SingI fn, SingI schema)

184+ :: (KnownSymbol fn, SingI schema)

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

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

182187

183−obj :: (SingI fields) => Iso' (JsonRepr ('SchemaObject fields)) (Rec FieldRepr fields)

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

184189obj = iso (\(ReprObject r) -> r) ReprObject

185190

186−arr

187− :: (SingI schema)

188− => Iso' (JsonRepr ('SchemaArray cs schema)) (V.Vector (JsonRepr schema))

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

189192arr = 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+14−6

@@ -1,5 +1,6 @@

11{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE TemplateHaskell #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE TemplateHaskell #-}

45module Data.Schematic.Migration where

@@ -7,10 +8,10 @@ import Data.Kind

78import Data.Schematic.DSL

89import Data.Schematic.Lens

910import Data.Schematic.Path

10−import Data.Tagged

1111import Data.Schematic.Schema

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

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

1313import Data.Singletons.TypeLits

14+import Data.Tagged

1415import Data.Vinyl

1516import Data.Vinyl.Functor

1617

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

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

4344

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

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

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

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

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

4748

4849type family UpdateKey

4950 (fn :: Symbol)

@@ -146,7 +147,7 @@ data instance Sing (v :: Versioned) where

146147

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

148149

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

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

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

151152 (:&&)

152153 :: (TopLevel s, SingI s)

@@ -156,10 +157,17 @@ data MList :: (* -> *) -> [Schema] -> Type where

156157

157158infixr 7 :&&

158159

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

159166migrateObject

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

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

162169 -> Tagged ('SchemaObject fs) (JsonRepr ('SchemaObject fh) -> m (JsonRepr ('SchemaObject fs)))

170+#endif

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

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

165173 pure $ withRepr @('SchemaObject fs) res

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

@@ -1,41 +1,36 @@

11module Data.Schematic.Path where

33import Data.Foldable as F

4−import Data.Monoid

5−import Data.Singletons

64import Data.Singletons.Prelude

75import Data.Singletons.TypeLits

86import Data.Text as T

7+import Data.Aeson.Internal

109

11−data PathSegment = Key Symbol | Ix Nat

12−

13−data instance Sing (jp :: PathSegment) where

14− SKey :: (SingI k) => Sing (k :: Symbol) -> Sing ('Key k)

15− SIx :: (SingI n) => Sing (n :: Nat) -> Sing ('Ix n)

16−

17−data DemotedPathSegment = DKey Text | DIx Integer

10+newtype JSONPathText = JSONPathText Text

1811 deriving (Show)

1912

20−-- | Textual representation of json path.

21−newtype JSONPath = JSONPath Text

22− deriving (Show)

13+data PathSegment = PathKey Symbol | PathIx Nat

14+

15+data instance Sing (jp :: PathSegment) where

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

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

2318

24−demotePath :: Sing (ps :: [PathSegment]) -> [DemotedPathSegment]

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

2520demotePath = go []

2621 where

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

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

2823 go acc SNil = acc

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

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

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

32− demote (SIx n) = DIx $ withKnownNat n $ natVal n

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

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

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

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

3328

34−demotedPathToText :: [DemotedPathSegment] -> JSONPath

35−demotedPathToText = JSONPath . F.foldl' renderPathSegment ""

29+demotedPathToText :: JSONPath -> JSONPathText

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

3631 where

37− renderPathSegment acc (DKey t) = acc <> "." <> t

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

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

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

3934

40−pathToText :: Sing (ps :: [PathSegment]) -> JSONPath

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

4136pathToText = demotedPathToText . demotePath

src/Data/Schematic/Schema.hs+148−60

@@ -1,6 +1,7 @@

11{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE OverloadedLists #-}

3−{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE OverloadedLists #-}

4+{-# LANGUAGE OverloadedStrings #-}

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

67module Data.Schematic.Schema where

@@ -12,6 +13,7 @@ import Data.Aeson.Types as J

1213import Data.HashMap.Strict as H

1314import Data.Kind

1415import Data.Maybe

16+import Data.Schematic.Generator

1517import Data.Schematic.Instances ()

1618import Data.Scientific

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

@@ -24,7 +26,8 @@ import Data.Vinyl hiding (Dict)

2426import qualified Data.Vinyl.TypeLevel as V

2527import GHC.Exts

2628import GHC.Generics (Generic)

27−import GHC.TypeLits (SomeNat(..), SomeSymbol(..), someSymbolVal, someNatVal)

29+import GHC.TypeLits

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

2831import Prelude as P

2932import Test.SmallCheck.Series

3033

@@ -48,33 +51,33 @@ data TextConstraint

4851instance SingKind TextConstraint where

4952 type Demote TextConstraint = DemotedTextConstraint

5053 fromSing = \case

51− STEq n -> withKnownNat n (DTEq $ natVal n)

52− STLt n -> withKnownNat n (DTLt $ natVal n)

53− STLe n -> withKnownNat n (DTLe $ natVal n)

54− STGt n -> withKnownNat n (DTGt $ natVal n)

55− STGe n -> withKnownNat n (DTGe $ natVal n)

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)

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

5760 STEnum s -> let

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

59− d SNil = []

62+ d SNil = []

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

6164 in DTEnum $ d s

6265 toSing = \case

6366 DTEq n -> case someNatVal n of

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

65− Nothing -> error "Negative singleton nat"

68+ Nothing -> error "Negative singleton nat"

6669 DTLt n -> case someNatVal n of

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

68− Nothing -> error "Negative singleton nat"

71+ Nothing -> error "Negative singleton nat"

6972 DTLe n -> case someNatVal n of

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

71− Nothing -> error "Negative singleton nat"

74+ Nothing -> error "Negative singleton nat"

7275 DTGt n -> case someNatVal n of

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

74− Nothing -> error "Negative singleton nat"

77+ Nothing -> error "Negative singleton nat"

7578 DTGe n -> case someNatVal n of

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

77− Nothing -> error "Negative singleton nat"

80+ Nothing -> error "Negative singleton nat"

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

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

8083 DTEnum ss -> case toSing ss of

@@ -88,7 +91,7 @@ data DemotedTextConstraint

8891 | DTGe Integer

8992 | DTRegex Text

9093 | DTEnum [Text]

91− deriving (Generic)

94+ deriving (Generic, Eq, Show)

9295

9396data instance Sing (tc :: TextConstraint) where

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

@@ -129,7 +132,7 @@ data DemotedNumberConstraint

129132 | DNGt Integer

130133 | DNGe Integer

131134 | DNEq Integer

132− deriving (Generic)

135+ deriving (Generic, Eq, Show)

133136

134137data instance Sing (nc :: NumberConstraint) where

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

@@ -153,51 +156,87 @@ instance Eq (Sing ('NGe n)) where _ == _ = True

153156instance SingKind NumberConstraint where

154157 type Demote NumberConstraint = DemotedNumberConstraint

155158 fromSing = \case

156− SNEq n -> withKnownNat n (DNEq $ natVal n)

157− SNGt n -> withKnownNat n (DNGt $ natVal n)

158− SNGe n -> withKnownNat n (DNGe $ natVal n)

159− SNLt n -> withKnownNat n (DNLt $ natVal n)

160− SNLe n -> withKnownNat n (DNLe $ natVal n)

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)

161164 toSing = \case

162165 DNEq n -> case someNatVal n of

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

164− Nothing -> error "Negative singleton nat"

167+ Nothing -> error "Negative singleton nat"

165168 DNGt n -> case someNatVal n of

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

167− Nothing -> error "Negative singleton nat"

170+ Nothing -> error "Negative singleton nat"

168171 DNGe n -> case someNatVal n of

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

170− Nothing -> error "Negative singleton nat"

173+ Nothing -> error "Negative singleton nat"

171174 DNLt n -> case someNatVal n of

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

173− Nothing -> error "Negative singleton nat"

176+ Nothing -> error "Negative singleton nat"

174177 DNLe n -> case someNatVal n of

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

176− Nothing -> error "Negative singleton nat"

179+ Nothing -> error "Negative singleton nat"

177180

178181data ArrayConstraint

179182 = AEq Nat

183+ | AGt Nat

184+ | AGe Nat

185+ | ALt Nat

186+ | ALe Nat

180187 deriving (Generic)

181188

182189data DemotedArrayConstraint

183190 = DAEq Integer

184− deriving (Generic)

191+ | DAGt Integer

192+ | DAGe Integer

193+ | DALt Integer

194+ | DALe Integer

195+ deriving (Generic, Eq, Show)

185196

186197data instance Sing (ac :: ArrayConstraint) where

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

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

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

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

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

188203

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

190209

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

192215

193216instance SingKind ArrayConstraint where

194217 type Demote ArrayConstraint = DemotedArrayConstraint

195218 fromSing = \case

196− SAEq n -> withKnownNat n (DAEq $ natVal n)

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)

197224 toSing = \case

198225 DAEq n -> case someNatVal n of

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

200− Nothing -> error "Negative singleton nat"

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"

201240

202241data Schema

203242 = SchemaText [TextConstraint]

@@ -219,7 +258,7 @@ data DemotedSchema

219258 | DSchemaNull

220259 | DSchemaOptional DemotedSchema

221260 | DSchemaUnion [DemotedSchema]

222− deriving (Generic)

261+ deriving (Generic, Eq, Show)

223262

224263data instance Sing (schema :: Schema) where

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

@@ -334,6 +373,31 @@ data JsonRepr :: Schema -> Type where

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

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

336375

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

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

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

379+

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

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

382+ series = decDepth $ fmap ReprNumber

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

384+

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

386+ series = cons0 ReprNull

387+

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

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

390+ series = decDepth $ fmap ReprArray

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

392+

393+instance (Serial m (JsonRepr s))

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

395+ series = cons1 ReprOptional

396+

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

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

399+ series = cons1 ReprObject

400+

337401-- | Move to the union package

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

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

@@ -341,39 +405,31 @@ instance Show (JsonRepr ('SchemaText cs)) where

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

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

343407

408+instance Show (JsonRepr 'SchemaBoolean) where

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

410+

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

345412

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

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

348415

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

417+instance

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

419+ , RecordToList fs )

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

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

422+#else

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

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

425+#endif

351426

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

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

354429

355−instance (Monad m, Serial m Text)

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

357− series = cons1 ReprText

358−

359−instance (Monad m, Serial m Scientific)

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

361− series = cons1 ReprNumber

362−

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

364− series = cons0 ReprNull

365−

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

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

368− series = cons1 ReprArray

369−

370−instance (Serial m (JsonRepr s))

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

372− series = cons1 ReprOptional

373−

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

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

376− series = cons1 ReprObject

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

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

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

377433

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

379435 ReprObject a == ReprObject b = a == b

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

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

385441 ReprNumber a == ReprNumber b = a == b

386442

443+instance Eq (JsonRepr 'SchemaBoolean) where

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

445+

387446instance Eq (JsonRepr 'SchemaNull) where

388447 ReprNull == ReprNull = True

389448

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

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

394453 ReprOptional a == ReprOptional b = a == b

395454

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+

396484instance IsList (JsonRepr ('SchemaArray cs s)) where

397485 type Item (JsonRepr ('SchemaArray cs s)) = JsonRepr s

398486 fromList = ReprArray . GHC.Exts.fromList

@@ -454,25 +542,25 @@ instance SingI schema => J.FromJSON (JsonRepr schema) where

454542 fieldRepr <- case s of

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

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

457− Nothing -> fail "schematext"

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

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

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

460− Nothing -> fail "schemanumber"

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

461549 SSchemaBoolean -> case H.lookup fieldName h of

462550 Just v -> FieldRepr <$> parseJSON v

463− Nothing -> fail "schemaboolean"

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

464552 SSchemaNull -> case H.lookup fieldName h of

465553 Just v -> FieldRepr <$> parseJSON v

466− Nothing -> fail "schemanull"

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

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

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

469− Nothing -> fail "schemaarray"

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

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

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

472− Nothing -> fail "schemaobject"

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

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

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

475− Nothing -> fail "schemaoptional"

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

476564 SSchemaUnion ss -> withSingI ss $ FieldRepr <$> parseUnion ss value

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

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

@@ -484,7 +572,7 @@ instance J.ToJSON (JsonRepr a) where

484572 toJSON (ReprText t) = J.String t

485573 toJSON (ReprNumber n) = J.Number n

486574 toJSON (ReprOptional s) = case s of

487− Just v -> toJSON v

575+ Just v -> toJSON v

488576 Nothing -> J.Null

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

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

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

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

1+module Data.Schematic.Schema where

3+import Data.Kind

4+import Data.Maybe

5+import Data.Schematic.Instances ()

6+import Data.Scientific

7+import Data.Singletons.TH

8+import Data.Singletons.TypeLits

9+import Data.Text as T

10+import Data.Union

11+import Data.Vector as V

12+import Data.Vinyl hiding (Dict)

13+import Prelude as P

14+

15+data TextConstraint

16+ = TEq Nat

17+ | TLt Nat

18+ | TLe Nat

19+ | TGt Nat

20+ | TGe Nat

21+ | TRegex Symbol

22+ | TEnum [Symbol]

23+

24+data DemotedTextConstraint

25+ = DTEq Integer

26+ | DTLt Integer

27+ | DTLe Integer

28+ | DTGt Integer

29+ | DTGe Integer

30+ | DTRegex Text

31+ | DTEnum [Text]

32+

33+data NumberConstraint

34+ = NLe Nat

35+ | NLt Nat

36+ | NGt Nat

37+ | NGe Nat

38+ | NEq Nat

39+

40+data DemotedNumberConstraint

41+ = DNLe Integer

42+ | DNLt Integer

43+ | DNGt Integer

44+ | DNGe Integer

45+ | DNEq Integer

46+

47+data ArrayConstraint

48+ = AEq Nat

49+ | AGt Nat

50+ | AGe Nat

51+ | ALt Nat

52+ | ALe Nat

53+

54+data DemotedArrayConstraint

55+ = DAEq Integer

56+ | DAGt Integer

57+ | DAGe Integer

58+ | DALt Integer

59+ | DALe Integer

60+

61+data Schema

62+ = SchemaText [TextConstraint]

63+ | SchemaBoolean

64+ | SchemaNumber [NumberConstraint]

65+ | SchemaObject [(Symbol, Schema)]

66+ | SchemaArray [ArrayConstraint] Schema

67+ | SchemaNull

68+ | SchemaOptional Schema

69+ | SchemaUnion [Schema]

70+

71+data DemotedSchema

72+ = DSchemaText [DemotedTextConstraint]

73+ | DSchemaNumber [DemotedNumberConstraint]

74+ | DSchemaBoolean

75+ | DSchemaObject [(Text, DemotedSchema)]

76+ | DSchemaArray [DemotedArrayConstraint] DemotedSchema

77+ | DSchemaNull

78+ | DSchemaOptional DemotedSchema

79+ | DSchemaUnion [DemotedSchema]

80+

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

82+ FieldRepr

83+ :: (SingI schema, KnownSymbol name)

84+ => JsonRepr schema

85+ -> FieldRepr '(name, schema)

86+

87+data JsonRepr :: Schema -> Type where

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

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

90+ ReprBoolean :: Bool -> JsonRepr 'SchemaBoolean

91+ ReprNull :: JsonRepr 'SchemaNull

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

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

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

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

src/Data/Schematic/Validation.hs+87−29

@@ -2,6 +2,9 @@ module Data.Schematic.Validation where

33import Control.Monad

44import Control.Monad.Validation

5+import Data.Aeson

6+import Data.Aeson.Internal

7+import Data.Aeson.Types

58import Data.Foldable

69import Data.Functor.Identity

710import Data.Monoid

@@ -30,6 +33,10 @@ data ParseResult a

3033 | ValidationError ErrorMap -- runtime

3134 deriving (Show, Eq, Functor, Foldable, Traversable)

3235

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

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

38+ parseJSON = pure . parseAndValidateJson @a

39+

3340isValid :: ParseResult a -> Bool

3441isValid (Valid _) = True

3542isValid _ = False

@@ -43,51 +50,51 @@ isValidationError (ValidationError _) = True

4350isValidationError _ = False

4451

4552validateTextConstraint

46− :: JSONPath

53+ :: JSONPathText

4754 -> Text

4855 -> Sing (tcs :: TextConstraint)

4956 -> Validation ()

50−validateTextConstraint (JSONPath path) t = \case

57+validateTextConstraint (JSONPathText path) t = \case

5158 STEq n -> do

5259 let

5360 nlen = withKnownNat n $ natVal n

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

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

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

5663 warn = vWarning $ mmSingleton path (pure errMsg)

5764 unless predicate warn

5865 STLt n -> do

5966 let

6067 nlen = withKnownNat n $ natVal n

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

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

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

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

6370 warn = vWarning $ mmSingleton path (pure errMsg)

6471 unless predicate warn

6572 STLe n -> do

6673 let

6774 nlen = withKnownNat n $ natVal n

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

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

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

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

7077 warn = vWarning $ mmSingleton path (pure errMsg)

7178 unless predicate warn

7279 STGt n -> do

7380 let

7481 nlen = withKnownNat n $ natVal n

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

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

82+ predicate = nlen < (fromIntegral $ T.length t)

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

7784 warn = vWarning $ mmSingleton path (pure errMsg)

7885 unless predicate warn

7986 STGe n -> do

8087 let

8188 nlen = withKnownNat n $ natVal n

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

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

89+ predicate = nlen <= (fromIntegral $ T.length t)

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

8491 warn = vWarning $ mmSingleton path (pure errMsg)

8592 unless predicate warn

8693 STRegex r -> do

8794 let

8895 regex = withKnownSymbol r $ fromSing r

8996 predicate = matchTest (makeRegex (T.unpack regex) :: Regex) (T.unpack t)

90− errMsg = path <> " must match " <> regex

97+ errMsg = "must match " <> regex

9198 warn = vWarning $ mmSingleton path (pure errMsg)

9299 unless predicate warn

93100 STEnum ss -> do

@@ -95,69 +102,97 @@ validateTextConstraint (JSONPath path) t = \case

95102 matching :: Sing (s :: [Symbol]) -> Bool

96103 matching SNil = False

97104 matching (SCons s@SSym fs) = T.pack (symbolVal s) == t || matching fs

98− errMsg = path <> " must be one of " <> T.pack (show (fromSing ss))

105+ errMsg = "must be one of " <> T.pack (show (fromSing ss))

99106 warn = vWarning $ mmSingleton path (pure errMsg)

100107 unless (matching ss) warn

101108

102109validateNumberConstraint

103− :: JSONPath

110+ :: JSONPathText

104111 -> Scientific

105112 -> Sing (tcs :: NumberConstraint)

106113 -> Validation ()

107−validateNumberConstraint (JSONPath path) num = \case

114+validateNumberConstraint (JSONPathText path) num = \case

108115 SNEq n -> do

109116 let

110117 nlen = withKnownNat n $ natVal n

111118 predicate = fromIntegral nlen == num

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

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

113120 warn = vWarning $ mmSingleton path (pure errMsg)

114121 unless predicate warn

115122 SNGt n -> do

116123 let

117124 nlen = withKnownNat n $ natVal n

118125 predicate = num > fromIntegral nlen

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

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

120127 warn = vWarning $ mmSingleton path (pure errMsg)

121128 unless predicate warn

122129 SNGe n -> do

123130 let

124131 nlen = withKnownNat n $ natVal n

125132 predicate = num >= fromIntegral nlen

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

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

127134 warn = vWarning $ mmSingleton path (pure errMsg)

128135 unless predicate warn

129136 SNLt n -> do

130137 let

131138 nlen = withKnownNat n $ natVal n

132− predicate = fromIntegral nlen < num

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

139+ predicate = num < fromIntegral nlen

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

134141 warn = vWarning $ mmSingleton path (pure errMsg)

135142 unless predicate warn

136143 SNLe n -> do

137144 let

138145 nlen = withKnownNat n $ natVal n

139− predicate = fromIntegral nlen <= num

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

146+ predicate = num <= fromIntegral nlen

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

141148 warn = vWarning $ mmSingleton path (pure errMsg)

142149 unless predicate warn

143150

144151validateArrayConstraint

145− :: JSONPath

152+ :: JSONPathText

146153 -> V.Vector a

147154 -> Sing (tcs :: ArrayConstraint)

148155 -> Validation ()

149−validateArrayConstraint (JSONPath path) v = \case

156+validateArrayConstraint (JSONPathText path) v = \case

150157 SAEq n -> do

151158 let

152159 nlen = withKnownNat n $ natVal n

153160 predicate = nlen == fromIntegral (V.length v)

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

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

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

163+ unless predicate warn

164+ SAGt n -> do

165+ let

166+ nlen = withKnownNat n $ natVal n

167+ predicate = fromIntegral (V.length v) > nlen

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

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

170+ unless predicate warn

171+ SAGe n -> do

172+ let

173+ nlen = withKnownNat n $ natVal n

174+ predicate = fromIntegral (V.length v) >= nlen

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

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

177+ unless predicate warn

178+ SALt n -> do

179+ let

180+ nlen = withKnownNat n $ natVal n

181+ predicate = fromIntegral (V.length v) < nlen

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

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

184+ unless predicate warn

185+ SALe n -> do

186+ let

187+ nlen = withKnownNat n $ natVal n

188+ predicate = fromIntegral (V.length v) <= nlen

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

155190 warn = vWarning $ mmSingleton path (pure errMsg)

156191 unless predicate warn

157192

158193validateJsonRepr

159194 :: Sing schema

160− -> [DemotedPathSegment]

195+ -> JSONPath

161196 -> JsonRepr schema

162197 -> Validation ()

163198validateJsonRepr sschema dpath jr = case jr of

@@ -191,7 +226,7 @@ validateJsonRepr sschema dpath jr = case jr of

191226 process cs

192227 process acs

193228 for_ (V.indexed v) $ \(ix, jr') -> do

194− let newPath = dpath <> pure (DIx $ fromIntegral ix)

229+ let newPath = dpath <> pure (Index $ fromIntegral ix)

195230 validateJsonRepr s newPath jr'

196231 ReprOptional d -> case sschema of

197232 SSchemaOptional ss -> case d of

@@ -203,7 +238,7 @@ validateJsonRepr sschema dpath jr = case jr of

203238 go :: Rec FieldRepr (ts :: [(Symbol, Schema)] ) -> Validation ()

204239 go RNil = pure ()

205240 go (f@(FieldRepr d) :& ftl) = do

206− let newPath = dpath <> [DKey (knownFieldName f)]

241+ let newPath = dpath <> [Key (knownFieldName f)]

207242 validateJsonRepr (knownFieldSchema f) newPath d

208243 go ftl

209244 ReprUnion _ -> pure () -- FIXME

@@ -215,7 +250,7 @@ validateJsonRepr sschema dpath jr = case jr of

215250 -- fail "impossible to produce subUnion, please report this as a bug"

216251 -- Just x -> do

217252 -- let

218− -- JSONPath path = demotedPathToText dpath

253+ -- JSONPathText path = demotedPathToText dpath

219254 -- case stl of

220255 -- SNil -> void $ vWarning $ mmSingleton path

221256 -- $ pure "union handling error, please report this as bug"

@@ -246,3 +281,26 @@ toUnion _ = ReprUnion . urelax

246281

247282umatch' :: UElem a as i => Sing a -> Union f as -> Maybe (f a)

248283umatch' _ u = umatch u

284+

285+parseAndValidateJson

286+ :: forall schema

287+ . (FromJSON (JsonRepr schema), TopLevel schema, SingI schema)

288+ => Value

289+ -> ParseResult (JsonRepr schema)

290+parseAndValidateJson v =

291+ case parseEither parseJSON v of

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

293+ Right jsonRepr ->

294+ let

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

296+ res = runIdentity . runValidationTEither $ validate

297+ in case res of

298+ Left em -> ValidationError em

299+ Right () -> Valid jsonRepr

300+

301+parseAndValidateJsonBy

302+ :: (FromJSON (JsonRepr schema), TopLevel schema, SingI schema)

303+ => proxy schema

304+ -> Value

305+ -> ParseResult (JsonRepr schema)

306+parseAndValidateJsonBy _ = parseAndValidateJson

src/Data/Schematic/Verifier.hsnew file+5

@@ -0,0 +1,5 @@

1+module Data.Schematic.Verifier (module X) where

3+import Data.Schematic.Verifier.Array as X

4+import Data.Schematic.Verifier.Number as X

5+import Data.Schematic.Verifier.Text as X

src/Data/Schematic/Verifier/Array.hsnew file+14

@@ -0,0 +1,14 @@

1+module Data.Schematic.Verifier.Array where

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

4+import Data.Schematic.Verifier.Common

6+data VerifiedArrayConstraint =

7+ VAEq Integer

8+ deriving (Show)

10+verifyArrayConstraint ::

11+ [DemotedArrayConstraint] -> Maybe (Maybe VerifiedArrayConstraint)

12+verifyArrayConstraint cs = do

13+ x <- verifyDNEq [x | DAEq x <- cs]

14+ pure $ VAEq <$> x

src/Data/Schematic/Verifier/Common.hsnew file+43

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

1+module Data.Schematic.Verifier.Common where

3+import Data.List (nub)

5+simplifyNumberConstraint :: ([Integer] -> Integer) -> [Integer] -> Maybe Integer

6+simplifyNumberConstraint f =

7+ \case

8+ [] -> Nothing

9+ x -> Just $ f x

10+

11+simplifyDNLs :: [Integer] -> Maybe Integer

12+simplifyDNLs = simplifyNumberConstraint minimum

13+

14+simplifyDNGs :: [Integer] -> Maybe Integer

15+simplifyDNGs = simplifyNumberConstraint maximum

16+

17+verifyDNEq :: [Integer] -> Maybe (Maybe Integer)

18+verifyDNEq x =

19+ case nub x of

20+ [] -> Just Nothing

21+ [y] -> Just $ Just y

22+ (_:_:_) -> Nothing

23+

24+verify3 :: Maybe Integer -> Maybe Integer -> Maybe Integer -> Maybe ()

25+verify3 (Just x) (Just y) (Just z) =

26+ if x < y && y < z

27+ then Just ()

28+ else Nothing

29+verify3 _ _ _ = Just ()

30+

31+verify2 :: Maybe Integer -> Maybe Integer -> Maybe ()

32+verify2 (Just x) (Just y) =

33+ if x < y

34+ then Just ()

35+ else Nothing

36+verify2 _ _ = Just ()

37+

38+verifyEquations :: Maybe Integer -> Maybe Integer -> Maybe Integer -> Maybe ()

39+verifyEquations mgt meq mlt = do

40+ verify3 mgt meq mlt

41+ verify2 mgt meq

42+ verify2 meq mlt

43+ verify2 mgt mlt

src/Data/Schematic/Verifier/Number.hsnew file+31

@@ -0,0 +1,31 @@

1+module Data.Schematic.Verifier.Number where

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

4+import Data.Schematic.Verifier.Common

6+toStrictNumber :: [DemotedNumberConstraint] -> [DemotedNumberConstraint]

7+toStrictNumber = map f

8+ where

9+ f (DNLe x) = DNLt (x + 1)

10+ f (DNGe x) = DNGt (x - 1)

11+ f x = x

12+

13+data VerifiedNumberConstraint

14+ = VNEq Integer

15+ | VNBounds (Maybe Integer) (Maybe Integer)

16+ deriving (Show)

17+

18+verifyNumberConstraints

19+ :: [DemotedNumberConstraint]

20+ -> Maybe VerifiedNumberConstraint

21+verifyNumberConstraints cs' = do

22+ let

23+ cs = toStrictNumber cs'

24+ mlt = simplifyDNLs [x | DNLt x <- cs]

25+ mgt = simplifyDNGs [x | DNGt x <- cs]

26+ meq <- verifyDNEq [x | DNEq x <- cs]

27+ verifyEquations mgt meq mlt

28+ Just $

29+ case meq of

30+ Just eq -> VNEq eq

31+ Nothing -> VNBounds mgt mlt

src/Data/Schematic/Verifier/Text.hsnew file+121

@@ -0,0 +1,121 @@

1+module Data.Schematic.Verifier.Text where

3+import Control.Monad

4+import Data.Maybe

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

6+import Data.Schematic.Verifier.Common

7+import Data.Text (Text, unpack)

8+import Text.Regex.TDFA.Pattern

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

10+

11+toStrictTextLength :: [DemotedTextConstraint] -> [DemotedTextConstraint]

12+toStrictTextLength = map f

13+ where

14+ f (DTLe x) = DTLt (x + 1)

15+ f (DTGe x) = DTGt (x - 1)

16+ f x = x

17+

18+data VerifiedTextConstraint

19+ = VTEq Integer

20+ | VTBounds (Maybe Integer) (Maybe Integer)

21+ | VTRegex Text Integer (Maybe Integer)

22+ | VTEnum [Text]

23+ deriving (Show)

24+

25+verifyTextLengthConstraints

26+ :: [DemotedTextConstraint]

27+ -> Maybe (Maybe VerifiedTextConstraint)

28+verifyTextLengthConstraints cs' = do

29+ let

30+ cs = toStrictTextLength cs'

31+ mlt = simplifyDNLs [x | DTLt x <- cs]

32+ mgt = simplifyDNGs [x | DTGt x <- cs]

33+ meq <- verifyDNEq [x | DTEq x <- cs]

34+ verifyEquations mgt meq mlt

35+ case all isNothing ([mgt, meq, mlt] :: [Maybe Integer]) of

36+ True -> Just Nothing

37+ _ ->

38+ Just $

39+ Just $

40+ case meq of

41+ Just eq -> VTEq eq

42+ Nothing -> VTBounds mgt mlt

43+

44+regexLength :: Text -> Maybe (Int, Maybe Int)

45+regexLength regexp =

46+ case parseRegex . unpack $ regexp of

47+ Right (p, _) -> Just (minRegexLength p, maxRegexLength p)

48+ Left _ -> Nothing

49+

50+minRegexLength :: Pattern -> Int

51+minRegexLength p =

52+ case p of

53+ PEmpty -> 0

54+ PChar {..} -> 1

55+ PAny {..} -> 1

56+ PAnyNot {..} -> 1

57+ PQuest _ -> 0

58+ PPlus sch -> minRegexLength $ PBound 1 Nothing sch

59+ PStar _ sch -> minRegexLength $ PBound 0 Nothing sch

60+ PBound low _ sch -> low * minRegexLength sch

61+ PConcat ps -> sum $ fmap minRegexLength ps

62+ POr xs -> minimum $ fmap minRegexLength xs

63+ PDot _ -> 1

64+ PEscape {..} -> 1

65+ PCarat _ -> 0

66+ PDollar _ -> 0

67+ _ -> 0

68+

69+maxRegexLength :: Pattern -> Maybe Int

70+maxRegexLength p =

71+ case p of

72+ PEmpty -> Just 0

73+ PChar _ _ -> Just 1

74+ PAny _ _ -> Just 1

75+ PAnyNot _ _ -> Just 1

76+ PQuest _ -> Just 0

77+ PPlus _ -> Nothing

78+ PStar _ _ -> Nothing

79+ PBound _ mhigh sch -> (*) <$> mhigh <*> maxRegexLength sch

80+ PConcat ps -> sum <$> mapM maxRegexLength ps

81+ POr xs -> maximum <$> mapM maxRegexLength xs

82+ PDot _ -> Just 1

83+ PEscape _ _ -> Just 1

84+ PCarat _ -> Just 0

85+ PDollar _ -> Just 0

86+ _ -> Just 0

87+

88+verifyTextRegexConstraint

89+ :: [DemotedTextConstraint]

90+ -> Maybe (Maybe VerifiedTextConstraint)

91+verifyTextRegexConstraint cs = do

92+ let regexps = [x | DTRegex x <- cs]

93+ case regexps of

94+ [] -> Just Nothing

95+ [x] -> do

96+ (l, mh) <- regexLength x

97+ Just $ Just $ VTRegex x (fromIntegral l) (fromIntegral <$> mh)

98+ _ -> Nothing

99+

100+verifyTextEnumConstraint

101+ :: [DemotedTextConstraint]

102+ -> Maybe (Maybe VerifiedTextConstraint)

103+verifyTextEnumConstraint cs = do

104+ let enums = concat [x | DTEnum x <- cs]

105+ case enums of

106+ [] -> Just Nothing

107+ x -> Just $ Just $ VTEnum x

108+

109+verifyTextConstraints

110+ :: [DemotedTextConstraint]

111+ -> Maybe [VerifiedTextConstraint]

112+verifyTextConstraints cs = do

113+ regexp <- verifyTextRegexConstraint cs

114+ void $

115+ case regexp of

116+ Just (VTRegex _ l mh) ->

117+ verifyTextLengthConstraints (DTGe l : cs ++ maybeToList (DTLe <$> mh))

118+ _ -> pure Nothing

119+ lengths <- verifyTextLengthConstraints cs

120+ enums <- verifyTextEnumConstraint cs

121+ return $ catMaybes [lengths, enums, regexp]

stack-13.21.yamlnew file+7

@@ -0,0 +1,7 @@

1+resolver: lts-13.21

2+extra-deps:

3+ - hjsonpointer-1.4.0@rev:0

4+ - hjsonschema-1.9.0@rev:0

5+ - validationt-0.3.0

6+nix:

7+ packages: [pcre, pkg-config, zlib]

stack.yaml+5−50

@@ -1,51 +1,6 @@

1−resolver: nightly-2017-09-17

2−

3−# User packages to be built.

4−# Various formats can be used as shown in the example below.

5−#

6−# packages:

7−# - some-directory

8−# - https://example.com/foo/bar/baz-0.0.2.tar.gz

9−# - location:

10−# git: https://github.com/commercialhaskell/stack.git

11−# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

12−# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a

13−# extra-dep: true

14−# subdirs:

15−# - auto-update

16−# - wai

17−#

18−# A package marked 'extra-dep: true' will only be built if demanded by a

19−# non-dependency (i.e. a user package), and its test suites and benchmarks

20−# will not be run. This is useful for tweaking upstream packages.

21−packages:

22−- '.'

23−

1+resolver: lts-14.22

242extra-deps:

25−- hjsonpointer-1.3.0

26−- hjsonschema-1.7.0

27−- validationt-0.2.0.0

28−

29−# Override default flag values for local packages and extra-deps

30−flags: {}

31−

32−# Extra package databases containing global packages

33−extra-package-dbs: []

34−

35−# Control whether we use the GHC we find on the path

36−# system-ghc: true

37−#

38−# Require a specific version of stack, using version ranges

39−# require-stack-version: -any # Default

40−# require-stack-version: ">=1.4"

41−#

42−# Override the architecture used by stack, especially useful on Windows

43−# arch: i386

44−# arch: x86_64

45−#

46−# Extra directories used by stack for building

47−# extra-include-dirs: [/path/to/dir]

48−# extra-lib-dirs: [/path/to/dir]

49−#

50−# Allow a newer minor version of GHC than the snapshot specifies

51−# compiler-check: newer-minor

3+- hjsonpointer-1.4.0@rev:0

4+- hjsonschema-1.9.0@rev:0

5+- git: https://github.com/typeable/validationt.git

6+ commit: 97fea97c4015ab5e99f3efb2c73e1fef4b8857d8

test/JsonSchemaSpec.hs+58

@@ -10,6 +10,7 @@ module JsonSchemaSpec (spec, main) where

1010import Data.Aeson as J

1111import Data.Maybe

1212import Data.Proxy

13+import Data.ByteString.Lazy as B

1314import Data.Schematic

1415import Data.Vinyl

1516import JSONSchema.Draft4 as D4

@@ -31,6 +32,27 @@ exampleData = withRepr @SchemaExample $

3132 :& field @"bar" (pure (ReprText "foo"))

3233 :& RNil

3334

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+

3456spec :: Spec

3557spec = do

3658 it "validates simple schema" $ do

@@ -38,6 +60,42 @@ spec = do

3860 fetchHTTPAndValidate schema (toJSON exampleData) >>= \case

3961 Left _ -> fail "failed to validate test example"

4062 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 ()

4199

42100main :: IO ()

43101main = hspec spec

test/LensSpec.hs+4−4

@@ -303,15 +303,15 @@ spec = do

303303 newFooVal = FieldRepr $ ReprArray [ReprNumber 15]

304304 fooProxy = Proxy @"foo"

305305 it "gets the field from an object" $ do

306− fget fooProxy objectData `shouldBe` arrayField

306+ fget @"foo" objectData `shouldBe` arrayField

307307 it "sets the object field" $ do

308− fget fooProxy (fput newFooVal objectData) `shouldBe` newFooVal

308+ fget @"foo" (fput newFooVal objectData) `shouldBe` newFooVal

309309

310310 describe "(using lens library) " $ do

311311 it "get the field from an object" $ do

312− objectData ^. flens (Proxy @"foo") `shouldBe` arrayField

312+ objectData ^. flens @"foo" `shouldBe` arrayField

313313 it "sets the object field" $ do

314− set (flens (Proxy @"foo")) newFooVal objectData ^. flens (Proxy @"foo")

314+ set (flens @"foo") newFooVal objectData ^. flens @"foo"

315315 `shouldBe` newFooVal

316316

317317main :: IO ()

test/SchemaSpec.hs+24

@@ -17,15 +17,26 @@ import Data.ByteString.Lazy

1717import Data.Functor.Identity

1818import Data.Proxy

1919import Data.Schematic

20+import Data.Schematic.Generator

21+import Data.Singletons

2022import Data.Tagged

2123import Data.Vinyl

2224import Test.Hspec

25+import Test.Hspec.SmallCheck

26+import Test.SmallCheck as SC

27+import Test.SmallCheck.Drivers as SC

28+import Test.SmallCheck.Series as SC

2329

30+import Debug.Trace

2431

2532type SchemaExample = 'SchemaObject

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

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

2835

36+type SchemaExample2 = 'SchemaObject

37+ '[ '("foo", 'SchemaArray '[ 'AEq 2] ('SchemaText '[ 'TGt 10]))

38+ , '("bar", 'SchemaOptional ('SchemaText '[ 'TRegex "[0-9]+"]))]

39+

2940jsonExample :: JsonRepr SchemaExample

3041jsonExample = withRepr @SchemaExample

3142 $ field @"bar" (Just "bar")

@@ -69,6 +80,12 @@ schemaJson = "{\"foo\": [13], \"bar\": null}"

6980schemaJson2 :: ByteString

7081schemaJson2 = "{\"foo\": [3], \"bar\": null}"

7182

83+schemaJsonSeries :: Monad m => SC.Series m (JsonRepr SchemaExample)

84+schemaJsonSeries = series

85+

86+schemaJsonSeries2 :: Monad m => SC.Series m (JsonRepr SchemaExample2)

87+schemaJsonSeries2 = series

88+

7289spec :: Spec

7390spec = do

7491 -- it "show/read JsonRepr properly" $

@@ -93,6 +110,13 @@ spec = do

93110 migrationList

94111 schemaJson

95112 `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+

96120

97121main :: IO ()

98122main = hspec spec