From 071e43e821a8527055c2e247a44502069dd596c2 Mon Sep 17 00:00:00 2001 From: Mario Rogic Date: Sat, 13 Apr 2024 16:32:16 +1000 Subject: [PATCH 1/8] Build Lamdera backends in optimize-legible mode as we move towards zero-serialisation migrations --- extra/Lamdera/CLI/Check.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/Lamdera/CLI/Check.hs b/extra/Lamdera/CLI/Check.hs index 4414695e..a394120c 100644 --- a/extra/Lamdera/CLI/Check.hs +++ b/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"] $ From 40b090849c2c6f72488fd80bdbb6ea0af1627a7e Mon Sep 17 00:00:00 2001 From: Mario Rogic Date: Sat, 20 Apr 2024 15:29:51 +1000 Subject: [PATCH 2/8] Generate function to allow for backend model migration or upgrades from V-1 --- extra/Lamdera.hs | 6 + extra/Lamdera/AppConfig.hs | 1 - extra/Lamdera/Evergreen/MigrationHarness.hs | 78 +++++++--- extra/Lamdera/Injection.hs | 15 +- extra/LocalDev/LocalDev.elm | 28 ++-- extra/SocketServer.hs | 2 + .../Evergreen/TestMigrationGenerator.hs | 2 +- .../Lamdera/Evergreen/TestMigrationHarness.hs | 138 ++++++++++++++++++ test/Test/Helpers.hs | 29 ++-- .../src/Frontend.elm | 24 +++ 10 files changed, 276 insertions(+), 47 deletions(-) diff --git a/extra/Lamdera.hs b/extra/Lamdera.hs index 9b6fbc44..9da83924 100644 --- a/extra/Lamdera.hs +++ b/extra/Lamdera.hs @@ -105,6 +105,7 @@ module Lamdera , getEnvMode , setEnvMode , setEnv + , forceEnv , unsetEnv , lookupEnv , requireEnv @@ -873,6 +874,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 diff --git a/extra/Lamdera/AppConfig.hs b/extra/Lamdera/AppConfig.hs index f46a7090..6472ceaf 100644 --- a/extra/Lamdera/AppConfig.hs +++ b/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" diff --git a/extra/Lamdera/Evergreen/MigrationHarness.hs b/extra/Lamdera/Evergreen/MigrationHarness.hs index 547605ad..c2e741ef 100644 --- a/extra/Lamdera/Evergreen/MigrationHarness.hs +++ b/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 + "" + final = [text| module LamderaGenerated exposing (..) @@ -87,7 +93,7 @@ generateFor nextVersion migrationFilepaths = do currentVersion = $nextVersion_ - + $upgradeBackendModel $decodeAndUpgrades |] @@ -95,25 +101,25 @@ generateFor nextVersion migrationFilepaths = do 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}_v$currentVersion_ : T$currentVersion_.$valueType -> UpgradeResult T$nextVersion_.$valueType T$nextVersion_.$cmdMsgType + upgrade${valueType}_v$currentVersion_ model_v$currentVersion_ = + model_v$currentVersion_ + |> M$nextVersion_.$valueTypeTitleCase + + + |] + + WithoutMigrations _ -> + [untrimming| + upgrade${valueType}_v$currentVersion_ : T$nextVersion_.$valueType -> UpgradeResult T$nextVersion_.$valueType T$nextVersion_.$cmdMsgType + upgrade${valueType}_v$currentVersion_ 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 : newModel -> Result String (UpgradeResult newModel msg) + unchanged model = + Ok ( Upgraded ( model, Cmd.none ) ) + + upgradeIsCurrent : Result String ( newModel, Cmd msg ) -> Result String (UpgradeResult newModel msg) upgradeIsCurrent priorResult = priorResult |> Result.map AlreadyCurrent diff --git a/extra/Lamdera/Injection.hs b/extra/Lamdera/Injection.hs index ef116476..8e95364a 100644 --- a/extra/Lamdera/Injection.hs +++ b/extra/Lamdera/Injection.hs @@ -185,6 +185,8 @@ injections isBackend isLocalDev = var fns = { decodeWirePayloadHeader: $$author$$project$$LamderaHelpers$$decodeWirePayloadHeader , decodeWireAnalytics: $$author$$project$$LamderaHelpers$$decodeWireAnalytics + , getUserModel : function() { return model.userModel } + , setUserModel : function(userModel) { model.userModel = userModel } } |] else @@ -288,9 +290,20 @@ injections isBackend isLocalDev = model = null; stepper = null; ports = null; + _Platform_effectsQueue = []; + + // Do we need to call these functions? Or will the `= []` be enough? + // _Platform_enqueueEffects(managers, $$elm$$core$$Platform$$Cmd$$none, $$elm$$core$$Platform$$Sub$$none); + // _Platform_enqueueEffects(managers, _Platform_batch(_List_Nil), _Platform_batch(_List_Nil)); } - return ports ? { ports: ports, gm: function() { return model }, eum: function() { upgradeMode = true }, die: die, fns: fns } : {}; + return ports ? { + ports: ports, + gm: function() { return model }, + eum: function() { upgradeMode = true }, + die: die, + fns: fns + } : {}; } |] diff --git a/extra/LocalDev/LocalDev.elm b/extra/LocalDev/LocalDev.elm index ea92678b..79546351 100644 --- a/extra/LocalDev/LocalDev.elm +++ b/extra/LocalDev/LocalDev.elm @@ -16,13 +16,13 @@ port module LocalDev exposing (main) be relied on in any way. -} --- import Bytes -- import Http -- import LamderaGenerated -- import LamderaHelpers exposing (..) import Backend import Browser +import Bytes import Env import Frontend import Html exposing (..) @@ -273,6 +273,24 @@ init flags url key = -- Prior backend model has failed to restore, notify the user of a resulting reset ( ibem, iBeCmds, True ) + _ = + case flags.b of + Nothing -> + bem + + Just backendModelBytes -> + if Bytes.width backendModelBytes > 1024 then + let + -- The backend model is really large now, it's not useful to + -- log to the console anymore and slows things down + _ = + log "☀️ Restored BackendModel " () + in + bem + + else + log "☀️ Restored BackendModel" bem + devbarInit = { expanded = False , location = BottomLeft @@ -305,14 +323,6 @@ init flags url key = -- Data might have reset since our last refresh , showResetNotification = didReset } - in - let - x = - if didReset || (bem == ibem) then - bem - - else - log "☀️ Restored BackendModel" bem nodeType = case flags.nt of diff --git a/extra/SocketServer.hs b/extra/SocketServer.hs index d0ec75c5..ba945848 100644 --- a/extra/SocketServer.hs +++ b/extra/SocketServer.hs @@ -42,6 +42,8 @@ socketHandler mClients mLeader beState onJoined onReceive clientId sessionId pen Just leaderId -> if leaderId == clientId then do + -- This client was the leader but is now disconnecting, + -- so we need to elect a new leader writeTVar mLeader (getNextLeader remainingClients) pure True diff --git a/test/Lamdera/Evergreen/TestMigrationGenerator.hs b/test/Lamdera/Evergreen/TestMigrationGenerator.hs index f85f9675..3e14be58 100644 --- a/test/Lamdera/Evergreen/TestMigrationGenerator.hs +++ b/test/Lamdera/Evergreen/TestMigrationGenerator.hs @@ -204,4 +204,4 @@ testExamples = withTestEnv $ do -- (_, _, Nothing) -> error $ "Could not find `expectation` string in test: " <> N.toChars moduleName -- (Nothing, Just typeNew, _) -> error $ "Could not find TypeOld in test: " <> N.toChars moduleName -- (Just typeOld, Nothing, _) -> error $ "Could not find TypeNew in test: " <> N.toChars moduleName <> " or " <> N.toChars moduleName2 --- (Nothing, Nothing, _) -> error $ "Could not find TypeOld or TypeNew in test: " <> N.toChars moduleName \ No newline at end of file +-- (Nothing, Nothing, _) -> error $ "Could not find TypeOld or TypeNew in test: " <> N.toChars moduleName diff --git a/test/Lamdera/Evergreen/TestMigrationHarness.hs b/test/Lamdera/Evergreen/TestMigrationHarness.hs index 41aa4276..5400c746 100644 --- a/test/Lamdera/Evergreen/TestMigrationHarness.hs +++ b/test/Lamdera/Evergreen/TestMigrationHarness.hs @@ -253,6 +253,12 @@ suite = tests 2 + upgradeBackendModel_v1 : T1.BackendModel -> UpgradeResult T2.BackendModel T2.BackendMsg + upgradeBackendModel_v1 model_v1 = + model_v1 + |> M2.backendModel + + decodeAndUpgradeBackendModel : Int -> Bytes -> UpgradeResult T2.BackendModel T2.BackendMsg decodeAndUpgradeBackendModel version bytes = case version of @@ -357,6 +363,138 @@ suite = tests |> upgradeIsCurrent |> otherwiseError + _ -> + UnknownVersion ( version, "ToFrontend", bytes ) + |] + , scope "full first - (WithoutMigrations 2)" $ do + + let + nextVersion = (WithoutMigrations 2) + migrationsFilenames = [] + migrations <- io $ Lamdera.Evergreen.MigrationHarness.getMigrationsSequence migrationsFilenames nextVersion 2 + result <- io $ withProdMode $ Lamdera.Evergreen.MigrationHarness.generateFor nextVersion migrationsFilenames + + scope "full" $ + expectEqualTextTrimmed result + [text| + + module LamderaGenerated exposing (..) + + import Evergreen.V1.Types as T1 + import Lamdera.Migrations exposing (..) + import Lamdera.Wire3 exposing (Bytes, Decoder, Encoder, bytesDecode, bytesEncode) + import LamderaHelpers exposing (..) + import Types as T2 + + + currentVersion : Int + currentVersion = + 2 + + + upgradeBackendModel_v1 : T2.BackendModel -> UpgradeResult T2.BackendModel T2.BackendMsg + upgradeBackendModel_v1 model_v1 = + unchanged model_v1 + + + decodeAndUpgradeBackendModel : Int -> Bytes -> UpgradeResult T2.BackendModel T2.BackendMsg + decodeAndUpgradeBackendModel version bytes = + case version of + 1 -> + decodeType 5 2 bytes T2.w3_decode_BackendModel + |> upgradeSucceeds + |> otherwiseError + + 2 -> + decodeType 5 version bytes T2.w3_decode_BackendModel + |> upgradeIsCurrent + |> otherwiseError + + _ -> + UnknownVersion ( version, "BackendModel", bytes ) + + + decodeAndUpgradeFrontendModel : Int -> Bytes -> UpgradeResult T2.FrontendModel T2.FrontendMsg + decodeAndUpgradeFrontendModel version bytes = + case version of + 1 -> + decodeType 4 2 bytes T2.w3_decode_FrontendModel + |> upgradeSucceeds + |> otherwiseError + + 2 -> + decodeType 4 version bytes T2.w3_decode_FrontendModel + |> upgradeIsCurrent + |> otherwiseError + + _ -> + UnknownVersion ( version, "FrontendModel", bytes ) + + + decodeAndUpgradeFrontendMsg : Int -> Bytes -> UpgradeResult T2.FrontendMsg T2.FrontendMsg + decodeAndUpgradeFrontendMsg version bytes = + case version of + 1 -> + decodeType 0 2 bytes T2.w3_decode_FrontendMsg + |> upgradeSucceeds + |> otherwiseError + + 2 -> + decodeType 0 version bytes T2.w3_decode_FrontendMsg + |> upgradeIsCurrent + |> otherwiseError + + _ -> + UnknownVersion ( version, "FrontendMsg", bytes ) + + + decodeAndUpgradeToBackend : Int -> Bytes -> UpgradeResult T2.ToBackend T2.BackendMsg + decodeAndUpgradeToBackend version bytes = + case version of + 1 -> + decodeType 1 2 bytes T2.w3_decode_ToBackend + |> upgradeSucceeds + |> otherwiseError + + 2 -> + decodeType 1 version bytes T2.w3_decode_ToBackend + |> upgradeIsCurrent + |> otherwiseError + + _ -> + UnknownVersion ( version, "ToBackend", bytes ) + + + decodeAndUpgradeBackendMsg : Int -> Bytes -> UpgradeResult T2.BackendMsg T2.BackendMsg + decodeAndUpgradeBackendMsg version bytes = + case version of + 1 -> + decodeType 2 2 bytes T2.w3_decode_BackendMsg + |> upgradeSucceeds + |> otherwiseError + + 2 -> + decodeType 2 version bytes T2.w3_decode_BackendMsg + |> upgradeIsCurrent + |> otherwiseError + + _ -> + UnknownVersion ( version, "BackendMsg", bytes ) + + + decodeAndUpgradeToFrontend : Int -> Bytes -> UpgradeResult T2.ToFrontend T2.FrontendMsg + decodeAndUpgradeToFrontend version bytes = + case version of + 1 -> + decodeType 3 2 bytes T2.w3_decode_ToFrontend + |> upgradeSucceeds + |> otherwiseError + + 2 -> + decodeType 3 version bytes T2.w3_decode_ToFrontend + |> upgradeIsCurrent + |> otherwiseError + _ -> UnknownVersion ( version, "ToFrontend", bytes ) |] diff --git a/test/Test/Helpers.hs b/test/Test/Helpers.hs index 617c6644..8795aa2c 100644 --- a/test/Test/Helpers.hs +++ b/test/Test/Helpers.hs @@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} module Test.Helpers where -import System.Environment (lookupEnv) import System.FilePath (()) import Data.Text as T import qualified Data.Text.Encoding as T @@ -24,20 +24,12 @@ aggressiveCacheClear project = do withDebug :: IO a -> IO a withDebug io = do - setEnv "LDEBUG" "1" - res <- io - unsetEnv "LDEBUG" - pure res + withEnvVars [ ("LDEBUG", "1") ] io withDebugPkg :: IO a -> IO a withDebugPkg io = do - setEnv "LDEBUG" "1" - setEnv "LOVR" "/Users/mario/dev/projects/lamdera/overrides" - res <- io - unsetEnv "LDEBUG" - unsetEnv "LOVR" - pure res + withEnvVars [ ("LDEBUG", "1"), ("LOVR", "/Users/mario/dev/projects/lamdera/overrides") ] io withTestEnv :: EasyTest.Test a -> EasyTest.Test a @@ -55,12 +47,17 @@ withTestEnv test = do withProdMode :: IO a -> IO a -withProdMode io = do - setEnv "LDEBUG" "1" - setEnv "LAMDERA_APP_NAME" "test-local" +withProdMode io = + -- The presence of LAMDERA_APP_NAME causes lamdera check to decide we're in production mode + withEnvVars [ ("LDEBUG", "1"), ("LAMDERA_APP_NAME", "test-local") ] io + + +withEnvVars :: [(String, String)] -> IO a -> IO a +withEnvVars vars io = do + originalVars <- traverse (\(k, _) -> (k,) <$> lookupEnv k) vars + traverse (uncurry setEnv) vars res <- io - unsetEnv "LDEBUG" - unsetEnv "LAMDERA_APP_NAME" + traverse (uncurry forceEnv) originalVars pure res diff --git a/test/scenario-empty-lamdera-init/src/Frontend.elm b/test/scenario-empty-lamdera-init/src/Frontend.elm index a1f7dfd9..684d1647 100644 --- a/test/scenario-empty-lamdera-init/src/Frontend.elm +++ b/test/scenario-empty-lamdera-init/src/Frontend.elm @@ -9,6 +9,22 @@ import Types exposing (..) import Url +main = + Browser.application + { init = flagInit + , update = update + , view = view + , subscriptions = \_ -> Sub.none + , onUrlRequest = UrlClicked + , onUrlChange = UrlChanged + } + + +flagInit : () -> (Url.Url -> Nav.Key -> ( Model, Cmd FrontendMsg )) +flagInit flags = + init + + type alias Model = FrontendModel @@ -25,8 +41,16 @@ app = } +testEquality = + NoOpFrontendMsg == NoOpFrontendMsg + + init : Url.Url -> Nav.Key -> ( Model, Cmd FrontendMsg ) init url key = + let + x = + testEquality + in ( { key = key , message = "Welcome to Lamdera! You're looking at the auto-generated base implementation. Check out src/Frontend.elm to start coding!" } From a1abfd6157908afc080a347ccf0aaa35b8ad2b0d Mon Sep 17 00:00:00 2001 From: Mario Rogic Date: Sat, 20 Apr 2024 21:41:57 +1000 Subject: [PATCH 3/8] Allow LamderaGenerated to reference unsafeCoerce without lamdera/core needing to expose it --- compiler/src/Compile.hs | 9 +- elm.cabal | 1 + extra/Lamdera/Evergreen/MigrationHarness.hs | 4 +- extra/Lamdera/Evergreen/ModifyAST.hs | 167 ++++++++++++++++++++ 4 files changed, 177 insertions(+), 4 deletions(-) create mode 100644 extra/Lamdera/Evergreen/ModifyAST.hs diff --git a/compiler/src/Compile.hs b/compiler/src/Compile.hs index 315a1f2c..9dc0d460 100644 --- a/compiler/src/Compile.hs +++ b/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 diff --git a/elm.cabal b/elm.cabal index 4f5b5660..83b3e681 100644 --- a/elm.cabal +++ b/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 diff --git a/extra/Lamdera/Evergreen/MigrationHarness.hs b/extra/Lamdera/Evergreen/MigrationHarness.hs index c2e741ef..1b8996a4 100644 --- a/extra/Lamdera/Evergreen/MigrationHarness.hs +++ b/extra/Lamdera/Evergreen/MigrationHarness.hs @@ -574,9 +574,9 @@ genSupportingCode = do priorResult |> Result.map Upgraded - unchanged : newModel -> Result String (UpgradeResult newModel msg) + unchanged : oldModel -> UpgradeResult newModel msg unchanged model = - Ok ( Upgraded ( model, Cmd.none ) ) + Upgraded ( unsafeCoerce model, Cmd.none ) upgradeIsCurrent : Result String ( newModel, Cmd msg ) -> Result String (UpgradeResult newModel msg) diff --git a/extra/Lamdera/Evergreen/ModifyAST.hs b/extra/Lamdera/Evergreen/ModifyAST.hs new file mode 100644 index 00000000..04db652c --- /dev/null +++ b/extra/Lamdera/Evergreen/ModifyAST.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Lamdera.Evergreen.ModifyAST (update) where + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Name as Name +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import NeatInterpolation + +import qualified Data.Utf8 +import AST.Canonical +import Elm.Package +import qualified AST.Canonical as Can +import qualified Elm.ModuleName as Module +import qualified Reporting.Annotation +import qualified Data.ByteString.Builder as B + +import Lamdera +import StandaloneInstances + + +{-| + +Finds any local vars `unsafeCoerce` within the `LamderaGenerated` module +and replaces them with a foreign var `Lamdera.Effect.unsafeCoerce`. + +This allows us to use `unsafeCoerce` in the generated code without exposing +it in the lamdera/core module, so it cannot be used in regular user code. + +-} +update :: Can.Module -> Can.Module +update canonical = + let + moduleName :: Module.Canonical = (Can._name canonical) + decls :: Can.Decls = (Can._decls canonical) + newDecls :: Can.Decls = updateDecls moduleName decls + in + canonical { Can._decls = newDecls } + + +updateDecls :: Module.Canonical -> Can.Decls -> Can.Decls +updateDecls fileName decls = + case fileName of + Module.Canonical (Name "author" "project") "LamderaGenerated" -> + 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.SaveTheEnvironment -> + Can.SaveTheEnvironment + + _ -> + decls + + +updateExpr :: Module.Canonical -> Name.Name -> Can.Expr -> Can.Expr +updateExpr fileName functionName (Reporting.Annotation.At location_ expr_) = + (case expr_ of + Can.VarLocal name -> Can.VarLocal name + Can.VarTopLevel canonical name -> Can.VarTopLevel canonical name + Can.VarKernel name name2 -> Can.VarKernel name name2 + Can.VarForeign canonical name annotation -> Can.VarForeign canonical name annotation + Can.VarCtor ctorOpts canonical name zeroBased annotation -> Can.VarCtor ctorOpts canonical name zeroBased annotation + Can.VarDebug canonical name annotation -> Can.VarDebug canonical name annotation + Can.VarOperator name canonical name2 annotation -> Can.VarOperator name canonical name2 annotation + Can.Chr string -> Can.Chr string + Can.Str string -> Can.Str string + Can.Int int -> Can.Int int + Can.Float float -> Can.Float float + Can.List exprs -> Can.List (fmap (updateExpr fileName functionName) exprs) + Can.Negate expr -> Can.Negate ((updateExpr fileName functionName) expr) + Can.Binop name canonical name2 annotation expr expr2 -> Can.Binop name canonical name2 annotation ((updateExpr fileName functionName) expr) ((updateExpr fileName functionName) expr2) + Can.Lambda patterns expr -> Can.Lambda patterns ((updateExpr fileName functionName) expr) + Can.Call (Reporting.Annotation.At location (Can.VarLocal "unsafeCoerce") ) params -> + Can.Call + (Reporting.Annotation.At + location + (Can.VarForeign + (Module.Canonical (Name "lamdera" "core") "Lamdera.Effect") + "unsafeCoerce" + (Forall Map.empty (TLambda (TVar "a") (TVar "b"))) + ) + ) + params + Can.Call expr exprs -> Can.Call ((updateExpr fileName functionName) expr) (fmap (updateExpr fileName functionName) exprs) + Can.If exprs expr -> + Can.If + (fmap + (\(first, second) -> + ((updateExpr fileName functionName) first + , (updateExpr fileName functionName) second + ) + ) + exprs + ) + ((updateExpr fileName functionName) expr) + Can.Let def expr -> + Can.Let + (updateDefs fileName def) + ((updateExpr fileName functionName) expr) + Can.LetRec defs expr -> + Can.LetRec + (fmap (updateDefs fileName) defs) + ((updateExpr fileName functionName) expr) + Can.LetDestruct pattern expr expr2 -> + Can.LetDestruct + pattern + ((updateExpr fileName functionName) expr) + ((updateExpr fileName functionName) expr2) + Can.Case expr caseBranches -> + Can.Case + ((updateExpr fileName functionName) expr) + (fmap + (\(Can.CaseBranch pattern caseExpr) -> + Can.CaseBranch pattern ((updateExpr fileName functionName) caseExpr) + ) + caseBranches + ) + Can.Accessor name -> Can.Accessor name + Can.Access expr name -> Can.Access ((updateExpr fileName functionName) expr) name + Can.Update name expr fieldUpdates -> + Can.Update + name + ((updateExpr fileName functionName) expr) + (fmap + (\(Can.FieldUpdate region expr__) -> + Can.FieldUpdate region (updateExpr fileName functionName expr__) + ) + fieldUpdates + ) + Can.Record fields -> Can.Record (fmap (\field -> updateExpr fileName functionName field) fields) + Can.Unit -> Can.Unit + Can.Tuple expr expr2 maybeExpr -> + Can.Tuple + ((updateExpr fileName functionName) expr) + ((updateExpr fileName functionName) expr2) + (fmap (updateExpr fileName functionName) maybeExpr) + Can.Shader shaderSource shaderTypes -> Can.Shader shaderSource shaderTypes + ) + & Reporting.Annotation.At location_ + + +updateDefs :: Module.Canonical -> Can.Def -> Can.Def +updateDefs fileName def = + case def of + Can.Def name patterns expr -> + Can.Def + name + patterns + ((updateExpr fileName (Reporting.Annotation.toValue name)) expr) + + Can.TypedDef name freeVars patterns expr type_ -> + Can.TypedDef + name + freeVars + patterns + ((updateExpr fileName (Reporting.Annotation.toValue name)) expr) + type_ From 561c63f74161f5c41188ceca11d5762b13efb466 Mon Sep 17 00:00:00 2001 From: Mario Rogic Date: Sun, 21 Apr 2024 21:20:18 +1000 Subject: [PATCH 4/8] Setup failing test for unsafeCoerce replacement --- extra/Lamdera/Evergreen/ModifyAST.hs | 6 ++- extra/Lamdera/Injection.hs | 10 ++++ test/EasyTest.hs | 17 +++++++ .../Evergreen/TestMigrationGenerator.hs | 3 +- .../Lamdera/Evergreen/TestMigrationHarness.hs | 46 +++++++++++++++++++ 5 files changed, 79 insertions(+), 3 deletions(-) diff --git a/extra/Lamdera/Evergreen/ModifyAST.hs b/extra/Lamdera/Evergreen/ModifyAST.hs index 04db652c..64910cbb 100644 --- a/extra/Lamdera/Evergreen/ModifyAST.hs +++ b/extra/Lamdera/Evergreen/ModifyAST.hs @@ -24,7 +24,7 @@ import StandaloneInstances {-| -Finds any local vars `unsafeCoerce` within the `LamderaGenerated` module +Finds any local vars `unsafeCoerce` within the `LamderaHelpers` module and replaces them with a foreign var `Lamdera.Effect.unsafeCoerce`. This allows us to use `unsafeCoerce` in the generated code without exposing @@ -38,13 +38,14 @@ update canonical = decls :: Can.Decls = (Can._decls canonical) newDecls :: Can.Decls = updateDecls moduleName decls in + debugHaskellPass "🟠🟠🟠🟠🟠 update on" moduleName $ canonical { Can._decls = newDecls } updateDecls :: Module.Canonical -> Can.Decls -> Can.Decls updateDecls fileName decls = case fileName of - Module.Canonical (Name "author" "project") "LamderaGenerated" -> + Module.Canonical (Name "author" "project") "LamderaHelpers" -> case decls of Can.Declare def nextDecl -> Can.Declare (updateDefs fileName def) (updateDecls fileName nextDecl) @@ -147,6 +148,7 @@ updateExpr fileName functionName (Reporting.Annotation.At location_ expr_) = Can.Shader shaderSource shaderTypes -> Can.Shader shaderSource shaderTypes ) & Reporting.Annotation.At location_ + & debugHaskell "🟠🟠🟠🟠🟠 updateExpr" updateDefs :: Module.Canonical -> Can.Def -> Can.Def diff --git a/extra/Lamdera/Injection.hs b/extra/Lamdera/Injection.hs index 8e95364a..0b6a2819 100644 --- a/extra/Lamdera/Injection.hs +++ b/extra/Lamdera/Injection.hs @@ -157,6 +157,15 @@ source mode mains = injections :: Bool -> Bool -> Text injections isBackend isLocalDev = let + previousVersionInt = + -- @TODO maybe its time to consolidate the global config... + (unsafePerformIO $ lookupEnv "VERSION") + & maybe "0" id + & read + & subtract 1 + + previousVersion = show_ previousVersionInt + isBackend_ = if isBackend then "true" @@ -187,6 +196,7 @@ injections isBackend isLocalDev = , decodeWireAnalytics: $$author$$project$$LamderaHelpers$$decodeWireAnalytics , getUserModel : function() { return model.userModel } , setUserModel : function(userModel) { model.userModel = userModel } + , upgradeBackendModel_v$previousVersion : function() { return $$author$$project$$LamderaGenerated$$upgradeBackendModel_v$previousVersion(model) } } |] else diff --git a/test/EasyTest.hs b/test/EasyTest.hs index 33f4595e..0d1370e0 100644 --- a/test/EasyTest.hs +++ b/test/EasyTest.hs @@ -90,6 +90,23 @@ expectTextContains haystack needle = , "◀️" ] +expectTextDoesNotContain :: T.Text -> T.Text -> Test () +expectTextDoesNotContain haystack needle = + if textContains needle haystack + then crash $ unlines + [ "" + , "💥💥💥" + , "Inside this haystack:" + , "▶️" + , (T.unpack haystack) + , "◀️" + , "I found this needle:" + , "▶️" + , (T.unpack needle) + , "◀️" + ] + else ok + textStripped :: T.Text -> T.Text textStripped t = diff --git a/test/Lamdera/Evergreen/TestMigrationGenerator.hs b/test/Lamdera/Evergreen/TestMigrationGenerator.hs index 3e14be58..0622d8d0 100644 --- a/test/Lamdera/Evergreen/TestMigrationGenerator.hs +++ b/test/Lamdera/Evergreen/TestMigrationGenerator.hs @@ -84,7 +84,8 @@ testMigrationGeneration scenario oldVersion newVersion = do Lamdera.Compile.makeDev "/Users/mario/dev/projects/lamdera-compiler/test/scenario-migration-generate" filenames compilationStdout `expectTextContains` - "This `Unimplemented` value is a:\n\n UnimplementedMigration" + -- "This `Unimplemented` value is a:\n\n UnimplementedMigration" + "This `Unimplemented` value is a:" testContainsUserTypes = do diff --git a/test/Lamdera/Evergreen/TestMigrationHarness.hs b/test/Lamdera/Evergreen/TestMigrationHarness.hs index 5400c746..7aa8efef 100644 --- a/test/Lamdera/Evergreen/TestMigrationHarness.hs +++ b/test/Lamdera/Evergreen/TestMigrationHarness.hs @@ -14,6 +14,7 @@ import Test.Helpers import Lamdera import Lamdera.Evergreen.MigrationHarness (VersionInfo(..)) import qualified Lamdera.Evergreen.MigrationHarness +import qualified Lamdera.Compile all = do @@ -366,6 +367,51 @@ suite = tests _ -> UnknownVersion ( version, "ToFrontend", bytes ) |] + + scope "compile and run" $ do + let + project = "/Users/mario/dev/projects/lamdera-compiler/test/scenario-migration-generate/" + helpers = "src/LamderaHelpers.elm" + target = "src/LamderaGenerated.elm" + filenames = [target] + + setup = do + writeUtf8 (project <> target) result + cp ("/Users/mario/lamdera/runtime/" <> helpers) (project <> helpers) + + cleanup _ = do + rm (project <> target) + rm (project <> helpers) + + test _ = do + + compilationStdout <- catchOutput $ + Lamdera.Compile.makeDev "/Users/mario/dev/projects/lamdera-compiler/test/scenario-migration-generate" filenames + + compilationStdout `expectTextDoesNotContain` + -- "This `Unimplemented` value is a:\n\n UnimplementedMigration" + "I cannot find a `unsafeCoerce` variable" + + -- actual <- catchOutput $ withStdinYesAll $ Ext.Common.withProjectRoot tmpFolder $ Init.run () () + + -- io $ formatHaskellValue "actual" actual + + -- expectTextContains actual + -- "Hello! Lamdera projects always start with an elm.json file, as well as four\\nsource files: Frontend.elm , Backend.elm, Types.elm and Env.elm\\n\\nIf you're new to Elm, the best starting point is\\n\\n\\nOtherwise check out for Lamdera\\nspecific information!\\n\\nKnowing all that, would you like me to create a starter implementation? [Y/n]: Okay, I created it! Now read those links, or get going with `lamdera live`.\\n" + + -- ignoreM <- io $ readUtf8Text $ tmpFolder ".gitignore" + + -- case ignoreM of + -- Just ignore -> + -- expectTextContains ignore "elm-stuff" + + -- Nothing -> + -- crash $ "Expected to find " <> tmpFolder <> "/.gitignore but didn't." + + + using setup cleanup test + + , scope "full first - (WithoutMigrations 2)" $ do let From 1a0dc1b8e0c2d46ef5eadeff928b719f4d9d2bec Mon Sep 17 00:00:00 2001 From: Mario Rogic Date: Sat, 27 Apr 2024 15:57:17 +1000 Subject: [PATCH 5/8] Fix type errors with unsafeCoerce mods, make upgrade function predictable to avoid version specific code --- builder/src/Generate.hs | 5 +++ compiler/src/Generate/Mode.hs | 22 ++++++++--- extra/Lamdera/Compile.hs | 2 +- extra/Lamdera/Evergreen/MigrationHarness.hs | 10 ++--- extra/Lamdera/Evergreen/ModifyAST.hs | 39 ++++++++++++------- extra/Lamdera/Injection.hs | 2 +- extra/Lamdera/Nitpick/DebugLog.hs | 4 +- extra/Lamdera/Wire3/Helpers.hs | 19 +++++++++ terminal/src/Make.hs | 4 +- .../Evergreen/TestMigrationGenerator.hs | 2 +- .../Lamdera/Evergreen/TestMigrationHarness.hs | 8 ++-- test/Test.hs | 3 ++ 12 files changed, 86 insertions(+), 34 deletions(-) diff --git a/builder/src/Generate.hs b/builder/src/Generate.hs index 1cc504b0..272e9327 100644 --- a/builder/src/Generate.hs +++ b/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.isLongNamesEnabled 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 diff --git a/compiler/src/Generate/Mode.hs b/compiler/src/Generate/Mode.hs index dab9b8b5..7d22aed6 100644 --- a/compiler/src/Generate/Mode.hs +++ b/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 diff --git a/extra/Lamdera/Compile.hs b/extra/Lamdera/Compile.hs index 5b0ef9ec..4dba942a 100644 --- a/extra/Lamdera/Compile.hs +++ b/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 diff --git a/extra/Lamdera/Evergreen/MigrationHarness.hs b/extra/Lamdera/Evergreen/MigrationHarness.hs index 1b8996a4..e52ff2cb 100644 --- a/extra/Lamdera/Evergreen/MigrationHarness.hs +++ b/extra/Lamdera/Evergreen/MigrationHarness.hs @@ -79,7 +79,7 @@ generateFor nextVersion migrationFilepaths = do if vinfoVersion nextVersion > 1 then upgradeFor migrationSequence nextVersion "BackendModel" else - "" + "upgradeBackendModelPrevious = ()\n\n" final = [text| @@ -169,8 +169,8 @@ upgradeFor migrationSequence nextVersion valueType = do case nextVersion of WithMigrations _ -> [untrimming| - upgrade${valueType}_v$currentVersion_ : T$currentVersion_.$valueType -> UpgradeResult T$nextVersion_.$valueType T$nextVersion_.$cmdMsgType - upgrade${valueType}_v$currentVersion_ model_v$currentVersion_ = + 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 @@ -179,8 +179,8 @@ upgradeFor migrationSequence nextVersion valueType = do WithoutMigrations _ -> [untrimming| - upgrade${valueType}_v$currentVersion_ : T$nextVersion_.$valueType -> UpgradeResult T$nextVersion_.$valueType T$nextVersion_.$cmdMsgType - upgrade${valueType}_v$currentVersion_ model_v$currentVersion_ = + upgrade${valueType}Previous : T$nextVersion_.$valueType -> UpgradeResult T$nextVersion_.$valueType T$nextVersion_.$cmdMsgType + upgrade${valueType}Previous model_v$currentVersion_ = unchanged model_v$currentVersion_ diff --git a/extra/Lamdera/Evergreen/ModifyAST.hs b/extra/Lamdera/Evergreen/ModifyAST.hs index 64910cbb..6714b1a1 100644 --- a/extra/Lamdera/Evergreen/ModifyAST.hs +++ b/extra/Lamdera/Evergreen/ModifyAST.hs @@ -18,6 +18,7 @@ import qualified Elm.ModuleName as Module import qualified Reporting.Annotation import qualified Data.ByteString.Builder as B +import qualified Lamdera.Wire3.Helpers import Lamdera import StandaloneInstances @@ -35,13 +36,17 @@ update :: Can.Module -> Can.Module update canonical = let moduleName :: Module.Canonical = (Can._name canonical) - decls :: Can.Decls = (Can._decls canonical) + decls :: Can.Decls = (Can._decls canonical) & removeUnsafeCoercePlaceholder newDecls :: Can.Decls = updateDecls moduleName decls in - debugHaskellPass "🟠🟠🟠🟠🟠 update on" moduleName $ canonical { Can._decls = newDecls } +removeUnsafeCoercePlaceholder :: Can.Decls -> Can.Decls +removeUnsafeCoercePlaceholder decls = + Lamdera.Wire3.Helpers.removeDefByName "unsafeCoerce" decls + + updateDecls :: Module.Canonical -> Can.Decls -> Can.Decls updateDecls fileName decls = case fileName of @@ -66,6 +71,24 @@ updateDecls fileName decls = updateExpr :: Module.Canonical -> Name.Name -> Can.Expr -> Can.Expr updateExpr fileName functionName (Reporting.Annotation.At location_ expr_) = (case expr_ of + Can.Call (Reporting.Annotation.At location + (Can.VarTopLevel (Module.Canonical (Name "author" "project") "LamderaHelpers") "unsafeCoerce") + ) params -> + Can.Call + (Reporting.Annotation.At + location + (Can.VarForeign + (Module.Canonical (Name "lamdera" "core") "Lamdera.Effect") + "unsafeCoerce" + (Forall + (Map.fromList [("a", ()), ("b", ())]) + (TLambda (TVar "a") (TVar "b")) + ) + ) + ) + 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 Can.VarKernel name name2 -> Can.VarKernel name name2 @@ -81,17 +104,6 @@ updateExpr fileName functionName (Reporting.Annotation.At location_ expr_) = Can.Negate expr -> Can.Negate ((updateExpr fileName functionName) expr) Can.Binop name canonical name2 annotation expr expr2 -> Can.Binop name canonical name2 annotation ((updateExpr fileName functionName) expr) ((updateExpr fileName functionName) expr2) Can.Lambda patterns expr -> Can.Lambda patterns ((updateExpr fileName functionName) expr) - Can.Call (Reporting.Annotation.At location (Can.VarLocal "unsafeCoerce") ) params -> - Can.Call - (Reporting.Annotation.At - location - (Can.VarForeign - (Module.Canonical (Name "lamdera" "core") "Lamdera.Effect") - "unsafeCoerce" - (Forall Map.empty (TLambda (TVar "a") (TVar "b"))) - ) - ) - params Can.Call expr exprs -> Can.Call ((updateExpr fileName functionName) expr) (fmap (updateExpr fileName functionName) exprs) Can.If exprs expr -> Can.If @@ -148,7 +160,6 @@ updateExpr fileName functionName (Reporting.Annotation.At location_ expr_) = Can.Shader shaderSource shaderTypes -> Can.Shader shaderSource shaderTypes ) & Reporting.Annotation.At location_ - & debugHaskell "🟠🟠🟠🟠🟠 updateExpr" updateDefs :: Module.Canonical -> Can.Def -> Can.Def diff --git a/extra/Lamdera/Injection.hs b/extra/Lamdera/Injection.hs index 0b6a2819..999128b5 100644 --- a/extra/Lamdera/Injection.hs +++ b/extra/Lamdera/Injection.hs @@ -196,7 +196,7 @@ injections isBackend isLocalDev = , decodeWireAnalytics: $$author$$project$$LamderaHelpers$$decodeWireAnalytics , getUserModel : function() { return model.userModel } , setUserModel : function(userModel) { model.userModel = userModel } - , upgradeBackendModel_v$previousVersion : function() { return $$author$$project$$LamderaGenerated$$upgradeBackendModel_v$previousVersion(model) } + , upgradeBackendModelPrevious : function() { model.userModel = $$author$$project$$LamderaGenerated$$upgradeBackendModelPrevious(model) } } |] else diff --git a/extra/Lamdera/Nitpick/DebugLog.hs b/extra/Lamdera/Nitpick/DebugLog.hs index fe9ab24e..b5ef9f1c 100644 --- a/extra/Lamdera/Nitpick/DebugLog.hs +++ b/extra/Lamdera/Nitpick/DebugLog.hs @@ -40,6 +40,7 @@ hasUselessDebugLogs canonical = first : rest -> Left $ E.LamderaBadDebugLog $ NE.List first rest [] -> Right () + checkDecls :: Can.Decls -> [A.Region] checkDecls decls = case decls of @@ -53,7 +54,6 @@ checkDecls decls = [] - checkDefs :: Can.Def -> [A.Region] checkDefs def = case def of @@ -167,4 +167,4 @@ checkExpr functionName (Reporting.Annotation.At _ expr) = Can.Shader shaderSource shaderTypes -> - [] \ No newline at end of file + [] diff --git a/extra/Lamdera/Wire3/Helpers.hs b/extra/Lamdera/Wire3/Helpers.hs index 12e4bc25..05b4bd88 100644 --- a/extra/Lamdera/Wire3/Helpers.hs +++ b/extra/Lamdera/Wire3/Helpers.hs @@ -328,6 +328,25 @@ removeDef def_ decls_ = SaveTheEnvironment +removeDefByName :: Data.Name.Name -> Decls -> Decls +removeDefByName name decls_ = + case decls_ of + Declare def decls -> + if (defName def == name) then + decls + else + Declare def (removeDefByName name decls) + + DeclareRec def defs decls -> + if (defName def == name) then + decls + else + DeclareRec def (List.filter (\d -> defName d /= name) defs) (removeDefByName name decls) + + SaveTheEnvironment -> + SaveTheEnvironment + + sameName :: Def -> Def -> Bool sameName d1 d2 = defName d1 == defName d2 diff --git a/terminal/src/Make.hs b/terminal/src/Make.hs index 431866d4..bd41f285 100644 --- a/terminal/src/Make.hs +++ b/terminal/src/Make.hs @@ -334,9 +334,11 @@ isDevNull name = -- Clone of run that uses attemptWithStyle_cleanup run_cleanup :: IO () -> [FilePath] -> Flags -> IO () -run_cleanup cleanup paths flags@(Flags _ _ _ report _ _ _) = +run_cleanup cleanup paths flags@(Flags _ _ _ report _ noWire optimizeLegible) = do style <- getStyle report maybeRoot <- Stuff.findRoot + Lamdera.onlyWhen noWire Lamdera.disableWire + Lamdera.onlyWhen optimizeLegible Lamdera.enableLongNames Reporting.attemptWithStyle_cleanup cleanup style Exit.makeToReport $ case maybeRoot of Just root -> runHelp root paths style flags diff --git a/test/Lamdera/Evergreen/TestMigrationGenerator.hs b/test/Lamdera/Evergreen/TestMigrationGenerator.hs index 0622d8d0..b6d0f5fe 100644 --- a/test/Lamdera/Evergreen/TestMigrationGenerator.hs +++ b/test/Lamdera/Evergreen/TestMigrationGenerator.hs @@ -50,7 +50,7 @@ suite :: Test () suite = tests [ scope "migration-scenarios" testExamples - -- , scope "e2e migration: 1 -> 2" $ testMigrationGeneration "scenario-migration-generate" 1 2 + , scope "e2e migration: 1 -> 2" $ testMigrationGeneration "scenario-migration-generate" 1 2 , scope "containsUserTypes" testContainsUserTypes ] diff --git a/test/Lamdera/Evergreen/TestMigrationHarness.hs b/test/Lamdera/Evergreen/TestMigrationHarness.hs index 7aa8efef..efa58922 100644 --- a/test/Lamdera/Evergreen/TestMigrationHarness.hs +++ b/test/Lamdera/Evergreen/TestMigrationHarness.hs @@ -254,8 +254,8 @@ suite = tests 2 - upgradeBackendModel_v1 : T1.BackendModel -> UpgradeResult T2.BackendModel T2.BackendMsg - upgradeBackendModel_v1 model_v1 = + upgradeBackendModelPrevious : T1.BackendModel -> UpgradeResult T2.BackendModel T2.BackendMsg + upgradeBackendModelPrevious model_v1 = model_v1 |> M2.backendModel @@ -438,8 +438,8 @@ suite = tests 2 - upgradeBackendModel_v1 : T2.BackendModel -> UpgradeResult T2.BackendModel T2.BackendMsg - upgradeBackendModel_v1 model_v1 = + upgradeBackendModelPrevious : T2.BackendModel -> UpgradeResult T2.BackendModel T2.BackendMsg + upgradeBackendModelPrevious model_v1 = unchanged model_v1 diff --git a/test/Test.hs b/test/Test.hs index e13980ed..3914cfa2 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -249,6 +249,9 @@ all = rerun seed = EasyTest.rerun seed allTests +rerunJust label = + EasyTest.rerunOnly 0 label allTests + rerunOnly seed label = EasyTest.rerunOnly seed label allTests From f8f8b2b7251f98a6ed41750c8e31403efc68e7e6 Mon Sep 17 00:00:00 2001 From: Mario Rogic Date: Sun, 28 Apr 2024 10:27:32 +1000 Subject: [PATCH 6/8] Setup test for unsafeCoerce replacement --- extra/Lamdera.hs | 13 ++++++++- .../Lamdera/Evergreen/TestMigrationHarness.hs | 29 +++++-------------- test/Test.hs | 1 + 3 files changed, 20 insertions(+), 23 deletions(-) diff --git a/extra/Lamdera.hs b/extra/Lamdera.hs index 9da83924..7d648458 100644 --- a/extra/Lamdera.hs +++ b/extra/Lamdera.hs @@ -91,6 +91,8 @@ module Lamdera , lamderaEnvModePath , lamderaExternalWarningsPath , lamderaBackendDevSnapshotPath + , withCompilerRoot + , withRuntimeRoot , Ext.Common.setProjectRoot , Ext.Common.getProjectRoot , Ext.Common.getProjectRootFor @@ -796,9 +798,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 diff --git a/test/Lamdera/Evergreen/TestMigrationHarness.hs b/test/Lamdera/Evergreen/TestMigrationHarness.hs index efa58922..d0ee4797 100644 --- a/test/Lamdera/Evergreen/TestMigrationHarness.hs +++ b/test/Lamdera/Evergreen/TestMigrationHarness.hs @@ -153,6 +153,10 @@ suite = tests 1 + upgradeBackendModelPrevious = + () + + decodeAndUpgradeBackendModel : Int -> Bytes -> UpgradeResult T1.BackendModel T1.BackendMsg decodeAndUpgradeBackendModel version bytes = case version of @@ -377,7 +381,7 @@ suite = tests setup = do writeUtf8 (project <> target) result - cp ("/Users/mario/lamdera/runtime/" <> helpers) (project <> helpers) + cp (withRuntimeRoot ("runtime/" <> helpers)) (project <> helpers) cleanup _ = do rm (project <> target) @@ -386,28 +390,9 @@ suite = tests test _ = do compilationStdout <- catchOutput $ - Lamdera.Compile.makeDev "/Users/mario/dev/projects/lamdera-compiler/test/scenario-migration-generate" filenames - - compilationStdout `expectTextDoesNotContain` - -- "This `Unimplemented` value is a:\n\n UnimplementedMigration" - "I cannot find a `unsafeCoerce` variable" - - -- actual <- catchOutput $ withStdinYesAll $ Ext.Common.withProjectRoot tmpFolder $ Init.run () () - - -- io $ formatHaskellValue "actual" actual - - -- expectTextContains actual - -- "Hello! Lamdera projects always start with an elm.json file, as well as four\\nsource files: Frontend.elm , Backend.elm, Types.elm and Env.elm\\n\\nIf you're new to Elm, the best starting point is\\n\\n\\nOtherwise check out for Lamdera\\nspecific information!\\n\\nKnowing all that, would you like me to create a starter implementation? [Y/n]: Okay, I created it! Now read those links, or get going with `lamdera live`.\\n" - - -- ignoreM <- io $ readUtf8Text $ tmpFolder ".gitignore" - - -- case ignoreM of - -- Just ignore -> - -- expectTextContains ignore "elm-stuff" - - -- Nothing -> - -- crash $ "Expected to find " <> tmpFolder <> "/.gitignore but didn't." + Lamdera.Compile.makeDev (withCompilerRoot "test/scenario-migration-generate") filenames + compilationStdout `expectTextDoesNotContain` "I cannot find a `unsafeCoerce` variable" using setup cleanup test diff --git a/test/Test.hs b/test/Test.hs index 3914cfa2..c20a2d2f 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -108,6 +108,7 @@ For more information on how to use the GHCi debugger, see the GHC User's Guide. -- target = previewProject -- target = liveReloadLive target = Test.all +-- target = rerunJust "Lamdera.Evergreen.TestMigrationHarness -> .full first - (WithMigrations 2)" -- target = checkUserConfig -- target = Test.Wire.buildAllPackages -- target = Lamdera.CLI.Login.run () () From e6022ea6b831717f9d630034b579ab360614412c Mon Sep 17 00:00:00 2001 From: Mario Rogic Date: Sun, 28 Apr 2024 15:59:26 +1000 Subject: [PATCH 7/8] Refine naming to read slightly better --- builder/src/Generate.hs | 2 +- extra/Lamdera.hs | 17 ++++++----------- 2 files changed, 7 insertions(+), 12 deletions(-) diff --git a/builder/src/Generate.hs b/builder/src/Generate.hs index 272e9327..aff6a71f 100644 --- a/builder/src/Generate.hs +++ b/builder/src/Generate.hs @@ -79,7 +79,7 @@ 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.isLongNamesEnabled + longNamesEnabled <- Task.io $ Lamdera.useLongNames let mode = Mode.Prod (Mode.shortenFieldNames graph) & Lamdera.alternativeImplementationWhen longNamesEnabled (Mode.Prod (Mode.legibleFieldNames graph)) diff --git a/extra/Lamdera.hs b/extra/Lamdera.hs index 7d648458..bc61b1be 100644 --- a/extra/Lamdera.hs +++ b/extra/Lamdera.hs @@ -45,8 +45,7 @@ module Lamdera , isWireEnabled_ , useLongNames_ , enableLongNames - , isLongNamesEnabled - , isLongNamesEnabled_ + , useLongNames , isTest , isLiveMode , setLiveMode @@ -442,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 From 9a0835965a312e24838540ed16edfb381207d4ef Mon Sep 17 00:00:00 2001 From: Mario Rogic Date: Mon, 29 Apr 2024 10:37:10 +1000 Subject: [PATCH 8/8] Try fix windows build issue --- .github/workflows/build-windows-x86_64.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/build-windows-x86_64.yml b/.github/workflows/build-windows-x86_64.yml index da5bdea1..1c065205 100644 --- a/.github/workflows/build-windows-x86_64.yml +++ b/.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: |