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,

src/Data/API/Changes.hs

@@ -200,10 +200,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
 
 
 --------------------
@@ -255,10 +256,11 @@ changelogTags (ChangesUpTo _ cs older) =
 
 -- | 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 (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)
 
 
 --------------------------------
@@ -484,6 +486,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 +617,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 (typeMigration 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 +735,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 (typeMigration 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

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

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

@@ -0,0 +1,168 @@
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE TemplateHaskell            #-}
+
+-- | Tests for union alternative migration with type changes
+--
+-- This module tests the 'alternative changed' changelog feature, which allows
+-- changing the type of a union alternative with a custom migration function.
+module Data.API.Test.UnionMigration
+    ( unionMigrationTests
+    ) where
+
+import           Data.API.Changes
+import           Data.API.JSON
+import           Data.API.JSON.Compat
+import           Data.API.Types
+import           Data.API.Utils
+
+import qualified Data.Aeson               as JS
+import qualified Data.Aeson.Encode.Pretty as JS
+import qualified Data.ByteString.Lazy.Char8 as BL
+import qualified Data.Text                as T
+import           Data.Version
+import           Test.Tasty
+import           Test.Tasty.HUnit
+
+import           Data.API.Test.UnionMigrationData
+
+
+-- Generate migration enums from changelog
+$(generateMigrationKinds typeSwapChangelog "TypeSwapDbMigration" "TypeSwapRecordMigration" "TypeSwapFieldMigration")
+
+
+-- -----------------------------------------------------------------------------
+-- Type Swap Migration (PersonV1 -> PersonV2)
+-- -----------------------------------------------------------------------------
+
+-- | Migrate PersonV1 to PersonV2
+--
+-- PersonV1: { "name": "John" }
+-- PersonV2: { "fullName": "John", "age": 0 }
+--
+-- 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 MigratePersonV1ToV2 (JS.Object obj) = do
+    nameVal <- lookupKey "name" obj ?! CustomMigrationError "missing 'name' field" (JS.Object obj)
+    case nameVal of
+        JS.String name -> return $ JS.Object $
+            insertKey "fullName" (JS.String name) $
+            singletonObject "age" (JS.Number 0)
+        _ -> Left $ CustomMigrationError "expected string for 'name'" (JS.Object obj)
+migratePersonV1ToV2 MigratePersonV1ToV2 v =
+    Left $ CustomMigrationError "expected object for PersonV1" v
+
+
+typeSwapMigration :: CustomMigrations JS.Object JS.Value TypeSwapDbMigration TypeSwapRecordMigration TypeSwapFieldMigration
+typeSwapMigration = CustomMigrations
+    { databaseMigration       = \ _ -> noDataChanges
+    , databaseMigrationSchema = \ _ -> noSchemaChanges
+    , typeMigration           = migratePersonV1ToV2
+    , typeMigrationSchema     = \ _ -> noSchemaChanges
+    , fieldMigration          = \ _ -> noDataChanges
+    }
+
+
+-- Test data for type swap
+--
+-- Start: Container with MyUnion containing PersonV1
+-- End:   Container with MyUnion containing PersonV2
+
+-- | Start data: { "person": { "person": { "name": "Alice" } } }
+startTypeSwapData :: JS.Value
+Just startTypeSwapData = JS.decode "{ \"person\": { \"person\": { \"name\": \"Alice\" } } }"
+
+-- | Expected end data: { "person": { "person": { "fullName": "Alice", "age": 0 } } }
+expectedTypeSwapData :: JS.Value
+Just expectedTypeSwapData = JS.decode "{ \"person\": { \"person\": { \"fullName\": \"Alice\", \"age\": 0 } } }"
+
+-- | Start data with "other" alternative (should pass through unchanged)
+startOtherAltData :: JS.Value
+Just startOtherAltData = JS.decode "{ \"person\": { \"other\": 42 } }"
+
+-- | Expected end data for "other" alternative (unchanged)
+expectedOtherAltData :: JS.Value
+Just expectedOtherAltData = JS.decode "{ \"person\": { \"other\": 42 } }"
+
+
+-- | Test migrating PersonV1 to PersonV2 within a union
+typeSwapMigrationTest :: Assertion
+typeSwapMigrationTest = do
+    -- Verify start data matches start schema
+    case dataMatchesAPI rootName startTypeSwapSchema startTypeSwapData of
+        Right () -> return ()
+        Left err -> assertFailure $ "Start data does not match start API: "
+                                      ++ prettyValueErrorPosition err
+
+    -- Verify expected end data matches end schema
+    case dataMatchesAPI rootName endTypeSwapSchema expectedTypeSwapData of
+        Right () -> return ()
+        Left err -> assertFailure $ "Expected end data does not match end API: "
+                                      ++ prettyValueErrorPosition err
+
+    -- Run migration
+    case migrateDataDump (startTypeSwapSchema, parseVer "0")
+                         (endTypeSwapSchema, Release (parseVer "1.0"))
+                         typeSwapChangelog typeSwapMigration rootName CheckAll
+                         startTypeSwapData of
+      Right (v, [])
+          | expectedTypeSwapData == v -> return ()
+          | otherwise -> assertFailure $ unlines
+              [ "Type swap migration produced wrong result"
+              , "Expected:"
+              , BL.unpack (JS.encodePretty expectedTypeSwapData)
+              , "but got:"
+              , BL.unpack (JS.encodePretty v)
+              ]
+      Right (_, ws) -> assertFailure $ "Unexpected warnings: " ++ show ws
+      Left err      -> assertFailure $ "Migration failed: " ++ prettyMigrateFailure err
+
+
+-- | Test that non-matching alternatives pass through unchanged
+otherAlternativeUnchangedTest :: Assertion
+otherAlternativeUnchangedTest = do
+    -- Verify start data matches start schema
+    case dataMatchesAPI rootName startTypeSwapSchema startOtherAltData of
+        Right () -> return ()
+        Left err -> assertFailure $ "Start data does not match start API: "
+                                      ++ prettyValueErrorPosition err
+
+    -- Verify expected end data matches end schema
+    case dataMatchesAPI rootName endTypeSwapSchema expectedOtherAltData of
+        Right () -> return ()
+        Left err -> assertFailure $ "Expected end data does not match end API: "
+                                      ++ prettyValueErrorPosition err
+
+    -- Run migration - "other" alternative should pass through unchanged
+    case migrateDataDump (startTypeSwapSchema, parseVer "0")
+                         (endTypeSwapSchema, Release (parseVer "1.0"))
+                         typeSwapChangelog typeSwapMigration rootName CheckAll
+                         startOtherAltData of
+      Right (v, [])
+          | expectedOtherAltData == v -> return ()
+          | otherwise -> assertFailure $ unlines
+              [ "Other alternative was incorrectly modified"
+              , "Expected:"
+              , BL.unpack (JS.encodePretty expectedOtherAltData)
+              , "but got:"
+              , BL.unpack (JS.encodePretty v)
+              ]
+      Right (_, ws) -> assertFailure $ "Unexpected warnings: " ++ show ws
+      Left err      -> assertFailure $ "Migration failed: " ++ prettyMigrateFailure err
+
+
+rootName :: TypeName
+rootName = TypeName "Container"
+
+parseVer :: String -> Version
+parseVer s = case simpleParseVersion s of
+    Just v -> v
+    Nothing -> error $ "Invalid version: " ++ s
+
+
+-- | All union migration tests
+unionMigrationTests :: TestTree
+unionMigrationTests = testGroup "Union Alternative Migration"
+  [ testCase "Type swap: PersonV1 -> PersonV2" typeSwapMigrationTest
+  , testCase "Other alternatives pass through unchanged" otherAlternativeUnchangedTest
+  ]

tests/Data/API/Test/UnionMigrationData.hs

@@ -0,0 +1,86 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+-- | Data for union alternative migration tests
+--
+-- This module tests the 'alternative changed' changelog feature, which allows
+-- swapping the type of a union alternative from one type to a completely
+-- different type, with a custom migration function to transform the data.
+module Data.API.Test.UnionMigrationData
+    ( -- * Type swap scenario (PersonV1 -> PersonV2)
+      startTypeSwapSchema
+    , endTypeSwapSchema
+    , typeSwapChangelog
+    ) where
+
+import           Data.API.Changes
+import           Data.API.Parse
+import           Data.API.Types
+
+
+-- -----------------------------------------------------------------------------
+-- Type Swap Scenario
+--
+-- This tests the primary use case: migrating a union alternative from one
+-- type (PersonV1) to a completely different type (PersonV2).
+--
+-- PersonV1 has: name :: string
+-- PersonV2 has: fullName :: string, age :: integer
+--
+-- The migration function transforms PersonV1 data to PersonV2 data.
+-- -----------------------------------------------------------------------------
+
+-- | Initial schema with PersonV1
+startTypeSwapSchema :: API
+startTypeSwapSchema = [api|
+
+personV1Prefix :: PersonV1
+    = record
+        name :: string
+
+containerPrefix :: Container
+    = record
+        person :: MyUnion
+
+myUnionPrefix :: MyUnion
+    = union
+        | person :: PersonV1
+        | other  :: integer
+|]
+
+
+-- | Final schema with PersonV2 and changelog
+endTypeSwapSchema :: API
+typeSwapChangelog :: APIChangelog
+(endTypeSwapSchema, typeSwapChangelog) = [apiWithChangelog|
+
+personV1Prefix :: PersonV1
+    = record
+        name :: string
+
+personV2Prefix :: PersonV2
+    = record
+        fullName :: string
+        age      :: integer
+
+containerPrefix :: Container
+    = record
+        person :: MyUnion
+
+myUnionPrefix :: MyUnion
+    = union
+        | person :: PersonV2
+        | other  :: integer
+
+changes
+
+version "1.0"
+  // Note: changes are processed bottom-up, so we must list the union change
+  // before adding the new type it references
+  changed union MyUnion
+    alternative changed person :: PersonV2 migration MigratePersonV1ToV2
+  added PersonV2 record
+    fullName :: string
+    age      :: integer
+
+version "0"
+|]