git.iko.soy/typeable/schematic
on master help sign in
Migration system fixed
commit2033814e2a38e4a1bc113c3b2adc4376ec05435d authorDenis Redozubov <denis.redozubov@gmail.com> dateTue 13 Jun 2017, 14:59 (9 years ago) parenta0b362e
3 files changed+37−46
compare with master
unifiedsplit
src/Data/Schematic.hs+11−33 src/Data/Schematic/Migration.hs+1−4 test/SchemaSpec.hs+25−9
src/Data/Schematic.hs+11−33
@@ -70,7 +70,10 @@ class Migratable (revisions :: [(Revision, Schema)]) where
7070 -> J.Value
7171 -> ParseResult (JsonRepr (Snd (Head revisions)))
7272
73−instance {-# OVERLAPPING #-} (TopLevel (Snd rev), SingI (Snd rev)) => Migratable '[rev] where
73+instance
74+ {-# OVERLAPPING #-}
75+ ( TopLevel (Snd rev), SingI (Snd rev) )
76+ => Migratable '[rev] where
7477 mparse _ = parseAndValidateJson
7578
7679instance {-# OVERLAPPABLE #-}
@@ -79,41 +82,16 @@ instance {-# OVERLAPPABLE #-}
7982 , SingI (Snd (Head revisions)))
8083 => Migratable revisions where
8184 mparse s v = case parseEither parseJSON v of
82− Left _ -> migrate <$> mparse (sTail s) v
85+ Left _ ->
86+ migrate <$> (mparse (sTail s) v :: ParseResult (JsonRepr (Snd (Head (Tail revisions)))))
8387 Right x -> Valid x
84−-- type family Migratable (revisions :: [(Revision, Schema)]) = (cs :: Constraint) where
85−-- Migratable '[rev] = (TopLevel (Snd rev), SingI (Snd rev))
86−-- Migratable revisions =
87−-- ( Migratable (Tail revisions)
88−-- , MigrateSchema (Snd (Head (Tail revisions))) (Snd (Head revisions))
89−-- , SingI (Snd (Head revisions)))
90−
91−-- mparseBySing
92−-- :: Sing schema
93−-- -> J.Value
94−-- -> ParseResult (JsonRepr (Snd (Head revisions)))
95−-- mparseBySing s v = undefined
96−
97−-- mparse
98−-- :: Migratable revisions
99−-- => Sing revisions
100−-- -> J.Value
101−-- -> ParseResult (JsonRepr (Snd (Head revisions)))
102−-- mparse s v =
103−-- let
104−-- st = sTail s
105−-- sth = sSnd $ sHead st
106−-- SCons x SNil -> parseAndValidateJson v
107−-- SCons sch _ -> case parseEither parseJSON v of
108−-- Left _ -> migrate <$> mparse (sTail s) v
109−-- Right x -> Valid x
11088
11189parseAndValidateVersionedJson
112− :: forall proxy v. (SingI (AllVersions v), Migratable (AllVersions v))
90+ :: forall proxy v. (SingI (Reverse (AllVersions v)), Migratable (Reverse (AllVersions v)))
11391 => proxy v
11492 -> J.Value
115− -> ParseResult (JsonRepr (Snd (Head (AllVersions v))))
116−parseAndValidateVersionedJson _ v = mparse (sing :: Sing (AllVersions v)) v
93+ -> ParseResult (JsonRepr (Snd (Head (Reverse (AllVersions v)))))
94+parseAndValidateVersionedJson _ v = mparse (sing :: Sing (Reverse (AllVersions v))) v
11795
11896decodeAndValidateJson
11997 :: forall schema
@@ -125,10 +103,10 @@ decodeAndValidateJson bs = case decode bs of
125103 Just x -> parseAndValidateJson x
126104
127105decodeAndValidateVersionedJson
128− :: (Migratable (AllVersions versioned), SingI (AllVersions versioned))
106+ :: (Migratable (Reverse (AllVersions versioned)), SingI (Reverse (AllVersions versioned)))
129107 => proxy versioned
130108 -> BL.ByteString
131− -> ParseResult (JsonRepr (Snd (Head (AllVersions versioned))))
109+ -> ParseResult (JsonRepr (Snd (Head (Reverse (AllVersions versioned)))))
132110decodeAndValidateVersionedJson vp bs = case decode bs of
133111 Nothing -> DecodingError "malformed json"
134112 Just x -> parseAndValidateVersionedJson vp x
src/Data/Schematic/Migration.hs+1−4
@@ -92,7 +92,7 @@ type family AllVersions (vd :: Versioned) :: [(Revision, Schema)] where
9292type family AllVersions' (acc :: [(Revision, Schema)]) (ms :: [Migration]) = (r :: [(Revision, Schema)]) where
9393 AllVersions' acc '[] = acc
9494 AllVersions' ( '(rh, sh) ': tl ) (m ': ms) =
95− AllVersions' ( ApplyMigration m sh ': tl ) ms
95+ AllVersions' ( '(rh, sh) ': ApplyMigration m sh ': tl ) ms
9696
9797type family TopVersion (rs :: [(Revision, Schema)]) :: Schema where
9898 TopVersion ( '(rh, sh) ': tl) = sh
@@ -100,9 +100,6 @@ type family TopVersion (rs :: [(Revision, Schema)]) :: Schema where
100100class MigrateSchema (a :: Schema) (b :: Schema) where
101101 migrate :: JsonRepr a -> JsonRepr b
102102
103−instance MigrateSchema a a where
104− migrate = id
105−
106103data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol
107104
108105data instance Sing (a :: Action) where
test/SchemaSpec.hs+25−9
@@ -8,6 +8,7 @@ import Data.Aeson
88import Data.Proxy
99import Data.Schematic
1010import Data.Singletons
11+import Data.Singletons.Prelude
1112import Data.Vinyl
1213import Test.Hspec
1314import Test.Hspec.SmallCheck
@@ -16,15 +17,16 @@ import Test.SmallCheck.Series.Instances
1617
1718
1819type SchemaExample
19− = SchemaObject
20− '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))
21− , '("bar", SchemaOptional (SchemaText '[TEnum '["foo", "bar"]]))]
20+ = 'SchemaObject
21+ '[ '("foo", 'SchemaArray '[AEq 1] ('SchemaNumber '[NGt 10]))
22+ , '("bar", 'SchemaOptional ('SchemaText '[TEnum '["foo", "bar"]]))]
2223
23−type VS =
24− 'Versioned SchemaExample
25− '[ 'Migration "test_revision"
26− '[ 'Diff '[ 'PKey "bar" ] ('Update ('SchemaText '[]))
27− , 'Diff '[ 'PKey "foo" ] ('Update ('SchemaNumber '[])) ] ]
24+type TestMigration =
25+ 'Migration "test_revision"
26+ '[ 'Diff '[ 'PKey "bar" ] ('Update ('SchemaText '[]))
27+ , 'Diff '[ 'PKey "foo" ] ('Update ('SchemaNumber '[])) ]
28+
29+type VS = 'Versioned SchemaExample '[ TestMigration ]
2830
2931exampleTest :: JsonRepr (SchemaOptional (SchemaText '[TEq 3]))
3032exampleTest = ReprOptional (Just (ReprText "lil"))
@@ -50,6 +52,19 @@ schemaJson2 = "{\"foo\": [3], \"bar\": null}"
5052schemaJsonTopVersion :: ByteString
5153schemaJsonTopVersion = "{ \"foo\": 42, \"bar\": \"bar\" }"
5254
55+instance
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 '[])])
62+ where
63+ migrate _ = ReprObject $
64+ FieldRepr (ReprNumber 42)
65+ :& FieldRepr (ReprText "test")
66+ :& RNil
67+
5368spec :: Spec
5469spec = do
5570 -- it "show/read JsonRepr properly" $
@@ -66,8 +81,9 @@ spec = do
6681 ((decodeAndValidateJson schemaJson2) :: ParseResult (JsonRepr SchemaExample))
6782 `shouldSatisfy` isValidationError
6883 it "validates versioned json" $ do
69− (decodeAndValidateVersionedJson (Proxy @VS) schemaJsonTopVersion)
84+ decodeAndValidateVersionedJson (Proxy @VS) schemaJson
7085 `shouldSatisfy` isValid
7186
87+
7288main :: IO ()
7389main = hspec spec