@@ -1,19 +1,24 @@
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
913import Data.Monoid
1014import Data.Schematic.Path
1115import Data.Schematic.Schema
1216import Data.Scientific
13−import Data.Singletons.Prelude
17+import Data.Singletons.Prelude hiding (Const)
1418import Data.Singletons.TypeLits
1519import Data.Text as T
1620import Data.Traversable
21+import Data.Type.Equality
1722import Data.Union
1823import Data.Vector as V
1924import Data.Vinyl
@@ -161,13 +166,16 @@ validateArrayConstraint (JSONPath path) v = \case
161166 warn = vWarning $ mmSingleton path (pure errMsg)
162167 unless predicate warn
163168
169+class Validatable schema where
170+ validateJsonRepr :: [DemotedPathSegment] -> JsonRepr schema -> Validation ()
171+
164172validateJsonRepr
165− :: Sing schema
166− -> [DemotedPathSegment]
173+ :: forall schema. SingI schema
174+ => [DemotedPathSegment]
167175 -> JsonRepr schema
168176 -> Validation ()
169−validateJsonRepr sschema dpath jr = case jr of
170− ReprText t -> case sschema of
177+validateJsonRepr dpath jr = withSingI (sing :: Sing schema) $ case jr of
178+ ReprText t -> case sing :: Sing schema of
171179 SSchemaText scs -> do
172180 let
173181 process :: Sing (cs :: [TextConstraint]) -> Validation ()
@@ -176,7 +184,7 @@ validateJsonRepr sschema dpath jr = case jr of
176184 validateTextConstraint (demotedPathToText dpath) t c
177185 process cs
178186 process scs
179− ReprNumber n -> case sschema of
187+ ReprNumber n -> case sing :: Sing schema of
180188 SSchemaNumber scs -> do
181189 let
182190 process :: Sing (cs :: [NumberConstraint]) -> Validation ()
@@ -187,7 +195,7 @@ validateJsonRepr sschema dpath jr = case jr of
187195 process scs
188196 ReprNull -> pure ()
189197 ReprBoolean _ -> pure ()
190− ReprArray v -> case sschema of
198+ ReprArray v -> case sing :: Sing schema of
191199 SSchemaArray acs s -> do
192200 let
193201 process :: Sing (cs :: [ArrayConstraint]) -> Validation ()
@@ -198,60 +206,52 @@ validateJsonRepr sschema dpath jr = case jr of
198206 process acs
199207 for_ (V.indexed v) $ \(ix, jr') -> do
200208 let newPath = dpath <> pure (DIx $ fromIntegral ix)
201− validateJsonRepr s newPath jr'
202− ReprOptional d -> case sschema of
209+ withSingI s $ validateJsonRepr newPath jr'
210+ ReprOptional d -> case sing :: Sing schema of
203211 SSchemaOptional ss -> case d of
204− Just x -> validateJsonRepr ss dpath x
212+ Just x -> withSingI ss $ validateJsonRepr dpath x
205213 Nothing -> pure ()
206− ReprObject fs -> case sschema of
214+ ReprObject fs -> case sing :: Sing schema of
207215 SSchemaObject _ -> go fs
208216 where
209217 go :: Rec FieldRepr (ts :: [(Symbol, Schema)] ) -> Validation ()
210218 go RNil = pure ()
211219 go (f@(FieldRepr d) :& ftl) = do
212220 let newPath = dpath <> [DKey (knownFieldName f)]
213− validateJsonRepr (knownFieldSchema f) newPath d
221+ withSingI (knownFieldSchema f)
222+ $ validateJsonRepr newPath d
214223 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
232−
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
224+ ReprUnion u -> pure () -- upeel u (sing :: Sing schema)
225+ -- ReprUnion u -> do
226+ -- let
227+ -- v :: forall s. JsonRepr s -> Const (Validation ()) s
228+ -- v j = Const $ validateJsonRepr (singByProxy j) dpath j
229+ -- peel :: Union (Const (Validation ())) ts -> Validation ()
230+ -- peel (That u) = peel u
231+ -- peel (This v) = getConst v
232+ -- peel (umap v u)
233+ -- ReprUnion u -> do
234+ -- let
235+ -- peel :: Union JsonRepr ss -> [DemotedSchema] -> Validation ()
236+ -- peel (That u) ds = peel u ds
237+ -- peel (This j) ds = case ds of
238+ -- [] -> error "peeling error: report this as a schematic bug"
239+ -- (ds' :_) -> let s' = toSing ds'
240+ -- in case s' of
241+ -- SomeSing s -> case s `testEquality` (singByProxy j) of
242+ -- Just Refl -> validateJsonRepr s dpath j
243+ -- case sschema of
244+ -- SSchemaUnion us -> peel u (fromSing us)
239245
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
246+class UPeel ss where
247+ upeel :: Union JsonRepr ss -> Sing (SchemaUnion ss :: Schema) -> Validation ()
245248
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
249+instance (UPeel stl) => UPeel (s ': stl) where
250+ upeel (That u) (SSchemaUnion (SCons _ stl)) = upeel @stl u (SSchemaUnion stl)
251+ upeel (This j) (SSchemaUnion (SCons s _)) = withSingI s $ validateJsonRepr mempty j
252252
253−umatch' :: UElem a as i => Sing a -> Union f as -> Maybe (f a)
254−umatch' _ u = umatch u
253+umatch' :: UElem a as i => Sing a -> Union JsonRepr as -> Maybe (JsonRepr a)
254+umatch' _ = umatch
255255
256256parseAndValidateJson
257257 :: forall schema
@@ -263,7 +263,7 @@ parseAndValidateJson v =
263263 Left s -> DecodingError $ T.pack s
264264 Right jsonRepr ->
265265 let
266− validate = validateJsonRepr (sing :: Sing schema) [] jsonRepr
266+ validate = validateJsonRepr [] jsonRepr
267267 res = runIdentity . runValidationTEither $ validate
268268 in case res of
269269 Left em -> ValidationError em