From a87edcfe5d2e9d8ee71918e82ae109dc7ed3839a Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli Date: Thu, 5 Feb 2026 10:04:48 +0100 Subject: [PATCH 1/2] Support migrating individual alternatives in unions --- api-tools.cabal | 2 + src/Data/API/Changes.hs | 38 ++++++-- src/Data/API/Changes/Types.hs | 4 + src/Data/API/Parse.y | 9 +- tests/Data/API/Test/UnionMigration.hs | 107 ++++++++++++++++++++++ tests/Data/API/Test/UnionMigrationData.hs | 50 ++++++++++ 6 files changed, 199 insertions(+), 11 deletions(-) create mode 100644 tests/Data/API/Test/UnionMigration.hs create mode 100644 tests/Data/API/Test/UnionMigrationData.hs diff --git a/api-tools.cabal b/api-tools.cabal index 5a89593..046e2bd 100644 --- a/api-tools.cabal +++ b/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, diff --git a/src/Data/API/Changes.hs b/src/Data/API/Changes.hs index 4d16dbd..b963565 100644 --- a/src/Data/API/Changes.hs +++ b/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.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) -------------------------------- @@ -484,6 +486,13 @@ 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 + 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 +616,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 (fieldMigration 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 +734,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 (fieldMigration 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 diff --git a/src/Data/API/Changes/Types.hs b/src/Data/API/Changes/Types.hs index e258205..ff90068 100644 --- a/src/Data/API/Changes/Types.hs +++ b/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 diff --git a/src/Data/API/Parse.y b/src/Data/API/Parse.y index 8b49c40..9f73a3d 100644 --- a/src/Data/API/Parse.y +++ b/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 diff --git a/tests/Data/API/Test/UnionMigration.hs b/tests/Data/API/Test/UnionMigration.hs new file mode 100644 index 0000000..1dd9bae --- /dev/null +++ b/tests/Data/API/Test/UnionMigration.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Standalone test for union alternative migration with field changes +module Data.API.Test.UnionMigration + ( unionMigrationTests + ) where + +import Data.API.Changes +import Data.API.JSON +import Data.API.JSON.Compat +import Data.API.Tools +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 testChangelog "TestDbMigration" "TestRecordMigration" "TestFieldMigration") + + +-- Custom field migration that adds a 'name' field prefixed with "id_" +testFieldMigration :: TestFieldMigration -> JS.Value -> Either ValueError JS.Value +testFieldMigration AddNameToTestRecord (JS.Object x) = do + i <- lookupKey "id" x ?! CustomMigrationError "missing id" (JS.Object x) + case i of + JS.Number n -> do + let name = JS.String $ "id_" `T.append` T.pack (show (floor (toRational n) :: Int)) + return $ JS.Object $ insertKey "name" name x + _ -> Left $ CustomMigrationError "bad id" (JS.Object x) +testFieldMigration AddNameToTestRecord v = Left $ CustomMigrationError "bad data" v + + +-- Custom migrations record +testMigration :: CustomMigrations JS.Object JS.Value TestDbMigration TestRecordMigration TestFieldMigration +testMigration = CustomMigrations + { databaseMigration = \ _ -> noDataChanges + , databaseMigrationSchema = \ _ -> noSchemaChanges + , typeMigration = \ _ -> noDataChanges + , typeMigrationSchema = \ _ -> noSchemaChanges + , fieldMigration = testFieldMigration + } + + +-- Test data +startUnionData :: JS.Value +Just startUnionData = JS.decode "{ \"alt\": {\"id\": 42} }" + +expectedUnionData :: JS.Value +Just expectedUnionData = JS.decode "{ \"alt\": {\"id\": 42, \"name\": \"id_42\"} }" + + +-- | The basic test case for union alternative migration +unionAlternativeMigrationTest :: Assertion +unionAlternativeMigrationTest = do + -- Verify data matches schemas + case dataMatchesAPI rootUnionName startUnionSchema startUnionData of + Right () -> return () + Left err -> assertFailure $ "Start data does not match start API: " + ++ prettyValueErrorPosition err + + case dataMatchesAPI rootUnionName endUnionSchema expectedUnionData of + Right () -> return () + Left err -> assertFailure $ "Expected end data does not match end API: " + ++ prettyValueErrorPosition err + + -- Run migration + let startVer = parseVer "0" + case migrateDataDump (startUnionSchema, startVer) (endUnionSchema, parseVerExtra "1.0") + testChangelog testMigration rootUnionName CheckAll startUnionData of + Right (v, []) | expectedUnionData == v -> return () + | otherwise -> assertFailure $ unlines + [ "Expected:" + , BL.unpack (JS.encodePretty expectedUnionData) + , "but got:" + , BL.unpack (JS.encodePretty v) + ] + Right (_, ws) -> assertFailure $ "Unexpected warnings: " ++ show ws + Left err -> assertFailure $ "Migration failed: " ++ prettyMigrateFailure err + + +rootUnionName :: TypeName +rootUnionName = TypeName "TestUnion" + +parseVer :: String -> Version +parseVer s = case simpleParseVersion s of + Just v -> v + Nothing -> error $ "Invalid version: " ++ s + +parseVerExtra :: String -> VersionExtra +parseVerExtra s = Release $ parseVer s + + +-- | All union migration tests +unionMigrationTests :: TestTree +unionMigrationTests = testGroup "Union Alternative Migration" + [ testCase "Union alternative migration with field change" unionAlternativeMigrationTest + ] diff --git a/tests/Data/API/Test/UnionMigrationData.hs b/tests/Data/API/Test/UnionMigrationData.hs new file mode 100644 index 0000000..3ff6da6 --- /dev/null +++ b/tests/Data/API/Test/UnionMigrationData.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- | Data for union alternative migration tests +module Data.API.Test.UnionMigrationData + ( startUnionSchema + , endUnionSchema + , testChangelog + ) where + +import Data.API.Changes +import Data.API.Parse +import Data.API.Types + + +-- Initial schema with a union containing a record type +startUnionSchema :: API +startUnionSchema = [api| + +testPrefix :: TestRecord + = record + id :: integer + +testUnionPrefix :: TestUnion + = union + | alt :: TestRecord +|] + + +-- Final schema and changelog +endUnionSchema :: API +testChangelog :: APIChangelog +(endUnionSchema, testChangelog) = [apiWithChangelog| + +testPrefix :: TestRecord + = record + id :: integer + name :: string + +testUnionPrefix :: TestUnion + = union + | alt :: TestRecord + +changes + +version "1.0" + changed union TestUnion + alternative changed alt :: TestRecord migration AddNameToTestRecord + +version "0" +|] From e08d75d3d95aa7bd75e6eae4db9cdc32a8d07a89 Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli Date: Thu, 5 Feb 2026 16:49:30 +0100 Subject: [PATCH 2/2] Fix bug in applyChangeToData --- src/Data/API/Changes.hs | 7 +- tests/Data/API/Test/Main.hs | 2 + tests/Data/API/Test/UnionMigration.hs | 159 +++++++++++++++------- tests/Data/API/Test/UnionMigrationData.hs | 76 ++++++++--- 4 files changed, 172 insertions(+), 72 deletions(-) diff --git a/src/Data/API/Changes.hs b/src/Data/API/Changes.hs index b963565..f030b2c 100644 --- a/src/Data/API/Changes.hs +++ b/src/Data/API/Changes.hs @@ -257,7 +257,7 @@ 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 (ChChangeUnionAlt _ _ _ 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) @@ -490,6 +490,7 @@ 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) @@ -619,7 +620,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 (fieldMigration custom tag) r p + r' <- liftMigration (typeMigration custom tag) r p return $ singletonObject (_FieldName fname) r' _ -> return un @@ -737,7 +738,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 (fieldMigration custom tag) v' (inField fn:p) + then Union fn <$!> liftMigration (typeMigration custom tag) v' (inField fn:p) else pure v applyChangeToData' _ (ChRenameEnumVal _ fname fname') _ v p = do diff --git a/tests/Data/API/Test/Main.hs b/tests/Data/API/Test/Main.hs index 58d12f2..092e224 100644 --- a/tests/Data/API/Test/Main.hs +++ b/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 diff --git a/tests/Data/API/Test/UnionMigration.hs b/tests/Data/API/Test/UnionMigration.hs index 1dd9bae..c89026d 100644 --- a/tests/Data/API/Test/UnionMigration.hs +++ b/tests/Data/API/Test/UnionMigration.hs @@ -1,7 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} --- | Standalone test for union alternative migration with field changes +-- | 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 @@ -9,7 +12,6 @@ module Data.API.Test.UnionMigration import Data.API.Changes import Data.API.JSON import Data.API.JSON.Compat -import Data.API.Tools import Data.API.Types import Data.API.Utils @@ -25,83 +27,142 @@ import Data.API.Test.UnionMigrationData -- Generate migration enums from changelog -$(generateMigrationKinds testChangelog "TestDbMigration" "TestRecordMigration" "TestFieldMigration") - - --- Custom field migration that adds a 'name' field prefixed with "id_" -testFieldMigration :: TestFieldMigration -> JS.Value -> Either ValueError JS.Value -testFieldMigration AddNameToTestRecord (JS.Object x) = do - i <- lookupKey "id" x ?! CustomMigrationError "missing id" (JS.Object x) - case i of - JS.Number n -> do - let name = JS.String $ "id_" `T.append` T.pack (show (floor (toRational n) :: Int)) - return $ JS.Object $ insertKey "name" name x - _ -> Left $ CustomMigrationError "bad id" (JS.Object x) -testFieldMigration AddNameToTestRecord v = Left $ CustomMigrationError "bad data" v - - --- Custom migrations record -testMigration :: CustomMigrations JS.Object JS.Value TestDbMigration TestRecordMigration TestFieldMigration -testMigration = CustomMigrations +$(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 = \ _ -> noDataChanges + , typeMigration = migratePersonV1ToV2 , typeMigrationSchema = \ _ -> noSchemaChanges - , fieldMigration = testFieldMigration + , fieldMigration = \ _ -> noDataChanges } --- Test data -startUnionData :: JS.Value -Just startUnionData = JS.decode "{ \"alt\": {\"id\": 42} }" +-- 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\" } } }" -expectedUnionData :: JS.Value -Just expectedUnionData = JS.decode "{ \"alt\": {\"id\": 42, \"name\": \"id_42\"} }" +-- | 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 } }" --- | The basic test case for union alternative migration -unionAlternativeMigrationTest :: Assertion -unionAlternativeMigrationTest = do - -- Verify data matches schemas - case dataMatchesAPI rootUnionName startUnionSchema startUnionData of +-- | 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 - case dataMatchesAPI rootUnionName endUnionSchema expectedUnionData of + -- 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 - let startVer = parseVer "0" - case migrateDataDump (startUnionSchema, startVer) (endUnionSchema, parseVerExtra "1.0") - testChangelog testMigration rootUnionName CheckAll startUnionData of - Right (v, []) | expectedUnionData == v -> return () - | otherwise -> assertFailure $ unlines - [ "Expected:" - , BL.unpack (JS.encodePretty expectedUnionData) - , "but got:" - , BL.unpack (JS.encodePretty v) - ] + 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 -rootUnionName :: TypeName -rootUnionName = TypeName "TestUnion" +rootName :: TypeName +rootName = TypeName "Container" parseVer :: String -> Version parseVer s = case simpleParseVersion s of Just v -> v Nothing -> error $ "Invalid version: " ++ s -parseVerExtra :: String -> VersionExtra -parseVerExtra s = Release $ parseVer s - -- | All union migration tests unionMigrationTests :: TestTree unionMigrationTests = testGroup "Union Alternative Migration" - [ testCase "Union alternative migration with field change" unionAlternativeMigrationTest + [ testCase "Type swap: PersonV1 -> PersonV2" typeSwapMigrationTest + , testCase "Other alternatives pass through unchanged" otherAlternativeUnchangedTest ] diff --git a/tests/Data/API/Test/UnionMigrationData.hs b/tests/Data/API/Test/UnionMigrationData.hs index 3ff6da6..5a509e1 100644 --- a/tests/Data/API/Test/UnionMigrationData.hs +++ b/tests/Data/API/Test/UnionMigrationData.hs @@ -1,10 +1,15 @@ {-# 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 - ( startUnionSchema - , endUnionSchema - , testChangelog + ( -- * Type swap scenario (PersonV1 -> PersonV2) + startTypeSwapSchema + , endTypeSwapSchema + , typeSwapChangelog ) where import Data.API.Changes @@ -12,39 +17,70 @@ import Data.API.Parse import Data.API.Types --- Initial schema with a union containing a record type -startUnionSchema :: API -startUnionSchema = [api| +-- ----------------------------------------------------------------------------- +-- 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. +-- ----------------------------------------------------------------------------- -testPrefix :: TestRecord +-- | Initial schema with PersonV1 +startTypeSwapSchema :: API +startTypeSwapSchema = [api| + +personV1Prefix :: PersonV1 + = record + name :: string + +containerPrefix :: Container = record - id :: integer + person :: MyUnion -testUnionPrefix :: TestUnion +myUnionPrefix :: MyUnion = union - | alt :: TestRecord + | person :: PersonV1 + | other :: integer |] --- Final schema and changelog -endUnionSchema :: API -testChangelog :: APIChangelog -(endUnionSchema, testChangelog) = [apiWithChangelog| +-- | Final schema with PersonV2 and changelog +endTypeSwapSchema :: API +typeSwapChangelog :: APIChangelog +(endTypeSwapSchema, typeSwapChangelog) = [apiWithChangelog| -testPrefix :: TestRecord +personV1Prefix :: PersonV1 = record - id :: integer name :: string -testUnionPrefix :: TestUnion +personV2Prefix :: PersonV2 + = record + fullName :: string + age :: integer + +containerPrefix :: Container + = record + person :: MyUnion + +myUnionPrefix :: MyUnion = union - | alt :: TestRecord + | person :: PersonV2 + | other :: integer changes version "1.0" - changed union TestUnion - alternative changed alt :: TestRecord migration AddNameToTestRecord + // 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" |]