@@ -1,19 +1,25 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+
13module Data.Schematic.Validation where
24
5+import Control.Applicative
36import Control.Monad
47import Control.Monad.Validation
58import Data.Aeson
69import Data.Aeson.Types
10+import Data.Coerce
711import Data.Foldable
812import Data.Functor.Identity
13+import Data.Kind
914import Data.Monoid
1015import Data.Schematic.Path
1116import Data.Schematic.Schema
1217import Data.Scientific
13−import Data.Singletons.Prelude
18+import Data.Singletons.Prelude hiding (Const)
1419import Data.Singletons.TypeLits
1520import Data.Text as T
1621import Data.Traversable
22+import Data.Type.Equality
1723import Data.Union
1824import Data.Vector as V
1925import Data.Vinyl
@@ -161,13 +167,25 @@ validateArrayConstraint (JSONPath path) v = \case
161167 warn = vWarning $ mmSingleton path (pure errMsg)
162168 unless predicate warn
163169
164−validateJsonRepr
165− :: Sing schema
166− -> [DemotedPathSegment]
170+lookaheadJsonRepr
171+ :: forall schema. (SingI schema)
172+ => [DemotedPathSegment]
167173 -> JsonRepr schema
168174 -> Validation ()
169−validateJsonRepr sschema dpath jr = case jr of
170− ReprText t -> case sschema of
175+lookaheadJsonRepr dpath jr = case sing :: Sing schema of
176+ SSchemaText s -> validateJsonRepr @schema dpath jr
177+ SSchemaNumber s -> validateJsonRepr @schema dpath jr
178+ SSchemaNull -> validateJsonRepr @schema dpath jr
179+ SSchemaBoolean -> validateJsonRepr @schema dpath jr
180+ SSchemaArray _ _ -> validateJsonRepr @schema dpath jr
181+ SSchemaObject _ -> validateJsonRepr @schema dpath jr
182+ SSchemaUnion _ -> validateJsonRepr @schema dpath jr
183+
184+class Validatable schema where
185+ validateJsonRepr :: [DemotedPathSegment] -> JsonRepr schema -> Validation ()
186+
187+instance SingI (SchemaText s) => Validatable (SchemaText s) where
188+ validateJsonRepr dpath (ReprText t) = case sing :: Sing (SchemaText s) of
171189 SSchemaText scs -> do
172190 let
173191 process :: Sing (cs :: [TextConstraint]) -> Validation ()
@@ -176,7 +194,9 @@ validateJsonRepr sschema dpath jr = case jr of
176194 validateTextConstraint (demotedPathToText dpath) t c
177195 process cs
178196 process scs
179− ReprNumber n -> case sschema of
197+
198+instance SingI (SchemaNumber s) => Validatable (SchemaNumber s) where
199+ validateJsonRepr dpath (ReprNumber n) = case sing :: Sing (SchemaNumber s) of
180200 SSchemaNumber scs -> do
181201 let
182202 process :: Sing (cs :: [NumberConstraint]) -> Validation ()
@@ -185,9 +205,13 @@ validateJsonRepr sschema dpath jr = case jr of
185205 validateNumberConstraint (demotedPathToText dpath) n c
186206 process cs
187207 process scs
188− ReprNull -> pure ()
189− ReprBoolean _ -> pure ()
190− ReprArray v -> case sschema of
208+
209+instance Validatable SchemaNull where validateJsonRepr _ _ = pure ()
210+
211+instance Validatable SchemaBoolean where validateJsonRepr _ _ = pure ()
212+
213+instance SingI (SchemaArray css s) => Validatable (SchemaArray css s) where
214+ validateJsonRepr dpath (ReprArray v) = case sing :: Sing (SchemaArray css s) of
191215 SSchemaArray acs s -> do
192216 let
193217 process :: Sing (cs :: [ArrayConstraint]) -> Validation ()
@@ -198,60 +222,72 @@ validateJsonRepr sschema dpath jr = case jr of
198222 process acs
199223 for_ (V.indexed v) $ \(ix, jr') -> do
200224 let newPath = dpath <> pure (DIx $ fromIntegral ix)
201− validateJsonRepr s newPath jr'
202− ReprOptional d -> case sschema of
203− SSchemaOptional ss -> case d of
204− Just x -> validateJsonRepr ss dpath x
225+ withSingI s $ lookaheadJsonRepr newPath jr'
226+
227+instance SingI (SchemaOptional s) => Validatable (SchemaOptional s) where
228+ validateJsonRepr dpath (ReprOptional s) = case sing :: Sing (SchemaOptional s) of
229+ SSchemaOptional ss -> case s of
230+ Just x -> withSingI ss $ lookaheadJsonRepr dpath x
205231 Nothing -> pure ()
206− ReprObject fs -> case sschema of
232+
233+instance SingI (SchemaObject s) => Validatable (SchemaObject s) where
234+ validateJsonRepr dpath (ReprObject fs) = case sing :: Sing (SchemaObject s) of
207235 SSchemaObject _ -> go fs
208236 where
209237 go :: Rec FieldRepr (ts :: [(Symbol, Schema)] ) -> Validation ()
210238 go RNil = pure ()
211239 go (f@(FieldRepr d) :& ftl) = do
212240 let newPath = dpath <> [DKey (knownFieldName f)]
213− validateJsonRepr (knownFieldSchema f) newPath d
241+ withSingI (knownFieldSchema f)
242+ $ lookaheadJsonRepr newPath d
214243 go ftl
215− ReprUnion _ -> pure () -- FIXME
216− -- case sschema of
217− -- SSchemaUnion ss -> case ss of
218− -- SCons s stl -> case umatch' s u of
219− -- Nothing -> case urestrict u of
220− -- Nothing ->
221− -- fail "impossible to produce subUnion, please report this as a bug"
222− -- Just x -> do
223− -- let
224− -- JSONPath path = demotedPathToText dpath
225− -- case stl of
226− -- SNil -> void $ vWarning $ mmSingleton path
227− -- $ pure "union handling error, please report this as bug"
228− -- SCons s' stl' ->
229− -- validateJsonRepr (SSchemaUnion (SCons s' stl')) dpath
230− -- $ toUnion (SCons s' stl') x
231− -- Just x -> validateJsonRepr s dpath x
232244
233−-- subUnion
234−-- :: Sing (s ': stl)
235−-- -> ( USubset stl (s ': stl) (RImage stl (s ': stl))
236−-- => Union f (s ': stl)
237−-- -> Maybe (Union f stl) )
238−-- subUnion (SCons s stl) = urestrict
245+instance
246+ (SingI (SchemaUnion (s ': tl)))
247+ => Validatable (SchemaUnion (s ': tl)) where
248+ validateJsonRepr dpath (ReprUnion u) = do
249+ let
250+ v :: forall s. Sing s -> JsonRepr s -> Const (Validation ()) s
251+ v s j = withSingI s $ Const $ lookaheadJsonRepr dpath j
252+ peel :: Union (Const (Validation ())) ts -> Validation ()
253+ peel (That u) = peel u
254+ peel (This v) = getConst v
255+ umap' :: (forall a . Sing a -> f a -> g a) -> SList as -> Union f as -> Union g as
256+ umap' f (SCons s' stl') = \case
257+ This a -> This (f s' a)
258+ That u -> That (umap' f stl' u)
259+ peel (umap' v sing u)
260+
261+ -- ReprUnion u -> do
262+ -- let
263+ -- v :: forall s. JsonRepr s -> Const (Validation ()) s
264+ -- v j = Const $ validateJsonRepr (singByProxy j) dpath j
265+ -- peel :: Union (Const (Validation ())) ts -> Validation ()
266+ -- peel (That u) = peel u
267+ -- peel (This v) = getConst v
268+ -- peel (umap v u)
269+ -- ReprUnion u -> do
270+ -- let
271+ -- peel :: Union JsonRepr ss -> [DemotedSchema] -> Validation ()
272+ -- peel (That u) ds = peel u ds
273+ -- peel (This j) ds = case ds of
274+ -- [] -> error "peeling error: report this as a schematic bug"
275+ -- (ds' :_) -> let s' = toSing ds'
276+ -- in case s' of
277+ -- SomeSing s -> case s `testEquality` (singByProxy j) of
278+ -- Just Refl -> validateJsonRepr s dpath j
279+ -- case sschema of
280+ -- SSchemaUnion us -> peel u (fromSing us)
239281
240−-- withUSubset
241−-- :: Sing (s ': stl)
242−-- -> (USubset stl (s ': stl) (RImage stl (s ': stl)) => Maybe (Union f stl))
243−-- -> Maybe (Union f stl)
244−-- withUSubset (SCons s stl) r = r
282+class UPeel ss where
283+ upeel :: Union JsonRepr ss -> Sing (SchemaUnion ss :: Schema) -> Validation ()
245284
246−toUnion
247− :: USubset s' (s ': ss) (RImage s' (s ': ss))
248− => Sing (s ': ss)
249− -> Union JsonRepr s'
250− -> JsonRepr ('SchemaUnion (s ': ss))
251−toUnion _ = ReprUnion . urelax
285+instance (UPeel stl) => UPeel (s ': stl) where
286+ upeel (That u) (SSchemaUnion (SCons _ stl)) = upeel @stl u (SSchemaUnion stl)
287+ upeel (This j) (SSchemaUnion (SCons s _)) = withSingI s $ lookaheadJsonRepr mempty j
252288
253−umatch' :: UElem a as i => Sing a -> Union f as -> Maybe (f a)
254−umatch' _ u = umatch u
289+umatch' :: UElem a as i => Sing a -> Union JsonRepr as -> Maybe (JsonRepr a)
290+umatch' _ = umatch
255291
256292parseAndValidateJson
257293 :: forall schema
@@ -263,7 +299,7 @@ parseAndValidateJson v =
263299 Left s -> DecodingError $ T.pack s
264300 Right jsonRepr ->
265301 let
266− validate = validateJsonRepr (sing :: Sing schema) [] jsonRepr
302+ validate = lookaheadJsonRepr [] jsonRepr
267303 res = runIdentity . runValidationTEither $ validate
268304 in case res of
269305 Left em -> ValidationError em