master...8b92be8 · typeable/schematic

git.iko.soy/typeable/schematic

on 8b92be8 help sign in

src/Data/Schematic/Validation.hs+89−53

since splitsnapshots

unifiedsplit

@@ -1,19 +1,25 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

1module Data.Schematic.Validation where

3module Data.Schematic.Validation where

5+import Control.Applicative

3import Control.Monad

6import Control.Monad

4import Control.Monad.Validation

7import Control.Monad.Validation

5import Data.Aeson

8import Data.Aeson

6import Data.Aeson.Types

9import Data.Aeson.Types

10+import Data.Coerce

7import Data.Foldable

11import Data.Foldable

8import Data.Functor.Identity

12import Data.Functor.Identity

13+import Data.Kind

9import Data.Monoid

14import Data.Monoid

10import Data.Schematic.Path

15import Data.Schematic.Path

11import Data.Schematic.Schema

16import Data.Schematic.Schema

12import Data.Scientific

17import Data.Scientific

13−import Data.Singletons.Prelude

18+import Data.Singletons.Prelude hiding (Const)

14import Data.Singletons.TypeLits

19import Data.Singletons.TypeLits

15import Data.Text as T

20import Data.Text as T

16import Data.Traversable

21import Data.Traversable

22+import Data.Type.Equality

17import Data.Union

23import Data.Union

18import Data.Vector as V

24import Data.Vector as V

19import Data.Vinyl

25import Data.Vinyl

@@ -161,13 +167,25 @@ validateArrayConstraint (JSONPath path) v = \case

161 warn = vWarning $ mmSingleton path (pure errMsg)

167 warn = vWarning $ mmSingleton path (pure errMsg)

162 unless predicate warn

168 unless predicate warn

163

169

164−validateJsonRepr

170+lookaheadJsonRepr

165− :: Sing schema

171+ :: forall schema. (SingI schema)

166− -> [DemotedPathSegment]

172+ => [DemotedPathSegment]

167 -> JsonRepr schema

173 -> JsonRepr schema

168 -> Validation ()

174 -> Validation ()

169−validateJsonRepr sschema dpath jr = case jr of

175+lookaheadJsonRepr dpath jr = case sing :: Sing schema of

170− ReprText t -> case sschema 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

171 SSchemaText scs -> do

189 SSchemaText scs -> do

172 let

190 let

173 process :: Sing (cs :: [TextConstraint]) -> Validation ()

191 process :: Sing (cs :: [TextConstraint]) -> Validation ()

@@ -176,7 +194,9 @@ validateJsonRepr sschema dpath jr = case jr of

176 validateTextConstraint (demotedPathToText dpath) t c

194 validateTextConstraint (demotedPathToText dpath) t c

177 process cs

195 process cs

178 process scs

196 process scs

197+

198+instance SingI (SchemaNumber s) => Validatable (SchemaNumber s) where

179− ReprNumber n -> case sschema of

199+ validateJsonRepr dpath (ReprNumber n) = case sing :: Sing (SchemaNumber s) of

180 SSchemaNumber scs -> do

200 SSchemaNumber scs -> do

181 let

201 let

182 process :: Sing (cs :: [NumberConstraint]) -> Validation ()

202 process :: Sing (cs :: [NumberConstraint]) -> Validation ()

@@ -185,9 +205,13 @@ validateJsonRepr sschema dpath jr = case jr of

185 validateNumberConstraint (demotedPathToText dpath) n c

205 validateNumberConstraint (demotedPathToText dpath) n c

186 process cs

206 process cs

187 process scs

207 process scs

188− ReprNull -> pure ()

208+

189− ReprBoolean _ -> pure ()

209+instance Validatable SchemaNull where validateJsonRepr _ _ = pure ()

190− ReprArray v -> case sschema of

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

191 SSchemaArray acs s -> do

215 SSchemaArray acs s -> do

192 let

216 let

193 process :: Sing (cs :: [ArrayConstraint]) -> Validation ()

217 process :: Sing (cs :: [ArrayConstraint]) -> Validation ()

@@ -198,60 +222,72 @@ validateJsonRepr sschema dpath jr = case jr of

198 process acs

222 process acs

199 for_ (V.indexed v) $ \(ix, jr') -> do

223 for_ (V.indexed v) $ \(ix, jr') -> do

200 let newPath = dpath <> pure (DIx $ fromIntegral ix)

224 let newPath = dpath <> pure (DIx $ fromIntegral ix)

201− validateJsonRepr s newPath jr'

225+ withSingI s $ lookaheadJsonRepr newPath jr'

226+

227+instance SingI (SchemaOptional s) => Validatable (SchemaOptional s) where

202− ReprOptional d -> case sschema of

228+ validateJsonRepr dpath (ReprOptional s) = case sing :: Sing (SchemaOptional s) of

203− SSchemaOptional ss -> case d of

229+ SSchemaOptional ss -> case s of

204− Just x -> validateJsonRepr ss dpath x

230+ Just x -> withSingI ss $ lookaheadJsonRepr dpath x

205 Nothing -> pure ()

231 Nothing -> pure ()

232+

233+instance SingI (SchemaObject s) => Validatable (SchemaObject s) where

206− ReprObject fs -> case sschema of

234+ validateJsonRepr dpath (ReprObject fs) = case sing :: Sing (SchemaObject s) of

207 SSchemaObject _ -> go fs

235 SSchemaObject _ -> go fs

208 where

236 where

209 go :: Rec FieldRepr (ts :: [(Symbol, Schema)] ) -> Validation ()

237 go :: Rec FieldRepr (ts :: [(Symbol, Schema)] ) -> Validation ()

210 go RNil = pure ()

238 go RNil = pure ()

211 go (f@(FieldRepr d) :& ftl) = do

239 go (f@(FieldRepr d) :& ftl) = do

212 let newPath = dpath <> [DKey (knownFieldName f)]

240 let newPath = dpath <> [DKey (knownFieldName f)]

213− validateJsonRepr (knownFieldSchema f) newPath d

241+ withSingI (knownFieldSchema f)

242+ $ lookaheadJsonRepr newPath d

214 go ftl

243 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

244

233−-- subUnion

245+instance

234−-- :: Sing (s ': stl)

246+ (SingI (SchemaUnion (s ': tl)))

235−-- -> ( USubset stl (s ': stl) (RImage stl (s ': stl))

247+ => Validatable (SchemaUnion (s ': tl)) where

236−-- => Union f (s ': stl)

248+ validateJsonRepr dpath (ReprUnion u) = do

237−-- -> Maybe (Union f stl) )

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

238−-- subUnion (SCons s stl) = urestrict

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)

239

281

240−-- withUSubset

282+class UPeel ss where

241−-- :: Sing (s ': stl)

283+ upeel :: Union JsonRepr ss -> Sing (SchemaUnion ss :: Schema) -> Validation ()

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

245

284

246−toUnion

285+instance (UPeel stl) => UPeel (s ': stl) where

247− :: USubset s' (s ': ss) (RImage s' (s ': ss))

286+ upeel (That u) (SSchemaUnion (SCons _ stl)) = upeel @stl u (SSchemaUnion stl)

248− => Sing (s ': ss)

287+ upeel (This j) (SSchemaUnion (SCons s _)) = withSingI s $ lookaheadJsonRepr mempty j

249− -> Union JsonRepr s'

250− -> JsonRepr ('SchemaUnion (s ': ss))

251−toUnion _ = ReprUnion . urelax

252

288

253−umatch' :: UElem a as i => Sing a -> Union f as -> Maybe (f a)

289+umatch' :: UElem a as i => Sing a -> Union JsonRepr as -> Maybe (JsonRepr a)

254−umatch' _ u = umatch u

290+umatch' _ = umatch

255

291

256parseAndValidateJson

292parseAndValidateJson

257 :: forall schema

293 :: forall schema

@@ -263,7 +299,7 @@ parseAndValidateJson v =

263 Left s -> DecodingError $ T.pack s

299 Left s -> DecodingError $ T.pack s

264 Right jsonRepr ->

300 Right jsonRepr ->

265 let

301 let

266− validate = validateJsonRepr (sing :: Sing schema) [] jsonRepr

302+ validate = lookaheadJsonRepr [] jsonRepr

267 res = runIdentity . runValidationTEither $ validate

303 res = runIdentity . runValidationTEither $ validate

268 in case res of

304 in case res of

269 Left em -> ValidationError em

305 Left em -> ValidationError em