Support migrating individual alternatives in unions

api-tools.cabal

@@ -176,6 +176,8 @@ Test-Suite test-api-tools
         Data.API.Test.Migration
         Data.API.Test.MigrationData
         Data.API.Test.Time
+        Data.API.Test.UnionMigration
+        Data.API.Test.UnionMigrationData
 
   Build-depends:
         api-tools,

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)
@@ -200,10 +205,11 @@ data DataChecks = NoChecks         -- ^ Not at all
 
 -- | Whether to validate the dataset after this change
 validateAfter :: DataChecks -> APIChange -> Bool
-validateAfter chks (ChChangeField{})  = chks >= CheckCustom
-validateAfter chks (ChCustomType{})   = chks >= CheckCustom
-validateAfter chks (ChCustomAll{})    = chks >= CheckCustom
-validateAfter chks _                  = chks >= CheckAll
+validateAfter chks (ChChangeField{})     = chks >= CheckCustom
+validateAfter chks (ChChangeUnionAlt{})  = chks >= CheckCustom
+validateAfter chks (ChCustomType{})      = chks >= CheckCustom
+validateAfter chks (ChCustomAll{})       = chks >= CheckCustom
+validateAfter chks _                     = chks >= CheckAll
 
 
 --------------------
@@ -243,22 +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 (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)
 
 
 --------------------------------
@@ -304,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]
@@ -484,6 +491,14 @@ applyAPIChangeToAPI _ _ (ChRenameUnionAlt tname fname fname') api = do
                            . Map.delete fname) unioninfo
   return (Map.insert tname tinfo' api, findUpdatePos tname api)
 
+applyAPIChangeToAPI _ _custom (ChChangeUnionAlt tname fname ftype _tag) api = do
+  tinfo     <- lookupType tname api
+  unioninfo <- expectUnionType tinfo        ?! TypeWrongKind tname TKUnion
+  guard (Map.member fname unioninfo)        ?! FieldDoesNotExist tname TKUnion fname
+  typeIsValid ftype api                     ?!? TypeMalformed ftype
+  let tinfo' = (NUnionType . Map.insert fname ftype) unioninfo
+  return (Map.insert tname tinfo' api, findUpdatePos tname api)
+
 applyAPIChangeToAPI _ _ (ChAddEnumVal tname fname) api = do
   tinfo    <- lookupType tname api
   enuminfo <- expectEnumType tinfo                 ?! TypeWrongKind tname TKEnum
@@ -607,6 +622,13 @@ applyChangeToData (ChRenameUnionAlt _ fname fname') _ = withObject $ \un p ->
                     | otherwise             -> return un
         Nothing -> Left (JSONError $ SyntaxError "Not singleton", p)
 
+applyChangeToData (ChChangeUnionAlt _ fname _ftype tag) custom = withObject $ \un p ->
+  case matchSingletonObject un of
+    Just (k, r) | k == _FieldName fname -> do
+        r' <- liftMigration (unionAltMigration custom tag) r p
+        return $ singletonObject (_FieldName fname) r'
+    _ -> return un
+
 applyChangeToData (ChRenameEnumVal _ fname fname') _ = withString $ \s _ ->
     if s == _FieldName fname then return (_FieldName fname')
                            else return s
@@ -718,6 +740,12 @@ applyChangeToData' _ (ChRenameUnionAlt _ fname fname') _ v p = do
     (fn, v') <- expectUnion v p
     pure $! if fn == fname then Union fname' v' else v
 
+applyChangeToData' _ (ChChangeUnionAlt _ fname _ftype tag) custom v p = do
+    (fn, v') <- expectUnion v p
+    if fn == fname
+      then Union fn <$!> liftMigration (unionAltMigration custom tag) v' (inField fn:p)
+      else pure v
+
 applyChangeToData' _ (ChRenameEnumVal _ fname fname') _ v p = do
     fn <- expectEnum v p
     pure $! if fn == fname then Enum fname' else v
@@ -864,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/Changes/Types.hs

@@ -57,6 +57,7 @@ data APIChange
     | ChAddUnionAlt    TypeName FieldName APIType
     | ChDeleteUnionAlt TypeName FieldName
     | ChRenameUnionAlt TypeName FieldName FieldName
+    | ChChangeUnionAlt TypeName FieldName APIType MigrationTag
 
       -- Changes for enum types
     | ChAddEnumVal    TypeName FieldName
@@ -87,6 +88,9 @@ instance PPLines APIChange where
                                       , "  alternative removed " ++ pp f]
   ppLines (ChRenameUnionAlt t f f') = [ "changed union " ++ pp t
                                       , "  alternative renamed " ++ pp f ++ " to " ++ pp f']
+  ppLines (ChChangeUnionAlt t f ty c) = [ "changed union " ++ pp t
+                                        , "  alternative changed " ++ pp f ++ " :: " ++ pp ty
+                                          ++ " migration " ++ pp c]
   ppLines (ChAddEnumVal t f)        = [ "changed enum " ++ pp t
                                       , "  alternative added " ++ pp f]
   ppLines (ChDeleteEnumVal t f)     = [ "changed enum " ++ pp t

src/Data/API/Parse.y

@@ -280,6 +280,7 @@ UnionChange :: { [UnionChange] }
     : alternative added FieldName '::' Type      { [UnChAdd $3 $5]          }
     | alternative removed FieldName              { [UnChDelete $3]          }
     | alternative renamed FieldName to FieldName { [UnChRename $3 $5]       }
+    | alternative changed FieldName '::' Type migration MigrationTag { [UnChChange $3 $5 $7] }
     | comment                                    { []                       }
 
 REnumChanges :: { [EnumChange] }
@@ -331,11 +332,13 @@ fldChangeToAPIChange t (FldChChange f ty m) = ChChangeField t f ty m
 data UnionChange = UnChAdd FieldName APIType
                  | UnChDelete FieldName
                  | UnChRename FieldName FieldName
+                 | UnChChange FieldName APIType MigrationTag
 
 unionChangeToAPIChange :: TypeName -> UnionChange -> APIChange
-unionChangeToAPIChange t (UnChAdd f ty)    = ChAddUnionAlt t f ty
-unionChangeToAPIChange t (UnChDelete f)    = ChDeleteUnionAlt t f
-unionChangeToAPIChange t (UnChRename f f') = ChRenameUnionAlt t f f'
+unionChangeToAPIChange t (UnChAdd f ty)       = ChAddUnionAlt t f ty
+unionChangeToAPIChange t (UnChDelete f)       = ChDeleteUnionAlt t f
+unionChangeToAPIChange t (UnChRename f f')    = ChRenameUnionAlt t f f'
+unionChangeToAPIChange t (UnChChange f ty m)  = ChChangeUnionAlt t f ty m
 
 data EnumChange = EnChAdd FieldName
                 | EnChDelete FieldName

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/Main.hs

@@ -3,6 +3,7 @@ import           Data.API.API.Gen
 import           Data.API.Test.JSON
 import           Data.API.Test.Migration
 import           Data.API.Test.Time
+import           Data.API.Test.UnionMigration
 
 import           Test.Tasty
 import           Test.Tasty.QuickCheck
@@ -12,6 +13,7 @@ main = defaultMain tests
 
 tests :: TestTree
 tests = testGroup "api-tools" [ migrationTests
+                              , unionMigrationTests
                               , jsonTests
                               , timeTests
                               , testProperty "Convert/unconvert" convertUncovertTest

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'