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/3] 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/3] 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" |] From 2dd637d7b428b1509fd6c27b7ce209e0c4d954a4 Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli Date: Tue, 10 Feb 2026 11:37:01 +0100 Subject: [PATCH 3/3] Address Adam's feedback --- main/MigrationTool.hs | 3 +- src/Data/API/Changes.hs | 81 +++++++++++++++------------ src/Data/API/Tutorial.hs | 9 +-- tests/Data/API/Test/Migration.hs | 8 ++- tests/Data/API/Test/UnionMigration.hs | 9 +-- 5 files changed, 62 insertions(+), 48 deletions(-) diff --git a/main/MigrationTool.hs b/main/MigrationTool.hs index 4f679b4..59b56f9 100644 --- a/main/MigrationTool.hs +++ b/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)) diff --git a/src/Data/API/Changes.hs b/src/Data/API/Changes.hs index f030b2c..2135979 100644 --- a/src/Data/API/Changes.hs +++ b/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,12 +129,16 @@ 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). @@ -142,23 +146,24 @@ migrateDataDump' startApi endApi changelog custom root chks db = do -- 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 () diff --git a/src/Data/API/Tutorial.hs b/src/Data/API/Tutorial.hs index bb7fc30..85c1210 100644 --- a/src/Data/API/Tutorial.hs +++ b/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 diff --git a/tests/Data/API/Test/Migration.hs b/tests/Data/API/Test/Migration.hs index 0270ff1..b13bc47 100644 --- a/tests/Data/API/Test/Migration.hs +++ b/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' diff --git a/tests/Data/API/Test/UnionMigration.hs b/tests/Data/API/Test/UnionMigration.hs index c89026d..448cf93 100644 --- a/tests/Data/API/Test/UnionMigration.hs +++ b/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 }