Skip to content

Commit 074720a

Browse files
adamgundryadamgundry
authored
Merge pull request #90 from iconnect/adinapoli/alternative-changes
Support migrating individual alternatives in unions
2 parents 8b85714 + 2dd637d commit 074720a

10 files changed

Lines changed: 350 additions & 48 deletions

File tree

‎api-tools.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -176,6 +176,8 @@ Test-Suite test-api-tools
176176
Data.API.Test.Migration
177177
Data.API.Test.MigrationData
178178
Data.API.Test.Time
179+
Data.API.Test.UnionMigration
180+
Data.API.Test.UnionMigrationData
179181

180182
Build-depends:
181183
api-tools,

‎main/MigrationTool.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -71,10 +71,11 @@ readApiFile file = fmap (parseAPIWithChangelog file (0,0)) (readFile file)
7171
data ChangeTag = None
7272
deriving (Read, Show)
7373

74-
customMigrations :: CustomMigrations JS.Object JS.Value ChangeTag ChangeTag ChangeTag
74+
customMigrations :: CustomMigrations JS.Object JS.Value ChangeTag ChangeTag ChangeTag ChangeTag
7575
customMigrations = CustomMigrations (nope JS.Object) (const noSchemaChanges)
7676
(nope id) (const noSchemaChanges)
7777
(nope id)
78+
(nope id)
7879
where
7980
nope toVal _ v = Left (CustomMigrationError "No custom migrations defined" (toVal v))
8081

‎src/Data/API/Changes.hs‎

Lines changed: 69 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -94,11 +94,11 @@ import Safe
9494
-- custom migration tags in the changelog, as generated by
9595
-- 'generateMigrationKind'.
9696

97-
migrateDataDump :: (Read db, Read rec, Read fld)
97+
migrateDataDump :: (Read db, Read rec, Read alt, Read fld)
9898
=> (API, Version) -- ^ Starting schema and version
9999
-> (API, VersionExtra) -- ^ Ending schema and version
100100
-> APIChangelog -- ^ Log of changes, containing both versions
101-
-> CustomMigrations JS.Object JS.Value db rec fld -- ^ Custom migration functions
101+
-> CustomMigrations JS.Object JS.Value db rec alt fld -- ^ Custom migration functions
102102
-> TypeName -- ^ Name of the dataset's type
103103
-> DataChecks -- ^ How thoroughly to validate changes
104104
-> JS.Value -- ^ Dataset to be migrated
@@ -110,11 +110,11 @@ migrateDataDump startApi endApi changelog custom root chks db = do
110110
db' <- applyChangesToDatabase root custom' db changes ?!? uncurry ValueError
111111
return (db', warnings)
112112

113-
migrateDataDump' :: (Read db, Read rec, Read fld)
113+
migrateDataDump' :: (Read db, Read rec, Read alt, Read fld)
114114
=> (API, Version) -- ^ Starting schema and version
115115
-> (API, VersionExtra) -- ^ Ending schema and version
116116
-> APIChangelog -- ^ Log of changes, containing both versions
117-
-> CustomMigrations Record Value db rec fld -- ^ Custom migration functions
117+
-> CustomMigrations Record Value db rec alt fld -- ^ Custom migration functions
118118
-> TypeName -- ^ Name of the dataset's type
119119
-> DataChecks -- ^ How thoroughly to validate changes
120120
-> Value.Value -- ^ Dataset to be migrated
@@ -129,36 +129,41 @@ migrateDataDump' startApi endApi changelog custom root chks db = do
129129

130130

131131
-- | Custom migrations used in the changelog must be implemented in
132-
-- Haskell, and supplied in this record. There are three kinds:
132+
-- Haskell, and supplied in this record. There are four kinds:
133133
--
134134
-- * Whole-database migrations, which may arbitrarily change the API
135135
-- schema and the data to match;
136136
--
137-
-- * Type migrations, which may change the schema of a single type; and
137+
-- * Type migrations, which may change the schema of a single type;
138+
--
139+
-- * Union alternative migrations, which may change the type of a
140+
-- single alternative within a union (with the new type specified in
141+
-- the changelog); and
138142
--
139143
-- * Single field migrations, which may change only the type of the
140144
-- field (with the new type specified in the changelog).
141145
--
142146
-- For database and type migrations, if the schema is unchanged, the
143147
-- corresponding function should return 'Nothing'.
144148
--
145-
-- The @db@, @ty@ and @fld@ parameters should be instantiated with
146-
-- the enumeration types generated by 'generateMigrationKinds', which
147-
-- correspond to the exact set of custom migration tags used in the
148-
-- changelog.
149-
data CustomMigrations o v db ty fld = CustomMigrations
149+
-- The @db@, @ty@, @alt@ and @fld@ parameters should be instantiated
150+
-- with the enumeration types generated by 'generateMigrationKinds',
151+
-- which correspond to the exact set of custom migration tags used in
152+
-- the changelog.
153+
data CustomMigrations o v db ty alt fld = CustomMigrations
150154
{ databaseMigration :: db -> o -> Either ValueError o
151155
, databaseMigrationSchema :: db -> NormAPI -> Either ApplyFailure (Maybe NormAPI)
152156
, typeMigration :: ty -> v -> Either ValueError v
153157
, typeMigrationSchema :: ty -> NormTypeDecl -> Either ApplyFailure (Maybe NormTypeDecl)
158+
, unionAltMigration :: alt -> v -> Either ValueError v
154159
, fieldMigration :: fld -> v -> Either ValueError v }
155160

156-
type CustomMigrationsTagged o v = CustomMigrations o v MigrationTag MigrationTag MigrationTag
161+
type CustomMigrationsTagged o v = CustomMigrations o v MigrationTag MigrationTag MigrationTag MigrationTag
157162

158-
readCustomMigrations :: (Read db, Read ty, Read fld)
159-
=> CustomMigrations o v db ty fld -> CustomMigrationsTagged o v
160-
readCustomMigrations (CustomMigrations db dbs r rs f) =
161-
CustomMigrations (db . read) (dbs . read) (r . read) (rs . read) (f . read)
163+
readCustomMigrations :: (Read db, Read ty, Read alt, Read fld)
164+
=> CustomMigrations o v db ty alt fld -> CustomMigrationsTagged o v
165+
readCustomMigrations (CustomMigrations db dbs r rs a f) =
166+
CustomMigrations (db . read) (dbs . read) (r . read) (rs . read) (a . read) (f . read)
162167

163168
-- | Lift a custom record migration to work on arbitrary values
164169
mkRecordMigration :: (JS.Object -> Either ValueError JS.Object)
@@ -200,10 +205,11 @@ data DataChecks = NoChecks -- ^ Not at all
200205

201206
-- | Whether to validate the dataset after this change
202207
validateAfter :: DataChecks -> APIChange -> Bool
203-
validateAfter chks (ChChangeField{}) = chks >= CheckCustom
204-
validateAfter chks (ChCustomType{}) = chks >= CheckCustom
205-
validateAfter chks (ChCustomAll{}) = chks >= CheckCustom
206-
validateAfter chks _ = chks >= CheckAll
208+
validateAfter chks (ChChangeField{}) = chks >= CheckCustom
209+
validateAfter chks (ChChangeUnionAlt{}) = chks >= CheckCustom
210+
validateAfter chks (ChCustomType{}) = chks >= CheckCustom
211+
validateAfter chks (ChCustomAll{}) = chks >= CheckCustom
212+
validateAfter chks _ = chks >= CheckAll
207213

208214

209215
--------------------
@@ -243,22 +249,23 @@ isChangelogOrdered changelog =
243249

244250

245251
-- | Sets of custom migration tags in the changelog for
246-
-- whole-database, single-record and single-field migrations
247-
changelogTags :: APIChangelog -> (Set MigrationTag, Set MigrationTag, Set MigrationTag)
248-
changelogTags (ChangesStart _) = (Set.empty, Set.empty, Set.empty)
252+
-- whole-database, single-type, union-alternative and single-field migrations
253+
changelogTags :: APIChangelog -> (Set MigrationTag, Set MigrationTag, Set MigrationTag, Set MigrationTag)
254+
changelogTags (ChangesStart _) = (Set.empty, Set.empty, Set.empty, Set.empty)
249255
changelogTags (ChangesUpTo _ cs older) =
250-
unions3 (map changeTags cs) `union3` changelogTags older
256+
unions4 (map changeTags cs) `union4` changelogTags older
251257
where
252-
union3 (a, b, c) (x, y, z) = (a `Set.union` x, b `Set.union` y, c `Set.union` z)
253-
unions3 xyzs = (Set.unions xs, Set.unions ys, Set.unions zs)
254-
where (xs, ys, zs) = unzip3 xyzs
258+
union4 (a, b, c, d) (x, y, z, w) = (a `Set.union` x, b `Set.union` y, c `Set.union` z, d `Set.union` w)
259+
unions4 xyzws = (Set.unions xs, Set.unions ys, Set.unions zs, Set.unions ws)
260+
where (xs, ys, zs, ws) = unzip4 xyzws
255261

256262
-- | Sets of custom migration tags in a single change
257-
changeTags :: APIChange -> (Set MigrationTag, Set MigrationTag, Set MigrationTag)
258-
changeTags (ChChangeField _ _ _ t) = (Set.empty, Set.empty, Set.singleton t)
259-
changeTags (ChCustomType _ t) = (Set.empty, Set.singleton t, Set.empty)
260-
changeTags (ChCustomAll t) = (Set.singleton t, Set.empty, Set.empty)
261-
changeTags _ = (Set.empty, Set.empty, Set.empty)
263+
changeTags :: APIChange -> (Set MigrationTag, Set MigrationTag, Set MigrationTag, Set MigrationTag)
264+
changeTags (ChChangeField _ _ _ t) = (Set.empty, Set.empty, Set.empty, Set.singleton t)
265+
changeTags (ChChangeUnionAlt _ _ _ t) = (Set.empty, Set.empty, Set.singleton t, Set.empty)
266+
changeTags (ChCustomType _ t) = (Set.empty, Set.singleton t, Set.empty, Set.empty)
267+
changeTags (ChCustomAll t) = (Set.singleton t, Set.empty, Set.empty, Set.empty)
268+
changeTags _ = (Set.empty, Set.empty, Set.empty, Set.empty)
262269

263270

264271
--------------------------------
@@ -304,11 +311,11 @@ findUpdatePos tname api = Map.alter (Just . UpdateHere) tname $
304311

305312
-- | Check that a changelog adequately describes how to migrate from
306313
-- one version to another.
307-
validateChanges :: (Read db, Read rec, Read fld)
314+
validateChanges :: (Read db, Read rec, Read alt, Read fld)
308315
=> (API, Version) -- ^ Starting schema and version
309316
-> (API, VersionExtra) -- ^ Ending schema and version
310317
-> APIChangelog -- ^ Changelog to be validated
311-
-> CustomMigrations o v db rec fld -- ^ Custom migration functions
318+
-> CustomMigrations o v db rec alt fld -- ^ Custom migration functions
312319
-> TypeName -- ^ Name of the dataset's type
313320
-> DataChecks -- ^ How thoroughly to validate changes
314321
-> Either ValidateFailure [ValidateWarning]
@@ -484,6 +491,14 @@ applyAPIChangeToAPI _ _ (ChRenameUnionAlt tname fname fname') api = do
484491
. Map.delete fname) unioninfo
485492
return (Map.insert tname tinfo' api, findUpdatePos tname api)
486493

494+
applyAPIChangeToAPI _ _custom (ChChangeUnionAlt tname fname ftype _tag) api = do
495+
tinfo <- lookupType tname api
496+
unioninfo <- expectUnionType tinfo ?! TypeWrongKind tname TKUnion
497+
guard (Map.member fname unioninfo) ?! FieldDoesNotExist tname TKUnion fname
498+
typeIsValid ftype api ?!? TypeMalformed ftype
499+
let tinfo' = (NUnionType . Map.insert fname ftype) unioninfo
500+
return (Map.insert tname tinfo' api, findUpdatePos tname api)
501+
487502
applyAPIChangeToAPI _ _ (ChAddEnumVal tname fname) api = do
488503
tinfo <- lookupType tname api
489504
enuminfo <- expectEnumType tinfo ?! TypeWrongKind tname TKEnum
@@ -607,6 +622,13 @@ applyChangeToData (ChRenameUnionAlt _ fname fname') _ = withObject $ \un p ->
607622
| otherwise -> return un
608623
Nothing -> Left (JSONError $ SyntaxError "Not singleton", p)
609624

625+
applyChangeToData (ChChangeUnionAlt _ fname _ftype tag) custom = withObject $ \un p ->
626+
case matchSingletonObject un of
627+
Just (k, r) | k == _FieldName fname -> do
628+
r' <- liftMigration (unionAltMigration custom tag) r p
629+
return $ singletonObject (_FieldName fname) r'
630+
_ -> return un
631+
610632
applyChangeToData (ChRenameEnumVal _ fname fname') _ = withString $ \s _ ->
611633
if s == _FieldName fname then return (_FieldName fname')
612634
else return s
@@ -718,6 +740,12 @@ applyChangeToData' _ (ChRenameUnionAlt _ fname fname') _ v p = do
718740
(fn, v') <- expectUnion v p
719741
pure $! if fn == fname then Union fname' v' else v
720742

743+
applyChangeToData' _ (ChChangeUnionAlt _ fname _ftype tag) custom v p = do
744+
(fn, v') <- expectUnion v p
745+
if fn == fname
746+
then Union fn <$!> liftMigration (unionAltMigration custom tag) v' (inField fn:p)
747+
else pure v
748+
721749
applyChangeToData' _ (ChRenameEnumVal _ fname fname') _ v p = do
722750
fn <- expectEnum v p
723751
pure $! if fn == fname then Enum fname' else v
@@ -864,17 +892,21 @@ type Decode t = JS.Value -> Either [(JSONError, Position)] t
864892

865893
-- | Generate enumeration datatypes corresponding to the custom
866894
-- migrations used in an API migration changelog.
867-
generateMigrationKinds :: APIChangelog -> String -> String -> String -> Q [Dec]
868-
generateMigrationKinds changes all_nm rec_nm fld_nm = do
895+
generateMigrationKinds :: APIChangelog -> String -> String -> String -> String -> Q [Dec]
896+
generateMigrationKinds changes all_nm rec_nm alt_nm fld_nm = do
869897
guardNoDups (all_tags `Set.intersection` rec_tags)
898+
guardNoDups (all_tags `Set.intersection` alt_tags)
870899
guardNoDups (all_tags `Set.intersection` fld_tags)
900+
guardNoDups (rec_tags `Set.intersection` alt_tags)
871901
guardNoDups (rec_tags `Set.intersection` fld_tags)
902+
guardNoDups (alt_tags `Set.intersection` fld_tags)
872903

873904
return [ mkDataD [] (mkName all_nm) [] (cons all_nm all_tags) derivs
874905
, mkDataD [] (mkName rec_nm) [] (cons rec_nm rec_tags) derivs
906+
, mkDataD [] (mkName alt_nm) [] (cons alt_nm alt_tags) derivs
875907
, mkDataD [] (mkName fld_nm) [] (cons fld_nm fld_tags) derivs ]
876908
where
877-
(all_tags, rec_tags, fld_tags) = changelogTags changes
909+
(all_tags, rec_tags, alt_tags, fld_tags) = changelogTags changes
878910

879911
guardNoDups xs
880912
| Set.null xs = return ()

‎src/Data/API/Changes/Types.hs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -57,6 +57,7 @@ data APIChange
5757
| ChAddUnionAlt TypeName FieldName APIType
5858
| ChDeleteUnionAlt TypeName FieldName
5959
| ChRenameUnionAlt TypeName FieldName FieldName
60+
| ChChangeUnionAlt TypeName FieldName APIType MigrationTag
6061

6162
-- Changes for enum types
6263
| ChAddEnumVal TypeName FieldName
@@ -87,6 +88,9 @@ instance PPLines APIChange where
8788
, " alternative removed " ++ pp f]
8889
ppLines (ChRenameUnionAlt t f f') = [ "changed union " ++ pp t
8990
, " alternative renamed " ++ pp f ++ " to " ++ pp f']
91+
ppLines (ChChangeUnionAlt t f ty c) = [ "changed union " ++ pp t
92+
, " alternative changed " ++ pp f ++ " :: " ++ pp ty
93+
++ " migration " ++ pp c]
9094
ppLines (ChAddEnumVal t f) = [ "changed enum " ++ pp t
9195
, " alternative added " ++ pp f]
9296
ppLines (ChDeleteEnumVal t f) = [ "changed enum " ++ pp t

‎src/Data/API/Parse.y‎

Lines changed: 6 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -280,6 +280,7 @@ UnionChange :: { [UnionChange] }
280280
: alternative added FieldName '::' Type { [UnChAdd $3 $5] }
281281
| alternative removed FieldName { [UnChDelete $3] }
282282
| alternative renamed FieldName to FieldName { [UnChRename $3 $5] }
283+
| alternative changed FieldName '::' Type migration MigrationTag { [UnChChange $3 $5 $7] }
283284
| comment { [] }
284285

285286
REnumChanges :: { [EnumChange] }
@@ -331,11 +332,13 @@ fldChangeToAPIChange t (FldChChange f ty m) = ChChangeField t f ty m
331332
data UnionChange = UnChAdd FieldName APIType
332333
| UnChDelete FieldName
333334
| UnChRename FieldName FieldName
335+
| UnChChange FieldName APIType MigrationTag
334336

335337
unionChangeToAPIChange :: TypeName -> UnionChange -> APIChange
336-
unionChangeToAPIChange t (UnChAdd f ty) = ChAddUnionAlt t f ty
337-
unionChangeToAPIChange t (UnChDelete f) = ChDeleteUnionAlt t f
338-
unionChangeToAPIChange t (UnChRename f f') = ChRenameUnionAlt t f f'
338+
unionChangeToAPIChange t (UnChAdd f ty) = ChAddUnionAlt t f ty
339+
unionChangeToAPIChange t (UnChDelete f) = ChDeleteUnionAlt t f
340+
unionChangeToAPIChange t (UnChRename f f') = ChRenameUnionAlt t f f'
341+
unionChangeToAPIChange t (UnChChange f ty m) = ChChangeUnionAlt t f ty m
339342

340343
data EnumChange = EnChAdd FieldName
341344
| EnChDelete FieldName

‎src/Data/API/Tutorial.hs‎

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -301,13 +301,14 @@ These types should then be used to create a 'CustomMigrations' record,
301301
which describes how to transform the data (and 'API', if appropriate)
302302
for each custom migration. For example,
303303
304-
> $(generateMigrationKinds myChangelog "DatabaseMigration" "TypeMigration" "FieldMigration")
304+
> $(generateMigrationKinds myChangelog "DatabaseMigration" "TypeMigration" "UnionAltMigration" "FieldMigration")
305305
306306
with the changelog fragment above would give
307307
308-
> data DatabaseMigration = MigrateWholeDatabase | ...
309-
> data TypeMigration = MigrateWidgetType | ...
310-
> data FieldMigration = MigrateFooField | ...
308+
> data DatabaseMigration = MigrateWholeDatabase | ...
309+
> data TypeMigration = MigrateWidgetType | ...
310+
> data UnionAltMigration = ...
311+
> data FieldMigration = MigrateFooField | ...
311312
312313
Calls to 'migrateDataDump' should include a suitable
313314
'CustomMigrations' record, which includes functions to perform the

‎tests/Data/API/Test/Main.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@ import Data.API.API.Gen
33
import Data.API.Test.JSON
44
import Data.API.Test.Migration
55
import Data.API.Test.Time
6+
import Data.API.Test.UnionMigration
67

78
import Test.Tasty
89
import Test.Tasty.QuickCheck
@@ -12,6 +13,7 @@ main = defaultMain tests
1213

1314
tests :: TestTree
1415
tests = testGroup "api-tools" [ migrationTests
16+
, unionMigrationTests
1517
, jsonTests
1618
, timeTests
1719
, testProperty "Convert/unconvert" convertUncovertTest

‎tests/Data/API/Test/Migration.hs‎

Lines changed: 5 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -40,7 +40,7 @@ import qualified Data.HashMap.Strict as HMap
4040
#endif
4141

4242

43-
$(generateMigrationKinds changelog "TestDatabaseMigration" "TestRecordMigration" "TestFieldMigration")
43+
$(generateMigrationKinds changelog "TestDatabaseMigration" "TestRecordMigration" "TestUnionAltMigration" "TestFieldMigration")
4444

4545

4646
-- Test of a whole-database migration: copy data between tables
@@ -121,18 +121,20 @@ testFieldMigration' ConvertBinaryToString (Value.Bytes bs) = return (Value.Strin
121121
testFieldMigration' ConvertBinaryToString v = Left $ CustomMigrationError "bad data" (JS.toJSON v)
122122

123123

124-
testMigration :: CustomMigrations JS.Object JS.Value TestDatabaseMigration TestRecordMigration TestFieldMigration
124+
testMigration :: CustomMigrations JS.Object JS.Value TestDatabaseMigration TestRecordMigration TestUnionAltMigration TestFieldMigration
125125
testMigration = CustomMigrations testDatabaseMigration
126126
testDatabaseMigrationSchema
127127
testRecordMigration
128128
testRecordMigrationSchema
129+
(\ _ -> noDataChanges)
129130
testFieldMigration
130131

131-
testMigration' :: CustomMigrations Value.Record Value.Value TestDatabaseMigration TestRecordMigration TestFieldMigration
132+
testMigration' :: CustomMigrations Value.Record Value.Value TestDatabaseMigration TestRecordMigration TestUnionAltMigration TestFieldMigration
132133
testMigration' = CustomMigrations testDatabaseMigration'
133134
testDatabaseMigrationSchema
134135
testRecordMigration'
135136
testRecordMigrationSchema
137+
(\ _ -> noDataChanges)
136138
testFieldMigration'
137139

138140

0 commit comments

Comments
 (0)