master...b1284d4 · typeable/schematic

git.iko.soy/typeable/schematic

on b1284d4 help sign in

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

since splitsnapshots

unifiedsplit

@@ -1,19 +1,24 @@

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

9import Data.Monoid

13import Data.Monoid

10import Data.Schematic.Path

14import Data.Schematic.Path

11import Data.Schematic.Schema

15import Data.Schematic.Schema

12import Data.Scientific

16import Data.Scientific

13−import Data.Singletons.Prelude

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

14import Data.Singletons.TypeLits

18import Data.Singletons.TypeLits

15import Data.Text as T

19import Data.Text as T

16import Data.Traversable

20import Data.Traversable

21+import Data.Type.Equality

17import Data.Union

22import Data.Union

18import Data.Vector as V

23import Data.Vector as V

19import Data.Vinyl

24import Data.Vinyl

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

161 warn = vWarning $ mmSingleton path (pure errMsg)

166 warn = vWarning $ mmSingleton path (pure errMsg)

162 unless predicate warn

167 unless predicate warn

163

168

164−validateJsonRepr

169+lookaheadJsonRepr

165− :: Sing schema

170+ :: forall schema. (SingI schema)

166− -> [DemotedPathSegment]

171+ => [DemotedPathSegment]

167 -> JsonRepr schema

172 -> JsonRepr schema

168 -> Validation ()

173 -> Validation ()

169−validateJsonRepr sschema dpath jr = case jr of

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

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

187+ validateJsonRepr dpath (ReprText t) = case sing :: Sing (SchemaText s) of

171 SSchemaText scs -> do

188 SSchemaText scs -> do

172 let

189 let

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

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

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

176 validateTextConstraint (demotedPathToText dpath) t c

193 validateTextConstraint (demotedPathToText dpath) t c

177 process cs

194 process cs

178 process scs

195 process scs

196+

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

179− ReprNumber n -> case sschema of

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

180 SSchemaNumber scs -> do

199 SSchemaNumber scs -> do

181 let

200 let

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

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

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

185 validateNumberConstraint (demotedPathToText dpath) n c

204 validateNumberConstraint (demotedPathToText dpath) n c

186 process cs

205 process cs

187 process scs

206 process scs

188− ReprNull -> pure ()

207+

189− ReprBoolean _ -> pure ()

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

190− ReprArray v -> case sschema of

209+

210+instance Validatable SchemaBoolean where validateJsonRepr _ _ = pure ()

211+

212+instance SingI (SchemaArray css s) => Validatable (SchemaArray css s) where

213+ validateJsonRepr dpath (ReprArray v) = case sing :: Sing (SchemaArray css s) of

191 SSchemaArray acs s -> do

214 SSchemaArray acs s -> do

192 let

215 let

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

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

@@ -198,60 +221,59 @@ validateJsonRepr sschema dpath jr = case jr of

198 process acs

221 process acs

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

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

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

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

201− validateJsonRepr s newPath jr'

224+ withSingI s $ lookaheadJsonRepr newPath jr'

225+

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

202− ReprOptional d -> case sschema of

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

203− SSchemaOptional ss -> case d of

228+ SSchemaOptional ss -> case s of

204− Just x -> validateJsonRepr ss dpath x

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

205 Nothing -> pure ()

230 Nothing -> pure ()

231+

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

206− ReprObject fs -> case sschema of

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

207 SSchemaObject _ -> go fs

234 SSchemaObject _ -> go fs

208 where

235 where

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

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

210 go RNil = pure ()

237 go RNil = pure ()

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

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

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

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

213− validateJsonRepr (knownFieldSchema f) newPath d

240+ withSingI (knownFieldSchema f)

241+ $ lookaheadJsonRepr newPath d

214 go ftl

242 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

243

233−-- subUnion

244+instance SingI (SchemaUnion s) => Validatable (SchemaUnion s) where

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

245+ validateJsonRepr dpath (ReprUnion u) = pure ()

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

246+

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

247+ -- ReprUnion u -> do

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

248+ -- let

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

249+ -- v :: forall s. JsonRepr s -> Const (Validation ()) s

250+ -- v j = Const $ validateJsonRepr (singByProxy j) dpath j

251+ -- peel :: Union (Const (Validation ())) ts -> Validation ()

252+ -- peel (That u) = peel u

253+ -- peel (This v) = getConst v

254+ -- peel (umap v u)

255+ -- ReprUnion u -> do

256+ -- let

257+ -- peel :: Union JsonRepr ss -> [DemotedSchema] -> Validation ()

258+ -- peel (That u) ds = peel u ds

259+ -- peel (This j) ds = case ds of

260+ -- [] -> error "peeling error: report this as a schematic bug"

261+ -- (ds' :_) -> let s' = toSing ds'

262+ -- in case s' of

263+ -- SomeSing s -> case s `testEquality` (singByProxy j) of

264+ -- Just Refl -> validateJsonRepr s dpath j

265+ -- case sschema of

266+ -- SSchemaUnion us -> peel u (fromSing us)

239

267

240−-- withUSubset

268+class UPeel ss where

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

269+ 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

270

246−toUnion

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

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

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

248− => Sing (s ': ss)

273+ 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

274

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

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

254−umatch' _ u = umatch u

276+umatch' _ = umatch

255

277

256parseAndValidateJson

278parseAndValidateJson

257 :: forall schema

279 :: forall schema

@@ -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 (sing :: Sing schema) [] 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