From 7aabcf5d8927408b181a95e15f9c110ef2316c9e Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 12 Jun 2024 10:43:53 -0700 Subject: [PATCH] Fix up Execute --- .../src/Unison/Codebase/Execute.hs | 27 ++++++-- unison-cli/src/Unison/Main.hs | 62 +++++++++++-------- 2 files changed, 58 insertions(+), 31 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Execute.hs b/parser-typechecker/src/Unison/Codebase/Execute.hs index 1149c5ee7..788bc5abe 100644 --- a/parser-typechecker/src/Unison/Codebase/Execute.hs +++ b/parser-typechecker/src/Unison/Codebase/Execute.hs @@ -7,15 +7,22 @@ module Unison.Codebase.Execute where import Control.Exception (finally) import Control.Monad.Except +import U.Codebase.Sqlite.Project (Project (..)) +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) +import U.Codebase.Sqlite.Queries qualified as Q import Unison.Codebase qualified as Codebase +import Unison.Codebase.Branch qualified as Branch +import Unison.Codebase.Branch.Names qualified as Branch import Unison.Codebase.MainTerm (getMainTerm) import Unison.Codebase.MainTerm qualified as MainTerm +import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath (ProjectPathG (..)) +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.Runtime (Runtime) import Unison.Codebase.Runtime qualified as Runtime import Unison.HashQualified qualified as HQ -import Unison.Name (Name) -import Unison.Names (Names) import Unison.Parser.Ann (Ann) +import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE import Unison.Symbol (Symbol) import Unison.Syntax.HashQualified qualified as HQ (toText) @@ -24,14 +31,22 @@ import Unison.Util.Pretty qualified as P execute :: Codebase.Codebase IO Symbol Ann -> Runtime Symbol -> - Names -> - HQ.HashQualified Name -> + PP.ProjectPathNames -> IO (Either Runtime.Error ()) -execute codebase runtime names mainName = +execute codebase runtime mainPath = (`finally` Runtime.terminate runtime) . runExceptT $ do + (project, branch) <- ExceptT $ (Codebase.runTransactionWithRollback codebase) \rollback -> do + project <- Q.loadProjectByName mainPath.project `whenNothingM` rollback (Left . P.text $ ("Project not found: " <> into @Text mainPath.project)) + branch <- Q.loadProjectBranchByName project.projectId mainPath.branch `whenNothingM` rollback (Left . P.text $ ("Branch not found: " <> into @Text mainPath.branch)) + pure . Right $ (project, branch) + projectRootNames <- fmap (Branch.toNames . Branch.head) . liftIO $ Codebase.expectProjectBranchRoot codebase project.projectId branch.branchId let loadTypeOfTerm = Codebase.getTypeOfTerm codebase let mainType = Runtime.mainType runtime - mt <- liftIO $ Codebase.runTransaction codebase $ getMainTerm loadTypeOfTerm names mainName mainType + mainName <- case Path.toName (mainPath ^. PP.path_) of + Just n -> pure (HQ.NameOnly n) + Nothing -> throwError ("Path must lead to an executable term: " <> P.text (Path.toText (PP.path mainPath))) + + mt <- liftIO $ Codebase.runTransaction codebase $ getMainTerm loadTypeOfTerm projectRootNames mainName mainType case mt of MainTerm.NotFound s -> throwError ("Not found: " <> P.text (HQ.toText s)) MainTerm.BadType s _ -> throwError (P.text (HQ.toText s) <> " is not of type '{IO} ()") diff --git a/unison-cli/src/Unison/Main.hs b/unison-cli/src/Unison/Main.hs index 97d9700fd..114958906 100644 --- a/unison-cli/src/Unison/Main.hs +++ b/unison-cli/src/Unison/Main.hs @@ -48,6 +48,7 @@ import System.Directory ) import System.Environment (getExecutablePath, getProgName, withArgs) import System.Exit qualified as Exit +import System.Exit qualified as System import System.FilePath ( replaceExtension, takeDirectory, @@ -62,6 +63,7 @@ import System.IO.Temp qualified as Temp import System.Path qualified as Path import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.Queries qualified as Queries +import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Codebase (Codebase, CodebasePath) import Unison.Codebase qualified as Codebase import Unison.Codebase.Editor.Input qualified as Input @@ -159,7 +161,7 @@ main version = do Run (RunFromSymbol mainName) args -> do getCodebaseOrExit mCodePathOption (SC.MigrateAutomatically SC.Backup SC.Vacuum) \(_, _, theCodebase) -> do RTI.withRuntime False RTI.OneOff (Version.gitDescribeWithDate version) \runtime -> do - withArgs args (execute theCodebase runtime _ mainName) >>= \case + withArgs args (execute theCodebase runtime mainName) >>= \case Left err -> exitError err Right () -> pure () Run (RunFromFile file mainName) args @@ -175,7 +177,7 @@ main version = do let noOpRootNotifier _ = pure () let noOpPathNotifier _ = pure () let serverUrl = Nothing - let startPath = Nothing + startProjectPath <- Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath launch version currentDir @@ -186,7 +188,7 @@ main version = do theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] serverUrl - startPath + (PP.toIds startProjectPath) initRes noOpRootNotifier noOpPathNotifier @@ -202,7 +204,7 @@ main version = do let noOpRootNotifier _ = pure () let noOpPathNotifier _ = pure () let serverUrl = Nothing - let startPath = Nothing + startProjectPath <- Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath launch version currentDir @@ -213,7 +215,7 @@ main version = do theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] serverUrl - startPath + (PP.toIds startProjectPath) initRes noOpRootNotifier noOpPathNotifier @@ -287,32 +289,42 @@ main version = do case mrtsStatsFp of Nothing -> action Just fp -> recordRtsStats fp action - Launch isHeadless codebaseServerOpts mayStartingPath shouldWatchFiles -> do + Launch isHeadless codebaseServerOpts mayStartingProject shouldWatchFiles -> do getCodebaseOrExit mCodePathOption (SC.MigrateAfterPrompt SC.Backup SC.Vacuum) \(initRes, _, theCodebase) -> do withRuntimes nrtp RTI.Persistent \(runtime, sbRuntime, nRuntime) -> do - startingPath <- case isHeadless of - WithCLI -> do - -- If the user didn't provide a starting path on the command line, put them in the most recent - -- path they cd'd to - case mayStartingPath of - Just startingPath -> pure startingPath - Nothing -> do - Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath - Headless -> pure $ fromMaybe defaultInitialPath mayStartingPath + startingProjectPath <- do + -- If the user didn't provide a starting path on the command line, put them in the most recent + -- path they cd'd to + case mayStartingProject of + Just startingProject -> do + Codebase.runTransaction theCodebase (ProjectUtils.getProjectAndBranchByNames startingProject) >>= \case + Nothing -> do + PT.putPrettyLn $ + P.callout + "❓" + ( P.lines + [ P.indentN 2 "I couldn't find the project branch: " <> P.text (into @Text startingProject) + ] + ) + System.exitFailure + Just pab -> do + pure $ PP.fromProjectAndBranch pab Path.absoluteEmpty + Nothing -> do + Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath rootCausalHash <- Codebase.runTransaction theCodebase (Queries.expectNamespaceRoot >>= Queries.expectCausalHash) - rootCausalHashVar <- newTVarIO rootCausalHash - pathVar <- newTVarIO startingPath + projectRootHashVar <- newTVarIO rootCausalHash + projectPathVar <- newTVarIO startingProjectPath let notifyOnRootChanges :: CausalHash -> STM () notifyOnRootChanges b = do - writeTVar rootCausalHashVar b - let notifyOnPathChanges :: Path.Absolute -> STM () - notifyOnPathChanges = writeTVar pathVar + writeTVar projectRootHashVar b + let notifyOnPathChanges :: PP.ProjectPath -> STM () + notifyOnPathChanges = writeTVar projectPathVar -- Unfortunately, the windows IO manager on GHC 8.* is prone to just hanging forever -- when waiting for input on handles, so if we listen for LSP connections it will -- prevent UCM from shutting down properly. Hopefully we can re-enable LSP on -- Windows when we move to GHC 9.* -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/1224 - void . Ki.fork scope $ LSP.spawnLsp lspFormattingConfig theCodebase runtime (readTVar rootCausalHashVar) (readTVar pathVar) + void . Ki.fork scope $ LSP.spawnLsp lspFormattingConfig theCodebase runtime (readTVar projectRootHashVar) (readTVar projectPathVar) Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) codebaseServerOpts sbRuntime theCodebase $ \baseUrl -> do case exitOption of DoNotExit -> do @@ -346,7 +358,7 @@ main version = do theCodebase [] (Just baseUrl) - (Just startingPath) + (PP.toIds startingProjectPath) initRes notifyOnRootChanges notifyOnPathChanges @@ -525,10 +537,10 @@ launch :: PP.ProjectPathIds -> InitResult -> (CausalHash -> STM ()) -> - (Path.Absolute -> STM ()) -> + (PP.ProjectPath -> STM ()) -> CommandLine.ShouldWatchFiles -> IO () -launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseUrl startingPath initResult notifyRootChange notifyPathChange shouldWatchFiles = do +launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseUrl startingPath initResult notifyRootChange notifyProjPathChange shouldWatchFiles = do showWelcomeHint <- Codebase.runTransaction codebase Queries.doProjectsExist let isNewCodebase = case initResult of CreatedCodebase -> NewlyCreatedCodebase @@ -548,7 +560,7 @@ launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseU serverBaseUrl ucmVersion notifyRootChange - notifyPathChange + notifyProjPathChange shouldWatchFiles newtype MarkdownFile = MarkdownFile FilePath