Address Adam's feedback

Author: adinapoli

main/MigrationTool.hs

@@ -71,10 +71,11 @@ readApiFile file = fmap (parseAPIWithChangelog file (0,0)) (readFile file)
 data ChangeTag = None
     deriving (Read, Show)
 
-customMigrations :: CustomMigrations JS.Object JS.Value ChangeTag ChangeTag ChangeTag
+customMigrations :: CustomMigrations JS.Object JS.Value ChangeTag ChangeTag ChangeTag ChangeTag
 customMigrations = CustomMigrations (nope JS.Object) (const noSchemaChanges)
                                     (nope id)        (const noSchemaChanges)
                                     (nope id)
+                                    (nope id)
   where
     nope toVal _ v = Left (CustomMigrationError "No custom migrations defined" (toVal v))
 

src/Data/API/Changes.hs

@@ -94,11 +94,11 @@ import           Safe
 -- custom migration tags in the changelog, as generated by
 -- 'generateMigrationKind'.
 
-migrateDataDump :: (Read db, Read rec, Read fld)
+migrateDataDump :: (Read db, Read rec, Read alt, Read fld)
                 => (API, Version)               -- ^ Starting schema and version
                 -> (API, VersionExtra)          -- ^ Ending schema and version
                 -> APIChangelog                 -- ^ Log of changes, containing both versions
-                -> CustomMigrations JS.Object JS.Value db rec fld  -- ^ Custom migration functions
+                -> CustomMigrations JS.Object JS.Value db rec alt fld  -- ^ Custom migration functions
                 -> TypeName                     -- ^ Name of the dataset's type
                 -> DataChecks                   -- ^ How thoroughly to validate changes
                 -> JS.Value                     -- ^ Dataset to be migrated
@@ -110,11 +110,11 @@ migrateDataDump startApi endApi changelog custom root chks db = do
     db' <- applyChangesToDatabase root custom' db changes  ?!? uncurry ValueError
     return (db', warnings)
 
-migrateDataDump' :: (Read db, Read rec, Read fld)
+migrateDataDump' :: (Read db, Read rec, Read alt, Read fld)
                 => (API, Version)               -- ^ Starting schema and version
                 -> (API, VersionExtra)          -- ^ Ending schema and version
                 -> APIChangelog                 -- ^ Log of changes, containing both versions
-                -> CustomMigrations Record Value db rec fld  -- ^ Custom migration functions
+                -> CustomMigrations Record Value db rec alt fld  -- ^ Custom migration functions
                 -> TypeName                     -- ^ Name of the dataset's type
                 -> DataChecks                   -- ^ How thoroughly to validate changes
                 -> Value.Value                  -- ^ Dataset to be migrated
@@ -129,36 +129,41 @@ migrateDataDump' startApi endApi changelog custom root chks db = do
 
 
 -- | Custom migrations used in the changelog must be implemented in
--- Haskell, and supplied in this record.  There are three kinds:
+-- Haskell, and supplied in this record.  There are four kinds:
 --
 -- * Whole-database migrations, which may arbitrarily change the API
 -- schema and the data to match;
 --
--- * Type migrations, which may change the schema of a single type; and
+-- * Type migrations, which may change the schema of a single type;
+--
+-- * Union alternative migrations, which may change the type of a
+-- single alternative within a union (with the new type specified in
+-- the changelog); and
 --
 -- * Single field migrations, which may change only the type of the
 -- field (with the new type specified in the changelog).
 --
 -- For database and type migrations, if the schema is unchanged, the
 -- corresponding function should return 'Nothing'.
 --
--- The @db@, @ty@ and @fld@ parameters should be instantiated with
--- the enumeration types generated by 'generateMigrationKinds', which
--- correspond to the exact set of custom migration tags used in the
--- changelog.
-data CustomMigrations o v db ty fld = CustomMigrations
+-- The @db@, @ty@, @alt@ and @fld@ parameters should be instantiated
+-- with the enumeration types generated by 'generateMigrationKinds',
+-- which correspond to the exact set of custom migration tags used in
+-- the changelog.
+data CustomMigrations o v db ty alt fld = CustomMigrations
     { databaseMigration       :: db -> o -> Either ValueError o
     , databaseMigrationSchema :: db -> NormAPI -> Either ApplyFailure (Maybe NormAPI)
     , typeMigration           :: ty -> v -> Either ValueError v
     , typeMigrationSchema     :: ty -> NormTypeDecl -> Either ApplyFailure (Maybe NormTypeDecl)
+    , unionAltMigration       :: alt -> v -> Either ValueError v
     , fieldMigration          :: fld -> v -> Either ValueError v }
 
-type CustomMigrationsTagged o v = CustomMigrations o v MigrationTag MigrationTag MigrationTag
+type CustomMigrationsTagged o v = CustomMigrations o v MigrationTag MigrationTag MigrationTag MigrationTag
 
-readCustomMigrations :: (Read db, Read ty, Read fld)
-                     => CustomMigrations o v db ty fld -> CustomMigrationsTagged o v
-readCustomMigrations (CustomMigrations db dbs r rs f) =
-    CustomMigrations (db . read) (dbs . read) (r . read) (rs . read) (f . read)
+readCustomMigrations :: (Read db, Read ty, Read alt, Read fld)
+                     => CustomMigrations o v db ty alt fld -> CustomMigrationsTagged o v
+readCustomMigrations (CustomMigrations db dbs r rs a f) =
+    CustomMigrations (db . read) (dbs . read) (r . read) (rs . read) (a . read) (f . read)
 
 -- | Lift a custom record migration to work on arbitrary values
 mkRecordMigration :: (JS.Object -> Either ValueError JS.Object)
@@ -244,23 +249,23 @@ isChangelogOrdered changelog =
 
 
 -- | Sets of custom migration tags in the changelog for
--- whole-database, single-record and single-field migrations
-changelogTags :: APIChangelog -> (Set MigrationTag, Set MigrationTag, Set MigrationTag)
-changelogTags (ChangesStart _) = (Set.empty, Set.empty, Set.empty)
+-- whole-database, single-type, union-alternative and single-field migrations
+changelogTags :: APIChangelog -> (Set MigrationTag, Set MigrationTag, Set MigrationTag, Set MigrationTag)
+changelogTags (ChangesStart _) = (Set.empty, Set.empty, Set.empty, Set.empty)
 changelogTags (ChangesUpTo _ cs older) =
-    unions3 (map changeTags cs) `union3` changelogTags older
+    unions4 (map changeTags cs) `union4` changelogTags older
   where
-    union3 (a, b, c) (x, y, z) = (a `Set.union` x, b `Set.union` y, c `Set.union` z)
-    unions3 xyzs = (Set.unions xs, Set.unions ys, Set.unions zs)
-      where (xs, ys, zs) = unzip3 xyzs
+    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)
+    unions4 xyzws = (Set.unions xs, Set.unions ys, Set.unions zs, Set.unions ws)
+      where (xs, ys, zs, ws) = unzip4 xyzws
 
 -- | Sets of custom migration tags in a single change
-changeTags :: APIChange -> (Set MigrationTag, Set MigrationTag, Set MigrationTag)
-changeTags (ChChangeField _ _ _ t)     = (Set.empty, Set.empty, Set.singleton t)
-changeTags (ChChangeUnionAlt _ _ _ t)  = (Set.empty, Set.singleton t, Set.empty)
-changeTags (ChCustomType _ t)          = (Set.empty, Set.singleton t, Set.empty)
-changeTags (ChCustomAll t)             = (Set.singleton t, Set.empty, Set.empty)
-changeTags _                           = (Set.empty, Set.empty, Set.empty)
+changeTags :: APIChange -> (Set MigrationTag, Set MigrationTag, Set MigrationTag, Set MigrationTag)
+changeTags (ChChangeField _ _ _ t)     = (Set.empty, Set.empty, Set.empty, Set.singleton t)
+changeTags (ChChangeUnionAlt _ _ _ t)  = (Set.empty, Set.empty, Set.singleton t, Set.empty)
+changeTags (ChCustomType _ t)          = (Set.empty, Set.singleton t, Set.empty, Set.empty)
+changeTags (ChCustomAll t)             = (Set.singleton t, Set.empty, Set.empty, Set.empty)
+changeTags _                           = (Set.empty, Set.empty, Set.empty, Set.empty)
 
 
 --------------------------------
@@ -306,11 +311,11 @@ findUpdatePos tname api = Map.alter (Just . UpdateHere) tname $
 
 -- | Check that a changelog adequately describes how to migrate from
 -- one version to another.
-validateChanges :: (Read db, Read rec, Read fld)
+validateChanges :: (Read db, Read rec, Read alt, Read fld)
                 => (API, Version)              -- ^ Starting schema and version
                 -> (API, VersionExtra)         -- ^ Ending schema and version
                 -> APIChangelog                -- ^ Changelog to be validated
-                -> CustomMigrations o v db rec fld -- ^ Custom migration functions
+                -> CustomMigrations o v db rec alt fld -- ^ Custom migration functions
                 -> TypeName                    -- ^ Name of the dataset's type
                 -> DataChecks                  -- ^ How thoroughly to validate changes
                 -> Either ValidateFailure [ValidateWarning]
@@ -620,7 +625,7 @@ applyChangeToData (ChRenameUnionAlt _ fname fname') _ = withObject $ \un p ->
 applyChangeToData (ChChangeUnionAlt _ fname _ftype tag) custom = withObject $ \un p ->
   case matchSingletonObject un of
     Just (k, r) | k == _FieldName fname -> do
-        r' <- liftMigration (typeMigration custom tag) r p
+        r' <- liftMigration (unionAltMigration custom tag) r p
         return $ singletonObject (_FieldName fname) r'
     _ -> return un
 
@@ -738,7 +743,7 @@ applyChangeToData' _ (ChRenameUnionAlt _ fname fname') _ v p = do
 applyChangeToData' _ (ChChangeUnionAlt _ fname _ftype tag) custom v p = do
     (fn, v') <- expectUnion v p
     if fn == fname
-      then Union fn <$!> liftMigration (typeMigration custom tag) v' (inField fn:p)
+      then Union fn <$!> liftMigration (unionAltMigration custom tag) v' (inField fn:p)
       else pure v
 
 applyChangeToData' _ (ChRenameEnumVal _ fname fname') _ v p = do
@@ -887,17 +892,21 @@ type Decode t = JS.Value -> Either [(JSONError, Position)] t
 
 -- | Generate enumeration datatypes corresponding to the custom
 -- migrations used in an API migration changelog.
-generateMigrationKinds :: APIChangelog -> String -> String -> String -> Q [Dec]
-generateMigrationKinds changes all_nm rec_nm fld_nm = do
+generateMigrationKinds :: APIChangelog -> String -> String -> String -> String -> Q [Dec]
+generateMigrationKinds changes all_nm rec_nm alt_nm fld_nm = do
     guardNoDups (all_tags `Set.intersection` rec_tags)
+    guardNoDups (all_tags `Set.intersection` alt_tags)
     guardNoDups (all_tags `Set.intersection` fld_tags)
+    guardNoDups (rec_tags `Set.intersection` alt_tags)
     guardNoDups (rec_tags `Set.intersection` fld_tags)
+    guardNoDups (alt_tags `Set.intersection` fld_tags)
 
     return [ mkDataD [] (mkName all_nm) [] (cons all_nm all_tags) derivs
            , mkDataD [] (mkName rec_nm) [] (cons rec_nm rec_tags) derivs
+           , mkDataD [] (mkName alt_nm) [] (cons alt_nm alt_tags) derivs
            , mkDataD [] (mkName fld_nm) [] (cons fld_nm fld_tags) derivs ]
   where
-    (all_tags, rec_tags, fld_tags) = changelogTags changes
+    (all_tags, rec_tags, alt_tags, fld_tags) = changelogTags changes
 
     guardNoDups xs
       | Set.null xs = return ()

src/Data/API/Tutorial.hs

@@ -301,13 +301,14 @@ These types should then be used to create a 'CustomMigrations' record,
 which describes how to transform the data (and 'API', if appropriate)
 for each custom migration.  For example,
 
-> $(generateMigrationKinds myChangelog "DatabaseMigration" "TypeMigration" "FieldMigration")
+> $(generateMigrationKinds myChangelog "DatabaseMigration" "TypeMigration" "UnionAltMigration" "FieldMigration")
 
 with the changelog fragment above would give
 
-> data DatabaseMigration = MigrateWholeDatabase | ...
-> data TypeMigration     = MigrateWidgetType    | ...
-> data FieldMigration    = MigrateFooField      | ...
+> data DatabaseMigration  = MigrateWholeDatabase | ...
+> data TypeMigration      = MigrateWidgetType    | ...
+> data UnionAltMigration  = ...
+> data FieldMigration     = MigrateFooField      | ...
 
 Calls to 'migrateDataDump' should include a suitable
 'CustomMigrations' record, which includes functions to perform the

tests/Data/API/Test/Migration.hs

@@ -40,7 +40,7 @@ import qualified Data.HashMap.Strict      as HMap
 #endif
 
 
-$(generateMigrationKinds changelog "TestDatabaseMigration" "TestRecordMigration" "TestFieldMigration")
+$(generateMigrationKinds changelog "TestDatabaseMigration" "TestRecordMigration" "TestUnionAltMigration" "TestFieldMigration")
 
 
 -- Test of a whole-database migration: copy data between tables
@@ -121,18 +121,20 @@ testFieldMigration' ConvertBinaryToString (Value.Bytes bs) = return (Value.Strin
 testFieldMigration' ConvertBinaryToString v = Left $ CustomMigrationError "bad data" (JS.toJSON v)
 
 
-testMigration :: CustomMigrations JS.Object JS.Value TestDatabaseMigration TestRecordMigration TestFieldMigration
+testMigration :: CustomMigrations JS.Object JS.Value TestDatabaseMigration TestRecordMigration TestUnionAltMigration TestFieldMigration
 testMigration = CustomMigrations testDatabaseMigration
                                  testDatabaseMigrationSchema
                                  testRecordMigration
                                  testRecordMigrationSchema
+                                 (\ _ -> noDataChanges)
                                  testFieldMigration
 
-testMigration' :: CustomMigrations Value.Record Value.Value TestDatabaseMigration TestRecordMigration TestFieldMigration
+testMigration' :: CustomMigrations Value.Record Value.Value TestDatabaseMigration TestRecordMigration TestUnionAltMigration TestFieldMigration
 testMigration' = CustomMigrations testDatabaseMigration'
                                   testDatabaseMigrationSchema
                                   testRecordMigration'
                                   testRecordMigrationSchema
+                                  (\ _ -> noDataChanges)
                                   testFieldMigration'
 
 

tests/Data/API/Test/UnionMigration.hs

@@ -27,7 +27,7 @@ import           Data.API.Test.UnionMigrationData
 
 
 -- Generate migration enums from changelog
-$(generateMigrationKinds typeSwapChangelog "TypeSwapDbMigration" "TypeSwapRecordMigration" "TypeSwapFieldMigration")
+$(generateMigrationKinds typeSwapChangelog "TypeSwapDbMigration" "TypeSwapRecordMigration" "TypeSwapUnionAltMigration" "TypeSwapFieldMigration")
 
 
 -- -----------------------------------------------------------------------------
@@ -41,7 +41,7 @@ $(generateMigrationKinds typeSwapChangelog "TypeSwapDbMigration" "TypeSwapRecord
 --
 -- This is a type migration because we're transforming the entire inner value
 -- of the union alternative from one type to another.
-migratePersonV1ToV2 :: TypeSwapRecordMigration -> JS.Value -> Either ValueError JS.Value
+migratePersonV1ToV2 :: TypeSwapUnionAltMigration -> JS.Value -> Either ValueError JS.Value
 migratePersonV1ToV2 MigratePersonV1ToV2 (JS.Object obj) = do
     nameVal <- lookupKey "name" obj ?! CustomMigrationError "missing 'name' field" (JS.Object obj)
     case nameVal of
@@ -53,12 +53,13 @@ migratePersonV1ToV2 MigratePersonV1ToV2 v =
     Left $ CustomMigrationError "expected object for PersonV1" v
 
 
-typeSwapMigration :: CustomMigrations JS.Object JS.Value TypeSwapDbMigration TypeSwapRecordMigration TypeSwapFieldMigration
+typeSwapMigration :: CustomMigrations JS.Object JS.Value TypeSwapDbMigration TypeSwapRecordMigration TypeSwapUnionAltMigration TypeSwapFieldMigration
 typeSwapMigration = CustomMigrations
     { databaseMigration       = \ _ -> noDataChanges
     , databaseMigrationSchema = \ _ -> noSchemaChanges
-    , typeMigration           = migratePersonV1ToV2
+    , typeMigration           = \ _ -> noDataChanges
     , typeMigrationSchema     = \ _ -> noSchemaChanges
+    , unionAltMigration       = migratePersonV1ToV2
     , fieldMigration          = \ _ -> noDataChanges
     }