git.iko.soy/schematic
on master help sign in
mlist check
aa474d0Denis Redozubov
src/Data/Schematic.hs+33
compare with master
unifiedsplit
@@ -7,9 +7,12 @@ module Data.Schematic
7 , module Data.Schematic.Utils
7 , module Data.Schematic.Utils
8 , decodeAndValidateJson
8 , decodeAndValidateJson
9 , parseAndValidateJson
9 , parseAndValidateJson
10+ , parseAndValidateJsonBy
10 , parseAndValidateVersionedJson
11 , parseAndValidateVersionedJson
11 , parseAndValidateTopVersionJson
12 , parseAndValidateTopVersionJson
12 , decodeAndValidateVersionedJson
13 , decodeAndValidateVersionedJson
14+ , parseAndValidateWithMList
15+ , decodeAndValidateVersionedWithMList
13 , isValid
16 , isValid
14 , isDecodingError
17 , isDecodingError
15 , isValidationError
18 , isValidationError
@@ -46,6 +49,13 @@ parseAndValidateJson v =
46 Left em -> ValidationError em
49 Left em -> ValidationError em
47 Right () -> Valid jsonRepr
50 Right () -> Valid jsonRepr
48
51
52+parseAndValidateJsonBy
53+ :: (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
54+ => proxy schema
55+ -> J.Value
56+ -> ParseResult (JsonRepr schema)
57+parseAndValidateJsonBy _ = parseAndValidateJson
58+
49parseAndValidateTopVersionJson
59parseAndValidateTopVersionJson
50 :: forall proxy (v :: Versioned)
60 :: forall proxy (v :: Versioned)
51 . (SingI (TopVersion (AllVersions v)))
61 . (SingI (TopVersion (AllVersions v)))
@@ -93,6 +103,16 @@ parseAndValidateVersionedJson
93 -> ParseResult (JsonRepr (Snd (Head (AllVersions v))))
103 -> ParseResult (JsonRepr (Snd (Head (AllVersions v))))
94parseAndValidateVersionedJson _ v = mparse (sing :: Sing (AllVersions v)) v
104parseAndValidateVersionedJson _ v = mparse (sing :: Sing (AllVersions v)) v
95
105
106+parseAndValidateWithMList
107+ :: MList revisions
108+ -> J.Value
109+ -> ParseResult (JsonRepr (Head revisions))
110+parseAndValidateWithMList MNil v = parseAndValidateJson v
111+parseAndValidateWithMList ((:&&) p f tl) v = case parseAndValidateJsonBy p v of
112+ Valid a -> Valid a
113+ DecodingError _ -> f <$> parseAndValidateWithMList tl v
114+ ValidationError _ -> f <$> parseAndValidateWithMList tl v
115+
96decodeAndValidateJson
116decodeAndValidateJson
97 :: forall schema
117 :: forall schema
98 . (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
118 . (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
@@ -110,3 +130,16 @@ decodeAndValidateVersionedJson
110decodeAndValidateVersionedJson vp bs = case decode bs of
130decodeAndValidateVersionedJson vp bs = case decode bs of
111 Nothing -> DecodingError "malformed json"
131 Nothing -> DecodingError "malformed json"
112 Just x -> parseAndValidateVersionedJson vp x
132 Just x -> parseAndValidateVersionedJson vp x
133+
134+type family MapSnd (l :: [(a,k)]) = (r :: [k]) where
135+ MapSnd '[] = '[]
136+ MapSnd ( '(a, b) ': tl) = b ': MapSnd tl
137+
138+decodeAndValidateVersionedWithMList
139+ :: proxy versioned
140+ -> MList (MapSnd (AllVersions versioned))
141+ -> BL.ByteString
142+ -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))
143+decodeAndValidateVersionedWithMList _ mlist bs = case decode bs of
144+ Nothing -> DecodingError "malformed json"
145+ Just x -> parseAndValidateWithMList mlist x
src/Data/Schematic/Migration.hs+13−15
@@ -80,6 +80,9 @@ type family SchemaByRevision (r :: Revision) (vd :: Versioned) :: Schema where
80 SchemaByRevision r ('Versioned s (m ': ms)) =
80 SchemaByRevision r ('Versioned s (m ': ms)) =
81 SchemaByRevision r ('Versioned (Snd (ApplyMigration m s)) ms)
81 SchemaByRevision r ('Versioned (Snd (ApplyMigration m s)) ms)
82
82
83+type family InitialSchema (v :: Versioned) = (s :: Schema) where
84+ InitialSchema ('Versioned s ms) = s
85+
83type family ElemOf (e :: k) (l :: [(a,k)]) :: Constraint where
86type family ElemOf (e :: k) (l :: [(a,k)]) :: Constraint where
84 ElemOf e '[] = 'True ~ 'False
87 ElemOf e '[] = 'True ~ 'False
85 ElemOf e ( '(a, e) ': es) = ()
88 ElemOf e ( '(a, e) ': es) = ()
@@ -143,18 +146,13 @@ data instance Sing (v :: Versioned) where
143 -> Sing (ms :: [Migration]) -- a bunch of migrations
146 -> Sing (ms :: [Migration]) -- a bunch of migrations
144 -> Sing ('Versioned s ms)
147 -> Sing ('Versioned s ms)
145
148
146−-- type SchemaExample
149+data MList :: [Schema] -> Type where
147−-- = 'SchemaObject
150+ MNil :: (SingI s, TopLevel s) => MList '[s]
148−-- '[ '("foo", 'SchemaArray '[ 'AEq 1] ( 'SchemaNumber '[ 'NGt 10 ]))
151+ (:&&)
149−-- , '("bar", 'SchemaOptional ( 'SchemaText '[ 'TRegex "\\w+", 'TEnum '["foo", "bar"]]))]
152+ :: (SingI s, TopLevel s)
150−
153+ => proxy s
151−-- type VS =
154+ -> (JsonRepr h -> JsonRepr s)
152−-- 'Versioned SchemaExample
155+ -> MList (h ': tl)
153−-- '[ 'Migration "test_revision"
156+ -> MList (s ': h ': tl)
154−-- '[ 'Diff '[ 'PKey "foo" ] ('Update ('SchemaText '[])) ] ]
157+
155−
158+infixr 7 :&&
156−-- jsonExample :: JsonRepr (TopVersion (AllVersions VS))
157−-- jsonExample = ReprObject $
158−-- FieldRepr (ReprText "foo")
159−-- :& FieldRepr (ReprOptional (Just (ReprText "bar")))
160−-- :& RNil
test/SchemaSpec.hs+21−11
@@ -52,18 +52,23 @@ schemaJson2 = "{\"foo\": [3], \"bar\": null}"
52schemaJsonTopVersion :: ByteString
52schemaJsonTopVersion :: ByteString
53schemaJsonTopVersion = "{ \"foo\": 42, \"bar\": \"bar\" }"
53schemaJsonTopVersion = "{ \"foo\": 42, \"bar\": \"bar\" }"
54
54
55+topObject
56+ :: JsonRepr
57+ ('SchemaObject
58+ '[ '("foo", 'SchemaNumber '[])
59+ , '("bar", 'SchemaText '[])])
60+topObject = ReprObject $
61+ FieldRepr (ReprNumber 42)
62+ :& FieldRepr (ReprText "test")
63+ :& RNil
64+
55instance
65instance
56− MigrateSchema
66+ MigrateSchema
57− ('SchemaObject
67+ SchemaExample
58− '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10 ])),
59− '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))])
60− ('SchemaObject
68+ ('SchemaObject
61− '[ '("foo", 'SchemaNumber '[]), '("bar", 'SchemaText '[])])
69+ '[ '("foo", 'SchemaNumber '[]), '("bar", 'SchemaText '[])])
62 where
70 where
63− migrate _ = ReprObject $
71+ migrate = const topObject
64− FieldRepr (ReprNumber 42)
65− :& FieldRepr (ReprText "test")
66− :& RNil
67
72
68spec :: Spec
73spec :: Spec
69spec = do
74spec = do
@@ -83,7 +88,12 @@ spec = do
83 it "validates versioned json" $ do
88 it "validates versioned json" $ do
84 decodeAndValidateVersionedJson (Proxy @VS) schemaJson
89 decodeAndValidateVersionedJson (Proxy @VS) schemaJson
85 `shouldSatisfy` isValid
90 `shouldSatisfy` isValid
86−
91+ it "validates with Migration List" $ do
92+ decodeAndValidateVersionedWithMList
93+ (Proxy @VS)
94+ ((:&&) (Proxy @(SchemaByRevision "test_revision" VS)) (const topObject) MNil)
95+ schemaJson
96+ `shouldSatisfy` isValid
87
97
88main :: IO ()
98main :: IO ()
89main = hspec spec
99main = hspec spec