85c3137...master · schematic

git.iko.soy/schematic

on master help sign in

.travis.yml+2−2

since splitsnapshots

unifiedsplit

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

1−sudo: false

1+sudo: required

3language: c

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

23cache:

24 directories:

25− - $HOME/.stack

25+ - $HOME/.stack

ChangeLog.md+21

@@ -1,5 +1,26 @@

1# Revision history for schematic

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

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

6+parsing error messages.

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

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

11+

12+## 0.4.2.0

13+

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

15+

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

17+

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

19+

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

21+

22+flens and fget now use type application syntax

23+

3## 0.4.0.0 -- 2017-10-17

24## 0.4.0.0 -- 2017-10-17

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

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

README.md+5−5

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

25## GHC Extensions

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

28either to a module or a cabal file:

30```

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

35```

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

40## GHC Options

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

132

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

134

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

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

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

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

137

138## Migrations

139

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

178acceptable by one schema to values acceptable by another.

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

180

181−```

181+```haskell

182type SchemaExample = 'SchemaObject

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

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

release+16−8

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

5dist=`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+

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

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

8stack test 2> /dev/null

14stack test 2> /dev/null

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

18 read -p "Hackage username: " username

24 read -p "Hackage username: " username

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

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

20 echo ""

26 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

23− docdir=$dist/doc/html

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

24− cd $docdir

25− doc=$1-$2-docs

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"

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"

28− cp -r $1 $doc

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

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

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

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

34+ cd $docdir

35+ cd ..

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"

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

32 exit $?

40 exit $?

33else

41else

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

42 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+15−7

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

1name: schematic

2−version: 0.4.0.0

2+version: 0.5.0.0

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

4license: BSD3

5license: BSD3

5license-file: LICENSE

6license-file: LICENSE

6author: Denis Redozubov

7author: Denis Redozubov

@@ -15,6 +16,8 @@ cabal-version: >=1.10

15library

16library

16 exposed-modules: Data.Schematic

17 exposed-modules: Data.Schematic

17 , Data.Schematic.DSL

18 , Data.Schematic.DSL

19+ , Data.Schematic.Generator

20+ , Data.Schematic.Generator.Regex

18 , Data.Schematic.Instances

21 , Data.Schematic.Instances

19 , Data.Schematic.JsonSchema

22 , Data.Schematic.JsonSchema

20 , Data.Schematic.Helpers

23 , Data.Schematic.Helpers

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

23 , Data.Schematic.Path

26 , Data.Schematic.Path

24 , Data.Schematic.Schema

27 , Data.Schematic.Schema

25 , Data.Schematic.Validation

28 , 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

26 ghc-options: -Wall

34 ghc-options: -Wall

27 default-extensions: ConstraintKinds

35 default-extensions: ConstraintKinds

28 , DataKinds

36 , DataKinds

@@ -57,7 +65,7 @@ library

57 , TypeOperators

65 , TypeOperators

58 , TypeSynonymInstances

66 , TypeSynonymInstances

59 , UndecidableInstances

67 , UndecidableInstances

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

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

61 , bytestring

69 , bytestring

62 , aeson >= 1

70 , aeson >= 1

63 , containers

71 , containers

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

67 , regex-tdfa

75 , regex-tdfa

68 , regex-tdfa-text

76 , regex-tdfa-text

69 , scientific

77 , scientific

70− , singletons >= 2.2

78+ , singletons >= 2.4

71 , smallcheck

79 , smallcheck

72 , tagged

80 , tagged

73 , template-haskell

81 , template-haskell

74 , text

82 , text

75 , union

83 , union

76 , unordered-containers

84 , unordered-containers

77− , validationt >= 0.1.0.1

85+ , validationt >= 0.2.1.0

78 , vector

86 , vector

79 , vinyl

87 , vinyl

80 hs-source-dirs: src

88 hs-source-dirs: src

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

87 default-language: Haskell2010

95 default-language: Haskell2010

88 build-depends: HUnit

96 build-depends: HUnit

89 , aeson >= 1

97 , aeson >= 1

90− , base >=4.9 && <4.11

98+ , base >=4.11 && <4.13

91 , bytestring

99 , bytestring

92 , containers

100 , containers

93 , hjsonschema

101 , hjsonschema

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

104 , tagged

112 , tagged

105 , text

113 , text

106 , unordered-containers

114 , unordered-containers

107− , validationt >= 0.1.0.1

115+ , validationt >= 0.2.1.0

108 , vinyl

116 , vinyl

109 other-modules: SchemaSpec

117 other-modules: SchemaSpec

110 , HelpersSpec

118 , HelpersSpec

111 , LensSpec

119 , LensSpec

112− , JsonSchemaSpec

120+ , JsonSchemaSpec

src/Data/Schematic.hs−23

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

39import Data.Text as T

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−

65parseAndValidateTopVersionJson

42parseAndValidateTopVersionJson

66 :: forall proxy (v :: Versioned)

43 :: forall proxy (v :: Versioned)

67 . (SingI (TopVersion (AllVersions v)))

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

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

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

1{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE CPP #-}

3module Data.Schematic.DSL where

4module Data.Schematic.DSL where

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

17import Data.Vinyl.Functor

18import Data.Vinyl.Functor

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

20type Constructor a

22type Constructor a

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

23+ = forall fields b

22− => Rec (Tagged (FieldsOf a) :. FieldRepr) 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

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

32+ -> JsonRepr ('SchemaObject fields)

24−

33+#endif

25withRepr :: Constructor a

34withRepr :: Constructor a

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

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

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

66 FieldsOf ('SchemaObject fs) = fs

75 FieldsOf ('SchemaObject fs) = fs

68type FieldConstructor fn =

77type FieldConstructor fn =

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

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

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

79+ => Repr byField

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

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

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

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

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

83field = 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 @@

4module Data.Schematic.Instances where

6import Data.Scientific

7+import Data.Text (Text, pack)

7import Data.Vector as V

8import Data.Vector as V

8import Data.Vinyl

9import Data.Vinyl

9import Test.SmallCheck.Series

10import Test.SmallCheck.Series

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

22instance Monad m => Serial m Scientific where

23instance Monad m => Serial m Scientific where

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

24 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

12import Data.Aeson as J

13import Data.Foldable as F

14import Data.HashMap.Strict as H

15+import Data.List as L

15import Data.List.NonEmpty as NE

16import Data.List.NonEmpty as NE

16import Data.Schematic.Schema as S

17import Data.Schematic.Schema as S

18+import Data.Set as Set

17import Data.Singletons

19import Data.Singletons

18import Data.Text

20import Data.Text

19import Data.Traversable

21import Data.Traversable

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

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

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

29 { _schemaMinLength = pure $ fromIntegral n

31 { _schemaMinLength = pure $ fromIntegral n

30 , _schemaMaxLength = pure $ fromIntegral n }

32 , _schemaMaxLength = pure $ fromIntegral n }

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

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

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

34 { _schemaMaxLength = pure . fromIntegral $ n }

35−textConstraint (DTGt 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

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

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

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

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

39 { _schemaMinLength = pure . fromIntegral $ n }

41 { _schemaMinLength = pure . fromIntegral $ n }

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

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

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

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

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

47 { _schemaMaximum = pure . fromIntegral $ n }

49 { _schemaMaximum = pure . fromIntegral $ n }

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

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

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

51+ { _schemaMaximum = pure . fromIntegral $ n

52+ , _schemaExclusiveMaximum = pure True }

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

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

54+ { _schemaMinimum = pure . fromIntegral $ n

55+ , _schemaExclusiveMinimum = pure True }

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

51 { _schemaMinimum = pure . fromIntegral $ n }

57 { _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' }

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

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

56 { _schemaMinimum = pure $ fromIntegral n

59 { _schemaMinimum = pure $ fromIntegral n

57 , _schemaMaximum = pure $ fromIntegral n }

60 , _schemaMaximum = pure $ fromIntegral n }

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

62arrayConstraint :: 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 }

62toJsonSchema

76toJsonSchema

63 :: forall proxy schema

77 :: forall proxy schema

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

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

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

85 s' <- toJsonSchema' s

99 s' <- toJsonSchema' s

86 pure (n, s')

100 pure (n, s')

101+ let

102+ nonOpt = \case

103+ (_, DSchemaOptional _) -> False

104+ _ -> True

87 pure $ emptySchema

105 pure $ emptySchema

88 { _schemaType = pure $ TypeValidatorString D4.SchemaObject

106 { _schemaType = pure $ TypeValidatorString D4.SchemaObject

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

89 , _schemaProperties = pure $ H.fromList res }

108 , _schemaProperties = pure $ H.fromList res }

90 DSchemaArray acs sch -> do

109 DSchemaArray acs sch -> do

91 res <- toJsonSchema' sch

110 res <- toJsonSchema' sch

92 pure $ execState (traverse_ arrayConstraint acs) $ emptySchema

111 pure $ execState (traverse_ arrayConstraint acs) $ emptySchema

93 { _schemaType = pure $ TypeValidatorString D4.SchemaArray

112 { _schemaType = pure $ TypeValidatorString D4.SchemaArray

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

113+ , _schemaItems = pure $ ItemsObject res }

95 DSchemaNull -> pure $ emptySchema

114 DSchemaNull -> pure $ emptySchema

96 { _schemaType = pure $ TypeValidatorString D4.SchemaNull }

115 { _schemaType = pure $ TypeValidatorString D4.SchemaNull }

97 DSchemaOptional sch -> do

116 DSchemaOptional sch -> do

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

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

10 , FSubset(..)

11 , obj

12 , arr

13+ , uni

14+ , txt

15+ , num

16+ , opt

17+ , bln

13 , textRepr

18 , textRepr

14 , numberRepr

19 , numberRepr

15 , boolRepr

20 , boolRepr

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

19 ) where

24 ) where

21import Data.Profunctor

26import Data.Profunctor

22−import Data.Proxy

23import Data.Schematic.Schema

27import Data.Schematic.Schema

24import Data.Scientific

28import Data.Scientific

25import Data.Singletons

29import Data.Singletons

26import Data.Text

30import Data.Text

31+import Data.Union

27import Data.Vector as V

32import Data.Vector as V

28import Data.Vinyl

33import Data.Vinyl

29import Data.Vinyl.Functor

34import Data.Vinyl.Functor

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

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

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

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

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

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+

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

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

40 type ByField fn rs i :: Schema

53 type ByField fn rs i :: Schema

41− flens

54+ flens :: Flens fn f g rs i

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)

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

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

49− fget

57+ fget :: FGetter fn f rs i

50− :: proxy fn

51− -> Rec f rs

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

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

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

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

60 -- 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 ::

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

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

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

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

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

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

66 {-# INLINE flens #-}

71 {-# INLINE flens #-}

68− fget k = getConst . flens k Const

73+ fget = getConst . flens Const

69 {-# INLINE fget #-}

74 {-# INLINE fget #-}

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

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

72 {-# INLINE fput #-}

77 {-# INLINE fput #-}

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

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

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

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

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

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

78 {-# INLINE flens #-}

83 {-# INLINE flens #-}

80− fget k = getConst . flens k Const

85+ fget = getConst . flens Const

81 {-# INLINE fget #-}

86 {-# INLINE fget #-}

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

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

84 {-# INLINE fput #-}

89 {-# INLINE fput #-}

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

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

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

144 ( ByField fn ss i ~ s

149 ( ByField fn ss i ~ s

145 , FElem fn ss i

150 , FElem fn ss i

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

151 , 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

148 where

153 where

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

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

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

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

151

156

152-- A bunch of @Iso@morphisms

157-- A bunch of @Iso@morphisms

153textRepr

158textRepr

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

159+ :: (KnownSymbol fn, SingI cs)

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

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

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

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

157

162

158numberRepr

163numberRepr

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

164+ :: (KnownSymbol fn, SingI cs)

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

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

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

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

162

167

163boolRepr

168boolRepr

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

169+ :: (KnownSymbol fn)

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

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

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

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

167

172

168arrayRepr

173arrayRepr

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

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

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

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

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

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

172

177

173objectRepr

178objectRepr

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

179+ :: (KnownSymbol fn, SingI fields)

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

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

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

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

177

182

178optionalRepr

183optionalRepr

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

184+ :: (KnownSymbol fn, SingI schema)

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

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

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

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

182

187

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

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

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

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

185

190

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

189arr = iso (\(ReprArray r) -> r) ReprArray

192arr = 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 @@

1{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE CPP #-}

2−{-# LANGUAGE TemplateHaskell #-}

3+{-# LANGUAGE TemplateHaskell #-}

4module Data.Schematic.Migration where

5module Data.Schematic.Migration where

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

7import Data.Schematic.DSL

8import Data.Schematic.DSL

8import Data.Schematic.Lens

9import Data.Schematic.Lens

9import Data.Schematic.Path

10import Data.Schematic.Path

10−import Data.Tagged

11import Data.Schematic.Schema

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

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

13import Data.Singletons.TypeLits

14+import Data.Tagged

14import Data.Vinyl

15import Data.Vinyl

15import Data.Vinyl.Functor

16import Data.Vinyl.Functor

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

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

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

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

45type 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 ('(fn, a) ': tl) = acc ++ tl

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

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

48type family UpdateKey

49type family UpdateKey

49 (fn :: Symbol)

50 (fn :: Symbol)

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

146

147

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

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

148

149

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

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

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

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

151 (:&&)

152 (:&&)

152 :: (TopLevel s, SingI s)

153 :: (TopLevel s, SingI s)

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

156

157

157infixr 7 :&&

158infixr 7 :&&

158

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

159migrateObject

166migrateObject

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

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

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

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

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

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

170+#endif

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

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

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

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

165 pure $ withRepr @('SchemaObject fs) res

173 pure $ withRepr @('SchemaObject fs) res

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

@@ -1,8 +1,6 @@

1module Data.Schematic.Path where

3import Data.Foldable as F

4−import Data.Monoid

5−import Data.Singletons

6import Data.Singletons.Prelude

4import Data.Singletons.Prelude

7import Data.Singletons.TypeLits

5import Data.Singletons.TypeLits

8import Data.Text as T

6import Data.Text as T

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

26 where

24 where

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

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

28 go acc SNil = acc

26 go acc SNil = acc

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

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

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

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

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

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

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

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

34demotedPathToText :: [DemotedPathSegment] -> JSONPath

32demotedPathToText :: [DemotedPathSegment] -> JSONPath

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

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

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

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

1{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE CPP #-}

2−{-# LANGUAGE OverloadedLists #-}

3+{-# LANGUAGE OverloadedLists #-}

3−{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE OverloadedStrings #-}

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

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

6module Data.Schematic.Schema where

7module Data.Schematic.Schema where

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

12import Data.HashMap.Strict as H

13import Data.HashMap.Strict as H

13import Data.Kind

14import Data.Kind

14import Data.Maybe

15import Data.Maybe

16+import Data.Schematic.Generator

15import Data.Schematic.Instances ()

17import Data.Schematic.Instances ()

16import Data.Scientific

18import Data.Scientific

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

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

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

24import qualified Data.Vinyl.TypeLevel as V

26import qualified Data.Vinyl.TypeLevel as V

25import GHC.Exts

27import GHC.Exts

26import GHC.Generics (Generic)

28import GHC.Generics (Generic)

29+import GHC.TypeLits

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

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

28import Prelude as P

31import Prelude as P

29import Test.SmallCheck.Series

32import Test.SmallCheck.Series

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

48instance SingKind TextConstraint where

51instance SingKind TextConstraint where

49 type Demote TextConstraint = DemotedTextConstraint

52 type Demote TextConstraint = DemotedTextConstraint

50 fromSing = \case

53 fromSing = \case

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

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

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

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

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

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

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

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

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

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

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

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

57 STEnum s -> let

60 STEnum s -> let

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

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

59− d SNil = []

62+ d SNil = []

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

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

61 in DTEnum $ d s

64 in DTEnum $ d s

62 toSing = \case

65 toSing = \case

63 DTEq n -> case someNatVal n of

66 DTEq n -> case someNatVal n of

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

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

65− Nothing -> error "Negative singleton nat"

68+ Nothing -> error "Negative singleton nat"

66 DTLt n -> case someNatVal n of

69 DTLt n -> case someNatVal n of

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

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

68− Nothing -> error "Negative singleton nat"

71+ Nothing -> error "Negative singleton nat"

69 DTLe n -> case someNatVal n of

72 DTLe n -> case someNatVal n of

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

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

71− Nothing -> error "Negative singleton nat"

74+ Nothing -> error "Negative singleton nat"

72 DTGt n -> case someNatVal n of

75 DTGt n -> case someNatVal n of

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

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

74− Nothing -> error "Negative singleton nat"

77+ Nothing -> error "Negative singleton nat"

75 DTGe n -> case someNatVal n of

78 DTGe n -> case someNatVal n of

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

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

77− Nothing -> error "Negative singleton nat"

80+ Nothing -> error "Negative singleton nat"

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

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

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

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

80 DTEnum ss -> case toSing ss of

83 DTEnum ss -> case toSing ss of

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

88 | DTGe Integer

91 | DTGe Integer

89 | DTRegex Text

92 | DTRegex Text

90 | DTEnum [Text]

93 | DTEnum [Text]

91− deriving (Generic)

94+ deriving (Generic, Eq, Show)

93data instance Sing (tc :: TextConstraint) where

96data instance Sing (tc :: TextConstraint) where

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

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

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

129 | DNGt Integer

132 | DNGt Integer

130 | DNGe Integer

133 | DNGe Integer

131 | DNEq Integer

134 | DNEq Integer

132− deriving (Generic)

135+ deriving (Generic, Eq, Show)

133

136

134data instance Sing (nc :: NumberConstraint) where

137data instance Sing (nc :: NumberConstraint) where

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

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

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

153instance SingKind NumberConstraint where

156instance SingKind NumberConstraint where

154 type Demote NumberConstraint = DemotedNumberConstraint

157 type Demote NumberConstraint = DemotedNumberConstraint

155 fromSing = \case

158 fromSing = \case

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

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

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

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

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

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

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

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

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

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

161 toSing = \case

164 toSing = \case

162 DNEq n -> case someNatVal n of

165 DNEq n -> case someNatVal n of

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

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

164− Nothing -> error "Negative singleton nat"

167+ Nothing -> error "Negative singleton nat"

165 DNGt n -> case someNatVal n of

168 DNGt n -> case someNatVal n of

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

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

167− Nothing -> error "Negative singleton nat"

170+ Nothing -> error "Negative singleton nat"

168 DNGe n -> case someNatVal n of

171 DNGe n -> case someNatVal n of

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

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

170− Nothing -> error "Negative singleton nat"

173+ Nothing -> error "Negative singleton nat"

171 DNLt n -> case someNatVal n of

174 DNLt n -> case someNatVal n of

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

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

173− Nothing -> error "Negative singleton nat"

176+ Nothing -> error "Negative singleton nat"

174 DNLe n -> case someNatVal n of

177 DNLe n -> case someNatVal n of

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

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

176− Nothing -> error "Negative singleton nat"

179+ Nothing -> error "Negative singleton nat"

177

180

178data ArrayConstraint

181data ArrayConstraint

179 = AEq Nat

182 = AEq Nat

183+ | AGt Nat

184+ | AGe Nat

185+ | ALt Nat

186+ | ALe Nat

180 deriving (Generic)

187 deriving (Generic)

181

188

182data DemotedArrayConstraint

189data DemotedArrayConstraint

183 = DAEq Integer

190 = DAEq Integer

191+ | DAGt Integer

192+ | DAGe Integer

193+ | DALt Integer

194+ | DALe Integer

184− deriving (Generic)

195+ deriving (Generic, Eq, Show)

185

196

186data instance Sing (ac :: ArrayConstraint) where

197data instance Sing (ac :: ArrayConstraint) where

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

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

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

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

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

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

188

203

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

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

190

209

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

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

192

215

193instance SingKind ArrayConstraint where

216instance SingKind ArrayConstraint where

194 type Demote ArrayConstraint = DemotedArrayConstraint

217 type Demote ArrayConstraint = DemotedArrayConstraint

195 fromSing = \case

218 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)

197 toSing = \case

224 toSing = \case

198 DAEq n -> case someNatVal n of

225 DAEq n -> case someNatVal n of

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

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

200− Nothing -> error "Negative singleton nat"

239+ Nothing -> error "Negative singleton nat"

201

240

202data Schema

241data Schema

203 = SchemaText [TextConstraint]

242 = SchemaText [TextConstraint]

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

219 | DSchemaNull

258 | DSchemaNull

220 | DSchemaOptional DemotedSchema

259 | DSchemaOptional DemotedSchema

221 | DSchemaUnion [DemotedSchema]

260 | DSchemaUnion [DemotedSchema]

222− deriving (Generic)

261+ deriving (Generic, Eq, Show)

223

262

224data instance Sing (schema :: Schema) where

263data instance Sing (schema :: Schema) where

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

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

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

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

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

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

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

336

375

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

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

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

379+

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

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

382+ series = decDepth $ fmap ReprNumber

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

384+

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

386+ series = cons0 ReprNull

387+

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

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

390+ series = decDepth $ fmap ReprArray

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

392+

393+instance (Serial m (JsonRepr s))

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

395+ series = cons1 ReprOptional

396+

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

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

399+ series = cons1 ReprObject

400+

337-- | Move to the union package

401-- | Move to the union package

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

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

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

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

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

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

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

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

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

343

407

408+instance Show (JsonRepr 'SchemaBoolean) where

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

410+

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

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

345

412

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

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

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

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

348

415

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

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

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

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

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

425+#endif

351

426

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

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

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

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

354

429

355−instance (Monad m, Serial m Text)

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

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

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

357− series = cons1 ReprText

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

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

377

433

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

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

379 ReprObject a == ReprObject b = a == b

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

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

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

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

385 ReprNumber a == ReprNumber b = a == b

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

386

442

443+instance Eq (JsonRepr 'SchemaBoolean) where

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

445+

387instance Eq (JsonRepr 'SchemaNull) where

446instance Eq (JsonRepr 'SchemaNull) where

388 ReprNull == ReprNull = True

447 ReprNull == ReprNull = True

389

448

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

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

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

394 ReprOptional a == ReprOptional b = a == b

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

395

454

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

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

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

458+

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

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

461+

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

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

464+

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

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

467+

468+instance Ord (JsonRepr 'SchemaBoolean) where

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

470+

471+instance Ord (JsonRepr 'SchemaNull) where

472+ compare _ _ = EQ

473+

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

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

476+

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

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

479+

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

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

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

483+

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

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

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

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

398 fromList = ReprArray . GHC.Exts.fromList

486 fromList = ReprArray . GHC.Exts.fromList

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

454 fieldRepr <- case s of

542 fieldRepr <- case s of

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

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

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

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

457− Nothing -> fail "schematext"

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

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

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

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

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

460− Nothing -> fail "schemanumber"

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

461 SSchemaBoolean -> case H.lookup fieldName h of

549 SSchemaBoolean -> case H.lookup fieldName h of

462 Just v -> FieldRepr <$> parseJSON v

550 Just v -> FieldRepr <$> parseJSON v

463− Nothing -> fail "schemaboolean"

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

464 SSchemaNull -> case H.lookup fieldName h of

552 SSchemaNull -> case H.lookup fieldName h of

465 Just v -> FieldRepr <$> parseJSON v

553 Just v -> FieldRepr <$> parseJSON v

466− Nothing -> fail "schemanull"

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

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

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

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

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

469− Nothing -> fail "schemaarray"

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

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

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

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

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

472− Nothing -> fail "schemaobject"

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

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

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

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

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

475− Nothing -> fail "schemaoptional"

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

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

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

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

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

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

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

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

484 toJSON (ReprText t) = J.String t

572 toJSON (ReprText t) = J.String t

485 toJSON (ReprNumber n) = J.Number n

573 toJSON (ReprNumber n) = J.Number n

486 toJSON (ReprOptional s) = case s of

574 toJSON (ReprOptional s) = case s of

487− Just v -> toJSON v

575+ Just v -> toJSON v

488 Nothing -> J.Null

576 Nothing -> J.Null

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

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

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

578 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+76−19

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

3import Control.Monad

4import Control.Monad.Validation

5+import Data.Aeson

6+import Data.Aeson.Types

5import Data.Foldable

7import Data.Foldable

6import Data.Functor.Identity

8import Data.Functor.Identity

7import Data.Monoid

9import Data.Monoid

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

30 | ValidationError ErrorMap -- runtime

32 | ValidationError ErrorMap -- runtime

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

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

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

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

37+ parseJSON = pure . parseAndValidateJson @a

38+

33isValid :: ParseResult a -> Bool

39isValid :: ParseResult a -> Bool

34isValid (Valid _) = True

40isValid (Valid _) = True

35isValid _ = False

41isValid _ = False

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

52 let

58 let

53 nlen = withKnownNat n $ natVal n

59 nlen = withKnownNat n $ natVal n

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

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

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

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

56 warn = vWarning $ mmSingleton path (pure errMsg)

62 warn = vWarning $ mmSingleton path (pure errMsg)

57 unless predicate warn

63 unless predicate warn

58 STLt n -> do

64 STLt n -> do

59 let

65 let

60 nlen = withKnownNat n $ natVal n

66 nlen = withKnownNat n $ natVal n

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

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

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

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

63 warn = vWarning $ mmSingleton path (pure errMsg)

69 warn = vWarning $ mmSingleton path (pure errMsg)

64 unless predicate warn

70 unless predicate warn

65 STLe n -> do

71 STLe n -> do

66 let

72 let

67 nlen = withKnownNat n $ natVal n

73 nlen = withKnownNat n $ natVal n

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

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

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

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

70 warn = vWarning $ mmSingleton path (pure errMsg)

76 warn = vWarning $ mmSingleton path (pure errMsg)

71 unless predicate warn

77 unless predicate warn

72 STGt n -> do

78 STGt n -> do

73 let

79 let

74 nlen = withKnownNat n $ natVal n

80 nlen = withKnownNat n $ natVal n

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

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

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

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

77 warn = vWarning $ mmSingleton path (pure errMsg)

83 warn = vWarning $ mmSingleton path (pure errMsg)

78 unless predicate warn

84 unless predicate warn

79 STGe n -> do

85 STGe n -> do

80 let

86 let

81 nlen = withKnownNat n $ natVal n

87 nlen = withKnownNat n $ natVal n

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

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

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

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

84 warn = vWarning $ mmSingleton path (pure errMsg)

90 warn = vWarning $ mmSingleton path (pure errMsg)

85 unless predicate warn

91 unless predicate warn

86 STRegex r -> do

92 STRegex r -> do

87 let

93 let

88 regex = withKnownSymbol r $ fromSing r

94 regex = withKnownSymbol r $ fromSing r

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

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

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

96+ errMsg = "must match " <> regex

91 warn = vWarning $ mmSingleton path (pure errMsg)

97 warn = vWarning $ mmSingleton path (pure errMsg)

92 unless predicate warn

98 unless predicate warn

93 STEnum ss -> do

99 STEnum ss -> do

@@ -95,7 +101,7 @@ validateTextConstraint (JSONPath path) t = \case

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

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

96 matching SNil = False

102 matching SNil = False

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

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

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

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

99 warn = vWarning $ mmSingleton path (pure errMsg)

105 warn = vWarning $ mmSingleton path (pure errMsg)

100 unless (matching ss) warn

106 unless (matching ss) warn

101

107

@@ -109,35 +115,35 @@ validateNumberConstraint (JSONPath path) num = \case

109 let

115 let

110 nlen = withKnownNat n $ natVal n

116 nlen = withKnownNat n $ natVal n

111 predicate = fromIntegral nlen == num

117 predicate = fromIntegral nlen == num

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

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

113 warn = vWarning $ mmSingleton path (pure errMsg)

119 warn = vWarning $ mmSingleton path (pure errMsg)

114 unless predicate warn

120 unless predicate warn

115 SNGt n -> do

121 SNGt n -> do

116 let

122 let

117 nlen = withKnownNat n $ natVal n

123 nlen = withKnownNat n $ natVal n

118 predicate = num > fromIntegral nlen

124 predicate = num > fromIntegral nlen

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

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

120 warn = vWarning $ mmSingleton path (pure errMsg)

126 warn = vWarning $ mmSingleton path (pure errMsg)

121 unless predicate warn

127 unless predicate warn

122 SNGe n -> do

128 SNGe n -> do

123 let

129 let

124 nlen = withKnownNat n $ natVal n

130 nlen = withKnownNat n $ natVal n

125 predicate = num >= fromIntegral nlen

131 predicate = num >= fromIntegral nlen

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

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

127 warn = vWarning $ mmSingleton path (pure errMsg)

133 warn = vWarning $ mmSingleton path (pure errMsg)

128 unless predicate warn

134 unless predicate warn

129 SNLt n -> do

135 SNLt n -> do

130 let

136 let

131 nlen = withKnownNat n $ natVal n

137 nlen = withKnownNat n $ natVal n

132− predicate = fromIntegral nlen < num

138+ predicate = num < fromIntegral nlen

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

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

134 warn = vWarning $ mmSingleton path (pure errMsg)

140 warn = vWarning $ mmSingleton path (pure errMsg)

135 unless predicate warn

141 unless predicate warn

136 SNLe n -> do

142 SNLe n -> do

137 let

143 let

138 nlen = withKnownNat n $ natVal n

144 nlen = withKnownNat n $ natVal n

139− predicate = fromIntegral nlen <= num

145+ predicate = num <= fromIntegral nlen

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

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

141 warn = vWarning $ mmSingleton path (pure errMsg)

147 warn = vWarning $ mmSingleton path (pure errMsg)

142 unless predicate warn

148 unless predicate warn

143

149

@@ -151,7 +157,35 @@ validateArrayConstraint (JSONPath path) v = \case

151 let

157 let

152 nlen = withKnownNat n $ natVal n

158 nlen = withKnownNat n $ natVal n

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

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

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

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

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

162+ unless predicate warn

163+ SAGt n -> do

164+ let

165+ nlen = withKnownNat n $ natVal n

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

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

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

169+ unless predicate warn

170+ SAGe n -> do

171+ let

172+ nlen = withKnownNat n $ natVal n

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

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

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

176+ unless predicate warn

177+ SALt n -> do

178+ let

179+ nlen = withKnownNat n $ natVal n

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

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

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

183+ unless predicate warn

184+ SALe n -> do

185+ let

186+ nlen = withKnownNat n $ natVal n

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

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

155 warn = vWarning $ mmSingleton path (pure errMsg)

189 warn = vWarning $ mmSingleton path (pure errMsg)

156 unless predicate warn

190 unless predicate warn

157

191

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

246

280

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

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

248umatch' _ u = umatch u

282umatch' _ u = umatch u

283+

284+parseAndValidateJson

285+ :: forall schema

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

287+ => Value

288+ -> ParseResult (JsonRepr schema)

289+parseAndValidateJson v =

290+ case parseEither parseJSON v of

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

292+ Right jsonRepr ->

293+ let

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

295+ res = runIdentity . runValidationTEither $ validate

296+ in case res of

297+ Left em -> ValidationError em

298+ Right () -> Valid jsonRepr

299+

300+parseAndValidateJsonBy

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

302+ => proxy schema

303+ -> Value

304+ -> ParseResult (JsonRepr schema)

305+parseAndValidateJsonBy _ = parseAndValidateJson

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

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

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

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

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

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

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

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

1+module Data.Schematic.Verifier.Array where

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

4+import Data.Schematic.Verifier.Common

6+data VerifiedArrayConstraint =

7+ VAEq Integer

8+ deriving (Show)

10+verifyArrayConstraint ::

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

12+verifyArrayConstraint cs = do

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

14+ pure $ VAEq <$> x

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

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

1+module Data.Schematic.Verifier.Common where

3+import Data.List (nub)

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

6+simplifyNumberConstraint f =

7+ \case

8+ [] -> Nothing

9+ x -> Just $ f x

10+

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

12+simplifyDNLs = simplifyNumberConstraint minimum

13+

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

15+simplifyDNGs = simplifyNumberConstraint maximum

16+

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

18+verifyDNEq x =

19+ case nub x of

20+ [] -> Just Nothing

21+ [y] -> Just $ Just y

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

23+

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

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

26+ if x < y && y < z

27+ then Just ()

28+ else Nothing

29+verify3 _ _ _ = Just ()

30+

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

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

33+ if x < y

34+ then Just ()

35+ else Nothing

36+verify2 _ _ = Just ()

37+

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

39+verifyEquations mgt meq mlt = do

40+ verify3 mgt meq mlt

41+ verify2 mgt meq

42+ verify2 meq mlt

43+ verify2 mgt mlt

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

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

1+module Data.Schematic.Verifier.Number where

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

4+import Data.Schematic.Verifier.Common

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

7+toStrictNumber = map f

8+ where

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

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

11+ f x = x

12+

13+data VerifiedNumberConstraint

14+ = VNEq Integer

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

16+ deriving (Show)

17+

18+verifyNumberConstraints

19+ :: [DemotedNumberConstraint]

20+ -> Maybe VerifiedNumberConstraint

21+verifyNumberConstraints cs' = do

22+ let

23+ cs = toStrictNumber cs'

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

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

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

27+ verifyEquations mgt meq mlt

28+ Just $

29+ case meq of

30+ Just eq -> VNEq eq

31+ Nothing -> VNBounds mgt mlt

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

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

1+module Data.Schematic.Verifier.Text where

3+import Control.Monad

4+import Data.Maybe

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

6+import Data.Schematic.Verifier.Common

7+import Data.Text (Text, unpack)

8+import Text.Regex.TDFA.Pattern

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

10+

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

12+toStrictTextLength = map f

13+ where

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

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

16+ f x = x

17+

18+data VerifiedTextConstraint

19+ = VTEq Integer

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

21+ | VTRegex Text Integer (Maybe Integer)

22+ | VTEnum [Text]

23+ deriving (Show)

24+

25+verifyTextLengthConstraints

26+ :: [DemotedTextConstraint]

27+ -> Maybe (Maybe VerifiedTextConstraint)

28+verifyTextLengthConstraints cs' = do

29+ let

30+ cs = toStrictTextLength cs'

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

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

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

34+ verifyEquations mgt meq mlt

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

36+ True -> Just Nothing

37+ _ ->

38+ Just $

39+ Just $

40+ case meq of

41+ Just eq -> VTEq eq

42+ Nothing -> VTBounds mgt mlt

43+

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

45+regexLength regexp =

46+ case parseRegex . unpack $ regexp of

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

48+ Left _ -> Nothing

49+

50+minRegexLength :: Pattern -> Int

51+minRegexLength p =

52+ case p of

53+ PEmpty -> 0

54+ PChar {..} -> 1

55+ PAny {..} -> 1

56+ PAnyNot {..} -> 1

57+ PQuest _ -> 0

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

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

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

61+ PConcat ps -> sum $ fmap minRegexLength ps

62+ POr xs -> minimum $ fmap minRegexLength xs

63+ PDot _ -> 1

64+ PEscape {..} -> 1

65+ PCarat _ -> 0

66+ PDollar _ -> 0

67+ _ -> 0

68+

69+maxRegexLength :: Pattern -> Maybe Int

70+maxRegexLength p =

71+ case p of

72+ PEmpty -> Just 0

73+ PChar _ _ -> Just 1

74+ PAny _ _ -> Just 1

75+ PAnyNot _ _ -> Just 1

76+ PQuest _ -> Just 0

77+ PPlus _ -> Nothing

78+ PStar _ _ -> Nothing

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

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

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

82+ PDot _ -> Just 1

83+ PEscape _ _ -> Just 1

84+ PCarat _ -> Just 0

85+ PDollar _ -> Just 0

86+ _ -> Just 0

87+

88+verifyTextRegexConstraint

89+ :: [DemotedTextConstraint]

90+ -> Maybe (Maybe VerifiedTextConstraint)

91+verifyTextRegexConstraint cs = do

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

93+ case regexps of

94+ [] -> Just Nothing

95+ [x] -> do

96+ (l, mh) <- regexLength x

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

98+ _ -> Nothing

99+

100+verifyTextEnumConstraint

101+ :: [DemotedTextConstraint]

102+ -> Maybe (Maybe VerifiedTextConstraint)

103+verifyTextEnumConstraint cs = do

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

105+ case enums of

106+ [] -> Just Nothing

107+ x -> Just $ Just $ VTEnum x

108+

109+verifyTextConstraints

110+ :: [DemotedTextConstraint]

111+ -> Maybe [VerifiedTextConstraint]

112+verifyTextConstraints cs = do

113+ regexp <- verifyTextRegexConstraint cs

114+ void $

115+ case regexp of

116+ Just (VTRegex _ l mh) ->

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

118+ _ -> pure Nothing

119+ lengths <- verifyTextLengthConstraints cs

120+ enums <- verifyTextEnumConstraint cs

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

stack-13.7.yamlnew file+5

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

1+resolver: lts-13.7

2+extra-deps:

3+ - hjsonpointer-1.4.0@rev:0

4+ - hjsonschema-1.9.0@rev:0

5+ - validationt-0.2.1.0

stack.yaml+4−50

@@ -1,51 +1,5 @@

1−resolver: nightly-2017-09-17

1+resolver: lts-12.0

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−

24extra-deps:

2extra-deps:

25−- hjsonpointer-1.3.0

3+ - hjsonpointer-1.4.0@rev:0

26−- hjsonschema-1.7.0

4+ - hjsonschema-1.9.0@rev:0

27−- validationt-0.2.0.0

5+ - validationt-0.2.1.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

test/JsonSchemaSpec.hs+58

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

10import Data.Aeson as J

11import Data.Maybe

12import Data.Proxy

13+import Data.ByteString.Lazy as B

13import Data.Schematic

14import Data.Schematic

14import Data.Vinyl

15import Data.Vinyl

15import JSONSchema.Draft4 as D4

16import JSONSchema.Draft4 as D4

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

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

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

32 :& RNil

33 :& RNil

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+

34spec :: Spec

56spec :: Spec

35spec = do

57spec = do

36 it "validates simple schema" $ do

58 it "validates simple schema" $ do

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

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

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

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

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

40 Right _ -> pure ()

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

42main :: IO ()

100main :: IO ()

43main = hspec spec

101main = hspec spec

test/LensSpec.hs+4−4

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

303 newFooVal = FieldRepr $ ReprArray [ReprNumber 15]

304 fooProxy = Proxy @"foo"

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

306− fget fooProxy objectData `shouldBe` arrayField

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

307 it "sets the object field" $ do

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

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 (Proxy @"foo") `shouldBe` arrayField

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

313 it "sets the object field" $ do

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

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

315 `shouldBe` newFooVal

316

317main :: IO ()

test/SchemaSpec.hs+24

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

17import Data.Functor.Identity

18import Data.Proxy

19import Data.Schematic

20+import Data.Schematic.Generator

21+import Data.Singletons

20import Data.Tagged

22import Data.Tagged

21import Data.Vinyl

23import Data.Vinyl

22import Test.Hspec

24import 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

30+import Debug.Trace

25type SchemaExample = 'SchemaObject

32type SchemaExample = 'SchemaObject

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

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

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

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

36+type SchemaExample2 = 'SchemaObject

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

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

39+

29jsonExample :: JsonRepr SchemaExample

40jsonExample :: JsonRepr SchemaExample

30jsonExample = withRepr @SchemaExample

41jsonExample = withRepr @SchemaExample

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

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

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

69schemaJson2 :: ByteString

80schemaJson2 :: ByteString

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

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

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+

72spec :: Spec

89spec :: Spec

73spec = do

90spec = do

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

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

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

93 migrationList

110 migrationList

94 schemaJson

111 schemaJson

95 `shouldSatisfy` isValid

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

97main :: IO ()

121main :: IO ()

98main = hspec spec

122main = hspec spec