master..85c3137 · schematic

git.iko.soy/schematic

on 85c3137 help sign in

.travis.yml+2−2

since splitsnapshots

unifiedsplit

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

1−sudo: required

1+sudo: false

3language: c

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

23cache:

24 directories:

25− - $HOME/.stack

25+ - $HOME/.stack

ChangeLog.md−21

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

1# Revision history for schematic

3−## 0.5.0.0 -- 2019-02-20

4−

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

6−parsing error messages.

7−

8−## 0.4.3.0 -- 2018-07-12

9−

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

11−

12−## 0.4.2.0

13−

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

15−

16−## 0.4.1.0 -- 2017-11-05

17−

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

19−

20−## 0.4.1.0 -- 2017-11-01

21−

22−flens and fget now use type application syntax

23−

24## 0.4.0.0 -- 2017-10-17

3## 0.4.0.0 -- 2017-10-17

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

5Object 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 if you don't use it - feel free to disable it.

38+so it 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 @"foo" (fput newFooVal objectData) == newFooVal`

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

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

136+* Using the lens library: `set (flens (Proxy @"foo")) newFooVal objectData ^. flens (Proxy @"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−```haskell

181+```

182type SchemaExample = 'SchemaObject

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

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

release+8−16

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

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

7−rootdir=`pwd`

8−

9−cabalfile=`ls *.cabal`

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

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

12−

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

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

14stack test 2> /dev/null

8stack test 2> /dev/null

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

24 read -p "Hackage username: " username

18 read -p "Hackage username: " username

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

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

26 echo ""

20 echo ""

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

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

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

23+ docdir=$dist/doc/html

24+ cd $docdir

25+ doc=$1-$2-docs

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"

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

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

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

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

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

34− cd $docdir

35− cd ..

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

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"

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

38− cd $rootdir

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

40 exit $?

32 exit $?

41else

33else

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

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

release.nixdeleted−32

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

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

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

3−}:

4−

5−let

6− _nixpkgs = import <nixpkgs> {};

7− inherit (_nixpkgs) pkgs lib;

8−

9− stackageOverlayPath = pkgs.fetchFromGitHub {

10− owner = "typeable";

11− repo = "nixpkgs-stackage";

12− rev = "abe0a03ba2bde609b0707ce45301ec836cb3ed29";

13− sha256 = "0ksdk83zbsgvs30izwsfyjh4xxwz8dsn9a5igrs3pjap4whpzqfv";

14− };

15−

16− nixpkgsArgs = {

17− overlays = [ (import stackageOverlayPath) ];

18− };

19−

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

21−

22− mkStackage = system:

23− let

24− nixpkgs = release.pkgsFor system;

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

26− in

27− stackage;

28−

29−in

30− lib.genAttrs supportedSystems (system: {

31− inherit (mkStackage system) schematic;

32− })

schematic.cabal+7−15

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

1name: schematic

2−version: 0.5.0.0

2+version: 0.4.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.

5license: BSD3

4license: BSD3

6license-file: LICENSE

5license-file: LICENSE

7author: Denis Redozubov

6author: Denis Redozubov

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

16library

15library

17 exposed-modules: Data.Schematic

16 exposed-modules: Data.Schematic

18 , Data.Schematic.DSL

17 , Data.Schematic.DSL

19− , Data.Schematic.Generator

20− , Data.Schematic.Generator.Regex

21 , Data.Schematic.Instances

18 , Data.Schematic.Instances

22 , Data.Schematic.JsonSchema

19 , Data.Schematic.JsonSchema

23 , Data.Schematic.Helpers

20 , Data.Schematic.Helpers

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

26 , Data.Schematic.Path

23 , Data.Schematic.Path

27 , Data.Schematic.Schema

24 , Data.Schematic.Schema

28 , Data.Schematic.Validation

25 , Data.Schematic.Validation

29− , Data.Schematic.Verifier

30− , Data.Schematic.Verifier.Array

31− , Data.Schematic.Verifier.Common

32− , Data.Schematic.Verifier.Number

33− , Data.Schematic.Verifier.Text

34 ghc-options: -Wall

26 ghc-options: -Wall

35 default-extensions: ConstraintKinds

27 default-extensions: ConstraintKinds

36 , DataKinds

28 , DataKinds

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

65 , TypeOperators

57 , TypeOperators

66 , TypeSynonymInstances

58 , TypeSynonymInstances

67 , UndecidableInstances

59 , UndecidableInstances

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

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

69 , bytestring

61 , bytestring

70 , aeson >= 1

62 , aeson >= 1

71 , containers

63 , containers

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

75 , regex-tdfa

67 , regex-tdfa

76 , regex-tdfa-text

68 , regex-tdfa-text

77 , scientific

69 , scientific

78− , singletons >= 2.4

70+ , singletons >= 2.2

79 , smallcheck

71 , smallcheck

80 , tagged

72 , tagged

81 , template-haskell

73 , template-haskell

82 , text

74 , text

83 , union

75 , union

84 , unordered-containers

76 , unordered-containers

85− , validationt >= 0.2.1.0

77+ , validationt >= 0.1.0.1

86 , vector

78 , vector

87 , vinyl

79 , vinyl

88 hs-source-dirs: src

80 hs-source-dirs: src

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

95 default-language: Haskell2010

87 default-language: Haskell2010

96 build-depends: HUnit

88 build-depends: HUnit

97 , aeson >= 1

89 , aeson >= 1

98− , base >=4.11 && <4.13

90+ , base >=4.9 && <4.11

99 , bytestring

91 , bytestring

100 , containers

92 , containers

101 , hjsonschema

93 , hjsonschema

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

112 , tagged

104 , tagged

113 , text

105 , text

114 , unordered-containers

106 , unordered-containers

115− , validationt >= 0.2.1.0

107+ , validationt >= 0.1.0.1

116 , vinyl

108 , vinyl

117 other-modules: SchemaSpec

109 other-modules: SchemaSpec

118 , HelpersSpec

110 , HelpersSpec

119 , LensSpec

111 , LensSpec

120− , JsonSchemaSpec

112+ , JsonSchemaSpec

src/Data/Schematic.hs+23

@@ -39,6 +39,29 @@ 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+

42parseAndValidateTopVersionJson

65parseAndValidateTopVersionJson

43 :: forall proxy (v :: Versioned)

66 :: forall proxy (v :: Versioned)

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

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

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

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

1{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE CPP #-}

4module Data.Schematic.DSL where

3module Data.Schematic.DSL where

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

18import Data.Vinyl.Functor

17import Data.Vinyl.Functor

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

22type Constructor a

20type Constructor a

23− = forall fields b

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

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

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

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

26− -> JsonRepr ('SchemaObject fields)

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

27−#else

24+

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

34withRepr :: Constructor a

25withRepr :: Constructor a

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

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

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

75 FieldsOf ('SchemaObject fs) = fs

66 FieldsOf ('SchemaObject fs) = fs

77type FieldConstructor fn =

68type FieldConstructor fn =

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

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

79− => Repr byField

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

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

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

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

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

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

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

src/Data/Schematic/Generator.hsdeleted−91

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

1−module Data.Schematic.Generator where

2−

3−import Data.Maybe

4−import Data.Schematic.Generator.Regex

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

6−import Data.Schematic.Verifier

7−import Data.Scientific

8−import Data.Text (Text, pack)

9−import qualified Data.Vector as V

10−import Test.SmallCheck.Series

11−

12−maxHigh :: Int

13−maxHigh = 30

14−

15−minLow :: Int

16−minLow = 2

17−

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

19−textLengthSeries =

20− \case

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

22− [VTBounds ml mh] -> do

23− let

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

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

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

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

28− _ -> pure "error"

29−

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

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

32−

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

34−textSeries cs = do

35− let mvcs = verifyTextConstraints cs

36− case mvcs of

37− Just vcs -> do

38− n <- textSeries' vcs

39− pure n

40− Nothing -> pure "error"

41−

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

43−textSeries' [] = pure "sample"

44−textSeries' vcs = do

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

46− case enums of

47− Just e -> textEnumSeries e

48− Nothing -> do

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

50− case regexps of

51− Just e -> regexSeries e

52− Nothing -> textLengthSeries vcs

53−

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

55−numberSeries cs = do

56− let mvcs = verifyNumberConstraints cs

57− case mvcs of

58− Just vcs -> do

59− n <- numberSeries' vcs

60− pure $ n

61− Nothing -> pure 0

62−

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

64−numberSeries' =

65− \case

66− VNEq eq -> pure $ fromIntegral eq

67− VNBounds ml mh -> do

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

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

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

71− pure $ fromIntegral n

72−

73−arraySeries

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

75− => [DemotedArrayConstraint]

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

77−arraySeries cs = do

78− let mvcs = verifyArrayConstraint cs

79− case mvcs of

80− Just vcs -> arraySeries' vcs

81− Nothing -> pure V.empty

82−

83−arraySeries'

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

85− => Maybe VerifiedArrayConstraint

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

87−arraySeries' ml = do

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

89− pure $ objs

90− where

91− f (VAEq l) = fromIntegral l

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

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

1−module Data.Schematic.Generator.Regex where

2−

3−import Control.Monad

4−import Data.List

5−import Data.Maybe

6−import qualified Data.Set as S

7−import Data.Text (Text, unpack)

8−import Data.Text.Lazy (toStrict)

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

10−import Test.SmallCheck.Series

11−import Text.Regex.TDFA.Pattern

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

13−

14−

15−minRepeat :: Int

16−minRepeat = 2

17−

18−maxRepeat :: Int

19−maxRepeat = 10

20−

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

22−regexSeries regexp =

23− case parseRegex . unpack $ regexp of

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

25− Left _ -> pure ""

26−

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

28−regexSeries' pt =

29− case pt of

30− PEmpty -> pure mempty

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

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

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

34− pure $ singleton x

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

36− x <-

37− generate $ \depth ->

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

39− pure $ singleton x

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

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

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

43− PBound low mhigh p -> do

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

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

46− decDepth $ do

47− ps <- replicateM n $ regexSeries' p

48− pure $ mconcat ps

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

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

51− PDot _ -> do

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

53− pure $ singleton x

54− PEscape {..} -> do

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

56− pure $ singleton x

57− PCarat _ -> pure mempty

58− PDollar _ -> pure mempty

59− _ -> pure mempty

60− where

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

62− expandEscape ch =

63− case ch of

64− 'n' -> "\n"

65− 't' -> "\t"

66− 'r' -> "\r"

67− 'f' -> "\f"

68− 'a' -> "\a"

69− 'e' -> "\ESC"

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

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

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

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

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

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

76− ch' -> [ch']

src/Data/Schematic/Instances.hs−4

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

4module Data.Schematic.Instances where

6import Data.Scientific

7−import Data.Text (Text, pack)

8import Data.Vector as V

7import Data.Vector as V

9import Data.Vinyl

8import Data.Vinyl

10import Test.SmallCheck.Series

9import Test.SmallCheck.Series

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

23instance Monad m => Serial m Scientific where

22instance Monad m => Serial m Scientific where

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

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

25−

26−instance Monad m => Serial m Text where

27− series = pack <$> series

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

@@ -12,10 +12,8 @@ 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

16import Data.List.NonEmpty as NE

15import Data.List.NonEmpty as NE

17import Data.Schematic.Schema as S

16import Data.Schematic.Schema as S

18−import Data.Set as Set

19import Data.Singletons

17import Data.Singletons

20import Data.Text

18import Data.Text

21import Data.Traversable

19import Data.Traversable

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

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

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

31 { _schemaMinLength = pure $ fromIntegral n

29 { _schemaMinLength = pure $ fromIntegral n

32 , _schemaMaxLength = pure $ fromIntegral n }

30 , _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 (DTLt n) =

35+textConstraint (DTGt n) =

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

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

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

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

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

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

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

41 { _schemaMinLength = pure . fromIntegral $ n }

39 { _schemaMinLength = pure . fromIntegral $ n }

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

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

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

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

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

49 { _schemaMaximum = pure . fromIntegral $ n }

47 { _schemaMaximum = pure . fromIntegral $ n }

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

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

51− { _schemaMaximum = pure . fromIntegral $ n

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

52− , _schemaExclusiveMaximum = pure True }

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

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

54− { _schemaMinimum = pure . fromIntegral $ n

55− , _schemaExclusiveMinimum = pure True }

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

57 { _schemaMinimum = pure . fromIntegral $ n }

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

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

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

59 { _schemaMinimum = pure $ fromIntegral n

56 { _schemaMinimum = pure $ fromIntegral n

60 , _schemaMaximum = pure $ fromIntegral n }

57 , _schemaMaximum = pure $ fromIntegral n }

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

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

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

60+arrayConstraint (DAEq _) = pure ()

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 }

76toJsonSchema

62toJsonSchema

77 :: forall proxy schema

63 :: forall proxy schema

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

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

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

99 s' <- toJsonSchema' s

85 s' <- toJsonSchema' s

100 pure (n, s')

86 pure (n, s')

101− let

102− nonOpt = \case

103− (_, DSchemaOptional _) -> False

104− _ -> True

105 pure $ emptySchema

87 pure $ emptySchema

106 { _schemaType = pure $ TypeValidatorString D4.SchemaObject

88 { _schemaType = pure $ TypeValidatorString D4.SchemaObject

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

108 , _schemaProperties = pure $ H.fromList res }

89 , _schemaProperties = pure $ H.fromList res }

109 DSchemaArray acs sch -> do

90 DSchemaArray acs sch -> do

110 res <- toJsonSchema' sch

91 res <- toJsonSchema' sch

111 pure $ execState (traverse_ arrayConstraint acs) $ emptySchema

92 pure $ execState (traverse_ arrayConstraint acs) $ emptySchema

112 { _schemaType = pure $ TypeValidatorString D4.SchemaArray

93 { _schemaType = pure $ TypeValidatorString D4.SchemaArray

113− , _schemaItems = pure $ ItemsObject res }

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

114 DSchemaNull -> pure $ emptySchema

95 DSchemaNull -> pure $ emptySchema

115 { _schemaType = pure $ TypeValidatorString D4.SchemaNull }

96 { _schemaType = pure $ TypeValidatorString D4.SchemaNull }

116 DSchemaOptional sch -> do

97 DSchemaOptional sch -> do

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

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

10 , FSubset(..)

11 , obj

12 , arr

13− , uni

14− , txt

15− , num

16− , opt

17− , bln

18 , textRepr

13 , textRepr

19 , numberRepr

14 , numberRepr

20 , boolRepr

15 , boolRepr

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

24 ) where

19 ) where

26import Data.Profunctor

21import Data.Profunctor

22+import Data.Proxy

27import Data.Schematic.Schema

23import Data.Schematic.Schema

28import Data.Scientific

24import Data.Scientific

29import Data.Singletons

25import Data.Singletons

30import Data.Text

26import Data.Text

31−import Data.Union

32import Data.Vector as V

27import Data.Vector as V

33import Data.Vinyl

28import Data.Vinyl

34import Data.Vinyl.Functor

29import Data.Vinyl.Functor

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

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

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

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

37 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−

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

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

53 type ByField fn rs i :: Schema

40 type ByField fn rs i :: Schema

54− flens :: Flens fn f g rs i

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)

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

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

57− fget :: FGetter fn f rs i

49+ fget

50+ :: proxy fn

51+ -> Rec f rs

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

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

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

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

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

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

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

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

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

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

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

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

71 {-# INLINE flens #-}

66 {-# INLINE flens #-}

73− fget = getConst . flens Const

68+ fget k = getConst . flens k Const

74 {-# INLINE fget #-}

69 {-# INLINE fget #-}

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

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

77 {-# INLINE fput #-}

72 {-# INLINE fput #-}

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

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

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

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

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

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

83 {-# INLINE flens #-}

78 {-# INLINE flens #-}

85− fget = getConst . flens Const

80+ fget k = getConst . flens k Const

86 {-# INLINE fget #-}

81 {-# INLINE fget #-}

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

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

89 {-# INLINE fput #-}

84 {-# INLINE fput #-}

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

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

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

149 ( ByField fn ss i ~ s

144 ( ByField fn ss i ~ s

150 , FElem fn ss i

145 , FElem fn ss i

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

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

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

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

153 where

148 where

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

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

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

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

156

151

157-- A bunch of @Iso@morphisms

152-- A bunch of @Iso@morphisms

158textRepr

153textRepr

159− :: (KnownSymbol fn, SingI cs)

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

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

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

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

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

162

157

163numberRepr

158numberRepr

164− :: (KnownSymbol fn, SingI cs)

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

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

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

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

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

167

162

168boolRepr

163boolRepr

169− :: (KnownSymbol fn)

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

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

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

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

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

172

167

173arrayRepr

168arrayRepr

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

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

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

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

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

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

177

172

178objectRepr

173objectRepr

179− :: (KnownSymbol fn, SingI fields)

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

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

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

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

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

182

177

183optionalRepr

178optionalRepr

184− :: (KnownSymbol fn, SingI schema)

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

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

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

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

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

187

182

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

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

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

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

190

185

186+arr

187+ :: (SingI schema)

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

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

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

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

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

1{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE CPP #-}

3−{-# LANGUAGE TemplateHaskell #-}

2+{-# LANGUAGE TemplateHaskell #-}

5module Data.Schematic.Migration where

4module Data.Schematic.Migration where

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

8import Data.Schematic.DSL

7import Data.Schematic.DSL

9import Data.Schematic.Lens

8import Data.Schematic.Lens

10import Data.Schematic.Path

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

15import Data.Vinyl

14import Data.Vinyl

16import Data.Vinyl.Functor

15import Data.Vinyl.Functor

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

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

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

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

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

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

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

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

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

49type family UpdateKey

48type family UpdateKey

50 (fn :: Symbol)

49 (fn :: Symbol)

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

147

146

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

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

149

148

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

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

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

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

152 (:&&)

151 (:&&)

153 :: (TopLevel s, SingI s)

152 :: (TopLevel s, SingI s)

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

157

156

158infixr 7 :&&

157infixr 7 :&&

159

158

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

166migrateObject

159migrateObject

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

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

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

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

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

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

170−#endif

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

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

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

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

173 pure $ withRepr @('SchemaObject fs) res

165 pure $ withRepr @('SchemaObject fs) res

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

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

1module Data.Schematic.Path where

3import Data.Foldable as F

4+import Data.Monoid

5+import Data.Singletons

4import Data.Singletons.Prelude

6import Data.Singletons.Prelude

5import Data.Singletons.TypeLits

7import Data.Singletons.TypeLits

6import Data.Text as T

8import Data.Text as T

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

24 where

26 where

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

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

26 go acc SNil = acc

28 go acc SNil = acc

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

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

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

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

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

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

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

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

32demotedPathToText :: [DemotedPathSegment] -> JSONPath

34demotedPathToText :: [DemotedPathSegment] -> JSONPath

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

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

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

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

1{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE CPP #-}

3−{-# LANGUAGE OverloadedLists #-}

2+{-# LANGUAGE OverloadedLists #-}

4−{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE OverloadedStrings #-}

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

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

7module Data.Schematic.Schema where

6module Data.Schematic.Schema where

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

13import Data.HashMap.Strict as H

12import Data.HashMap.Strict as H

14import Data.Kind

13import Data.Kind

15import Data.Maybe

14import Data.Maybe

16−import Data.Schematic.Generator

17import Data.Schematic.Instances ()

15import Data.Schematic.Instances ()

18import Data.Scientific

16import Data.Scientific

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

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

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

26import qualified Data.Vinyl.TypeLevel as V

24import qualified Data.Vinyl.TypeLevel as V

27import GHC.Exts

25import GHC.Exts

28import GHC.Generics (Generic)

26import GHC.Generics (Generic)

29−import GHC.TypeLits

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

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

31import Prelude as P

28import Prelude as P

32import Test.SmallCheck.Series

29import Test.SmallCheck.Series

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

51instance SingKind TextConstraint where

48instance SingKind TextConstraint where

52 type Demote TextConstraint = DemotedTextConstraint

49 type Demote TextConstraint = DemotedTextConstraint

53 fromSing = \case

50 fromSing = \case

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

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

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

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

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

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

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

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

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

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

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

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

60 STEnum s -> let

57 STEnum s -> let

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

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

62− d SNil = []

59+ d SNil = []

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

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

64 in DTEnum $ d s

61 in DTEnum $ d s

65 toSing = \case

62 toSing = \case

66 DTEq n -> case someNatVal n of

63 DTEq n -> case someNatVal n of

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

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

68− Nothing -> error "Negative singleton nat"

65+ Nothing -> error "Negative singleton nat"

69 DTLt n -> case someNatVal n of

66 DTLt n -> case someNatVal n of

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

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

71− Nothing -> error "Negative singleton nat"

68+ Nothing -> error "Negative singleton nat"

72 DTLe n -> case someNatVal n of

69 DTLe n -> case someNatVal n of

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

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

74− Nothing -> error "Negative singleton nat"

71+ Nothing -> error "Negative singleton nat"

75 DTGt n -> case someNatVal n of

72 DTGt n -> case someNatVal n of

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

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

77− Nothing -> error "Negative singleton nat"

74+ Nothing -> error "Negative singleton nat"

78 DTGe n -> case someNatVal n of

75 DTGe n -> case someNatVal n of

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

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

80− Nothing -> error "Negative singleton nat"

77+ Nothing -> error "Negative singleton nat"

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

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

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

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

83 DTEnum ss -> case toSing ss of

80 DTEnum ss -> case toSing ss of

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

91 | DTGe Integer

88 | DTGe Integer

92 | DTRegex Text

89 | DTRegex Text

93 | DTEnum [Text]

90 | DTEnum [Text]

94− deriving (Generic, Eq, Show)

91+ deriving (Generic)

96data instance Sing (tc :: TextConstraint) where

93data instance Sing (tc :: TextConstraint) where

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

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

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

132 | DNGt Integer

129 | DNGt Integer

133 | DNGe Integer

130 | DNGe Integer

134 | DNEq Integer

131 | DNEq Integer

135− deriving (Generic, Eq, Show)

132+ deriving (Generic)

136

133

137data instance Sing (nc :: NumberConstraint) where

134data instance Sing (nc :: NumberConstraint) where

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

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

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

156instance SingKind NumberConstraint where

153instance SingKind NumberConstraint where

157 type Demote NumberConstraint = DemotedNumberConstraint

154 type Demote NumberConstraint = DemotedNumberConstraint

158 fromSing = \case

155 fromSing = \case

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

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

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

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

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

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

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

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

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

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

164 toSing = \case

161 toSing = \case

165 DNEq n -> case someNatVal n of

162 DNEq n -> case someNatVal n of

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

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

167− Nothing -> error "Negative singleton nat"

164+ Nothing -> error "Negative singleton nat"

168 DNGt n -> case someNatVal n of

165 DNGt n -> case someNatVal n of

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

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

170− Nothing -> error "Negative singleton nat"

167+ Nothing -> error "Negative singleton nat"

171 DNGe n -> case someNatVal n of

168 DNGe n -> case someNatVal n of

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

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

173− Nothing -> error "Negative singleton nat"

170+ Nothing -> error "Negative singleton nat"

174 DNLt n -> case someNatVal n of

171 DNLt n -> case someNatVal n of

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

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

176− Nothing -> error "Negative singleton nat"

173+ Nothing -> error "Negative singleton nat"

177 DNLe n -> case someNatVal n of

174 DNLe n -> case someNatVal n of

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

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

179− Nothing -> error "Negative singleton nat"

176+ Nothing -> error "Negative singleton nat"

180

177

181data ArrayConstraint

178data ArrayConstraint

182 = AEq Nat

179 = AEq Nat

183− | AGt Nat

184− | AGe Nat

185− | ALt Nat

186− | ALe Nat

187 deriving (Generic)

180 deriving (Generic)

188

181

189data DemotedArrayConstraint

182data DemotedArrayConstraint

190 = DAEq Integer

183 = DAEq Integer

191− | DAGt Integer

192− | DAGe Integer

193− | DALt Integer

194− | DALe Integer

195− deriving (Generic, Eq, Show)

184+ deriving (Generic)

196

185

197data instance Sing (ac :: ArrayConstraint) where

186data instance Sing (ac :: ArrayConstraint) where

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

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

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

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

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

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

203

188

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

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

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

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

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

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

209

190

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

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

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

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

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

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

215

192

216instance SingKind ArrayConstraint where

193instance SingKind ArrayConstraint where

217 type Demote ArrayConstraint = DemotedArrayConstraint

194 type Demote ArrayConstraint = DemotedArrayConstraint

218 fromSing = \case

195 fromSing = \case

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

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

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

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

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

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

224 toSing = \case

197 toSing = \case

225 DAEq n -> case someNatVal n of

198 DAEq n -> case someNatVal n of

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

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

227− Nothing -> error "Negative singleton nat"

228− DAGt n -> case someNatVal n of

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

230− Nothing -> error "Negative singleton nat"

231− DAGe n -> case someNatVal n of

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

233− Nothing -> error "Negative singleton nat"

234− DALt n -> case someNatVal n of

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

236− Nothing -> error "Negative singleton nat"

237− DALe n -> case someNatVal n of

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

239− Nothing -> error "Negative singleton nat"

200+ Nothing -> error "Negative singleton nat"

240

201

241data Schema

202data Schema

242 = SchemaText [TextConstraint]

203 = SchemaText [TextConstraint]

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

258 | DSchemaNull

219 | DSchemaNull

259 | DSchemaOptional DemotedSchema

220 | DSchemaOptional DemotedSchema

260 | DSchemaUnion [DemotedSchema]

221 | DSchemaUnion [DemotedSchema]

261− deriving (Generic, Eq, Show)

222+ deriving (Generic)

262

223

263data instance Sing (schema :: Schema) where

224data instance Sing (schema :: Schema) where

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

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

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

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

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

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

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

375

336

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

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

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

379−

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

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

382− series = decDepth $ fmap ReprNumber

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

384−

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

386− series = cons0 ReprNull

387−

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

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

390− series = decDepth $ fmap ReprArray

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

392−

393−instance (Serial m (JsonRepr s))

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

395− series = cons1 ReprOptional

396−

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

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

399− series = cons1 ReprObject

400−

401-- | Move to the union package

337-- | Move to the union package

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

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

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

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

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

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

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

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

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

407

343

408−instance Show (JsonRepr 'SchemaBoolean) where

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

410−

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

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

412

345

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

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

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

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

415

348

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

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

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

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

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

425−#endif

426

351

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

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

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

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

429

354

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

355+instance (Monad m, Serial m Text)

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

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

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

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

433

377

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

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

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

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

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

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

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

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

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

442

386

443−instance Eq (JsonRepr 'SchemaBoolean) where

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

445−

446instance Eq (JsonRepr 'SchemaNull) where

387instance Eq (JsonRepr 'SchemaNull) where

447 ReprNull == ReprNull = True

388 ReprNull == ReprNull = True

448

389

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

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

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

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

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

454

395

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−

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

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

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

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

486 fromList = ReprArray . GHC.Exts.fromList

398 fromList = ReprArray . GHC.Exts.fromList

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

542 fieldRepr <- case s of

454 fieldRepr <- case s of

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

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

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

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

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

457+ Nothing -> fail "schematext"

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

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

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

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

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

460+ Nothing -> fail "schemanumber"

549 SSchemaBoolean -> case H.lookup fieldName h of

461 SSchemaBoolean -> case H.lookup fieldName h of

550 Just v -> FieldRepr <$> parseJSON v

462 Just v -> FieldRepr <$> parseJSON v

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

463+ Nothing -> fail "schemaboolean"

552 SSchemaNull -> case H.lookup fieldName h of

464 SSchemaNull -> case H.lookup fieldName h of

553 Just v -> FieldRepr <$> parseJSON v

465 Just v -> FieldRepr <$> parseJSON v

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

466+ Nothing -> fail "schemanull"

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

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

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

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

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

469+ Nothing -> fail "schemaarray"

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

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

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

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

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

472+ Nothing -> fail "schemaobject"

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

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

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

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

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

475+ Nothing -> fail "schemaoptional"

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

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

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

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

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

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

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

572 toJSON (ReprText t) = J.String t

484 toJSON (ReprText t) = J.String t

573 toJSON (ReprNumber n) = J.Number n

485 toJSON (ReprNumber n) = J.Number n

574 toJSON (ReprOptional s) = case s of

486 toJSON (ReprOptional s) = case s of

575− Just v -> toJSON v

487+ Just v -> toJSON v

576 Nothing -> J.Null

488 Nothing -> J.Null

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

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

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

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

src/Data/Schematic/Schema.hs-bootdeleted−95

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

1−module Data.Schematic.Schema where

2−

3−import Data.Kind

4−import Data.Maybe

5−import Data.Schematic.Instances ()

6−import Data.Scientific

7−import Data.Singletons.TH

8−import Data.Singletons.TypeLits

9−import Data.Text as T

10−import Data.Union

11−import Data.Vector as V

12−import Data.Vinyl hiding (Dict)

13−import Prelude as P

14−

15−data TextConstraint

16− = TEq Nat

17− | TLt Nat

18− | TLe Nat

19− | TGt Nat

20− | TGe Nat

21− | TRegex Symbol

22− | TEnum [Symbol]

23−

24−data DemotedTextConstraint

25− = DTEq Integer

26− | DTLt Integer

27− | DTLe Integer

28− | DTGt Integer

29− | DTGe Integer

30− | DTRegex Text

31− | DTEnum [Text]

32−

33−data NumberConstraint

34− = NLe Nat

35− | NLt Nat

36− | NGt Nat

37− | NGe Nat

38− | NEq Nat

39−

40−data DemotedNumberConstraint

41− = DNLe Integer

42− | DNLt Integer

43− | DNGt Integer

44− | DNGe Integer

45− | DNEq Integer

46−

47−data ArrayConstraint

48− = AEq Nat

49− | AGt Nat

50− | AGe Nat

51− | ALt Nat

52− | ALe Nat

53−

54−data DemotedArrayConstraint

55− = DAEq Integer

56− | DAGt Integer

57− | DAGe Integer

58− | DALt Integer

59− | DALe Integer

60−

61−data Schema

62− = SchemaText [TextConstraint]

63− | SchemaBoolean

64− | SchemaNumber [NumberConstraint]

65− | SchemaObject [(Symbol, Schema)]

66− | SchemaArray [ArrayConstraint] Schema

67− | SchemaNull

68− | SchemaOptional Schema

69− | SchemaUnion [Schema]

70−

71−data DemotedSchema

72− = DSchemaText [DemotedTextConstraint]

73− | DSchemaNumber [DemotedNumberConstraint]

74− | DSchemaBoolean

75− | DSchemaObject [(Text, DemotedSchema)]

76− | DSchemaArray [DemotedArrayConstraint] DemotedSchema

77− | DSchemaNull

78− | DSchemaOptional DemotedSchema

79− | DSchemaUnion [DemotedSchema]

80−

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

82− FieldRepr

83− :: (SingI schema, KnownSymbol name)

84− => JsonRepr schema

85− -> FieldRepr '(name, schema)

86−

87−data JsonRepr :: Schema -> Type where

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

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

90− ReprBoolean :: Bool -> JsonRepr 'SchemaBoolean

91− ReprNull :: JsonRepr 'SchemaNull

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

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

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

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

src/Data/Schematic/Validation.hs+19−76

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

3import Control.Monad

4import Control.Monad.Validation

5−import Data.Aeson

6−import Data.Aeson.Types

7import Data.Foldable

5import Data.Foldable

8import Data.Functor.Identity

6import Data.Functor.Identity

9import Data.Monoid

7import Data.Monoid

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

32 | ValidationError ErrorMap -- runtime

30 | ValidationError ErrorMap -- runtime

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

31 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−

39isValid :: ParseResult a -> Bool

33isValid :: ParseResult a -> Bool

40isValid (Valid _) = True

34isValid (Valid _) = True

41isValid _ = False

35isValid _ = False

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

58 let

52 let

59 nlen = withKnownNat n $ natVal n

53 nlen = withKnownNat n $ natVal n

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

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

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

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

62 warn = vWarning $ mmSingleton path (pure errMsg)

56 warn = vWarning $ mmSingleton path (pure errMsg)

63 unless predicate warn

57 unless predicate warn

64 STLt n -> do

58 STLt n -> do

65 let

59 let

66 nlen = withKnownNat n $ natVal n

60 nlen = withKnownNat n $ natVal n

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

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

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

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

69 warn = vWarning $ mmSingleton path (pure errMsg)

63 warn = vWarning $ mmSingleton path (pure errMsg)

70 unless predicate warn

64 unless predicate warn

71 STLe n -> do

65 STLe n -> do

72 let

66 let

73 nlen = withKnownNat n $ natVal n

67 nlen = withKnownNat n $ natVal n

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

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

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

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

76 warn = vWarning $ mmSingleton path (pure errMsg)

70 warn = vWarning $ mmSingleton path (pure errMsg)

77 unless predicate warn

71 unless predicate warn

78 STGt n -> do

72 STGt n -> do

79 let

73 let

80 nlen = withKnownNat n $ natVal n

74 nlen = withKnownNat n $ natVal n

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

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

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

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

83 warn = vWarning $ mmSingleton path (pure errMsg)

77 warn = vWarning $ mmSingleton path (pure errMsg)

84 unless predicate warn

78 unless predicate warn

85 STGe n -> do

79 STGe n -> do

86 let

80 let

87 nlen = withKnownNat n $ natVal n

81 nlen = withKnownNat n $ natVal n

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

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

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

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

90 warn = vWarning $ mmSingleton path (pure errMsg)

84 warn = vWarning $ mmSingleton path (pure errMsg)

91 unless predicate warn

85 unless predicate warn

92 STRegex r -> do

86 STRegex r -> do

93 let

87 let

94 regex = withKnownSymbol r $ fromSing r

88 regex = withKnownSymbol r $ fromSing r

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

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

96− errMsg = "must match " <> regex

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

97 warn = vWarning $ mmSingleton path (pure errMsg)

91 warn = vWarning $ mmSingleton path (pure errMsg)

98 unless predicate warn

92 unless predicate warn

99 STEnum ss -> do

93 STEnum ss -> do

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

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

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

102 matching SNil = False

96 matching SNil = False

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

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

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

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

105 warn = vWarning $ mmSingleton path (pure errMsg)

99 warn = vWarning $ mmSingleton path (pure errMsg)

106 unless (matching ss) warn

100 unless (matching ss) warn

107

101

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

115 let

109 let

116 nlen = withKnownNat n $ natVal n

110 nlen = withKnownNat n $ natVal n

117 predicate = fromIntegral nlen == num

111 predicate = fromIntegral nlen == num

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

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

119 warn = vWarning $ mmSingleton path (pure errMsg)

113 warn = vWarning $ mmSingleton path (pure errMsg)

120 unless predicate warn

114 unless predicate warn

121 SNGt n -> do

115 SNGt n -> do

122 let

116 let

123 nlen = withKnownNat n $ natVal n

117 nlen = withKnownNat n $ natVal n

124 predicate = num > fromIntegral nlen

118 predicate = num > fromIntegral nlen

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

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

126 warn = vWarning $ mmSingleton path (pure errMsg)

120 warn = vWarning $ mmSingleton path (pure errMsg)

127 unless predicate warn

121 unless predicate warn

128 SNGe n -> do

122 SNGe n -> do

129 let

123 let

130 nlen = withKnownNat n $ natVal n

124 nlen = withKnownNat n $ natVal n

131 predicate = num >= fromIntegral nlen

125 predicate = num >= fromIntegral nlen

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

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

133 warn = vWarning $ mmSingleton path (pure errMsg)

127 warn = vWarning $ mmSingleton path (pure errMsg)

134 unless predicate warn

128 unless predicate warn

135 SNLt n -> do

129 SNLt n -> do

136 let

130 let

137 nlen = withKnownNat n $ natVal n

131 nlen = withKnownNat n $ natVal n

138− predicate = num < fromIntegral nlen

132+ predicate = fromIntegral nlen < num

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

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

140 warn = vWarning $ mmSingleton path (pure errMsg)

134 warn = vWarning $ mmSingleton path (pure errMsg)

141 unless predicate warn

135 unless predicate warn

142 SNLe n -> do

136 SNLe n -> do

143 let

137 let

144 nlen = withKnownNat n $ natVal n

138 nlen = withKnownNat n $ natVal n

145− predicate = num <= fromIntegral nlen

139+ predicate = fromIntegral nlen <= num

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

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

147 warn = vWarning $ mmSingleton path (pure errMsg)

141 warn = vWarning $ mmSingleton path (pure errMsg)

148 unless predicate warn

142 unless predicate warn

149

143

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

157 let

151 let

158 nlen = withKnownNat n $ natVal n

152 nlen = withKnownNat n $ natVal n

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

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

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

154+ errMsg = "length of " <> path <> " 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)

189 warn = vWarning $ mmSingleton path (pure errMsg)

155 warn = vWarning $ mmSingleton path (pure errMsg)

190 unless predicate warn

156 unless predicate warn

191

157

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

280

246

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

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

282umatch' _ u = umatch u

248umatch' _ 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.hsdeleted−5

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

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

2−

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

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

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

src/Data/Schematic/Verifier/Array.hsdeleted−14

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

1−module Data.Schematic.Verifier.Array where

2−

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

4−import Data.Schematic.Verifier.Common

5−

6−data VerifiedArrayConstraint =

7− VAEq Integer

8− deriving (Show)

9−

10−verifyArrayConstraint ::

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

12−verifyArrayConstraint cs = do

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

14− pure $ VAEq <$> x

src/Data/Schematic/Verifier/Common.hsdeleted−43

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

1−module Data.Schematic.Verifier.Common where

2−

3−import Data.List (nub)

4−

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

6−simplifyNumberConstraint f =

7− \case

8− [] -> Nothing

9− x -> Just $ f x

10−

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

12−simplifyDNLs = simplifyNumberConstraint minimum

13−

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

15−simplifyDNGs = simplifyNumberConstraint maximum

16−

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

18−verifyDNEq x =

19− case nub x of

20− [] -> Just Nothing

21− [y] -> Just $ Just y

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

23−

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

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

26− if x < y && y < z

27− then Just ()

28− else Nothing

29−verify3 _ _ _ = Just ()

30−

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

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

33− if x < y

34− then Just ()

35− else Nothing

36−verify2 _ _ = Just ()

37−

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

39−verifyEquations mgt meq mlt = do

40− verify3 mgt meq mlt

41− verify2 mgt meq

42− verify2 meq mlt

43− verify2 mgt mlt

src/Data/Schematic/Verifier/Number.hsdeleted−31

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

1−module Data.Schematic.Verifier.Number where

2−

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

4−import Data.Schematic.Verifier.Common

5−

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

7−toStrictNumber = map f

8− where

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

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

11− f x = x

12−

13−data VerifiedNumberConstraint

14− = VNEq Integer

15− | VNBounds (Maybe Integer) (Maybe Integer)

16− deriving (Show)

17−

18−verifyNumberConstraints

19− :: [DemotedNumberConstraint]

20− -> Maybe VerifiedNumberConstraint

21−verifyNumberConstraints cs' = do

22− let

23− cs = toStrictNumber cs'

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

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

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

27− verifyEquations mgt meq mlt

28− Just $

29− case meq of

30− Just eq -> VNEq eq

31− Nothing -> VNBounds mgt mlt

src/Data/Schematic/Verifier/Text.hsdeleted−121

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

1−module Data.Schematic.Verifier.Text where

2−

3−import Control.Monad

4−import Data.Maybe

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

6−import Data.Schematic.Verifier.Common

7−import Data.Text (Text, unpack)

8−import Text.Regex.TDFA.Pattern

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

10−

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

12−toStrictTextLength = map f

13− where

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

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

16− f x = x

17−

18−data VerifiedTextConstraint

19− = VTEq Integer

20− | VTBounds (Maybe Integer) (Maybe Integer)

21− | VTRegex Text Integer (Maybe Integer)

22− | VTEnum [Text]

23− deriving (Show)

24−

25−verifyTextLengthConstraints

26− :: [DemotedTextConstraint]

27− -> Maybe (Maybe VerifiedTextConstraint)

28−verifyTextLengthConstraints cs' = do

29− let

30− cs = toStrictTextLength cs'

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

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

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

34− verifyEquations mgt meq mlt

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

36− True -> Just Nothing

37− _ ->

38− Just $

39− Just $

40− case meq of

41− Just eq -> VTEq eq

42− Nothing -> VTBounds mgt mlt

43−

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

45−regexLength regexp =

46− case parseRegex . unpack $ regexp of

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

48− Left _ -> Nothing

49−

50−minRegexLength :: Pattern -> Int

51−minRegexLength p =

52− case p of

53− PEmpty -> 0

54− PChar {..} -> 1

55− PAny {..} -> 1

56− PAnyNot {..} -> 1

57− PQuest _ -> 0

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

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

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

61− PConcat ps -> sum $ fmap minRegexLength ps

62− POr xs -> minimum $ fmap minRegexLength xs

63− PDot _ -> 1

64− PEscape {..} -> 1

65− PCarat _ -> 0

66− PDollar _ -> 0

67− _ -> 0

68−

69−maxRegexLength :: Pattern -> Maybe Int

70−maxRegexLength p =

71− case p of

72− PEmpty -> Just 0

73− PChar _ _ -> Just 1

74− PAny _ _ -> Just 1

75− PAnyNot _ _ -> Just 1

76− PQuest _ -> Just 0

77− PPlus _ -> Nothing

78− PStar _ _ -> Nothing

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

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

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

82− PDot _ -> Just 1

83− PEscape _ _ -> Just 1

84− PCarat _ -> Just 0

85− PDollar _ -> Just 0

86− _ -> Just 0

87−

88−verifyTextRegexConstraint

89− :: [DemotedTextConstraint]

90− -> Maybe (Maybe VerifiedTextConstraint)

91−verifyTextRegexConstraint cs = do

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

93− case regexps of

94− [] -> Just Nothing

95− [x] -> do

96− (l, mh) <- regexLength x

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

98− _ -> Nothing

99−

100−verifyTextEnumConstraint

101− :: [DemotedTextConstraint]

102− -> Maybe (Maybe VerifiedTextConstraint)

103−verifyTextEnumConstraint cs = do

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

105− case enums of

106− [] -> Just Nothing

107− x -> Just $ Just $ VTEnum x

108−

109−verifyTextConstraints

110− :: [DemotedTextConstraint]

111− -> Maybe [VerifiedTextConstraint]

112−verifyTextConstraints cs = do

113− regexp <- verifyTextRegexConstraint cs

114− void $

115− case regexp of

116− Just (VTRegex _ l mh) ->

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

118− _ -> pure Nothing

119− lengths <- verifyTextLengthConstraints cs

120− enums <- verifyTextEnumConstraint cs

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

stack-13.7.yamldeleted−5

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

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+50−4

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

1−resolver: lts-12.0

1+resolver: nightly-2017-09-17

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+

2extra-deps:

24extra-deps:

3− - hjsonpointer-1.4.0@rev:0

25+- hjsonpointer-1.3.0

4− - hjsonschema-1.9.0@rev:0

26+- hjsonschema-1.7.0

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

test/JsonSchemaSpec.hs−58

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

10import Data.Aeson as J

11import Data.Maybe

12import Data.Proxy

13−import Data.ByteString.Lazy as B

14import Data.Schematic

13import Data.Schematic

15import Data.Vinyl

14import Data.Vinyl

16import JSONSchema.Draft4 as D4

15import JSONSchema.Draft4 as D4

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

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

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

33 :& RNil

32 :& 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−

56spec :: Spec

34spec :: Spec

57spec = do

35spec = do

58 it "validates simple schema" $ do

36 it "validates simple schema" $ do

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

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

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

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

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

62 Right _ -> pure ()

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

100main :: IO ()

42main :: IO ()

101main = hspec spec

43main = 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 @"foo" objectData `shouldBe` arrayField

306+ fget fooProxy objectData `shouldBe` arrayField

307 it "sets the object field" $ do

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

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

309

310 describe "(using lens library) " $ do

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

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

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

313 it "sets the object field" $ do

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

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

315 `shouldBe` newFooVal

316

317main :: IO ()

test/SchemaSpec.hs−24

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

17import Data.Functor.Identity

18import Data.Proxy

19import Data.Schematic

20−import Data.Schematic.Generator

21−import Data.Singletons

22import Data.Tagged

20import Data.Tagged

23import Data.Vinyl

21import Data.Vinyl

24import Test.Hspec

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

32type SchemaExample = 'SchemaObject

25type SchemaExample = 'SchemaObject

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

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

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

27 , '("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−

40jsonExample :: JsonRepr SchemaExample

29jsonExample :: JsonRepr SchemaExample

41jsonExample = withRepr @SchemaExample

30jsonExample = withRepr @SchemaExample

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

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

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

80schemaJson2 :: ByteString

69schemaJson2 :: ByteString

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

70schemaJson2 = "{\"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−

89spec :: Spec

72spec :: Spec

90spec = do

73spec = do

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

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

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

110 migrationList

93 migrationList

111 schemaJson

94 schemaJson

112 `shouldSatisfy` isValid

95 `shouldSatisfy` isValid

113− it "validates json series" $ property $

114− SC.over schemaJsonSeries $ \x ->

115− isValid (parseAndValidateJson @SchemaExample (toJSON x))

116− it "validates json series 2" $ property $

117− SC.over schemaJsonSeries2 $ \x ->

118− isValid (parseAndValidateJson @SchemaExample2 (toJSON x))

119−

120

121main :: IO ()

97main :: IO ()

122main = hspec spec

98main = hspec spec