9accf73 · typeable/schematic

git.iko.soy/typeable/schematic

an attempt WIP

commit9accf73d19d9556b3abbcf52cda767af5fda5a9d authorDenis Redozubov <denis.redozubov@gmail.com> dateFri 6 Oct 2017, 16:32 (9 years ago) parentb98c6e1

5 files changed+91−30

compare with master

unifiedsplit

schematic.cabal+1 src/Data/Schematic/JsonSchema.hs+33−20 src/Data/Schematic/Schema.hs+46−8 src/Data/Schematic/Validation.hs+9−1 test/JsonSchemaSpec.hs+2−1

schematic.cabal+1

@@ -71,6 +71,7 @@ library

7171 , smallcheck

7272 , tagged

7373 , text

74+ , union

7475 , unordered-containers

7576 , validationt >= 0.1.0.1

7677 , vector

src/Data/Schematic/JsonSchema.hs+33−20

@@ -16,6 +16,7 @@ import Data.List.NonEmpty as NE

1616import Data.Schematic.Schema as S

1717import Data.Singletons

1818import Data.Text

19+import Data.Traversable

1920import JSONSchema.Draft4.Schema as D4

2021import JSONSchema.Validator.Draft4 as D4

2122

@@ -62,31 +63,43 @@ toJsonSchema

6263 :: forall proxy schema

6364 . SingI schema

6465 => proxy (schema :: S.Schema)

65− -> D4.Schema

66−toJsonSchema _ = (toJsonSchema' $ fromSing (sing :: Sing schema))

67− { _schemaVersion = pure draft4 }

66+ -> Maybe D4.Schema

67+toJsonSchema _ = do

68+ js <- toJsonSchema' $ fromSing (sing :: Sing schema)

69+ pure $ js { _schemaVersion = pure draft4 }

6870

6971toJsonSchema'

7072 :: DemotedSchema

71− -> D4.Schema

73+ -> Maybe D4.Schema

7274toJsonSchema' = \case

7375 DSchemaText tcs ->

74− execState (traverse_ textConstraint tcs) $ emptySchema

76+ pure $ execState (traverse_ textConstraint tcs) $ emptySchema

7577 { _schemaType = pure $ TypeValidatorString D4.SchemaString }

7678 DSchemaNumber ncs ->

77− execState (traverse_ numberConstraint ncs) $ emptySchema

79+ pure $ execState (traverse_ numberConstraint ncs) $ emptySchema

7880 { _schemaType = pure $ TypeValidatorString D4.SchemaNumber }

79− DSchemaBoolean -> emptySchema

80− { _schemaType = pure $ TypeValidatorString D4.SchemaBoolean }

81− DSchemaObject objs -> emptySchema

82− { _schemaType = pure $ TypeValidatorString D4.SchemaObject

83− , _schemaProperties = pure $ H.fromList $ (\(n,s) -> (n, toJsonSchema' s))

84− <$> objs }

85− DSchemaArray acs sch ->

86− execState (traverse_ arrayConstraint acs) $ emptySchema

87− { _schemaType = pure $ TypeValidatorString D4.SchemaArray

88− , _schemaItems = pure $ ItemsArray [toJsonSchema' sch] }

89− DSchemaNull -> emptySchema

90− { _schemaType = pure $ TypeValidatorString D4.SchemaNull }

91− DSchemaOptional sch -> emptySchema

92− { _schemaOneOf = pure $ toJsonSchema' DSchemaNull :| [toJsonSchema' sch] }

81+ DSchemaBoolean -> pure $ emptySchema

82+ { _schemaType = pure $ TypeValidatorString D4.SchemaBoolean }

83+ DSchemaObject objs -> do

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

85+ s' <- toJsonSchema' s

86+ pure (n, s')

87+ pure $ emptySchema

88+ { _schemaType = pure $ TypeValidatorString D4.SchemaObject

89+ , _schemaProperties = pure $ H.fromList res }

90+ DSchemaArray acs sch -> do

91+ res <- toJsonSchema' sch

92+ pure $ execState (traverse_ arrayConstraint acs) $ emptySchema

93+ { _schemaType = pure $ TypeValidatorString D4.SchemaArray

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

95+ DSchemaNull -> pure $ emptySchema

96+ { _schemaType = pure $ TypeValidatorString D4.SchemaNull }

97+ DSchemaOptional sch -> do

98+ snull <- toJsonSchema' DSchemaNull

99+ sres <- toJsonSchema' sch

100+ pure $ emptySchema { _schemaOneOf = pure (snull :| [sres]) }

101+ DSchemaUnion sch -> do

102+ schemaUnion <- traverse toJsonSchema' sch >>= \case

103+ [] -> Nothing

104+ x -> Just x

105+ pure $ emptySchema { _schemaAnyOf = pure $ NE.fromList schemaUnion }

src/Data/Schematic/Schema.hs+46−8

@@ -5,7 +5,7 @@

66module Data.Schematic.Schema where

8−import Control.Applicative ()

8+import Control.Applicative ((<|>))

99import Control.Monad

1010import Data.Aeson as J

1111import Data.Aeson.Types as J

@@ -14,10 +14,11 @@ import Data.Kind

1414import Data.Maybe

1515import Data.Schematic.Instances ()

1616import Data.Scientific

17−import Data.Singletons.Prelude.List hiding (All)

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

1818import Data.Singletons.TH

1919import Data.Singletons.TypeLits

2020import Data.Text as T

21+import Data.Union

2122import Data.Vector as V

2223import Data.Vinyl hiding (Dict)

2324import qualified Data.Vinyl.TypeLevel as V

@@ -205,6 +206,7 @@ data Schema

205206 | SchemaArray [ArrayConstraint] Schema

206207 | SchemaNull

207208 | SchemaOptional Schema

209+ | SchemaUnion [Schema]

208210 deriving (Generic)

209211

210212data DemotedSchema

@@ -215,6 +217,7 @@ data DemotedSchema

215217 | DSchemaArray [DemotedArrayConstraint] DemotedSchema

216218 | DSchemaNull

217219 | DSchemaOptional DemotedSchema

220+ | DSchemaUnion [DemotedSchema]

218221 deriving (Generic)

219222

220223data instance Sing (schema :: Schema) where

@@ -225,6 +228,7 @@ data instance Sing (schema :: Schema) where

225228 SSchemaObject :: Sing fields -> Sing ('SchemaObject fields)

226229 SSchemaOptional :: Sing s -> Sing ('SchemaOptional s)

227230 SSchemaNull :: Sing 'SchemaNull

231+ SSchemaUnion :: Sing ss -> Sing ('SchemaUnion ss)

228232

229233instance SingI sl => SingI ('SchemaText sl) where

230234 sing = SSchemaText sing

@@ -240,6 +244,8 @@ instance SingI stl => SingI ('SchemaObject stl) where

240244 sing = SSchemaObject sing

241245instance SingI s => SingI ('SchemaOptional s) where

242246 sing = SSchemaOptional sing

247+instance SingI s => SingI ('SchemaUnion s) where

248+ sing = SSchemaUnion sing

243249

244250instance Eq (Sing ('SchemaText cs)) where _ == _ = True

245251instance Eq (Sing ('SchemaNumber cs)) where _ == _ = True

@@ -248,6 +254,7 @@ instance Eq (Sing 'SchemaBoolean) where _ == _ = True

248254instance Eq (Sing ('SchemaArray as s)) where _ == _ = True

249255instance Eq (Sing ('SchemaObject cs)) where _ == _ = True

250256instance Eq (Sing ('SchemaOptional s)) where _ == _ = True

257+instance Eq (Sing ('SchemaUnion s)) where _ == _ = True

251258

252259instance SingKind Schema where

253260 type Demote Schema = DemotedSchema

@@ -258,12 +265,8 @@ instance SingKind Schema where

258265 SSchemaArray cs s -> DSchemaArray (fromSing cs) (fromSing s)

259266 SSchemaOptional s -> DSchemaOptional $ fromSing s

260267 SSchemaNull -> DSchemaNull

261− SSchemaObject cs -> let

262− dem :: Sing (s :: [(Symbol, Schema)]) -> [(Text, DemotedSchema)]

263− dem SNil = []

264− dem (SCons (STuple2 ss ssch) fs) = withKnownSymbol ss

265− $ (T.pack (symbolVal ss), fromSing ssch) : dem fs

266− in DSchemaObject $ dem cs

268+ SSchemaObject cs -> DSchemaObject $ fromSing cs

269+ SSchemaUnion ss -> DSchemaUnion $ fromSing ss

267270 toSing = \case

268271 DSchemaText cs -> case toSing cs of

269272 SomeSing scs -> SomeSing $ SSchemaText scs

@@ -277,6 +280,8 @@ instance SingKind Schema where

277280 DSchemaNull -> SomeSing SSchemaNull

278281 DSchemaObject cs -> case toSing cs of

279282 SomeSing scs -> SomeSing $ SSchemaObject scs

283+ DSchemaUnion ss -> case toSing ss of

284+ SomeSing sss -> SomeSing $ SSchemaUnion sss

280285

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

282287 FieldRepr

@@ -322,6 +327,16 @@ data JsonRepr :: Schema -> Type where

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

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

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

330+ ReprUnion :: Union JsonRepr s -> JsonRepr ('SchemaUnion ss)

331+

332+-- | Move to the different package

333+type family UnionAll (f :: u -> *) (rs :: [u]) (c :: * -> Constraint) :: Constraint where

334+ UnionAll f '[] c = ()

335+ UnionAll f (r ': rs) c = (c (f r), UnionAll f rs c)

336+

337+-- instance (UnionAll f as Show) => Show (Union f as) where

338+-- show (This fa) = "This " P.++ show fa

339+-- show (That u) = "That " P.++ show u

325340

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

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

@@ -340,6 +355,8 @@ instance V.RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where

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

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

342357

358+deriving instance UnionAll f as Show => Show (Union f as)

359+

343360instance (Monad m, Serial m Text)

344361 => Serial m (JsonRepr ('SchemaText cs)) where

345362 series = cons1 ReprText

@@ -388,6 +405,24 @@ fromOptional

388405 -> Parser (Maybe (JsonRepr s))

389406fromOptional _ = parseJSON

390407

408+parseUnion

409+ :: FromJSON (JsonRepr ('SchemaUnion ss))

410+ => sing (ss :: [Schema])

411+ -> Value

412+ -> Parser (JsonRepr ('SchemaUnion ss))

413+parseUnion _ val = parseJSON val

414+

415+instance FromJSON (Union JsonRepr '[]) where

416+ parseJSON = fail "empty union"

417+

418+instance (SingI a, FromJSON (Union JsonRepr as)) => FromJSON (Union JsonRepr (a ': as)) where

419+ parseJSON val = (This <$> parseJSON val)

420+ <|> (That <$> (parseJSON val :: Parser (Union JsonRepr as)))

421+

422+instance ToJSON (Union JsonRepr as) where

423+ toJSON (This fa) = toJSON fa

424+ toJSON (That u) = toJSON u

425+

391426instance SingI schema => J.FromJSON (JsonRepr schema) where

392427 parseJSON value = case sing :: Sing schema of

393428 SSchemaText _ -> withText "String" (pure . ReprText) value

@@ -427,8 +462,10 @@ instance SingI schema => J.FromJSON (JsonRepr schema) where

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

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

429464 Nothing -> fail "schemaoptional"

465+ SSchemaUnion ss -> withSingI ss $ FieldRepr <$> parseUnion ss value

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

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

468+ SSchemaUnion ss -> parseUnion ss value

432469

433470instance J.ToJSON (JsonRepr a) where

434471 toJSON ReprNull = J.Null

@@ -449,6 +486,7 @@ instance J.ToJSON (JsonRepr a) where

449486 fold = \case

450487 RNil -> []

451488 fr@(FieldRepr _) :& tl -> (extract fr) : fold tl

489+ toJSON (ReprUnion u) = toJSON u

452490

453491class FalseConstraint a

454492

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

@@ -13,6 +13,7 @@ import Data.Singletons.Prelude

1313import Data.Singletons.TypeLits

1414import Data.Text as T

1515import Data.Traversable

16+import Data.Union

1617import Data.Vector as V

1718import Data.Vinyl

1819import Prelude as P

@@ -199,9 +200,16 @@ validateJsonRepr sschema dpath jr = case jr of

199200 ReprObject fs -> case sschema of

200201 SSchemaObject _ -> go fs

201202 where

202− go :: Rec FieldRepr (ts :: [ (Symbol, Schema) ] ) -> Validation ()

203+ go :: Rec FieldRepr (ts :: [(Symbol, Schema)] ) -> Validation ()

203204 go RNil = pure ()

204205 go (f@(FieldRepr d) :& ftl) = do

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

206207 validateJsonRepr (knownFieldSchema f) newPath d

207208 go ftl

209+ ReprUnion u -> case sschema of

210+ SSchemaUnion ss -> case ss of

211+ SNil -> vWarning $ mmSingleton (demotedPathToText dpath)

212+ $ pure "union handling error, please report this as bug"

213+ SCons s stl -> case u of

214+ This x -> validateJsonRepr s dpath x

215+ That u' -> validateJsonRepr (SSchemaUnion ss) dpath (ReprUnion u')

test/JsonSchemaSpec.hs+2−1

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

11module JsonSchemaSpec (spec, main) where

33import Data.Aeson as J

4+import Data.Maybe

45import Data.Proxy

56import Data.Schematic

67import Data.Vinyl

@@ -34,7 +35,7 @@ exampleData = ReprObject objectData

3435spec :: Spec

3536spec = do

3637 it "validates simple schema" $ do

37− let schema = D4.SchemaWithURI (toJsonSchema (Proxy @SchemaExample)) Nothing

38+ let schema = D4.SchemaWithURI (fromJust $ toJsonSchema (Proxy @SchemaExample)) Nothing

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

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

4041 Right _ -> pure ()