mirror of
https://github.com/unisonweb/unison.git
synced 2024-10-04 05:37:14 +03:00
Fix up Execute
This commit is contained in:
Chris Penner
parent
7298bbeffe
commit
7aabcf5d89
@ -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} ()")
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user