0a19087 · typeable/schematic

git.iko.soy/typeable/schematic

on master help sign in

Add: validation for Union

0a19087Dmitry Olshansky8 years ago

src/Data/Schematic/Validation.hs+9−42

compare with master

unifiedsplit

@@ -17,7 +17,6 @@ import Data.Traversable

17import Data.Union

18import Data.Vector as V

19import Data.Vinyl

20−import Data.Vinyl.TypeLevel

21import Prelude as P

20import Prelude as P

22import Text.Regex.TDFA

21import Text.Regex.TDFA

@@ -38,7 +37,7 @@ instance (TopLevel a, SingI a, FromJSON (JsonRepr a))

39isValid :: ParseResult a -> Bool

38isValid :: ParseResult a -> Bool

40isValid (Valid _) = True

39isValid (Valid _) = True

41−isValid _ = False

40+isValid _ = False

43isDecodingError :: ParseResult a -> Bool

42isDecodingError :: ParseResult a -> Bool

44isDecodingError (DecodingError _) = True

43isDecodingError (DecodingError _) = True

@@ -212,46 +211,14 @@ validateJsonRepr sschema dpath jr = case jr of

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

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

213 validateJsonRepr (knownFieldSchema f) newPath d

212 validateJsonRepr (knownFieldSchema f) newPath d

214 go ftl

213 go ftl

215− ReprUnion _ -> pure () -- FIXME

216− -- case sschema of

214+ ReprUnion ru -> case sschema of

217− -- SSchemaUnion ss -> case ss of

215+ SSchemaUnion su -> validateUnion su ru

218− -- SCons s stl -> case umatch' s u of

216+ where

219− -- Nothing -> case urestrict u of

217+ validateUnion :: Sing us -> Union JsonRepr us -> Validation ()

220− -- Nothing ->

218+ validateUnion ss r = case (ss,r) of

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

219+ (SCons s _, This v) -> validateJsonRepr s dpath v

222− -- Just x -> do

220+ (SCons _ stl, That r') -> validateUnion stl r'

223− -- let

221+ (SNil,_) -> fail "Invalid union. Please report this as a bug"

224− -- JSONPath path = demotedPathToText dpath

225− -- case stl of

226− -- SNil -> void $ vWarning $ mmSingleton path

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

228− -- SCons s' stl' ->

229− -- validateJsonRepr (SSchemaUnion (SCons s' stl')) dpath

230− -- $ toUnion (SCons s' stl') x

231− -- Just x -> validateJsonRepr s dpath x

232−

233−-- subUnion

234−-- :: Sing (s ': stl)

235−-- -> ( USubset stl (s ': stl) (RImage stl (s ': stl))

236−-- => Union f (s ': stl)

237−-- -> Maybe (Union f stl) )

238−-- subUnion (SCons s stl) = urestrict

239−

240−-- withUSubset

241−-- :: Sing (s ': stl)

242−-- -> (USubset stl (s ': stl) (RImage stl (s ': stl)) => Maybe (Union f stl))

243−-- -> Maybe (Union f stl)

244−-- withUSubset (SCons s stl) r = r

245−

246−toUnion

247− :: USubset s' (s ': ss) (RImage s' (s ': ss))

248− => Sing (s ': ss)

249− -> Union JsonRepr s'

250− -> JsonRepr ('SchemaUnion (s ': ss))

251−toUnion _ = ReprUnion . urelax

252−

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

254−umatch' _ u = umatch u

255

222

256parseAndValidateJson

223parseAndValidateJson

257 :: forall schema

224 :: forall schema

test/HelpersSpec.hs+4−4

@@ -1,17 +1,17 @@

1{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}

3−{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE LambdaCase #-}

5−{-# LANGUAGE DataKinds #-}

5+{-# LANGUAGE DataKinds #-}

6−{-# LANGUAGE TypeApplications #-}

7{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE OverloadedStrings #-}

7+{-# LANGUAGE TypeApplications #-}

9module HelpersSpec (spec, main) where

11import Control.Lens

12import Data.ByteString.Lazy.Lens

13import Data.Foldable

14−import Data.Monoid

14+import Data.Monoid ((<>))

15import Data.Schematic

16import Data.Text as T

17import Data.Text.Lens

test/LensSpec.hs+3−5

@@ -1,12 +1,11 @@

1−{-# LANGUAGE DataKinds #-}

1+{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE TypeApplications #-}

3−{-# LANGUAGE OverloadedLists #-}

2+{-# LANGUAGE OverloadedLists #-}

4{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE TypeApplications #-}

6module LensSpec (spec, main) where

8import Control.Lens

9−import Data.Proxy

10import Data.Schematic

9import Data.Schematic

11import Data.Vinyl

10import Data.Vinyl

12import Test.Hspec

11import Test.Hspec

@@ -301,7 +300,6 @@ spec :: Spec

301spec = do

300spec = do

302 let

301 let

303 newFooVal = FieldRepr $ ReprArray [ReprNumber 15]

302 newFooVal = FieldRepr $ ReprArray [ReprNumber 15]

304− fooProxy = Proxy @"foo"

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

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

306 fget @"foo" objectData `shouldBe` arrayField

304 fget @"foo" objectData `shouldBe` arrayField

307 it "sets the object field" $ do

305 it "sets the object field" $ do

test/SchemaSpec.hs+23−15

@@ -1,33 +1,28 @@

1+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}

1{-# OPTIONS_GHC -fprint-potential-instances #-}

2{-# OPTIONS_GHC -fprint-potential-instances #-}

3−{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE GADTs #-}

6−{-# LANGUAGE OverloadedLists #-}

7+{-# LANGUAGE OverloadedLists #-}

7−{-# LANGUAGE OverloadedStrings #-}

8+{-# LANGUAGE OverloadedStrings #-}

8−{-# LANGUAGE RankNTypes #-}

9+{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE ScopedTypeVariables #-}

10−{-# LANGUAGE TypeApplications #-}

11+{-# LANGUAGE TypeApplications #-}

12module SchemaSpec (spec, main) where

13module SchemaSpec (spec, main) where

14import Control.Lens

15import Control.Lens

15import Data.Aeson

16import Data.Aeson

16import Data.ByteString.Lazy

17import Data.ByteString.Lazy

17−import Data.Functor.Identity

18import Data.Proxy

19import Data.Schematic

20−import Data.Schematic.Generator

21−import Data.Singletons

22−import Data.Tagged

23import Data.Vinyl

20import Data.Vinyl

24import Test.Hspec

21import Test.Hspec

25import Test.Hspec.SmallCheck

22import Test.Hspec.SmallCheck

26import Test.SmallCheck as SC

23import Test.SmallCheck as SC

27−import Test.SmallCheck.Drivers as SC

28import Test.SmallCheck.Series as SC

24import Test.SmallCheck.Series as SC

30−import Debug.Trace

32type SchemaExample = 'SchemaObject

27type SchemaExample = 'SchemaObject

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

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

@@ -37,6 +32,13 @@ type SchemaExample2 = 'SchemaObject

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

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

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

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

35+type SchemaExample3 = 'SchemaUnion '[SchemaExample]

36+

37+type SchemaExample4 = 'SchemaObject

38+ '[ '("baz3", SchemaExample3)

39+ , '("baz1", SchemaExample)]

40+

41+

40jsonExample :: JsonRepr SchemaExample

42jsonExample :: JsonRepr SchemaExample

41jsonExample = withRepr @SchemaExample

43jsonExample = withRepr @SchemaExample

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

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

@@ -45,7 +47,7 @@ jsonExample = withRepr @SchemaExample

46type AddQuuz =

48type AddQuuz =

47 'Migration "add_field_quuz"

49 'Migration "add_field_quuz"

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

50+ '[ 'Diff '[] ('AddKey "quuz" ('SchemaNumber '[])) ]

50type DeleteQuuz =

52type DeleteQuuz =

51 'Migration "remove_field_quuz"

53 'Migration "remove_field_quuz"

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

80schemaJson2 :: ByteString

82schemaJson2 :: ByteString

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

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

85+schemaJson3 :: ByteString

86+schemaJson3 = schemaJson

87+

88+schemaJson4 :: ByteString

89+schemaJson4 = "{\"baz1\": "<>schemaJson<>", \"baz3\": "<>schemaJson3<>"}"

90+

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

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

84schemaJsonSeries = series

92schemaJsonSeries = series

@@ -93,7 +101,7 @@ spec = do

93 it "decode/encode JsonRepr properly" $

101 it "decode/encode JsonRepr properly" $

94 decode (encode jsonExample) == Just jsonExample

102 decode (encode jsonExample) == Just jsonExample

95 it "validates correct representation" $

103 it "validates correct representation" $

96− ((decodeAndValidateJson schemaJson) :: ParseResult (JsonRepr SchemaExample))

104+ ((decodeAndValidateJson schemaJson4) :: ParseResult (JsonRepr SchemaExample4))

97 `shouldSatisfy` isValid

105 `shouldSatisfy` isValid

98 it "returns decoding error on structurally incorrect input" $

106 it "returns decoding error on structurally incorrect input" $

99 ((decodeAndValidateJson "{}") :: ParseResult (JsonRepr SchemaExample))

107 ((decodeAndValidateJson "{}") :: ParseResult (JsonRepr SchemaExample))