Merge pull request #19 from lamdera/zero-serialisation-migrations

Zero-serialisation migration support

.github/workflows/build-windows-x86_64.yml

@@ -96,7 +96,7 @@ jobs:
           max_attempts: 4
           # https://gitlab.haskell.org/ghc/ghc/-/issues/20878
           # https://gitlab.haskell.org/ghc/ghc/-/issues/20010#note_359766
-          command: stack install --ghc-options '-optl"-Wl,-Bstatic,-lstdc++,-lgcc_s,-lwinpthread,-Bdynamic"'
+          command: (rm -rf reactor/elm-stuff || true) && stack install --ghc-options '-optl"-Wl,-Bstatic,-lstdc++,-lgcc_s,-lwinpthread,-Bdynamic"'
 
       - name: Copy binary files, dlls & check
         run: |

builder/src/Generate.hs

@@ -34,6 +34,8 @@ import qualified Reporting.Task as Task
 import qualified Stuff
 
 
+import Lamdera ((&))
+import qualified Lamdera
 import qualified Lamdera.AppConfig
 
 -- NOTE: This is used by Make, Repl, and Reactor right now. But it may be
@@ -77,7 +79,10 @@ prod root details (Build.Artifacts pkg _ roots modules) =
       checkForDebugUses objects
       let graph_ = objectsToGlobalGraph objects
       graph <- Task.io $ Lamdera.AppConfig.injectConfig graph_
+      longNamesEnabled <- Task.io $ Lamdera.useLongNames
       let mode = Mode.Prod (Mode.shortenFieldNames graph)
+                   & Lamdera.alternativeImplementationWhen longNamesEnabled
+                       (Mode.Prod (Mode.legibleFieldNames graph))
       let mains = gatherMains pkg objects roots
       return $ JS.generate mode graph mains
 

compiler/src/Compile.hs

@@ -37,6 +37,8 @@ import qualified Data.Text as T
 import qualified Data.Utf8
 import qualified Lamdera.UiSourceMap
 import qualified Lamdera.Nitpick.DebugLog
+import qualified Lamdera.Evergreen.ModifyAST
+
 
 -- import StandaloneInstances
 
@@ -68,8 +70,11 @@ compile pkg ifaces modul = do
   canonical0  <- canonicalize pkg ifaces modul_
   -- ()          <- debugPassText "starting canonical2" moduleName (pure ())
 
-  -- Add Canonical Wire gens, i.e. the `w3_[en|de]code_TYPENAME` functions
-  canonical2 <- Lamdera.Wire3.Core.addWireGenerations canonical0 pkg ifaces modul_
+  canonical2 <-
+    -- Add Canonical Wire gens, i.e. the `w3_[en|de]code_TYPENAME` functions
+    Lamdera.Wire3.Core.addWireGenerations canonical0 pkg ifaces modul_
+      -- Allow migrations to access non-exposed unsafeCoerce in lamdera/core
+      & fmap Lamdera.Evergreen.ModifyAST.update
 
   -- () <- unsafePerformIO $ do
   --   case (pkg, Src.getName modul) of

compiler/src/Generate/Mode.hs

@@ -3,6 +3,8 @@ module Generate.Mode
   , isDebug
   , ShortFieldNames
   , shortenFieldNames
+  -- @LAMDERA
+  , legibleFieldNames
   )
   where
 
@@ -57,14 +59,24 @@ addToBuckets field frequency buckets =
 addToShortNames :: [Name.Name] -> ShortFieldNames -> ShortFieldNames
 addToShortNames fields shortNames =
   List.foldl' addField shortNames fields
-    & Lamdera.alternativeImplementationWhen (Lamdera.isLongNamesEnabled_)
-        (List.foldl' (\shortNames field ->
-            Map.insert field (JsName.fromLocal field) shortNames
-          ) shortNames fields
-        )
 
 
 addField :: ShortFieldNames -> Name.Name -> ShortFieldNames
 addField shortNames field =
   let rename = JsName.fromInt (Map.size shortNames) in
   Map.insert field rename shortNames
+
+
+-- @LAMDERA
+
+legibleFieldNames :: Opt.GlobalGraph -> ShortFieldNames
+legibleFieldNames (Opt.GlobalGraph _ frequencies) =
+  Map.foldr addToNamesLegible Map.empty $
+    Map.foldrWithKey addToBuckets Map.empty frequencies
+
+addToNamesLegible :: [Name.Name] -> ShortFieldNames -> ShortFieldNames
+addToNamesLegible fields shortNames =
+  -- Does not shorten field names, but adds them to the short names map
+  List.foldl' (\shortNames field ->
+    Map.insert field (JsName.fromLocal field) shortNames
+  ) shortNames fields

elm.cabal

@@ -246,6 +246,7 @@ Executable lamdera
         Lamdera.Evergreen.MigrationGeneratorUnion
         Lamdera.Evergreen.MigrationHarness
         Lamdera.Evergreen.MigrationSpecialCases
+        Lamdera.Evergreen.ModifyAST
         Lamdera.Evergreen.Snapshot
         Lamdera.Extensions
         Lamdera.Graph

extra/Lamdera.hs

@@ -45,8 +45,7 @@ module Lamdera
   , isWireEnabled_
   , useLongNames_
   , enableLongNames
-  , isLongNamesEnabled
-  , isLongNamesEnabled_
+  , useLongNames
   , isTest
   , isLiveMode
   , setLiveMode
@@ -91,6 +90,8 @@ module Lamdera
   , lamderaEnvModePath
   , lamderaExternalWarningsPath
   , lamderaBackendDevSnapshotPath
+  , withCompilerRoot
+  , withRuntimeRoot
   , Ext.Common.setProjectRoot
   , Ext.Common.getProjectRoot
   , Ext.Common.getProjectRootFor
@@ -105,6 +106,7 @@ module Lamdera
   , getEnvMode
   , setEnvMode
   , setEnv
+  , forceEnv
   , unsetEnv
   , lookupEnv
   , requireEnv
@@ -439,20 +441,16 @@ isWireEnabled_ = unsafePerformIO $ isWireEnabled
 useLongNames_ :: MVar Bool
 useLongNames_ = unsafePerformIO $ newMVar False
 
+{-# NOINLINE useLongNames #-}
+useLongNames :: IO Bool
+useLongNames = do
+  readMVar useLongNames_
+
 enableLongNames :: IO ()
 enableLongNames = do
   debug $ "🗜️ enableLongNames"
   modifyMVar_ useLongNames_ (\_ -> pure True)
 
-{-# NOINLINE isLongNamesEnabled #-}
-isLongNamesEnabled :: IO Bool
-isLongNamesEnabled = do
-  readMVar useLongNames_
-
-{-# NOINLINE isLongNamesEnabled_ #-}
-isLongNamesEnabled_ :: Bool
-isLongNamesEnabled_ = unsafePerformIO $ isLongNamesEnabled
-
 
 isTest :: IO Bool
 isTest = do
@@ -795,9 +793,18 @@ lamderaBackendDevSnapshotPath = do
   pure $ lamderaCache root </> ".lamdera-bem-dev"
 
 
+withCompilerRoot :: FilePath -> FilePath
+withCompilerRoot path =
+  unsafePerformIO $ do
+    home <- Dir.getHomeDirectory
+    pure $ home </> "dev" </> "projects" </> "lamdera-compiler" </> path
 
 
-
+withRuntimeRoot :: FilePath -> FilePath
+withRuntimeRoot path =
+  unsafePerformIO $ do
+    home <- Dir.getHomeDirectory
+    pure $ home </> "dev" </> "projects" </> "lamdera-runtime" </> path
 
 
 lowerFirstLetter :: String -> Text
@@ -873,6 +880,11 @@ setEnv name value = do
   debug $ Prelude.concat ["🌏✍️  ENV ", name, ":", value]
   Env.setEnv name value
 
+forceEnv :: String -> Maybe String -> IO ()
+forceEnv name value = do
+  case value of
+    Just v -> setEnv name v
+    Nothing -> unsetEnv name
 
 unsetEnv :: String -> IO ()
 unsetEnv name = do

extra/Lamdera/AppConfig.hs

@@ -271,7 +271,6 @@ fetchAppConfigItems appName token = do
       if textContains "-local" appName
         then
           "http://localhost:8082/_r/configItemsJson"
-          -- "https://" <> T.unpack appName <> ".lamdera.test/_i"
         else
           "https://dashboard.lamdera.app/_r/configItemsJson"
 

extra/Lamdera/CLI/Check.hs

@@ -590,7 +590,7 @@ buildProductionJsFiles root inProduction_ versionInfo = do
         , _report = Nothing
         , _docs = Nothing
         , _noWire = False
-        , _optimizeLegible = False
+        , _optimizeLegible = True
         }
 
     Make.run ["src" </> "LFR.elm"] $

extra/Lamdera/Compile.hs

@@ -68,7 +68,7 @@ make_ root = do
           , _report = Nothing
           , _docs = Nothing
           , _noWire = False
-          , _optimizeLegible = False
+          , _optimizeLegible = True
           }
   wait r
   -- The compilation process ends by printing to terminal in a way that overwrites

extra/Lamdera/Evergreen/MigrationHarness.hs

@@ -75,6 +75,12 @@ generateFor nextVersion migrationFilepaths = do
   debug_ $ "Generated source for LamderaGenerated"
 
   let
+    upgradeBackendModel =
+      if vinfoVersion nextVersion > 1 then
+        upgradeFor migrationSequence nextVersion "BackendModel"
+      else
+        "upgradeBackendModelPrevious = ()\n\n"
+
     final =
       [text|
         module LamderaGenerated exposing (..)
@@ -87,33 +93,33 @@ generateFor nextVersion migrationFilepaths = do
         currentVersion =
             $nextVersion_
 
-
+        $upgradeBackendModel
         $decodeAndUpgrades
 
       |]
 
   pure $ Ext.ElmFormat.formatOrPassthrough final
 
 
+valueTypeToCmdMsgType :: Text -> Text
+valueTypeToCmdMsgType valueType =
+  case valueType of
+    "BackendModel"  -> "BackendMsg"
+    "FrontendModel" -> "FrontendMsg"
+    "FrontendMsg"   -> "FrontendMsg"
+    "ToBackend"     -> "BackendMsg"
+    "BackendMsg"    -> "BackendMsg"
+    "ToFrontend"    -> "FrontendMsg"
+    _               ->
+      error $ "Evergreen.Generation: impossible value type: " <> show valueType
+
 
 decodeAndUpgradeFor migrationSequence nextVersion valueType = do
   let
-    nextVersion_ = show_ $ vinfoVersion nextVersion
-
+    nextVersion_        = show_ $ vinfoVersion nextVersion
     historicMigrations_ = historicMigrations migrationSequence nextVersion valueType
-
-    cmdMsgType =
-      case valueType of
-        "BackendModel"  -> "BackendMsg"
-        "FrontendModel" -> "FrontendMsg"
-        "FrontendMsg"   -> "FrontendMsg"
-        "ToBackend"     -> "BackendMsg"
-        "BackendMsg"    -> "BackendMsg"
-        "ToFrontend"    -> "FrontendMsg"
-        _               ->
-          error $ "Evergreen.Generation: impossible value type: " <> show valueType
-
-    valueTypeInt = show_ $ tipeStringToInt valueType
+    cmdMsgType          = valueTypeToCmdMsgType valueType
+    valueTypeInt        = show_ $ tipeStringToInt valueType
 
     caseAll =
       if historicMigrations_ /= "" then
@@ -151,7 +157,37 @@ decodeAndUpgradeFor migrationSequence nextVersion valueType = do
   |]
 
 
-typeImports :: [(a, [VersionInfo])] -> VersionInfo -> [Text]
+upgradeFor migrationSequence nextVersion valueType = do
+  let
+    nextVersion_        = show_ $ vinfoVersion nextVersion
+    currentVersion_     = show_ $ (vinfoVersion nextVersion) - 1
+    historicMigrations_ = historicMigrations migrationSequence nextVersion valueType
+    cmdMsgType          = valueTypeToCmdMsgType valueType
+    valueTypeInt        = show_ $ tipeStringToInt valueType
+    valueTypeTitleCase  = lowerFirstLetter_ valueType
+
+  case nextVersion of
+    WithMigrations _ ->
+        [untrimming|
+          upgrade${valueType}Previous : T$currentVersion_.$valueType -> UpgradeResult T$nextVersion_.$valueType T$nextVersion_.$cmdMsgType
+          upgrade${valueType}Previous model_v$currentVersion_ =
+              model_v$currentVersion_
+                  |> M$nextVersion_.$valueTypeTitleCase
+
+
+        |]
+
+    WithoutMigrations _ ->
+        [untrimming|
+          upgrade${valueType}Previous : T$nextVersion_.$valueType -> UpgradeResult T$nextVersion_.$valueType T$nextVersion_.$cmdMsgType
+          upgrade${valueType}Previous model_v$currentVersion_ =
+              unchanged model_v$currentVersion_
+
+
+        |]
+
+
+typeImports :: (Show a) => [(a, [VersionInfo])] -> VersionInfo -> [Text]
 typeImports migrationSequence nextVersion =
   migrationSequence
     & List.head
@@ -379,12 +415,11 @@ data VersionInfo = WithMigrations Int | WithoutMigrations Int deriving (Eq, Show
 justWithMigrationVersions :: [VersionInfo] -> [Int]
 justWithMigrationVersions versions =
   versions
-    & fmap (\vinfo ->
+    & filterMap (\vinfo ->
       case vinfo of
         WithMigrations v -> Just v
         WithoutMigrations v -> Nothing
     )
-    & justs
 
 
 vinfoVersion :: VersionInfo -> Int
@@ -539,6 +574,11 @@ genSupportingCode = do
             priorResult |> Result.map Upgraded
 
 
+        unchanged : oldModel -> UpgradeResult newModel msg
+        unchanged model =
+            Upgraded ( unsafeCoerce model, Cmd.none )
+
+
         upgradeIsCurrent : Result String ( newModel, Cmd msg ) -> Result String (UpgradeResult newModel msg)
         upgradeIsCurrent priorResult =
             priorResult |> Result.map AlreadyCurrent