Merge pull request #15 from lamdera/fix-phantom-types-migration

supermario · web-flow · commit 511600348672 · 2024-02-19T09:38:00.000+10:00
Ignore phantom types when doing migration code gen
diff --git a/extra/Lamdera/Evergreen/MigrationGenerator.hs b/extra/Lamdera/Evergreen/MigrationGenerator.hs
@@ -218,7 +218,7 @@ migrateUnionDefinition_ author pkg oldUnion newUnion tvarMapOld tvarMapNew oldVe
 
     tvarPairs :: [(Can.Type, Can.Type)]
     tvarPairs =
-      zip (loadTvars tvarsOld tvarMapOld) (loadTvars tvarsNew tvarMapNew)
+      zip (loadTvars (fmap fst paramMigrationPairs) tvarMapOld) (loadTvars (fmap snd paramMigrationPairs) tvarMapNew)
 
     tvarMigrations :: [Migration]
     tvarMigrations =  migrateTvars oldVersion newVersion scope interfaces recursionSet tvarMapOld tvarMapNew tvarPairs
@@ -254,12 +254,17 @@ migrateUnionDefinition_ author pkg oldUnion newUnion tvarMapOld tvarMapNew oldVe
     migration :: Text
     migration = migrationName <> " " <> tvarMigrationTextsCombined
 
-    paramMigrationPairs = zip tvarsOld tvarsNew
+    paramMigrationPairs :: [(N.Name, N.Name)]
+    paramMigrationPairs = filter (\(_, newTVar) -> isTVarInUseUnion newTVar) (zip tvarsOld tvarsNew)
 
     paramMigrationFnsTypeSig :: [Text]
     paramMigrationFnsTypeSig =
       paramMigrationPairs
-        & fmap (\(oldT, newT) -> T.concat [ "(", N.toText oldT, "_old -> ", N.toText newT, "_new)" ] )
+        & fmap (\(oldT, newT) -> T.concat [ "(", N.toText oldT, "_old -> ", N.toText newT, "_new)" ])
+
+    isTVarInUseUnion :: N.Name -> Bool
+    isTVarInUseUnion newTVar =
+        any (\(Can.Ctor _ _ _ params) -> any (isTVarInUse newTVar) params) (Can._u_alts newUnion)
 
     paramMigrationVars :: Text
     paramMigrationVars =
diff --git a/extra/Lamdera/Evergreen/MigrationGeneratorHelpers.hs b/extra/Lamdera/Evergreen/MigrationGeneratorHelpers.hs
@@ -645,6 +645,35 @@ loadTvar tvarMap name =
       -- This would be the alternative:
       -- Can.Tvar name
 
+isTVarInUse :: N.Name -> Can.Type -> Bool
+isTVarInUse tVar typeValue =
+    case typeValue of
+        Can.TLambda a b -> isTVarInUse tVar a || isTVarInUse tVar b
+
+        Can.TVar name -> tVar == name
+
+        Can.TType _ _ typeVars -> any (isTVarInUse tVar) typeVars
+
+        Can.TRecord fields maybeExtension ->
+            any (\(Can.FieldType _ fieldType) -> isTVarInUse tVar fieldType) fields
+            || case maybeExtension of
+                Just extension -> tVar == extension
+                Nothing -> False
+
+        Can.TUnit -> False
+
+        Can.TTuple t0 t1 maybeT2 ->
+          isTVarInUse tVar t0
+              || isTVarInUse tVar t1
+              || case maybeT2 of
+                  Just t2 -> isTVarInUse tVar t2
+                  Nothing -> False
+
+        Can.TAlias moduleNameCanonical name fields aliasType ->
+            any (\(_, fieldType) -> isTVarInUse tVar fieldType) fields
+            || case aliasType of
+                Can.Holey a -> isTVarInUse tVar a
+                Can.Filled a -> isTVarInUse tVar a
 
 tvarResolveParams :: [Can.Type] -> [(N.Name, Can.Type)] -> [Can.Type]
 tvarResolveParams params tvarMap =
diff --git a/test/scenario-migration-generate/src/Migrate_All/Actual.elm b/test/scenario-migration-generate/src/Migrate_All/Actual.elm
@@ -181,6 +181,7 @@ migrate_Migrate_All_New_BackendModel old =
     , url = old.url
     , userCache = old.userCache |> migrate_AssocList_Dict identity migrate_IncludedBySpecialCasedParam_Custom
     , apps = (Unimplemented {- Type `Dict (String) (Migrate_All.New.App)` was added in V2. I need you to set a default value. -})
+    , id = old.id |> migrate_Migrate_All_New_Id
     , depthTests = (Unimplemented {- Field of type `Dict (String) (Migrate_All.Old.Depth)` was removed in V2. I need you to do something with the `old.depthTests` value if you wish to keep the data, then remove this line. -})
     , removed = (Unimplemented {- Field of type `String` was removed in V2. I need you to do something with the `old.removed` value if you wish to keep the data, then remove this line. -})
     , removedRecord = (Unimplemented {- Field of type `Evergreen.V1.External.AllCoreTypes` was removed in V2. I need you to do something with the `old.removedRecord` value if you wish to keep the data, then remove this line. -})
@@ -197,6 +198,13 @@ migrate_Migrate_All_New_CustomType old =
             Migrate_All.New.CustomTwo
 
 
+migrate_Migrate_All_New_Id : Migrate_All.Old.Id a_old -> Migrate_All.New.Id a_new
+migrate_Migrate_All_New_Id old =
+    case old of
+        Migrate_All.Old.Id p0 ->
+            Migrate_All.New.Id p0
+
+
 migrate_Migrate_All_New_UserType : Migrate_All.Old.UserType -> Migrate_All.New.UserType
 migrate_Migrate_All_New_UserType old =
     case old of
diff --git a/test/scenario-migration-generate/src/Migrate_All/Expected.elm b/test/scenario-migration-generate/src/Migrate_All/Expected.elm
@@ -181,6 +181,7 @@ migrate_Migrate_All_New_BackendModel old =
     , url = old.url
     , userCache = old.userCache |> migrate_AssocList_Dict identity migrate_IncludedBySpecialCasedParam_Custom
     , apps = (Unimplemented {- Type `Dict (String) (Migrate_All.New.App)` was added in V2. I need you to set a default value. -})
+    , id = old.id |> migrate_Migrate_All_New_Id
     , depthTests = (Unimplemented {- Field of type `Dict (String) (Migrate_All.Old.Depth)` was removed in V2. I need you to do something with the `old.depthTests` value if you wish to keep the data, then remove this line. -})
     , removed = (Unimplemented {- Field of type `String` was removed in V2. I need you to do something with the `old.removed` value if you wish to keep the data, then remove this line. -})
     , removedRecord = (Unimplemented {- Field of type `Evergreen.V1.External.AllCoreTypes` was removed in V2. I need you to do something with the `old.removedRecord` value if you wish to keep the data, then remove this line. -})
@@ -197,6 +198,14 @@ migrate_Migrate_All_New_CustomType old =
             Migrate_All.New.CustomTwo
 
 
+migrate_Migrate_All_New_Id : Migrate_All.Old.Id a_old -> Migrate_All.New.Id a_new
+migrate_Migrate_All_New_Id old =
+    case old of
+        Migrate_All.Old.Id p0 ->
+            Migrate_All.New.Id p0
+
+
+
 migrate_Migrate_All_New_UserType : Migrate_All.Old.UserType -> Migrate_All.New.UserType
 migrate_Migrate_All_New_UserType old =
     case old of
diff --git a/test/scenario-migration-generate/src/Migrate_All/New.elm b/test/scenario-migration-generate/src/Migrate_All/New.elm
@@ -56,6 +56,9 @@ type alias BackendModel =
 
     -- WIP
     , apps : Dict String App
+
+    -- Phantom type
+    , id : Id UserId
     }
 
 
@@ -144,3 +147,11 @@ type alias ConfigUses =
 
 type alias ConfigUse =
     ( String, String, List String )
+
+
+type Id a =
+    Id String
+
+
+type UserId =
+    UserId
diff --git a/test/scenario-migration-generate/src/Migrate_All/Old.elm b/test/scenario-migration-generate/src/Migrate_All/Old.elm
@@ -57,6 +57,9 @@ type alias BackendModel =
 
     -- WIP
     , depthTests : Dict String Depth
+
+    -- Phantom type
+    , id : Id UserId
     }
 
 
@@ -154,3 +157,11 @@ type UnionThatGetsMoved
 
 type alias AliasThatGetsMoved =
     { someThing : String }
+
+
+type Id a =
+    Id String
+
+
+type UserId =
+    UserId
diff --git a/test/scenario-migration-generate/src/Migrate_External_Paramed/Actual.elm b/test/scenario-migration-generate/src/Migrate_External_Paramed/Actual.elm
@@ -103,11 +103,11 @@ migrate_Migrate_External_Paramed_New_NColor old =
 
 migrate_Migrate_External_Paramed_New_Point2d : (units_old -> units_new) -> (coordinates_old -> coordinates_new) -> Migrate_External_Paramed.Old.Point2d units_old coordinates_old -> Migrate_External_Paramed.New.Point2d units_new coordinates_new
 migrate_Migrate_External_Paramed_New_Point2d migrate_units migrate_coordinates old =
-    old |> migrate_Migrate_External_Paramed_New_Point2d_ migrate_units migrate_coordinates
+    old |> migrate_Migrate_External_Paramed_New_Point2d_
 
 
-migrate_Migrate_External_Paramed_New_Point2d_ : (units_old -> units_new) -> (coordinates_old -> coordinates_new) -> Migrate_External_Paramed.Old.Point2d_ units_old coordinates_old -> Migrate_External_Paramed.New.Point2d_ units_new coordinates_new
-migrate_Migrate_External_Paramed_New_Point2d_ migrate_units migrate_coordinates old =
+migrate_Migrate_External_Paramed_New_Point2d_ : Migrate_External_Paramed.Old.Point2d_ units_old coordinates_old -> Migrate_External_Paramed.New.Point2d_ units_new coordinates_new
+migrate_Migrate_External_Paramed_New_Point2d_ old =
     case old of
         Migrate_External_Paramed.Old.Point2d_ p0 ->
             Migrate_External_Paramed.New.Point2d_ p0
diff --git a/test/scenario-migration-generate/src/Migrate_External_Paramed/Expected.elm b/test/scenario-migration-generate/src/Migrate_External_Paramed/Expected.elm
@@ -103,11 +103,11 @@ migrate_Migrate_External_Paramed_New_NColor old =
 
 migrate_Migrate_External_Paramed_New_Point2d : (units_old -> units_new) -> (coordinates_old -> coordinates_new) -> Migrate_External_Paramed.Old.Point2d units_old coordinates_old -> Migrate_External_Paramed.New.Point2d units_new coordinates_new
 migrate_Migrate_External_Paramed_New_Point2d migrate_units migrate_coordinates old =
-    old |> migrate_Migrate_External_Paramed_New_Point2d_ migrate_units migrate_coordinates
+    old |> migrate_Migrate_External_Paramed_New_Point2d_
 
 
-migrate_Migrate_External_Paramed_New_Point2d_ : (units_old -> units_new) -> (coordinates_old -> coordinates_new) -> Migrate_External_Paramed.Old.Point2d_ units_old coordinates_old -> Migrate_External_Paramed.New.Point2d_ units_new coordinates_new
-migrate_Migrate_External_Paramed_New_Point2d_ migrate_units migrate_coordinates old =
+migrate_Migrate_External_Paramed_New_Point2d_ : Migrate_External_Paramed.Old.Point2d_ units_old coordinates_old -> Migrate_External_Paramed.New.Point2d_ units_new coordinates_new
+migrate_Migrate_External_Paramed_New_Point2d_ old =
     case old of
         Migrate_External_Paramed.Old.Point2d_ p0 ->
             Migrate_External_Paramed.New.Point2d_ p0
