git.iko.soy/typeable/schematic
on ae6719f help sign in
typeable/schematic/test/SchemaSpec.hs
112 lines 3.5 kB history raw
1{-# OPTIONS_GHC -fprint-potential-instances #-}
3{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE GADTs #-}
6{-# LANGUAGE OverloadedLists #-}
7{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE TypeApplications #-}
12module SchemaSpec (spec, main) where
14import Control.Lens
15import Data.Aeson
16import Data.ByteString.Lazy
17import Data.Functor.Identity
18import Data.Proxy
19import Data.Schematic
20import Data.Schematic.Generator
21import Data.Singletons
22import Data.Tagged
23import Data.Vinyl
24import Test.Hspec
25import Test.Hspec.SmallCheck
26import Test.SmallCheck as SC
27import Test.SmallCheck.Drivers as SC
28import Test.SmallCheck.Series as SC
30import Debug.Trace
32type SchemaExample = 'SchemaObject
33 '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]))
34 , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]
36jsonExample :: JsonRepr SchemaExample
37jsonExample = withRepr @SchemaExample
38 $ field @"bar" (Just "bar")
39 :& field @"foo" [12]
40 :& RNil
42type AddQuuz =
43 'Migration "add_field_quuz"
44 '[ 'Diff '[] ('AddKey "quuz" (SchemaNumber '[])) ]
46type DeleteQuuz =
47 'Migration "remove_field_quuz"
48 '[ 'Diff '[] ( 'DeleteKey "quuz") ]
50type SwapFields =
51 'Migration "swap_fields"
52 '[ 'Diff '[ 'PKey "bar" ] ('Update
53 ('SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10])))
54 , 'Diff '[ 'PKey "foo" ] ('Update
55 ('SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))) ]
57type Migrations = '[ AddQuuz
58 , DeleteQuuz ]
59 -- , SwapFields ]
61type VersionedJson = 'Versioned SchemaExample Migrations
63migrationList :: MigrationList Identity VersionedJson
64migrationList
65 = (migrateObject (\r -> Identity $ field @"quuz" 42 :& r))
66 :&& shrinkObject
67 -- :&& (migrateObject (\r -> Identity
68 -- $ field @"foo" (r ^. flens (Proxy @"bar") . _Just . optionalRepr)
69 -- :& field @"bar" (r ^. flens (Proxy @"foo") . arrayRepr)
70 -- :& RNil))
71 :&& MNil
73schemaJson :: ByteString
74schemaJson = "{\"foo\": [13], \"bar\": null}"
76schemaJson2 :: ByteString
77schemaJson2 = "{\"foo\": [3], \"bar\": null}"
79schemaJsonSeries :: Monad m => SC.Series m Value
80schemaJsonSeries = valueSeries $ fromSing (sing :: Sing SchemaExample)
82spec :: Spec
83spec = do
84 -- it "show/read JsonRepr properly" $
85 -- read (show example) == example
86 it "decode/encode JsonRepr properly" $
87 decode (encode jsonExample) == Just jsonExample
88 it "validates correct representation" $
89 ((decodeAndValidateJson schemaJson) :: ParseResult (JsonRepr SchemaExample))
90 `shouldSatisfy` isValid
91 it "returns decoding error on structurally incorrect input" $
92 ((decodeAndValidateJson "{}") :: ParseResult (JsonRepr SchemaExample))
93 `shouldSatisfy` isDecodingError
94 it "validates incorrect representation" $
95 ((decodeAndValidateJson schemaJson2) :: ParseResult (JsonRepr SchemaExample))
96 `shouldSatisfy` isValidationError
97 -- it "validates versioned json" $ do
98 -- decodeAndValidateVersionedJson (Proxy @VS) schemaJson
99 -- `shouldSatisfy` isValid
100 it "validates versioned json with a migration list" $ do
101 decodeAndValidateVersionedWithPureMList
102 (Proxy @VersionedJson)
103 migrationList
104 schemaJson
105 `shouldSatisfy` isValid
106 it "validates json series" $ property $
107 SC.over schemaJsonSeries $ \x ->
108 isValid (parseAndValidateJson @SchemaExample x)
111main :: IO ()
112main = hspec spec