Production harness checker needs the unsafeCoerce helper trick as well

lamdera · May 6, 2024 · 433ec5e · 433ec5e
1 parent f2f2287
commit 433ec5e
Show file tree

Hide file tree

Showing 3 changed files with 59 additions and 30 deletions.
diff --git a/extra/Lamdera/Evergreen/MigrationHarness.hs b/extra/Lamdera/Evergreen/MigrationHarness.hs
@@ -169,18 +169,25 @@ upgradeFor migrationSequence nextVersion valueType = do
   case nextVersion of
     WithMigrations _ ->
         [untrimming|
-          -- upgrade${valueType}Previous : T$currentVersion_.$valueType -> UpgradeResult T$nextVersion_.$valueType T$nextVersion_.$cmdMsgType
+          {-| upgrade${valueType}Previous : T$currentVersion_.$valueType -> UpgradeResult T$nextVersion_.$valueType T$nextVersion_.$cmdMsgType
+          -}
           upgrade${valueType}Previous : previousModel -> UpgradeResult T$nextVersion_.$valueType T$nextVersion_.$cmdMsgType
           upgrade${valueType}Previous model_v$currentVersion_ =
-              unsafeCoerce model_v$currentVersion_
-                  |> M$nextVersion_.$valueTypeTitleCase
+              case unsafeCoerce model_v$currentVersion_ |> M$nextVersion_.$valueTypeTitleCase of
+                ModelMigrated ( newValue, cmds ) ->
+                  Upgraded ( newValue, cmds )
+
+                ModelUnchanged ->
+                  -- Should be impossible in this context
+                  unchanged model_v$currentVersion_
 
 
         |]
 
     WithoutMigrations _ ->
         [untrimming|
-          -- upgrade${valueType}Previous : T$nextVersion_.$valueType -> UpgradeResult T$nextVersion_.$valueType T$nextVersion_.$cmdMsgType
+          {-| upgrade${valueType}Previous : T$currentVersion_.$valueType -> UpgradeResult T$nextVersion_.$valueType T$nextVersion_.$cmdMsgType
+          -}
           upgrade${valueType}Previous : previousModel -> UpgradeResult T$nextVersion_.$valueType T$nextVersion_.$cmdMsgType
           upgrade${valueType}Previous model_v$currentVersion_ =
               unchanged model_v$currentVersion_
@@ -531,7 +538,27 @@ genSupportingCode = do
     then
       -- In production, use shared injected code that the LBR/LFR runtime harnesses
       -- also reference to share types and type check everything together
-      pure "import LamderaHelpers exposing (..)\n"
+      pure [text|
+        import Lamdera exposing (sendToFrontend)
+        import LamderaHelpers exposing (..)
+
+
+        {-|
+          All local call-sites to this function will get replaced by the compiler
+          to point to Lamdera.Effect.unsafeCoerce instead, and this def will be removed
+          See lamdera-compiler/extra/Lamdera/Evergreen/ModifyAST.hs
+        -}
+        unsafeCoerce : a -> b
+        unsafeCoerce =
+            let
+                -- This is a hack to ensure the Lamdera.Effect module gets included
+                -- in overall compile scope given we cannot reference it directly
+                forceInclusion =
+                    sendToFrontend
+            in
+            Debug.todo "unsafeCoerce"
+
+      |]
     else
       -- In development, we aren't building with the harnesses, so rather than an extra
       -- file dependency, just inject the additional helpers we need to type check our migrations

diff --git a/extra/Lamdera/Evergreen/ModifyAST.hs b/extra/Lamdera/Evergreen/ModifyAST.hs
@@ -41,12 +41,10 @@ update canonical =
     newCanonical :: Can.Module = canonical { Can._decls = newDecls }
   in
   case moduleName of
-    Module.Canonical (Name "author" "project") "LamderaHelpers" ->
-      newCanonical
-    Module.Canonical (Name "author" "project") "LamderaCheckBoth" ->
-      newCanonical
-    _ ->
-      canonical
+    Module.Canonical (Name "author" "project") "LamderaHelpers" ->   newCanonical
+    Module.Canonical (Name "author" "project") "LamderaCheckBoth" -> newCanonical
+    Module.Canonical (Name "author" "project") "LamderaGenerated" -> newCanonical
+    _ -> canonical
 
 
 removeUnsafeCoercePlaceholder :: Can.Decls -> Can.Decls
@@ -56,23 +54,18 @@ removeUnsafeCoercePlaceholder decls =
 
 updateDecls :: Module.Canonical -> Can.Decls -> Can.Decls
 updateDecls fileName decls =
-  case fileName of
-    Module.Canonical (Name "author" "project") "LamderaHelpers" ->
-      case decls of
-        Can.Declare def nextDecl ->
-          Can.Declare (updateDefs fileName def) (updateDecls fileName nextDecl)
+  case decls of
+    Can.Declare def nextDecl ->
+      Can.Declare (updateDefs fileName def) (updateDecls fileName nextDecl)
 
-        Can.DeclareRec def remainingDefs nextDecl ->
-          Can.DeclareRec
-            (updateDefs fileName def)
-            (map (updateDefs fileName) remainingDefs)
-            (updateDecls fileName nextDecl)
+    Can.DeclareRec def remainingDefs nextDecl ->
+      Can.DeclareRec
+        (updateDefs fileName def)
+        (map (updateDefs fileName) remainingDefs)
+        (updateDecls fileName nextDecl)
 
-        Can.SaveTheEnvironment ->
-          Can.SaveTheEnvironment
-
-    _ ->
-        decls
+    Can.SaveTheEnvironment ->
+      Can.SaveTheEnvironment
 
 
 updateExpr :: Module.Canonical -> Name.Name -> Can.Expr -> Can.Expr
@@ -101,6 +94,11 @@ updateExpr fileName functionName (Reporting.Annotation.At location_ expr_) =
         ) params ->
           replaceCall location params
 
+      Can.Call (Reporting.Annotation.At location
+          (Can.VarTopLevel (Module.Canonical (Name "author" "project") "LamderaGenerated") "unsafeCoerce")
+        ) params ->
+          replaceCall location params
+
       -- The recursive rest. Might be worth looking at revisiting recursion schemes again, esp if error messages have improved
       Can.VarLocal name -> Can.VarLocal name
       Can.VarTopLevel canonical name -> Can.VarTopLevel canonical name

diff --git a/test/Lamdera/Evergreen/TestMigrationHarness.hs b/test/Lamdera/Evergreen/TestMigrationHarness.hs
@@ -154,7 +154,7 @@ suite = tests
 
 
           upgradeBackendModelPrevious =
-              ()
+              unchanged
 
 
           decodeAndUpgradeBackendModel : Int -> Bytes -> UpgradeResult T1.BackendModel T1.BackendMsg
@@ -258,9 +258,11 @@ suite = tests
               2
 
 
-          upgradeBackendModelPrevious : T1.BackendModel -> UpgradeResult T2.BackendModel T2.BackendMsg
+          {-| upgradeBackendModelPrevious : T1.BackendModel -> UpgradeResult T2.BackendModel T2.BackendMsg
+          -}
+          upgradeBackendModelPrevious : previousModel -> UpgradeResult T2.BackendModel T2.BackendMsg
           upgradeBackendModelPrevious model_v1 =
-              model_v1
+              unsafeCoerce model_v1
                   |> M2.backendModel
 
 
@@ -423,7 +425,9 @@ suite = tests
               2
 
 
-          upgradeBackendModelPrevious : T2.BackendModel -> UpgradeResult T2.BackendModel T2.BackendMsg
+          {-| upgradeBackendModelPrevious : T1.BackendModel -> UpgradeResult T2.BackendModel T2.BackendMsg
+          -}
+          upgradeBackendModelPrevious : previousModel -> UpgradeResult T2.BackendModel T2.BackendMsg
           upgradeBackendModelPrevious model_v1 =
               unchanged model_v1