git.iko.soy/typeable/schematic
on master help sign in
Moved to Validatable typeclass
b1284d4Denis Redozubov
src/Data/Schematic/Validation.hs+42−20
compare with master
unifiedsplit
@@ -166,16 +166,25 @@ validateArrayConstraint (JSONPath path) v = \case
166 warn = vWarning $ mmSingleton path (pure errMsg)
166 warn = vWarning $ mmSingleton path (pure errMsg)
167 unless predicate warn
167 unless predicate warn
168
168
169−class Validatable schema where
169+lookaheadJsonRepr
170− validateJsonRepr :: [DemotedPathSegment] -> JsonRepr schema -> Validation ()
171−
172−validateJsonRepr
173− :: forall schema. SingI schema
170+ :: forall schema. (SingI schema)
174 => [DemotedPathSegment]
171 => [DemotedPathSegment]
175 -> JsonRepr schema
172 -> JsonRepr schema
176 -> Validation ()
173 -> Validation ()
177−validateJsonRepr dpath jr = withSingI (sing :: Sing schema) $ case jr of
174+lookaheadJsonRepr dpath jr = case sing :: Sing schema of
175+ SSchemaText s -> validateJsonRepr @schema dpath jr
176+ SSchemaNumber s -> validateJsonRepr @schema dpath jr
177+ SSchemaNull -> validateJsonRepr @schema dpath jr
178+ SSchemaBoolean -> validateJsonRepr @schema dpath jr
179+ SSchemaArray _ _ -> validateJsonRepr @schema dpath jr
180+ SSchemaObject _ -> validateJsonRepr @schema dpath jr
181+ SSchemaUnion _ -> validateJsonRepr @schema dpath jr
182+
183+class Validatable schema where
184+ validateJsonRepr :: [DemotedPathSegment] -> JsonRepr schema -> Validation ()
185+
186+instance SingI (SchemaText s) => Validatable (SchemaText s) where
178− ReprText t -> case sing :: Sing schema of
187+ validateJsonRepr dpath (ReprText t) = case sing :: Sing (SchemaText s) of
179 SSchemaText scs -> do
188 SSchemaText scs -> do
180 let
189 let
181 process :: Sing (cs :: [TextConstraint]) -> Validation ()
190 process :: Sing (cs :: [TextConstraint]) -> Validation ()
@@ -184,7 +193,9 @@ validateJsonRepr dpath jr = withSingI (sing :: Sing schema) $ case jr of
184 validateTextConstraint (demotedPathToText dpath) t c
193 validateTextConstraint (demotedPathToText dpath) t c
185 process cs
194 process cs
186 process scs
195 process scs
196+
197+instance SingI (SchemaNumber s) => Validatable (SchemaNumber s) where
187− ReprNumber n -> case sing :: Sing schema of
198+ validateJsonRepr dpath (ReprNumber n) = case sing :: Sing (SchemaNumber s) of
188 SSchemaNumber scs -> do
199 SSchemaNumber scs -> do
189 let
200 let
190 process :: Sing (cs :: [NumberConstraint]) -> Validation ()
201 process :: Sing (cs :: [NumberConstraint]) -> Validation ()
@@ -193,9 +204,13 @@ validateJsonRepr dpath jr = withSingI (sing :: Sing schema) $ case jr of
193 validateNumberConstraint (demotedPathToText dpath) n c
204 validateNumberConstraint (demotedPathToText dpath) n c
194 process cs
205 process cs
195 process scs
206 process scs
196− ReprNull -> pure ()
207+
197− ReprBoolean _ -> pure ()
208+instance Validatable SchemaNull where validateJsonRepr _ _ = pure ()
209+
210+instance Validatable SchemaBoolean where validateJsonRepr _ _ = pure ()
211+
212+instance SingI (SchemaArray css s) => Validatable (SchemaArray css s) where
198− ReprArray v -> case sing :: Sing schema of
213+ validateJsonRepr dpath (ReprArray v) = case sing :: Sing (SchemaArray css s) of
199 SSchemaArray acs s -> do
214 SSchemaArray acs s -> do
200 let
215 let
201 process :: Sing (cs :: [ArrayConstraint]) -> Validation ()
216 process :: Sing (cs :: [ArrayConstraint]) -> Validation ()
@@ -206,12 +221,16 @@ validateJsonRepr dpath jr = withSingI (sing :: Sing schema) $ case jr of
206 process acs
221 process acs
207 for_ (V.indexed v) $ \(ix, jr') -> do
222 for_ (V.indexed v) $ \(ix, jr') -> do
208 let newPath = dpath <> pure (DIx $ fromIntegral ix)
223 let newPath = dpath <> pure (DIx $ fromIntegral ix)
209− withSingI s $ validateJsonRepr newPath jr'
224+ withSingI s $ lookaheadJsonRepr newPath jr'
225+
226+instance SingI (SchemaOptional s) => Validatable (SchemaOptional s) where
210− ReprOptional d -> case sing :: Sing schema of
227+ validateJsonRepr dpath (ReprOptional s) = case sing :: Sing (SchemaOptional s) of
211− SSchemaOptional ss -> case d of
228+ SSchemaOptional ss -> case s of
212− Just x -> withSingI ss $ validateJsonRepr dpath x
229+ Just x -> withSingI ss $ lookaheadJsonRepr dpath x
213 Nothing -> pure ()
230 Nothing -> pure ()
231+
232+instance SingI (SchemaObject s) => Validatable (SchemaObject s) where
214− ReprObject fs -> case sing :: Sing schema of
233+ validateJsonRepr dpath (ReprObject fs) = case sing :: Sing (SchemaObject s) of
215 SSchemaObject _ -> go fs
234 SSchemaObject _ -> go fs
216 where
235 where
217 go :: Rec FieldRepr (ts :: [(Symbol, Schema)] ) -> Validation ()
236 go :: Rec FieldRepr (ts :: [(Symbol, Schema)] ) -> Validation ()
@@ -219,9 +238,12 @@ validateJsonRepr dpath jr = withSingI (sing :: Sing schema) $ case jr of
219 go (f@(FieldRepr d) :& ftl) = do
238 go (f@(FieldRepr d) :& ftl) = do
220 let newPath = dpath <> [DKey (knownFieldName f)]
239 let newPath = dpath <> [DKey (knownFieldName f)]
221 withSingI (knownFieldSchema f)
240 withSingI (knownFieldSchema f)
222− $ validateJsonRepr newPath d
241+ $ lookaheadJsonRepr newPath d
223 go ftl
242 go ftl
243+
244+instance SingI (SchemaUnion s) => Validatable (SchemaUnion s) where
224− ReprUnion u -> pure () -- upeel u (sing :: Sing schema)
245+ validateJsonRepr dpath (ReprUnion u) = pure ()
246+
225 -- ReprUnion u -> do
247 -- ReprUnion u -> do
226 -- let
248 -- let
227 -- v :: forall s. JsonRepr s -> Const (Validation ()) s
249 -- v :: forall s. JsonRepr s -> Const (Validation ()) s
@@ -248,7 +270,7 @@ class UPeel ss where
248
270
249instance (UPeel stl) => UPeel (s ': stl) where
271instance (UPeel stl) => UPeel (s ': stl) where
250 upeel (That u) (SSchemaUnion (SCons _ stl)) = upeel @stl u (SSchemaUnion stl)
272 upeel (That u) (SSchemaUnion (SCons _ stl)) = upeel @stl u (SSchemaUnion stl)
251− upeel (This j) (SSchemaUnion (SCons s _)) = withSingI s $ validateJsonRepr mempty j
273+ upeel (This j) (SSchemaUnion (SCons s _)) = withSingI s $ lookaheadJsonRepr mempty j
252
274
253umatch' :: UElem a as i => Sing a -> Union JsonRepr as -> Maybe (JsonRepr a)
275umatch' :: UElem a as i => Sing a -> Union JsonRepr as -> Maybe (JsonRepr a)
254umatch' _ = umatch
276umatch' _ = umatch
@@ -263,7 +285,7 @@ parseAndValidateJson v =
263 Left s -> DecodingError $ T.pack s
285 Left s -> DecodingError $ T.pack s
264 Right jsonRepr ->
286 Right jsonRepr ->
265 let
287 let
266− validate = validateJsonRepr [] jsonRepr
288+ validate = lookaheadJsonRepr [] jsonRepr
267 res = runIdentity . runValidationTEither $ validate
289 res = runIdentity . runValidationTEither $ validate
268 in case res of
290 in case res of
269 Left em -> ValidationError em
291 Left em -> ValidationError em