master...0a19087 · typeable/schematic

git.iko.soy/typeable/schematic

on 0a19087 help sign in

4 files changed+39−66

since splitsnapshots

unifiedsplit

src/Data/Schematic/Validation.hs+9−42 test/HelpersSpec.hs+4−4 test/LensSpec.hs+3−5 test/SchemaSpec.hs+23−15

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

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

1717import Data.Union

1818import Data.Vector as V

1919import Data.Vinyl

20−import Data.Vinyl.TypeLevel

2120import Prelude as P

2221import Text.Regex.TDFA

2322

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

3837

3938isValid :: ParseResult a -> Bool

4039isValid (Valid _) = True

41−isValid _ = False

40+isValid _ = False

4241

4342isDecodingError :: ParseResult a -> Bool

4443isDecodingError (DecodingError _) = True

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

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

213212 validateJsonRepr (knownFieldSchema f) newPath d

214213 go ftl

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

216− -- case sschema of

217− -- SSchemaUnion ss -> case ss of

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

219− -- Nothing -> case urestrict u of

220− -- Nothing ->

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

222− -- Just x -> do

223− -- let

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

214+ ReprUnion ru -> case sschema of

215+ SSchemaUnion su -> validateUnion su ru

216+ where

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

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

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

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

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

255222

256223parseAndValidateJson

257224 :: forall schema

test/HelpersSpec.hs+4−4

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

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

3−{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE LambdaCase #-}

5−{-# LANGUAGE DataKinds #-}

6−{-# LANGUAGE TypeApplications #-}

5+{-# LANGUAGE DataKinds #-}

76{-# LANGUAGE OverloadedStrings #-}

7+{-# LANGUAGE TypeApplications #-}

99module HelpersSpec (spec, main) where

1010

1111import Control.Lens

1212import Data.ByteString.Lazy.Lens

1313import Data.Foldable

14−import Data.Monoid

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

1515import Data.Schematic

1616import Data.Text as T

1717import Data.Text.Lens

test/LensSpec.hs+3−5

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

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE TypeApplications #-}

3−{-# LANGUAGE OverloadedLists #-}

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE OverloadedLists #-}

43{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE TypeApplications #-}

66module LensSpec (spec, main) where

88import Control.Lens

9−import Data.Proxy

109import Data.Schematic

1110import Data.Vinyl

1211import Test.Hspec

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

301300spec = do

302301 let

303302 newFooVal = FieldRepr $ ReprArray [ReprNumber 15]

304− fooProxy = Proxy @"foo"

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

306304 fget @"foo" objectData `shouldBe` arrayField

307305 it "sets the object field" $ do

test/SchemaSpec.hs+23−15

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

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

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

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE GADTs #-}

6−{-# LANGUAGE OverloadedLists #-}

7−{-# LANGUAGE OverloadedStrings #-}

8−{-# LANGUAGE RankNTypes #-}

4+{-# LANGUAGE DataKinds #-}

5+{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE OverloadedLists #-}

8+{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE RankNTypes #-}

910{-# LANGUAGE ScopedTypeVariables #-}

10−{-# LANGUAGE TypeApplications #-}

11+{-# LANGUAGE TypeApplications #-}

1112

1213module SchemaSpec (spec, main) where

1314

1415import Control.Lens

1516import Data.Aeson

1617import Data.ByteString.Lazy

17−import Data.Functor.Identity

1818import Data.Proxy

1919import Data.Schematic

20−import Data.Schematic.Generator

21−import Data.Singletons

22−import Data.Tagged

2320import Data.Vinyl

2421import Test.Hspec

2522import Test.Hspec.SmallCheck

2623import Test.SmallCheck as SC

27−import Test.SmallCheck.Drivers as SC

2824import Test.SmallCheck.Series as SC

2925

30−import Debug.Trace

3126

3227type SchemaExample = 'SchemaObject

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

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

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

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

3934

35+type SchemaExample3 = 'SchemaUnion '[SchemaExample]

36+

37+type SchemaExample4 = 'SchemaObject

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

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

40+

41+

4042jsonExample :: JsonRepr SchemaExample

4143jsonExample = withRepr @SchemaExample

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

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

4547

4648type AddQuuz =

4749 'Migration "add_field_quuz"

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

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

4951

5052type DeleteQuuz =

5153 'Migration "remove_field_quuz"

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

8082schemaJson2 :: ByteString

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

8284

85+schemaJson3 :: ByteString

86+schemaJson3 = schemaJson

87+

88+schemaJson4 :: ByteString

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

90+

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

8492schemaJsonSeries = series

8593

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

93101 it "decode/encode JsonRepr properly" $

94102 decode (encode jsonExample) == Just jsonExample

95103 it "validates correct representation" $

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

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

97105 `shouldSatisfy` isValid

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

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