master..87c1751 · schematic

git.iko.soy/schematic

28 files changed+235−999

unifiedsplit

.travis.yml+2−2

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

1−sudo: required

1+sudo: false

33language: c

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

2222

2323cache:

2424 directories:

25− - $HOME/.stack

25+ - $HOME/.stack

ChangeLog.md−21

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

11# 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−

243## 0.4.0.0 -- 2017-10-17

254

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

README.md+5−5

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

2424

2525## GHC Extensions

2626

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

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

2828either to a module or a cabal file:

2929

3030```

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

3535```

3636

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

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

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

3939

4040## GHC Options

4141

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

132132

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

134134

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

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

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

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

137137

138138## Migrations

139139

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

178178acceptable by one schema to values acceptable by another.

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

180180

181−```haskell

181+```

182182type SchemaExample = 'SchemaObject

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

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

release+8−16

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

55dist=`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−

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

148stack test 2> /dev/null

159

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

2418 read -p "Hackage username: " username

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

2620 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

2822

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

23+ docdir=$dist/doc/html

24+ cd $docdir

25+ doc=$1-$2-docs

3026

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

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

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

28+ cp -r $1 $doc

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

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

34− cd $docdir

35− cd ..

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

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

38− cd $rootdir

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

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"

4032 exit $?

4133else

4234 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 @@

11name: schematic

2−version: 0.5.0.0

2+version: 0.4.0.0

33synopsis: JSON-biased spec and validation tool

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

54license: BSD3

65license-file: LICENSE

76author: Denis Redozubov

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

1615library

1716 exposed-modules: Data.Schematic

1817 , Data.Schematic.DSL

19− , Data.Schematic.Generator

20− , Data.Schematic.Generator.Regex

2118 , Data.Schematic.Instances

2219 , Data.Schematic.JsonSchema

2320 , Data.Schematic.Helpers

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

2623 , Data.Schematic.Path

2724 , Data.Schematic.Schema

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

3426 ghc-options: -Wall

3527 default-extensions: ConstraintKinds

3628 , DataKinds

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

6557 , TypeOperators

6658 , TypeSynonymInstances

6759 , UndecidableInstances

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

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

6961 , bytestring

7062 , aeson >= 1

7163 , containers

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

7567 , regex-tdfa

7668 , regex-tdfa-text

7769 , scientific

78− , singletons >= 2.4

70+ , singletons >= 2.2

7971 , smallcheck

8072 , tagged

8173 , template-haskell

8274 , text

8375 , union

8476 , unordered-containers

85− , validationt >= 0.2.1.0

77+ , validationt >= 0.1.0.1

8678 , vector

8779 , vinyl

8880 hs-source-dirs: src

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

9587 default-language: Haskell2010

9688 build-depends: HUnit

9789 , aeson >= 1

98− , base >=4.11 && <4.13

90+ , base >=4.9 && <4.11

9991 , bytestring

10092 , containers

10193 , hjsonschema

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

112104 , tagged

113105 , text

114106 , unordered-containers

115− , validationt >= 0.2.1.0

107+ , validationt >= 0.1.0.1

116108 , vinyl

117109 other-modules: SchemaSpec

118110 , HelpersSpec

119111 , LensSpec

120− , JsonSchemaSpec

112+ , JsonSchemaSpec

src/Data/Schematic.hs+23

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

3939import Data.Text as T

4040

4141

42+parseAndValidateJson

43+ :: forall schema

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

45+ => J.Value

46+ -> ParseResult (JsonRepr schema)

47+parseAndValidateJson v =

48+ case parseEither parseJSON v of

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

50+ Right jsonRepr ->

51+ let

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

53+ res = runIdentity . runValidationTEither $ validate

54+ in case res of

55+ Left em -> ValidationError em

56+ Right () -> Valid jsonRepr

57+

58+parseAndValidateJsonBy

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

60+ => proxy schema

61+ -> J.Value

62+ -> ParseResult (JsonRepr schema)

63+parseAndValidateJsonBy _ = parseAndValidateJson

64+

4265parseAndValidateTopVersionJson

4366 :: forall proxy (v :: Versioned)

4467 . (SingI (TopVersion (AllVersions v)))

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

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

11{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE CPP #-}

43module Data.Schematic.DSL where

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

1817import Data.Vinyl.Functor

1918

2019

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

2220type Constructor a

23− = forall fields b

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

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

26− -> JsonRepr ('SchemaObject fields)

27−#else

28−type Constructor a

29− = forall fields b

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

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

32− -> JsonRepr ('SchemaObject fields)

33−#endif

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

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

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

24+

3425withRepr :: Constructor a

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

3627

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

7566 FieldsOf ('SchemaObject fs) = fs

7667

7768type FieldConstructor fn =

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

79− => Repr byField

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

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

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

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

8172

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

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

44module Data.Schematic.Instances where

66import Data.Scientific

7−import Data.Text (Text, pack)

87import Data.Vector as V

98import Data.Vinyl

109import Test.SmallCheck.Series

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

2221

2322instance Monad m => Serial m Scientific where

2423 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

1212import Data.Aeson as J

1313import Data.Foldable as F

1414import Data.HashMap.Strict as H

15−import Data.List as L

1615import Data.List.NonEmpty as NE

1716import Data.Schematic.Schema as S

18−import Data.Set as Set

1917import Data.Singletons

2018import Data.Text

2119import Data.Traversable

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

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

3129 { _schemaMinLength = pure $ fromIntegral n

3230 , _schemaMaxLength = pure $ fromIntegral n }

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

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

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

3434 { _schemaMaxLength = pure . fromIntegral $ n }

35−textConstraint (DTLt n) =

35+textConstraint (DTGt n) =

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

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

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

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

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

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

4139 { _schemaMinLength = pure . fromIntegral $ n }

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

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

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

4947 { _schemaMaximum = pure . fromIntegral $ n }

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

51− { _schemaMaximum = pure . fromIntegral $ n

52− , _schemaExclusiveMaximum = pure True }

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

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

54− { _schemaMinimum = pure . fromIntegral $ n

55− , _schemaExclusiveMinimum = pure True }

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

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

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

5956 { _schemaMinimum = pure $ fromIntegral n

6057 , _schemaMaximum = pure $ fromIntegral n }

6158

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

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

64− { _schemaMaxItems = pure . fromIntegral $ n }

65−arrayConstraint (DALt n) =

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

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

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

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

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

71− { _schemaMinItems = pure . fromIntegral $ n }

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

73− { _schemaMinItems = pure $ fromIntegral n

74− , _schemaMaxItems = pure $ fromIntegral n }

60+arrayConstraint (DAEq _) = pure ()

7561

7662toJsonSchema

7763 :: forall proxy schema

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

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

9985 s' <- toJsonSchema' s

10086 pure (n, s')

101− let

102− nonOpt = \case

103− (_, DSchemaOptional _) -> False

104− _ -> True

10587 pure $ emptySchema

10688 { _schemaType = pure $ TypeValidatorString D4.SchemaObject

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

10889 , _schemaProperties = pure $ H.fromList res }

10990 DSchemaArray acs sch -> do

11091 res <- toJsonSchema' sch

11192 pure $ execState (traverse_ arrayConstraint acs) $ emptySchema

11293 { _schemaType = pure $ TypeValidatorString D4.SchemaArray

113− , _schemaItems = pure $ ItemsObject res }

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

11495 DSchemaNull -> pure $ emptySchema

11596 { _schemaType = pure $ TypeValidatorString D4.SchemaNull }

11697 DSchemaOptional sch -> do

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

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

1010 , FSubset(..)

1111 , obj

1212 , arr

13− , uni

14− , txt

15− , num

16− , opt

17− , bln

1813 , textRepr

1914 , numberRepr

2015 , boolRepr

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

2419 ) where

2520

2621import Data.Profunctor

22+import Data.Proxy

2723import Data.Schematic.Schema

2824import Data.Scientific

2925import Data.Singletons

3026import Data.Text

31−import Data.Union

3227import Data.Vector as V

3328import Data.Vinyl

3429import Data.Vinyl.Functor

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

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

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

4338

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−

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

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

5547

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

5853

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

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

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

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

6964

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

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

7166 {-# INLINE flens #-}

7267

73− fget = getConst . flens Const

68+ fget k = getConst . flens k Const

7469 {-# INLINE fget #-}

7570

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

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

7772 {-# INLINE fput #-}

7873

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

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

8176

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

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

8378 {-# INLINE flens #-}

8479

85− fget = getConst . flens Const

80+ fget k = getConst . flens k Const

8681 {-# INLINE fget #-}

8782

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

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

8984 {-# INLINE fput #-}

9085

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

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

149144 ( ByField fn ss i ~ s

150145 , FElem fn ss i

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

153148 where

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

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

156151

157152-- A bunch of @Iso@morphisms

158153textRepr

159− :: (KnownSymbol fn, SingI cs)

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

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

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

162157

163158numberRepr

164− :: (KnownSymbol fn, SingI cs)

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

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

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

167162

168163boolRepr

169− :: (KnownSymbol fn)

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

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

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

172167

173168arrayRepr

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

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

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

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

177172

178173objectRepr

179− :: (KnownSymbol fn, SingI fields)

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

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

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

182177

183178optionalRepr

184− :: (KnownSymbol fn, SingI schema)

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

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

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

187182

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

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

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

190185

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

186+arr

187+ :: (SingI schema)

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

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

11{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE CPP #-}

3−{-# LANGUAGE TemplateHaskell #-}

2+{-# LANGUAGE TemplateHaskell #-}

54module Data.Schematic.Migration where

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

87import Data.Schematic.DSL

98import Data.Schematic.Lens

109import Data.Schematic.Path

10+import Data.Tagged

1111import Data.Schematic.Schema

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

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

1313import Data.Singletons.TypeLits

14−import Data.Tagged

1514import Data.Vinyl

1615import Data.Vinyl.Functor

1716

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

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

4443

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

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

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

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

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

4847

4948type family UpdateKey

5049 (fn :: Symbol)

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

147146

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

149148

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

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

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

152151 (:&&)

153152 :: (TopLevel s, SingI s)

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

157156

158157infixr 7 :&&

159158

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

166159migrateObject

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

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

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

170−#endif

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

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

173165 pure $ withRepr @('SchemaObject fs) res

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

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

11module Data.Schematic.Path where

33import Data.Foldable as F

4+import Data.Monoid

5+import Data.Singletons

46import Data.Singletons.Prelude

57import Data.Singletons.TypeLits

68import Data.Text as T

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

2426 where

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

2628 go acc SNil = acc

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

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

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

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

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

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

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

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

3133

3234demotedPathToText :: [DemotedPathSegment] -> JSONPath

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

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

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

11{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE CPP #-}

3−{-# LANGUAGE OverloadedLists #-}

4−{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE OverloadedLists #-}

3+{-# LANGUAGE OverloadedStrings #-}

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

76module Data.Schematic.Schema where

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

1312import Data.HashMap.Strict as H

1413import Data.Kind

1514import Data.Maybe

16−import Data.Schematic.Generator

1715import Data.Schematic.Instances ()

1816import Data.Scientific

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

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

2624import qualified Data.Vinyl.TypeLevel as V

2725import GHC.Exts

2826import GHC.Generics (Generic)

29−import GHC.TypeLits

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

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

3128import Prelude as P

3229import Test.SmallCheck.Series

3330

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

5148instance SingKind TextConstraint where

5249 type Demote TextConstraint = DemotedTextConstraint

5350 fromSing = \case

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

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

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

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

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

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

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

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

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

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

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

6057 STEnum s -> let

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

62− d SNil = []

59+ d SNil = []

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

6461 in DTEnum $ d s

6562 toSing = \case

6663 DTEq n -> case someNatVal n of

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

68− Nothing -> error "Negative singleton nat"

65+ Nothing -> error "Negative singleton nat"

6966 DTLt n -> case someNatVal n of

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

71− Nothing -> error "Negative singleton nat"

68+ Nothing -> error "Negative singleton nat"

7269 DTLe n -> case someNatVal n of

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

74− Nothing -> error "Negative singleton nat"

71+ Nothing -> error "Negative singleton nat"

7572 DTGt n -> case someNatVal n of

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

77− Nothing -> error "Negative singleton nat"

74+ Nothing -> error "Negative singleton nat"

7875 DTGe n -> case someNatVal n of

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

80− Nothing -> error "Negative singleton nat"

77+ Nothing -> error "Negative singleton nat"

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

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

8380 DTEnum ss -> case toSing ss of

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

9188 | DTGe Integer

9289 | DTRegex Text

9390 | DTEnum [Text]

94− deriving (Generic, Eq, Show)

91+ deriving (Generic)

9592

9693data instance Sing (tc :: TextConstraint) where

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

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

132129 | DNGt Integer

133130 | DNGe Integer

134131 | DNEq Integer

135− deriving (Generic, Eq, Show)

132+ deriving (Generic)

136133

137134data instance Sing (nc :: NumberConstraint) where

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

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

156153instance SingKind NumberConstraint where

157154 type Demote NumberConstraint = DemotedNumberConstraint

158155 fromSing = \case

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

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

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

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

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

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

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

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

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

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

164161 toSing = \case

165162 DNEq n -> case someNatVal n of

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

167− Nothing -> error "Negative singleton nat"

164+ Nothing -> error "Negative singleton nat"

168165 DNGt n -> case someNatVal n of

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

170− Nothing -> error "Negative singleton nat"

167+ Nothing -> error "Negative singleton nat"

171168 DNGe n -> case someNatVal n of

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

173− Nothing -> error "Negative singleton nat"

170+ Nothing -> error "Negative singleton nat"

174171 DNLt n -> case someNatVal n of

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

176− Nothing -> error "Negative singleton nat"

173+ Nothing -> error "Negative singleton nat"

177174 DNLe n -> case someNatVal n of

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

179− Nothing -> error "Negative singleton nat"

176+ Nothing -> error "Negative singleton nat"

180177

181178data ArrayConstraint

182179 = AEq Nat

183− | AGt Nat

184− | AGe Nat

185− | ALt Nat

186− | ALe Nat

187180 deriving (Generic)

188181

189182data DemotedArrayConstraint

190183 = DAEq Integer

191− | DAGt Integer

192− | DAGe Integer

193− | DALt Integer

194− | DALe Integer

195− deriving (Generic, Eq, Show)

184+ deriving (Generic)

196185

197186data instance Sing (ac :: ArrayConstraint) where

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

203188

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

209190

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

215192

216193instance SingKind ArrayConstraint where

217194 type Demote ArrayConstraint = DemotedArrayConstraint

218195 fromSing = \case

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

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

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

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

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

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

224197 toSing = \case

225198 DAEq n -> case someNatVal n of

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

240201

241202data Schema

242203 = SchemaText [TextConstraint]

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

258219 | DSchemaNull

259220 | DSchemaOptional DemotedSchema

260221 | DSchemaUnion [DemotedSchema]

261− deriving (Generic, Eq, Show)

222+ deriving (Generic)

262223

263224data instance Sing (schema :: Schema) where

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

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

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

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

375336

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−

401337-- | Move to the union package

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

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

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

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

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

407343

408−instance Show (JsonRepr 'SchemaBoolean) where

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

410−

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

412345

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

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

415348

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

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

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

425−#endif

426351

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

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

429354

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

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

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

355+instance (Monad m, Serial m Text)

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

357+ series = cons1 ReprText

358+

359+instance (Monad m, Serial m Scientific)

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

361+ series = cons1 ReprNumber

362+

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

364+ series = cons0 ReprNull

365+

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

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

368+ series = cons1 ReprArray

369+

370+instance (Serial m (JsonRepr s))

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

372+ series = cons1 ReprOptional

373+

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

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

376+ series = cons1 ReprObject

433377

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

435379 ReprObject a == ReprObject b = a == b

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

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

441385 ReprNumber a == ReprNumber b = a == b

442386

443−instance Eq (JsonRepr 'SchemaBoolean) where

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

445−

446387instance Eq (JsonRepr 'SchemaNull) where

447388 ReprNull == ReprNull = True

448389

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

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

453394 ReprOptional a == ReprOptional b = a == b

454395

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−

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

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

486398 fromList = ReprArray . GHC.Exts.fromList

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

542454 fieldRepr <- case s of

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

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

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

457+ Nothing -> fail "schematext"

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

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

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

460+ Nothing -> fail "schemanumber"

549461 SSchemaBoolean -> case H.lookup fieldName h of

550462 Just v -> FieldRepr <$> parseJSON v

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

463+ Nothing -> fail "schemaboolean"

552464 SSchemaNull -> case H.lookup fieldName h of

553465 Just v -> FieldRepr <$> parseJSON v

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

466+ Nothing -> fail "schemanull"

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

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

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

469+ Nothing -> fail "schemaarray"

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

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

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

472+ Nothing -> fail "schemaobject"

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

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

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

475+ Nothing -> fail "schemaoptional"

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

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

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

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

572484 toJSON (ReprText t) = J.String t

573485 toJSON (ReprNumber n) = J.Number n

574486 toJSON (ReprOptional s) = case s of

575− Just v -> toJSON v

487+ Just v -> toJSON v

576488 Nothing -> J.Null

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

578490 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

33import Control.Monad

44import Control.Monad.Validation

5−import Data.Aeson

6−import Data.Aeson.Types

75import Data.Foldable

86import Data.Functor.Identity

97import Data.Monoid

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

3230 | ValidationError ErrorMap -- runtime

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

3432

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

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

37− parseJSON = pure . parseAndValidateJson @a

38−

3933isValid :: ParseResult a -> Bool

4034isValid (Valid _) = True

4135isValid _ = False

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

5852 let

5953 nlen = withKnownNat n $ natVal n

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

6256 warn = vWarning $ mmSingleton path (pure errMsg)

6357 unless predicate warn

6458 STLt n -> do

6559 let

6660 nlen = withKnownNat n $ natVal n

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

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

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

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

6963 warn = vWarning $ mmSingleton path (pure errMsg)

7064 unless predicate warn

7165 STLe n -> do

7266 let

7367 nlen = withKnownNat n $ natVal n

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

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

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

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

7670 warn = vWarning $ mmSingleton path (pure errMsg)

7771 unless predicate warn

7872 STGt n -> do

7973 let

8074 nlen = withKnownNat n $ natVal n

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

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

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

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

8377 warn = vWarning $ mmSingleton path (pure errMsg)

8478 unless predicate warn

8579 STGe n -> do

8680 let

8781 nlen = withKnownNat n $ natVal n

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

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

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

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

9084 warn = vWarning $ mmSingleton path (pure errMsg)

9185 unless predicate warn

9286 STRegex r -> do

9387 let

9488 regex = withKnownSymbol r $ fromSing r

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

96− errMsg = "must match " <> regex

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

9791 warn = vWarning $ mmSingleton path (pure errMsg)

9892 unless predicate warn

9993 STEnum ss -> do

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

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

10296 matching SNil = False

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

10599 warn = vWarning $ mmSingleton path (pure errMsg)

106100 unless (matching ss) warn

107101

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

115109 let

116110 nlen = withKnownNat n $ natVal n

117111 predicate = fromIntegral nlen == num

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

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

119113 warn = vWarning $ mmSingleton path (pure errMsg)

120114 unless predicate warn

121115 SNGt n -> do

122116 let

123117 nlen = withKnownNat n $ natVal n

124118 predicate = num > fromIntegral nlen

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

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

126120 warn = vWarning $ mmSingleton path (pure errMsg)

127121 unless predicate warn

128122 SNGe n -> do

129123 let

130124 nlen = withKnownNat n $ natVal n

131125 predicate = num >= fromIntegral nlen

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

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

133127 warn = vWarning $ mmSingleton path (pure errMsg)

134128 unless predicate warn

135129 SNLt n -> do

136130 let

137131 nlen = withKnownNat n $ natVal n

138− predicate = num < fromIntegral nlen

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

132+ predicate = fromIntegral nlen < num

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

140134 warn = vWarning $ mmSingleton path (pure errMsg)

141135 unless predicate warn

142136 SNLe n -> do

143137 let

144138 nlen = withKnownNat n $ natVal n

145− predicate = num <= fromIntegral nlen

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

139+ predicate = fromIntegral nlen <= num

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

147141 warn = vWarning $ mmSingleton path (pure errMsg)

148142 unless predicate warn

149143

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

157151 let

158152 nlen = withKnownNat n $ natVal n

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

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)

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

189155 warn = vWarning $ mmSingleton path (pure errMsg)

190156 unless predicate warn

191157

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

280246

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

282248umatch' _ 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+

224extra-deps:

3− - hjsonpointer-1.4.0@rev:0

4− - hjsonschema-1.9.0@rev:0

5− - validationt-0.2.1.0

25+- hjsonpointer-1.3.0

26+- hjsonschema-1.7.0

27+- validationt-0.2.0.0

28+

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

30+flags: {}

31+

32+# Extra package databases containing global packages

33+extra-package-dbs: []

34+

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

36+# system-ghc: true

37+#

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

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

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

41+#

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

43+# arch: i386

44+# arch: x86_64

45+#

46+# Extra directories used by stack for building

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

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

49+#

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

51+# compiler-check: newer-minor

test/JsonSchemaSpec.hs−58

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

1010import Data.Aeson as J

1111import Data.Maybe

1212import Data.Proxy

13−import Data.ByteString.Lazy as B

1413import Data.Schematic

1514import Data.Vinyl

1615import JSONSchema.Draft4 as D4

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

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

3332 :& RNil

3433

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−

5634spec :: Spec

5735spec = do

5836 it "validates simple schema" $ do

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

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

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

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

9941

10042main :: IO ()

10143main = hspec spec

test/LensSpec.hs+4−4

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

303303 newFooVal = FieldRepr $ ReprArray [ReprNumber 15]

304304 fooProxy = Proxy @"foo"

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

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

306+ fget fooProxy objectData `shouldBe` arrayField

307307 it "sets the object field" $ do

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

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

309309

310310 describe "(using lens library) " $ do

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

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

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

313313 it "sets the object field" $ do

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

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

315315 `shouldBe` newFooVal

316316

317317main :: IO ()

test/SchemaSpec.hs−24

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

1717import Data.Functor.Identity

1818import Data.Proxy

1919import Data.Schematic

20−import Data.Schematic.Generator

21−import Data.Singletons

2220import Data.Tagged

2321import Data.Vinyl

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

2923

30−import Debug.Trace

3124

3225type SchemaExample = 'SchemaObject

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

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

3528

36−type SchemaExample2 = 'SchemaObject

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

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

39−

4029jsonExample :: JsonRepr SchemaExample

4130jsonExample = withRepr @SchemaExample

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

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

8069schemaJson2 :: ByteString

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

8271

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−

8972spec :: Spec

9073spec = do

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

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

11093 migrationList

11194 schemaJson

11295 `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−

12096

12197main :: IO ()

12298main = hspec spec