git.iko.soy/schematic
on master help sign in
schematic/test/SchemaSpec.hs
122 lines 3.9 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"]]))]
36type SchemaExample2 = 'SchemaObject
37 '[ '("foo", 'SchemaArray '[ 'AEq 2] ('SchemaText '[ 'TGt 10]))
38 , '("bar", 'SchemaOptional ('SchemaText '[ 'TRegex "[0-9]+"]))]
40jsonExample :: JsonRepr SchemaExample
41jsonExample = withRepr @SchemaExample
42 $ field @"bar" (Just "bar")
43 :& field @"foo" [12]
44 :& RNil
46type AddQuuz =
47 'Migration "add_field_quuz"
48 '[ 'Diff '[] ('AddKey "quuz" (SchemaNumber '[])) ]
50type DeleteQuuz =
51 'Migration "remove_field_quuz"
52 '[ 'Diff '[] ( 'DeleteKey "quuz") ]
54type SwapFields =
55 'Migration "swap_fields"
56 '[ 'Diff '[ 'PKey "bar" ] ('Update
57 ('SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10])))
58 , 'Diff '[ 'PKey "foo" ] ('Update
59 ('SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))) ]
61type Migrations = '[ AddQuuz
62 , DeleteQuuz ]
63 -- , SwapFields ]
65type VersionedJson = 'Versioned SchemaExample Migrations
67migrationList :: MigrationList Identity VersionedJson
68migrationList
69 = (migrateObject (\r -> Identity $ field @"quuz" 42 :& r))
70 :&& shrinkObject
71 -- :&& (migrateObject (\r -> Identity
72 -- $ field @"foo" (r ^. flens (Proxy @"bar") . _Just . optionalRepr)
73 -- :& field @"bar" (r ^. flens (Proxy @"foo") . arrayRepr)
74 -- :& RNil))
75 :&& MNil
77schemaJson :: ByteString
78schemaJson = "{\"foo\": [13], \"bar\": null}"
80schemaJson2 :: ByteString
81schemaJson2 = "{\"foo\": [3], \"bar\": null}"
83schemaJsonSeries :: Monad m => SC.Series m (JsonRepr SchemaExample)
84schemaJsonSeries = series
86schemaJsonSeries2 :: Monad m => SC.Series m (JsonRepr SchemaExample2)
87schemaJsonSeries2 = series
89spec :: Spec
90spec = do
91 -- it "show/read JsonRepr properly" $
92 -- read (show example) == example
93 it "decode/encode JsonRepr properly" $
94 decode (encode jsonExample) == Just jsonExample
95 it "validates correct representation" $
96 ((decodeAndValidateJson schemaJson) :: ParseResult (JsonRepr SchemaExample))
97 `shouldSatisfy` isValid
98 it "returns decoding error on structurally incorrect input" $
99 ((decodeAndValidateJson "{}") :: ParseResult (JsonRepr SchemaExample))
100 `shouldSatisfy` isDecodingError
101 it "validates incorrect representation" $
102 ((decodeAndValidateJson schemaJson2) :: ParseResult (JsonRepr SchemaExample))
103 `shouldSatisfy` isValidationError
104 -- it "validates versioned json" $ do
105 -- decodeAndValidateVersionedJson (Proxy @VS) schemaJson
106 -- `shouldSatisfy` isValid
107 it "validates versioned json with a migration list" $ do
108 decodeAndValidateVersionedWithPureMList
109 (Proxy @VersionedJson)
110 migrationList
111 schemaJson
112 `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))
121main :: IO ()
122main = hspec spec