git.iko.soy/schematic
on master help sign in
WIP
commitfe46056cae1d91ae0b1e6de17b7b989e565678b9 authorDenis Redozubov <denis.redozubov@gmail.com> dateWed 8 Nov 2017, 13:13 (9 years ago) parent1c6c894
3 files changed+56−17
compare with master
unifiedsplit
src/Data/Schematic/Migration.hs−15 src/Data/Schematic/Path.hs+29 src/Data/Schematic/Validation.hs+27−2
src/Data/Schematic/Migration.hs−15
@@ -10,25 +10,10 @@ import Data.Schematic.Path
1010import Data.Tagged
1111import Data.Schematic.Schema
1212import Data.Singletons.Prelude hiding (All, (:.))
13−import Data.Singletons.TypeLits
1413import Data.Vinyl
1514import Data.Vinyl.Functor
1615
1716
18−data Path
19− = PKey Symbol -- traverse into the object by key
20− | PTraverse -- traverse into the array
21−
22−data instance Sing (p :: Path) where
23− SPKey :: Sing s -> Sing ('PKey s)
24− SPTraverse :: Sing 'PTraverse
25−
26−instance KnownSymbol s => SingI ('PKey s) where
27− sing = SPKey sing
28−
29−instance SingI 'PTraverse where
30− sing = SPTraverse
31−
3217-- Result type blueprint
3318data Builder
3419 = BKey Schema Symbol Builder -- field schema
src/Data/Schematic/Path.hs+29
@@ -2,12 +2,41 @@ module Data.Schematic.Path where
22
33import Data.Foldable as F
44import Data.Monoid
5+import Data.Schematic.Schema
56import Data.Singletons
67import Data.Singletons.Prelude
78import Data.Singletons.TypeLits
89import Data.Text as T
910
1011
12+-- Schema level path
13+
14+data Path
15+ = PKey Symbol -- traverse into the object by key
16+ | PTraverse -- traverse into the array
17+
18+data instance Sing (p :: Path) where
19+ SPKey :: Sing s -> Sing ('PKey s)
20+ SPTraverse :: Sing 'PTraverse
21+
22+instance KnownSymbol s => SingI ('PKey s) where
23+ sing = SPKey sing
24+
25+instance SingI 'PTraverse where
26+ sing = SPTraverse
27+
28+type family TraverseStep (p :: Path) (s :: Schema) :: Schema where
29+ TraverseStep ('PKey fn) ('SchemaObject ( '(fn, s) ': tl )) = s
30+ TraverseStep ('PKey fn) ('SchemaObject ( '(x, s) ': tl )) =
31+ TraverseStep ('PKey fn) ('SchemaObject tl)
32+ TraverseStep 'PTraverse ('SchemaArray cs s) = s
33+
34+type family TraversePath (ps :: [Path]) (s :: Schema) :: Schema where
35+ TraversePath '[] s = s
36+ TraversePath (p ': ps) s = TraversePath ps (TraverseStep p s)
37+
38+-- Data level path
39+
1140data PathSegment = Key Symbol | Ix Nat
1241
1342data instance Sing (jp :: PathSegment) where
src/Data/Schematic/Validation.hs+27−2
@@ -1,4 +1,15 @@
1−module Data.Schematic.Validation where
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+
3+module Data.Schematic.Validation
4+ ( Validation
5+ , ErrorMap
6+ , ParseResult(..)
7+ , isValid
8+ , isDecodingError
9+ , isValidationError
10+ , zoomTo
11+ , validateJsonRepr
12+ ) where
213
314import Control.Monad
415import Control.Monad.Validation
@@ -42,6 +53,20 @@ isValidationError :: ParseResult a -> Bool
4253isValidationError (ValidationError _) = True
4354isValidationError _ = False
4455
56+-- zoomTo
57+-- :: ASetter' (JsonRepr s) (JsonRepr a)
58+-- -> Validation a
59+-- -> Validation s
60+-- zoomTo l =
61+
62+type ZoomTo path s
63+ = Demote [Path]
64+ -> Validation (ParseResult (JsonRepr s))
65+ -> Validation (ParseResult (JsonRepr (TraversePath path s)))
66+
67+zoomTo :: ZoomTo path s
68+zoomTo l = undefined
69+
4570validateTextConstraint
4671 :: JSONPath
4772 -> Text
@@ -206,7 +231,7 @@ validateJsonRepr sschema dpath jr = case jr of
206231 let newPath = dpath <> [DKey (knownFieldName f)]
207232 validateJsonRepr (knownFieldSchema f) newPath d
208233 go ftl
209− ReprUnion _ -> pure () -- FIXME
234+ ReprUnion _ -> pure ()
210235 -- case sschema of
211236 -- SSchemaUnion ss -> case ss of
212237 -- SCons s stl -> case umatch' s u of