git.iko.soy/typeable/schematic
on master help sign in
mlist check
commitaa474d06b837a909b4444d73afff8054bea9d132 authorDenis Redozubov <denis.redozubov@gmail.com> dateWed 14 Jun 2017, 01:28 (9 years ago) parent4e8e2c4
3 files changed+67−26
compare with master
unifiedsplit
src/Data/Schematic.hs+33 src/Data/Schematic/Migration.hs+13−15 test/SchemaSpec.hs+21−11
src/Data/Schematic.hs+33
@@ -7,9 +7,12 @@ module Data.Schematic
77 , module Data.Schematic.Utils
88 , decodeAndValidateJson
99 , parseAndValidateJson
10+ , parseAndValidateJsonBy
1011 , parseAndValidateVersionedJson
1112 , parseAndValidateTopVersionJson
1213 , decodeAndValidateVersionedJson
14+ , parseAndValidateWithMList
15+ , decodeAndValidateVersionedWithMList
1316 , isValid
1417 , isDecodingError
1518 , isValidationError
@@ -46,6 +49,13 @@ parseAndValidateJson v =
4649 Left em -> ValidationError em
4750 Right () -> Valid jsonRepr
4851
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+
4959parseAndValidateTopVersionJson
5060 :: forall proxy (v :: Versioned)
5161 . (SingI (TopVersion (AllVersions v)))
@@ -93,6 +103,16 @@ parseAndValidateVersionedJson
93103 -> ParseResult (JsonRepr (Snd (Head (AllVersions v))))
94104parseAndValidateVersionedJson _ v = mparse (sing :: Sing (AllVersions v)) v
95105
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+
96116decodeAndValidateJson
97117 :: forall schema
98118 . (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
@@ -110,3 +130,16 @@ decodeAndValidateVersionedJson
110130decodeAndValidateVersionedJson vp bs = case decode bs of
111131 Nothing -> DecodingError "malformed json"
112132 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
8080 SchemaByRevision r ('Versioned s (m ': ms)) =
8181 SchemaByRevision r ('Versioned (Snd (ApplyMigration m s)) ms)
8282
83+type family InitialSchema (v :: Versioned) = (s :: Schema) where
84+ InitialSchema ('Versioned s ms) = s
85+
8386type family ElemOf (e :: k) (l :: [(a,k)]) :: Constraint where
8487 ElemOf e '[] = 'True ~ 'False
8588 ElemOf e ( '(a, e) ': es) = ()
@@ -143,18 +146,13 @@ data instance Sing (v :: Versioned) where
143146 -> Sing (ms :: [Migration]) -- a bunch of migrations
144147 -> Sing ('Versioned s ms)
145148
146−-- type SchemaExample
147−-- = 'SchemaObject
148−-- '[ '("foo", 'SchemaArray '[ 'AEq 1] ( 'SchemaNumber '[ 'NGt 10 ]))
149−-- , '("bar", 'SchemaOptional ( 'SchemaText '[ 'TRegex "\\w+", 'TEnum '["foo", "bar"]]))]
150−
151−-- type VS =
152−-- 'Versioned SchemaExample
153−-- '[ 'Migration "test_revision"
154−-- '[ 'Diff '[ 'PKey "foo" ] ('Update ('SchemaText '[])) ] ]
155−
156−-- jsonExample :: JsonRepr (TopVersion (AllVersions VS))
157−-- jsonExample = ReprObject $
158−-- FieldRepr (ReprText "foo")
159−-- :& FieldRepr (ReprOptional (Just (ReprText "bar")))
160−-- :& RNil
149+data MList :: [Schema] -> Type where
150+ MNil :: (SingI s, TopLevel s) => MList '[s]
151+ (:&&)
152+ :: (SingI s, TopLevel s)
153+ => proxy s
154+ -> (JsonRepr h -> JsonRepr s)
155+ -> MList (h ': tl)
156+ -> MList (s ': h ': tl)
157+
158+infixr 7 :&&
test/SchemaSpec.hs+21−11
@@ -52,18 +52,23 @@ schemaJson2 = "{\"foo\": [3], \"bar\": null}"
5252schemaJsonTopVersion :: ByteString
5353schemaJsonTopVersion = "{ \"foo\": 42, \"bar\": \"bar\" }"
5454
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+
5565instance
56− MigrateSchema
57− ('SchemaObject
58− '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10 ])),
59− '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))])
60− ('SchemaObject
61− '[ '("foo", 'SchemaNumber '[]), '("bar", 'SchemaText '[])])
66+ MigrateSchema
67+ SchemaExample
68+ ('SchemaObject
69+ '[ '("foo", 'SchemaNumber '[]), '("bar", 'SchemaText '[])])
6270 where
63− migrate _ = ReprObject $
64− FieldRepr (ReprNumber 42)
65− :& FieldRepr (ReprText "test")
66− :& RNil
71+ migrate = const topObject
6772
6873spec :: Spec
6974spec = do
@@ -83,7 +88,12 @@ spec = do
8388 it "validates versioned json" $ do
8489 decodeAndValidateVersionedJson (Proxy @VS) schemaJson
8590 `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
8797
8898main :: IO ()
8999main = hspec spec