git.iko.soy/typeable/schematic
on master help sign in
Add optional fields
78b8149Denis Redozubov
src/Data/Schematic/Schema.hs+50−20
compare with master
unifiedsplit
@@ -98,6 +98,7 @@ data Schema
98 | SchemaObject [(Symbol, Schema)]
98 | SchemaObject [(Symbol, Schema)]
99 | SchemaArray [ArrayConstraint] Schema
99 | SchemaArray [ArrayConstraint] Schema
100 | SchemaNull
100 | SchemaNull
101+ | SchemaOptional Schema
101 deriving (Generic)
102 deriving (Generic)
102
103
103data instance Sing (schema :: Schema) where
104data instance Sing (schema :: Schema) where
@@ -105,6 +106,7 @@ data instance Sing (schema :: Schema) where
105 SSchemaNumber :: Known (Sing ncs) => Sing ncs -> Sing (SchemaNumber ncs)
106 SSchemaNumber :: Known (Sing ncs) => Sing ncs -> Sing (SchemaNumber ncs)
106 SSchemaArray :: (Known (Sing acs), Known (Sing schema)) => Sing acs -> Sing schema -> Sing (SchemaArray acs schema)
107 SSchemaArray :: (Known (Sing acs), Known (Sing schema)) => Sing acs -> Sing schema -> Sing (SchemaArray acs schema)
107 SSchemaObject :: Known (Sing fields) => Sing fields -> Sing (SchemaObject fields)
108 SSchemaObject :: Known (Sing fields) => Sing fields -> Sing (SchemaObject fields)
109+ SSchemaOptional :: Known (Sing s) => Sing s -> Sing (SchemaOptional s)
108 SSchemaNull :: Sing SchemaNull
110 SSchemaNull :: Sing SchemaNull
109
111
110instance Known (Sing sl) => Known (Sing (SchemaText sl)) where
112instance Known (Sing sl) => Known (Sing (SchemaText sl)) where
@@ -117,12 +119,15 @@ instance (Known (Sing ac), Known (Sing s)) => Known (Sing (SchemaArray ac s)) wh
117 known = SSchemaArray known known
119 known = SSchemaArray known known
118instance Known (Sing stl) => Known (Sing (SchemaObject stl)) where
120instance Known (Sing stl) => Known (Sing (SchemaObject stl)) where
119 known = SSchemaObject known
121 known = SSchemaObject known
122+instance Known (Sing s) => Known (Sing (SchemaOptional s)) where
123+ known = SSchemaOptional known
120
124
121instance Eq (Sing (SchemaText cs)) where a == b = True
125instance Eq (Sing (SchemaText cs)) where a == b = True
122instance Eq (Sing (SchemaNumber cs)) where a == b = True
126instance Eq (Sing (SchemaNumber cs)) where a == b = True
123instance Eq (Sing SchemaNull) where a == b = True
127instance Eq (Sing SchemaNull) where a == b = True
124instance Eq (Sing (SchemaArray as s)) where a == b = True
128instance Eq (Sing (SchemaArray as s)) where a == b = True
125instance Eq (Sing (SchemaObject cs)) where a == b = True
129instance Eq (Sing (SchemaObject cs)) where a == b = True
130+instance Eq (Sing (SchemaOptional s)) where a == b = True
126
131
127data FieldRepr :: (Symbol, Schema) -> Type where
132data FieldRepr :: (Symbol, Schema) -> Type where
128 FieldRepr :: KnownSymbol name => JsonRepr schema -> FieldRepr '(name, schema)
133 FieldRepr :: KnownSymbol name => JsonRepr schema -> FieldRepr '(name, schema)
@@ -148,6 +153,7 @@ data JsonRepr :: Schema -> Type where
148 ReprNull :: JsonRepr SchemaNull
153 ReprNull :: JsonRepr SchemaNull
149 ReprArray :: V.Vector (JsonRepr s) -> JsonRepr (SchemaArray cs s)
154 ReprArray :: V.Vector (JsonRepr s) -> JsonRepr (SchemaArray cs s)
150 ReprObject :: Rec FieldRepr fs -> JsonRepr (SchemaObject fs)
155 ReprObject :: Rec FieldRepr fs -> JsonRepr (SchemaObject fs)
156+ ReprOptional :: Maybe (JsonRepr s) -> JsonRepr (SchemaOptional s)
151
157
152instance Show (JsonRepr (SchemaText cs)) where
158instance Show (JsonRepr (SchemaText cs)) where
153 show (ReprText t) = "ReprText " P.++ show t
159 show (ReprText t) = "ReprText " P.++ show t
@@ -163,6 +169,9 @@ instance Show (JsonRepr s) => Show (JsonRepr (SchemaArray acs s)) where
163instance RecAll FieldRepr fs Show => Show (JsonRepr (SchemaObject fs)) where
169instance RecAll FieldRepr fs Show => Show (JsonRepr (SchemaObject fs)) where
164 show (ReprObject fs) = "ReprObject " P.++ show fs
170 show (ReprObject fs) = "ReprObject " P.++ show fs
165
171
172+instance Show (JsonRepr s) => Show (JsonRepr (SchemaOptional s)) where
173+ show (ReprOptional s) = "ReprOptional " P.++ show s
174+
166instance (Monad m, Serial m Text)
175instance (Monad m, Serial m Text)
167 => Serial m (JsonRepr (SchemaText cs)) where
176 => Serial m (JsonRepr (SchemaText cs)) where
168 series = cons1 ReprText
177 series = cons1 ReprText
@@ -178,6 +187,10 @@ instance (Serial m (V.Vector (JsonRepr s)))
178 => Serial m (JsonRepr (SchemaArray cs s)) where
187 => Serial m (JsonRepr (SchemaArray cs s)) where
179 series = cons1 ReprArray
188 series = cons1 ReprArray
180
189
190+instance (Serial m (JsonRepr s))
191+ => Serial m (JsonRepr (SchemaOptional s)) where
192+ series = cons1 ReprOptional
193+
181instance (Monad m, Serial m (Rec FieldRepr fs))
194instance (Monad m, Serial m (Rec FieldRepr fs))
182 => Serial m (JsonRepr (SchemaObject fs)) where
195 => Serial m (JsonRepr (SchemaObject fs)) where
183 series = cons1 ReprObject
196 series = cons1 ReprObject
@@ -197,15 +210,26 @@ instance Eq (JsonRepr SchemaNull) where
197instance Eq (JsonRepr s) => Eq (JsonRepr (SchemaArray as s)) where
210instance Eq (JsonRepr s) => Eq (JsonRepr (SchemaArray as s)) where
198 ReprArray a == ReprArray b = a == b
211 ReprArray a == ReprArray b = a == b
199
212
213+instance Eq (JsonRepr s) => Eq (JsonRepr (SchemaOptional s)) where
214+ ReprOptional a == ReprOptional b = a == b
215+
216+fromOptional
217+ :: (Known (Sing s))
218+ => Sing (SchemaOptional s)
219+ -> J.Value
220+ -> Parser (Maybe (JsonRepr s))
221+fromOptional _ = parseJSON
222+
200instance Known (Sing schema) => J.FromJSON (JsonRepr schema) where
223instance Known (Sing schema) => J.FromJSON (JsonRepr schema) where
201 parseJSON value = case known :: Sing schema of
224 parseJSON value = case known :: Sing schema of
202− SSchemaText _ -> withText "String" (pure . ReprText) value
225+ SSchemaText _ -> withText "String" (pure . ReprText) value
203− SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value
226+ SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value
204− SSchemaNull -> case value of
227+ SSchemaNull -> case value of
205 J.Null -> pure ReprNull
228 J.Null -> pure ReprNull
206 _ -> typeMismatch "Null" value
229 _ -> typeMismatch "Null" value
230+ so@(SSchemaOptional _) -> ReprOptional <$> fromOptional so value
207− SSchemaArray c s -> withArray "Array" (fmap ReprArray . traverse parseJSON) value
231+ SSchemaArray c s -> withArray "Array" (fmap ReprArray . traverse parseJSON) value
208− SSchemaObject fs -> do
232+ SSchemaObject fs -> do
209 let
233 let
210 demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (Rec FieldRepr s)
234 demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (Rec FieldRepr s)
211 demoteFields SNil h = pure RNil
235 demoteFields SNil h = pure RNil
@@ -213,29 +237,35 @@ instance Known (Sing schema) => J.FromJSON (JsonRepr schema) where
213 let fieldName = T.pack $ symbolVal (Proxy @fn)
237 let fieldName = T.pack $ symbolVal (Proxy @fn)
214 fieldRepr <- case s of
238 fieldRepr <- case s of
215 SSchemaText _ -> case H.lookup fieldName h of
239 SSchemaText _ -> case H.lookup fieldName h of
216− Just v -> FieldRepr <$> parseJSON v
240+ Just v -> FieldRepr <$> parseJSON v
217− Nothing -> fail "schematext"
241+ Nothing -> fail "schematext"
218 SSchemaNumber _ -> case H.lookup fieldName h of
242 SSchemaNumber _ -> case H.lookup fieldName h of
219− Just v -> FieldRepr <$> parseJSON v
243+ Just v -> FieldRepr <$> parseJSON v
220− Nothing -> fail "schemanumber"
244+ Nothing -> fail "schemanumber"
221 SSchemaNull -> case H.lookup fieldName h of
245 SSchemaNull -> case H.lookup fieldName h of
222− Just v -> FieldRepr <$> parseJSON v
246+ Just v -> FieldRepr <$> parseJSON v
223− Nothing -> fail "schemanull"
247+ Nothing -> fail "schemanull"
224 SSchemaArray _ _ -> case H.lookup fieldName h of
248 SSchemaArray _ _ -> case H.lookup fieldName h of
225− Just v -> FieldRepr <$> parseJSON v
249+ Just v -> FieldRepr <$> parseJSON v
226− Nothing -> fail "schemaarray"
250+ Nothing -> fail "schemaarray"
227 SSchemaObject _ -> case H.lookup fieldName h of
251 SSchemaObject _ -> case H.lookup fieldName h of
228− Just v -> FieldRepr <$> parseJSON v
252+ Just v -> FieldRepr <$> parseJSON v
229− Nothing -> fail "schemaobject"
253+ Nothing -> fail "schemaobject"
254+ SSchemaOptional s -> case H.lookup fieldName h of
255+ Just v -> FieldRepr <$> parseJSON v
256+ Nothing -> fail "schemaoptional"
230 (fieldRepr :&) <$> demoteFields tl h
257 (fieldRepr :&) <$> demoteFields tl h
231 ReprObject <$> withObject "Object" (demoteFields fs) value
258 ReprObject <$> withObject "Object" (demoteFields fs) value
232
259
233instance J.ToJSON (JsonRepr a) where
260instance J.ToJSON (JsonRepr a) where
234− toJSON ReprNull = J.Null
261+ toJSON ReprNull = J.Null
235− toJSON (ReprText t) = J.String t
262+ toJSON (ReprText t) = J.String t
236− toJSON (ReprNumber n) = J.Number n
263+ toJSON (ReprNumber n) = J.Number n
264+ toJSON (ReprOptional s) = case s of
265+ Just v -> toJSON v
266+ Nothing -> J.Null
237− toJSON (ReprArray v) = J.Array $ toJSON <$> v
267+ toJSON (ReprArray v) = J.Array $ toJSON <$> v
238− toJSON (ReprObject r) = J.Object . H.fromList . fold $ r
268+ toJSON (ReprObject r) = J.Object . H.fromList . fold $ r
239 where
269 where
240 extract :: forall name s . (KnownSymbol name)
270 extract :: forall name s . (KnownSymbol name)
241 => FieldRepr '(name, s)
271 => FieldRepr '(name, s)
test/SchemaSpec.hs+7−5
@@ -15,10 +15,10 @@ import Test.SmallCheck.Series.Instances
15type SchemaExample
15type SchemaExample
16 = SchemaObject
16 = SchemaObject
17 '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))
17 '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))
18− , '("bar", SchemaText '[TRegex "\\w+"])]
18+ , '("bar", SchemaOptional (SchemaText '[TRegex "\\w+"]))]
19
19
20−exampleTest :: JsonRepr (SchemaText '[TEq 3])
20+exampleTest :: JsonRepr (SchemaOptional (SchemaText '[TEq 3]))
21−exampleTest = ReprText "lil"
21+exampleTest = ReprOptional (Just (ReprText "lil"))
22
22
23exampleNumber :: JsonRepr (SchemaNumber '[NGt 10])
23exampleNumber :: JsonRepr (SchemaNumber '[NGt 10])
24exampleNumber = ReprNumber 12
24exampleNumber = ReprNumber 12
@@ -27,12 +27,14 @@ exampleArray :: JsonRepr (SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))
27exampleArray = ReprArray [exampleNumber]
27exampleArray = ReprArray [exampleNumber]
28
28
29exampleObject :: JsonRepr SchemaExample
29exampleObject :: JsonRepr SchemaExample
30−exampleObject = ReprObject $ FieldRepr exampleArray :& FieldRepr (ReprText "barval") :& RNil
30+exampleObject = ReprObject $ FieldRepr exampleArray
31+ :& FieldRepr (ReprOptional (Just (ReprText "barval")))
32+ :& RNil
31
33
32jsonExample :: JsonRepr SchemaExample
34jsonExample :: JsonRepr SchemaExample
33jsonExample = ReprObject $
35jsonExample = ReprObject $
34 FieldRepr (ReprArray [ReprNumber 12])
36 FieldRepr (ReprArray [ReprNumber 12])
35− :& FieldRepr (ReprText "tes")
37+ :& FieldRepr (ReprOptional (Just (ReprText "tes")))
36 :& RNil
38 :& RNil
37
39
38-- schemaExample :: Sing SchemaExample
40-- schemaExample :: Sing SchemaExample