{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}

module Unison.Main
  ( main,
  )
where

import ArgParse
  ( CodebasePathOption (..),
    Command (..),
    GlobalOptions (..),
    IsHeadless (Headless, WithCLI),
    RunSource (..),
    ShouldExit (DoNotExit, Exit),
    ShouldForkCodebase (..),
    ShouldSaveCodebase (..),
    TranscriptCodebaseSetup (..),
    UsageRenderer,
    parseCLIArgs,
  )
import Compat (defaultInterruptHandler, withInterruptHandler)
import Control.Concurrent (newEmptyMVar, putMVar, runInUnboundThread, takeMVar)
import Control.Exception (displayException, fromException)
import Data.Bitraversable (bitraverse)
import Data.ByteString qualified as BS
import Data.Either.Validation (Validation (..))
import Data.List.NonEmpty (NonEmpty)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Data.Text.IO qualified as Text
import GHC.Conc (setUncaughtExceptionHandler)
import GHC.Conc qualified
import Ki qualified
import Network.HTTP.Client qualified as HTTP
import Network.HTTP.Client.TLS qualified as HTTP
import Network.Socket qualified as Socket
import Stats (recordRtsStats)
import System.Directory (canonicalizePath, getCurrentDirectory, removeDirectoryRecursive)
import System.Environment (getProgName, lookupEnv, setEnv, withArgs)
import System.Exit (ExitCode (..))
import System.Exit qualified as Exit
import System.Exit qualified as System
import System.FilePath (replaceExtension, takeExtension, (</>))
import System.IO (hFlush, hIsTerminalDevice, stderr, stdout)
import System.IO.CodePage (withCP65001)
import System.IO.Temp qualified as Temp
import System.Path qualified as Path
import Text.Megaparsec qualified as MP
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Auth.CredentialManager qualified as AuthN
import Unison.Auth.HTTPClient qualified as AuthN
import Unison.Auth.Tokens qualified as AuthN
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
import Unison.Codebase.Editor.UCMVersion (UCMVersion)
import Unison.Codebase.Execute (execute)
import Unison.Codebase.Init (CodebaseInitOptions (..), InitError (..), InitResult (..), SpecifiedCodebase (..))
import Unison.Codebase.Init qualified as CodebaseInit
import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..))
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.Runtime.Profile (ProfileSpec (..))
import Unison.Codebase.SqliteCodebase qualified as SC
import Unison.Codebase.Transcript.Parser qualified as Transcript
import Unison.Codebase.Transcript.Runner qualified as Transcript
import Unison.Codebase.Verbosity qualified as Verbosity
import Unison.CommandLine.Helpers (plural')
import Unison.CommandLine.Main qualified as CommandLine
import Unison.CommandLine.OutputMessages (fetchIssueFromGitHub)
import Unison.CommandLine.Types qualified as CommandLine
import Unison.CommandLine.Welcome (CodebaseInitStatus (..))
import Unison.CommandLine.Welcome qualified as Welcome
import Unison.Core.Project (ProjectAndBranch (..), ProjectName (..))
import Unison.Hashing.V2 qualified as ABT
import Unison.LSP qualified as LSP
import Unison.LSP.Util.Signal qualified as Signal
import Unison.MCP qualified as MCP
import Unison.MCP.Server qualified as MCP
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import Unison.PrettyTerminal qualified as PT
import Unison.Project (defaultBranchName)
import Unison.Runtime.Interface qualified as RTI
import Unison.Runtime.JIT qualified as JIT
import Unison.Runtime.JIT.Config qualified as JITConfig
import Unison.Server.Backend qualified as Backend
import Unison.Server.CodebaseServer qualified as Server
import Unison.Symbol (Symbol)
import Unison.Util.Pretty qualified as P
import Unison.Version (Version)
import Unison.Version qualified as Version
import UnliftIO qualified as UnliftIO
import UnliftIO.Directory (getHomeDirectory)
import UnliftIO.Directory qualified as Directory

type Runtimes = (RTI.Runtime Symbol, RTI.Runtime Symbol)

-- | Determine whether the codebase should be locked, based on the @UNISON_CODEBASE_LOCK@ environment variable.
--
-- By default we lock the codebase (@DoLock@), but setting @UNISON_CODEBASE_LOCK=false@ disables locking for the
-- operations that would otherwise take a lock.
getCodebaseLockOption :: IO SC.CodebaseLockOption
getCodebaseLockOption :: IO CodebaseLockOption
getCodebaseLockOption = do
  Maybe [Char]
lockEnv <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"UNISON_CODEBASE_LOCK"
  pure case Maybe [Char]
lockEnv of
    Just [Char]
"false" -> CodebaseLockOption
SC.DontLock
    Maybe [Char]
_ -> CodebaseLockOption
SC.DoLock

main :: Version -> IO ()
main :: Version -> IO ()
main Version
version = do
  -- Replace the default exception handler with one complains loudly, because we shouldn't have any uncaught exceptions.
  -- Sometimes `show` and `displayException` are different strings; in this case, we want to show them both, so this
  -- issue is easier to debug.
  --
  -- We've made one exception for `ExitSuccess`, because we've discovered the `lsp` library unhelpfully throws it from a
  -- background thread as part of the default "exit notification handler", with no way to modify the behavior.
  (SomeException -> IO ()) -> IO ()
setUncaughtExceptionHandler \SomeException
exception -> do
    if
      | SomeException -> Bool
isExitSuccess SomeException
exception -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      -- This is a bit of a hack to make hashing failures more user-friendly.
      -- https://github.com/unisonweb/unison/pull/6007
      | Just HashingWarning
hf <- forall e. Exception e => SomeException -> Maybe e
fromException @ABT.HashingWarning SomeException
exception -> do
          Handle -> Text -> IO ()
Text.hPutStrLn Handle
stderr (Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HashingWarning -> Text
forall a. Show a => a -> Text
tShow HashingWarning
hf Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n")
      | Bool
otherwise -> do
          let shown :: Text
shown = SomeException -> Text
forall a. Show a => a -> Text
tShow SomeException
exception
          let displayed :: Text
displayed = [Char] -> Text
Text.pack (SomeException -> [Char]
forall e. Exception e => e -> [Char]
displayException SomeException
exception)
          let indented :: Text -> Text
indented = [Text] -> Text
Text.unlines ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.lines

          Handle -> Text -> IO ()
Text.hPutStrLn Handle
stderr (Text -> IO ()) -> ([[Text]] -> Text) -> [[Text]] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.unlines ([Text] -> Text) -> ([[Text]] -> [Text]) -> [[Text]] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Text]] -> [Text]
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([[Text]] -> IO ()) -> [[Text]] -> IO ()
forall a b. (a -> b) -> a -> b
$
            [ [ Text
"Uh oh, an unexpected exception brought the process down! That should never happen. Please file a bug report.",
                Text
"",
                Text
"Here's a stringy rendering of the exception:",
                Text
"",
                Text -> Text
indented Text
shown
              ],
              if Text
shown Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
displayed
                then
                  [ Text
"And here's a different one, in case it's easier to understand:",
                    Text
"",
                    Text -> Text
indented Text
displayed
                  ]
                else []
            ]
  -- This makes our error messages more safe w/r to concurrency. Without it sometimes the
  -- error messaging from the UCM server and LSP server (both running in separate threads) get
  -- interleaved.
  -- https://hackage.haskell.org/package/base-4.21.0.0/docs/GHC-IO-Handle.html#v:hPutStr
  Handle -> BufferMode -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
UnliftIO.hSetBuffering Handle
UnliftIO.stderr BufferMode
UnliftIO.LineBuffering

  IO () -> IO ()
forall a. IO a -> IO a
withCP65001 (IO () -> IO ())
-> ((Scope -> IO ()) -> IO ()) -> (Scope -> IO ()) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall a. IO a -> IO a
runInUnboundThread (IO () -> IO ())
-> ((Scope -> IO ()) -> IO ()) -> (Scope -> IO ()) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Scope -> IO ()) -> IO ()
forall a. (Scope -> IO a) -> IO a
Ki.scoped ((Scope -> IO ()) -> IO ()) -> (Scope -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Scope
scope -> do
    IO ()
interruptHandler <- IO (IO ())
defaultInterruptHandler
    IO () -> IO () -> IO ()
forall a. IO () -> IO a -> IO a
withInterruptHandler IO ()
interruptHandler (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      IO (Thread ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Thread ()) -> IO ()) -> IO (Thread ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Scope -> IO () -> IO (Thread ())
forall a. Scope -> IO a -> IO (Thread a)
Ki.fork Scope
scope (Version -> IO ()
initHTTPClient Version
version)
      [Char]
progName <- IO [Char]
getProgName
      -- hSetBuffering stdout NoBuffering -- cool
      (UsageRenderer
renderUsageInfo, GlobalOptions
globalOptions, Command
command) <- [Char] -> [Char] -> IO (UsageRenderer, GlobalOptions, Command)
parseCLIArgs [Char]
progName (Text -> [Char]
Text.unpack (Version -> Text
Version.gitDescribeWithDate Version
version))
      let GlobalOptions {codebasePathOption :: GlobalOptions -> Maybe CodebasePathOption
codebasePathOption = Maybe CodebasePathOption
mCodePathOption, ShouldExit
exitOption :: ShouldExit
exitOption :: GlobalOptions -> ShouldExit
exitOption, LspFormattingConfig
lspFormattingConfig :: LspFormattingConfig
lspFormattingConfig :: GlobalOptions -> LspFormattingConfig
lspFormattingConfig, Maybe [Char]
jitOption :: Maybe [Char]
jitOption :: GlobalOptions -> Maybe [Char]
jitOption, Maybe [Char]
jitDumpIROption :: Maybe [Char]
jitDumpIROption :: GlobalOptions -> Maybe [Char]
jitDumpIROption} = GlobalOptions
globalOptions
      -- The runtime reads its JIT settings from the environment, once, at startup.
      Maybe [Char] -> ([Char] -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe [Char]
jitOption ([Char] -> [Char] -> IO ()
setEnv [Char]
"UNISON_JIT")
      -- the dump is one of the settings behind UNISON_JIT_DEBUG (JIT.Config)
      Maybe [Char] -> ([Char] -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe [Char]
jitDumpIROption (\[Char]
dir -> [Char] -> [Char] -> IO ()
setEnv [Char]
"UNISON_JIT_DEBUG" [Char]
"1" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> [Char] -> IO ()
setEnv [Char]
"UNISON_JIT_DUMP_IR" [Char]
dir)
      JIT
jit <- Config -> IO JIT
JIT.newJIT (Config -> IO JIT) -> IO Config -> IO JIT
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Config
JIT.readConfig
      JIT -> IO ()
announceJIT JIT
jit
      [Char]
currentDir <- IO [Char]
getCurrentDirectory
      case Command
command of
        Command
PrintVersion ->
          Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
Text.pack [Char]
progName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" version: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Version -> Text
Version.gitDescribeWithDate Version
version
        Command
MCPServer -> do
          let ucmVersion :: Text
ucmVersion = Version -> Text
Version.gitDescribeWithDate Version
version
          let credMan :: CredentialManager
credMan = CredentialManager
AuthN.globalCredentialManager
          AuthenticatedHttpClient
authenticatedHTTPClient <- Text -> CredentialManager -> IO AuthenticatedHttpClient
initTranscriptAuthenticatedHTTPClient Text
ucmVersion CredentialManager
credMan
          Maybe CodebasePathOption
-> CodebaseLockOption
-> MigrationStrategy
-> ((InitResult, [Char], Codebase IO Symbol Ann) -> IO ())
-> IO ()
forall r.
Maybe CodebasePathOption
-> CodebaseLockOption
-> MigrationStrategy
-> ((InitResult, [Char], Codebase IO Symbol Ann) -> IO r)
-> IO r
getCodebaseOrExit Maybe CodebasePathOption
mCodePathOption CodebaseLockOption
SC.DontLock (BackupStrategy -> VacuumStrategy -> MigrationStrategy
SC.MigrateAfterPrompt BackupStrategy
SC.Backup VacuumStrategy
SC.Vacuum) \(InitResult
_initRes, [Char]
_, Codebase IO Symbol Ann
theCodebase) -> do
            JIT -> RuntimeHost -> (Runtimes -> IO ()) -> IO ()
forall a. JIT -> RuntimeHost -> (Runtimes -> IO a) -> IO a
withRuntimes JIT
jit RuntimeHost
RTI.Persistent \(Runtime Symbol
runtime, Runtime Symbol
sbRuntime) -> do
              Codebase IO Symbol Ann
-> Runtime Symbol
-> Runtime Symbol
-> [Char]
-> Text
-> AuthenticatedHttpClient
-> IO ()
MCP.runOnStdIO Codebase IO Symbol Ann
theCodebase Runtime Symbol
runtime Runtime Symbol
sbRuntime [Char]
currentDir Text
ucmVersion AuthenticatedHttpClient
authenticatedHTTPClient
        Command
Init -> do
          Pretty ColorText -> IO ()
forall a. Pretty ColorText -> IO a
exitError
            ( [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
                [ Pretty ColorText
"The Init command has been removed",
                  Pretty ColorText
forall s. IsString s => Pretty s
P.newline,
                  Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap Pretty ColorText
"Use --codebase-create to create a codebase at a specified location and open it:",
                  Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText
P.hiBlue Pretty ColorText
"$ ucm --codebase-create myNewCodebase"),
                  Pretty ColorText
"Running UCM without the --codebase-create flag: ",
                  Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText
P.hiBlue Pretty ColorText
"$ ucm"),
                  Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap (Pretty ColorText
"will " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText -> Pretty ColorText
P.bold Pretty ColorText
"always" Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
" create a codebase in your home directory if one does not already exist.")
                ]
            )
        Run (RunFromSymbol ProjectPathNames
mainName) [[Char]]
args -> do
          Maybe CodebasePathOption
-> CodebaseLockOption
-> MigrationStrategy
-> ((InitResult, [Char], Codebase IO Symbol Ann) -> IO ())
-> IO ()
forall r.
Maybe CodebasePathOption
-> CodebaseLockOption
-> MigrationStrategy
-> ((InitResult, [Char], Codebase IO Symbol Ann) -> IO r)
-> IO r
getCodebaseOrExit Maybe CodebasePathOption
mCodePathOption CodebaseLockOption
SC.DontLock MigrationStrategy
SC.DontMigrate \(InitResult
_, [Char]
_, Codebase IO Symbol Ann
theCodebase) -> do
            JIT
-> Bool
-> RuntimeHost
-> Text
-> (Runtime Symbol -> IO ())
-> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
JIT
-> Bool -> RuntimeHost -> Text -> (Runtime Symbol -> m a) -> m a
RTI.withRuntime JIT
jit Bool
False RuntimeHost
RTI.OneOff (Version -> Text
Version.gitDescribeWithDate Version
version) \Runtime Symbol
runtime -> do
              [[Char]] -> IO (Either Error ()) -> IO (Either Error ())
forall a. [[Char]] -> IO a -> IO a
withArgs [[Char]]
args (Codebase IO Symbol Ann
-> Runtime Symbol -> ProjectPathNames -> IO (Either Error ())
execute Codebase IO Symbol Ann
theCodebase Runtime Symbol
runtime ProjectPathNames
mainName) IO (Either Error ()) -> (Either Error () -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Left Error
err -> Pretty ColorText -> IO ()
forall a. Pretty ColorText -> IO a
exitError (Pretty ColorText -> IO ()) -> IO (Pretty ColorText) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Word -> IO (Pretty ColorText)) -> Error -> IO (Pretty ColorText)
forall (f :: * -> *).
Applicative f =>
(Word -> f (Pretty ColorText)) -> Error -> f (Pretty ColorText)
RTI.prettyError Word -> IO (Pretty ColorText)
fetchIssueFromGitHub Error
err
                Right () -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Run (RunFromFile [Char]
file HashQualified Name
mainName) [[Char]]
args
          | Bool -> Bool
not ([Char] -> Bool
isDotU [Char]
file) -> Pretty ColorText -> IO ()
forall a. Pretty ColorText -> IO a
exitError Pretty ColorText
"Files must have a .u extension."
          | Bool
otherwise -> do
              Either IOException Text
e <- [Char] -> IO (Either IOException Text)
safeReadUtf8 [Char]
file
              case Either IOException Text
e of
                Left IOException
_ -> Pretty ColorText -> IO ()
forall a. Pretty ColorText -> IO a
exitError Pretty ColorText
"I couldn't find that file or it is for some reason unreadable."
                Right Text
contents -> do
                  Maybe CodebasePathOption
-> CodebaseLockOption
-> MigrationStrategy
-> ((InitResult, [Char], Codebase IO Symbol Ann) -> IO ())
-> IO ()
forall r.
Maybe CodebasePathOption
-> CodebaseLockOption
-> MigrationStrategy
-> ((InitResult, [Char], Codebase IO Symbol Ann) -> IO r)
-> IO r
getCodebaseOrExit Maybe CodebasePathOption
mCodePathOption CodebaseLockOption
SC.DontLock MigrationStrategy
SC.DontMigrate \(InitResult
initRes, [Char]
_, Codebase IO Symbol Ann
theCodebase) -> do
                    JIT -> RuntimeHost -> (Runtimes -> IO ()) -> IO ()
forall a. JIT -> RuntimeHost -> (Runtimes -> IO a) -> IO a
withRuntimes JIT
jit RuntimeHost
RTI.OneOff \(Runtime Symbol
rt, Runtime Symbol
sbrt) -> do
                      let fileEvent :: Event
fileEvent = Text -> Text -> Event
Input.UnisonFileChanged ([Char] -> Text
Text.pack [Char]
file) Text
contents
                      let noOpCheckForChanges :: p -> f ()
noOpCheckForChanges p
_ = () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                      let serverUrl :: Maybe a
serverUrl = Maybe a
forall a. Maybe a
Nothing
                      let ucmVersion :: Text
ucmVersion = Version -> Text
Version.gitDescribeWithDate Version
version
                      let credMan :: CredentialManager
credMan = CredentialManager
AuthN.globalCredentialManager
                      AuthenticatedHttpClient
authenticatedHTTPClient <- Text -> CredentialManager -> IO AuthenticatedHttpClient
initTranscriptAuthenticatedHTTPClient Text
ucmVersion CredentialManager
credMan
                      ProjectPath
startProjectPath <- Codebase IO Symbol Ann -> Transaction ProjectPath -> IO ProjectPath
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Codebase IO Symbol Ann
theCodebase Transaction ProjectPath
HasCallStack => Transaction ProjectPath
Codebase.expectCurrentProjectPath
                      Version
-> [Char]
-> Runtime Symbol
-> Runtime Symbol
-> Codebase IO Symbol Ann
-> [Either Event Input]
-> AuthenticatedHttpClient
-> CredentialManager
-> Maybe BaseUrl
-> ProjectPathIds
-> InitResult
-> (ProjectPathIds -> IO ())
-> ShouldWatchFiles
-> IO ()
launch
                        Version
version
                        [Char]
currentDir
                        Runtime Symbol
rt
                        Runtime Symbol
sbrt
                        Codebase IO Symbol Ann
theCodebase
                        [Event -> Either Event Input
forall a b. a -> Either a b
Left Event
fileEvent, Input -> Either Event Input
forall a b. b -> Either a b
Right (Input -> Either Event Input) -> Input -> Either Event Input
forall a b. (a -> b) -> a -> b
$ ProfileSpec -> HashQualified Name -> [[Char]] -> Input
Input.ExecuteI ProfileSpec
NoProf HashQualified Name
mainName [[Char]]
args, Input -> Either Event Input
forall a b. b -> Either a b
Right Input
Input.QuitI]
                        AuthenticatedHttpClient
authenticatedHTTPClient
                        CredentialManager
credMan
                        Maybe BaseUrl
serverUrl
                        (ProjectPath -> ProjectPathIds
PP.toIds ProjectPath
startProjectPath)
                        InitResult
initRes
                        ProjectPathIds -> IO ()
noOpCheckForChanges
                        ShouldWatchFiles
CommandLine.ShouldNotWatchFiles
        Run (RunFromPipe HashQualified Name
mainName) [[Char]]
args -> do
          Either IOException Text
e <- IO (Either IOException Text)
safeReadUtf8StdIn
          case Either IOException Text
e of
            Left IOException
_ -> Pretty ColorText -> IO ()
forall a. Pretty ColorText -> IO a
exitError Pretty ColorText
"I had trouble reading this input."
            Right Text
contents -> do
              Maybe CodebasePathOption
-> CodebaseLockOption
-> MigrationStrategy
-> ((InitResult, [Char], Codebase IO Symbol Ann) -> IO ())
-> IO ()
forall r.
Maybe CodebasePathOption
-> CodebaseLockOption
-> MigrationStrategy
-> ((InitResult, [Char], Codebase IO Symbol Ann) -> IO r)
-> IO r
getCodebaseOrExit Maybe CodebasePathOption
mCodePathOption CodebaseLockOption
SC.DontLock MigrationStrategy
SC.DontMigrate \(InitResult
initRes, [Char]
_, Codebase IO Symbol Ann
theCodebase) -> do
                JIT -> RuntimeHost -> (Runtimes -> IO ()) -> IO ()
forall a. JIT -> RuntimeHost -> (Runtimes -> IO a) -> IO a
withRuntimes JIT
jit RuntimeHost
RTI.OneOff \(Runtime Symbol
rt, Runtime Symbol
sbrt) -> do
                  let fileEvent :: Event
fileEvent = Text -> Text -> Event
Input.UnisonFileChanged ([Char] -> Text
Text.pack [Char]
"<standard input>") Text
contents
                  let noOpCheckForChanges :: p -> f ()
noOpCheckForChanges p
_ = () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                  let serverUrl :: Maybe a
serverUrl = Maybe a
forall a. Maybe a
Nothing
                  let ucmVersion :: Text
ucmVersion = Version -> Text
Version.gitDescribeWithDate Version
version
                  let credMan :: CredentialManager
credMan = CredentialManager
AuthN.globalCredentialManager
                  AuthenticatedHttpClient
authenticatedHTTPClient <- Text -> CredentialManager -> IO AuthenticatedHttpClient
initTranscriptAuthenticatedHTTPClient Text
ucmVersion CredentialManager
credMan
                  ProjectPath
startProjectPath <- Codebase IO Symbol Ann -> Transaction ProjectPath -> IO ProjectPath
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Codebase IO Symbol Ann
theCodebase Transaction ProjectPath
HasCallStack => Transaction ProjectPath
Codebase.expectCurrentProjectPath
                  Version
-> [Char]
-> Runtime Symbol
-> Runtime Symbol
-> Codebase IO Symbol Ann
-> [Either Event Input]
-> AuthenticatedHttpClient
-> CredentialManager
-> Maybe BaseUrl
-> ProjectPathIds
-> InitResult
-> (ProjectPathIds -> IO ())
-> ShouldWatchFiles
-> IO ()
launch
                    Version
version
                    [Char]
currentDir
                    Runtime Symbol
rt
                    Runtime Symbol
sbrt
                    Codebase IO Symbol Ann
theCodebase
                    [Event -> Either Event Input
forall a b. a -> Either a b
Left Event
fileEvent, Input -> Either Event Input
forall a b. b -> Either a b
Right (Input -> Either Event Input) -> Input -> Either Event Input
forall a b. (a -> b) -> a -> b
$ ProfileSpec -> HashQualified Name -> [[Char]] -> Input
Input.ExecuteI ProfileSpec
NoProf HashQualified Name
mainName [[Char]]
args, Input -> Either Event Input
forall a b. b -> Either a b
Right Input
Input.QuitI]
                    AuthenticatedHttpClient
authenticatedHTTPClient
                    CredentialManager
credMan
                    Maybe BaseUrl
serverUrl
                    (ProjectPath -> ProjectPathIds
PP.toIds ProjectPath
startProjectPath)
                    InitResult
initRes
                    ProjectPathIds -> IO ()
noOpCheckForChanges
                    ShouldWatchFiles
CommandLine.ShouldNotWatchFiles
        Run (RunCompiled [Char]
file) [[Char]]
args ->
          [Char] -> IO ByteString
BS.readFile [Char]
file IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ByteString
bs ->
            IO (Either [Char] (Text, Text, CombIx, StoredCache))
-> IO
     (Either
        RuntimeExn (Either [Char] (Text, Text, CombIx, StoredCache)))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (ByteString -> IO (Either [Char] (Text, Text, CombIx, StoredCache))
RTI.decodeStandalone ByteString
bs) IO
  (Either
     RuntimeExn (Either [Char] (Text, Text, CombIx, StoredCache)))
-> (Either
      RuntimeExn (Either [Char] (Text, Text, CombIx, StoredCache))
    -> IO ())
-> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Left RuntimeExn
re -> do
                Pretty ColorText
exnMessage <- (Word -> IO (Pretty ColorText))
-> RuntimeExn -> IO (Pretty ColorText)
forall (f :: * -> *).
Applicative f =>
(Word -> f (Pretty ColorText))
-> RuntimeExn -> f (Pretty ColorText)
RTI.prettyRuntimeExn Word -> IO (Pretty ColorText)
fetchIssueFromGitHub RuntimeExn
re
                Pretty ColorText -> IO ()
forall a. Pretty ColorText -> IO a
exitError (Pretty ColorText -> IO ())
-> ([Pretty ColorText] -> Pretty ColorText)
-> [Pretty ColorText]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines ([Pretty ColorText] -> IO ()) -> [Pretty ColorText] -> IO ()
forall a b. (a -> b) -> a -> b
$
                  [ Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap (Pretty ColorText -> Pretty ColorText)
-> (Text -> Pretty ColorText) -> Text -> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Pretty ColorText
forall s. IsString s => Text -> Pretty s
P.text (Text -> Pretty ColorText) -> Text -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$
                      Text
"I was unable to parse this file as a compiled\
                      \ program. The parser generated the following error:",
                    Pretty ColorText
"",
                    Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 Pretty ColorText
exnMessage
                  ]
              Right (Left [Char]
err) ->
                Pretty ColorText -> IO ()
forall a. Pretty ColorText -> IO a
exitError (Pretty ColorText -> IO ())
-> ([Pretty ColorText] -> Pretty ColorText)
-> [Pretty ColorText]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines ([Pretty ColorText] -> IO ()) -> [Pretty ColorText] -> IO ()
forall a b. (a -> b) -> a -> b
$
                  [ Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap (Pretty ColorText -> Pretty ColorText)
-> (Text -> Pretty ColorText) -> Text -> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Pretty ColorText
forall s. IsString s => Text -> Pretty s
P.text (Text -> Pretty ColorText) -> Text -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$
                      Text
"I was unable to parse this file as a compiled\
                      \ program. The parser generated the following error:",
                    Pretty ColorText
"",
                    Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ [Char] -> Pretty ColorText
forall s. IsString s => [Char] -> Pretty s
P.string [Char]
err
                  ]
              Right (Right (Text
v, Text
rf, CombIx
combIx, StoredCache
sto))
                | Bool -> Bool
not Bool
vmatch -> IO ()
mismatchMsg
                | Bool
otherwise ->
                    [[Char]] -> IO (Either Error ()) -> IO (Either Error ())
forall a. [[Char]] -> IO a -> IO a
withArgs [[Char]]
args (JIT -> Bool -> StoredCache -> CombIx -> IO (Either Error ())
RTI.runStandalone JIT
jit Bool
False StoredCache
sto CombIx
combIx) IO (Either Error ()) -> (Either Error () -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                      Left Error
err -> Pretty ColorText -> IO ()
forall a. Pretty ColorText -> IO a
exitError (Pretty ColorText -> IO ()) -> IO (Pretty ColorText) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Word -> IO (Pretty ColorText)) -> Error -> IO (Pretty ColorText)
forall (f :: * -> *).
Applicative f =>
(Word -> f (Pretty ColorText)) -> Error -> f (Pretty ColorText)
RTI.prettyError Word -> IO (Pretty ColorText)
fetchIssueFromGitHub Error
err
                      Right () -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                where
                  vmatch :: Bool
vmatch = Text
v Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Version -> Text
Version.gitDescribeWithDate Version
version
                  ws :: Text -> Pretty s
ws Text
s = Pretty s -> Pretty s
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap (Text -> Pretty s
forall s. IsString s => Text -> Pretty s
P.text Text
s)
                  ifile :: [Char]
ifile
                    | Char
'c' : Char
'u' : Char
'.' : [Char]
rest <- [Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
file = [Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
rest
                    | Bool
otherwise = [Char]
file
                  mismatchMsg :: IO ()
mismatchMsg =
                    Pretty ColorText -> IO ()
PT.putPrettyLn (Pretty ColorText -> IO ())
-> ([Pretty ColorText] -> Pretty ColorText)
-> [Pretty ColorText]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines ([Pretty ColorText] -> IO ()) -> [Pretty ColorText] -> IO ()
forall a b. (a -> b) -> a -> b
$
                      [ Text -> Pretty ColorText
forall {s}.
(Item s ~ Char, ListLike s Char, IsString s) =>
Text -> Pretty s
ws
                          Text
"I can't run this compiled program since \
                          \it works with a different version of Unison \
                          \than the one you're running.",
                        Pretty ColorText
"",
                        Pretty ColorText
"Compiled file version",
                        Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
4 (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ Text -> Pretty ColorText
forall s. IsString s => Text -> Pretty s
P.text Text
v,
                        Pretty ColorText
"",
                        Pretty ColorText
"Your version",
                        Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
4 (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ Text -> Pretty ColorText
forall s. IsString s => Text -> Pretty s
P.text (Text -> Pretty ColorText) -> Text -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ Version -> Text
Version.gitDescribeWithDate Version
version,
                        Pretty ColorText
"",
                        Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$
                          Pretty ColorText
"The program was compiled from hash "
                            Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> (Text -> Pretty ColorText
forall s. IsString s => Text -> Pretty s
P.text (Text -> Pretty ColorText) -> Text -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ Text
"`" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rf Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`.")
                            Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
"If you have that hash in your codebase,"
                            Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
"you can do:",
                        Pretty ColorText
"",
                        Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
4 (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$
                          Pretty ColorText
".> compile "
                            Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Text -> Pretty ColorText
forall s. IsString s => Text -> Pretty s
P.text Text
rf
                            Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
" "
                            Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> [Char] -> Pretty ColorText
forall s. IsString s => [Char] -> Pretty s
P.string [Char]
ifile,
                        Pretty ColorText
"",
                        Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap
                          Pretty ColorText
"to produce a new compiled program \
                          \that matches your version of Unison."
                      ]
        Transcript TranscriptCodebaseSetup
codebaseSetup Maybe RtsStatsPath
mrtsStatsFp NonEmpty [Char]
transcriptFiles -> do
          let action :: IO ()
action = JIT
-> Version
-> Verbosity
-> UsageRenderer
-> TranscriptCodebaseSetup
-> Maybe CodebasePathOption
-> NonEmpty [Char]
-> IO ()
runTranscripts JIT
jit Version
version Verbosity
Verbosity.Verbose UsageRenderer
renderUsageInfo TranscriptCodebaseSetup
codebaseSetup Maybe CodebasePathOption
mCodePathOption NonEmpty [Char]
transcriptFiles
          case Maybe RtsStatsPath
mrtsStatsFp of
            Maybe RtsStatsPath
Nothing -> IO ()
action
            Just RtsStatsPath
fp -> RtsStatsPath -> IO () -> IO ()
forall a. RtsStatsPath -> IO a -> IO a
recordRtsStats RtsStatsPath
fp IO ()
action
        Launch IsHeadless
isHeadless CodebaseServerOpts
codebaseServerOpts Maybe (ProjectAndBranch ProjectName ProjectBranchName)
mayStartingProject ShouldWatchFiles
shouldWatchFiles -> do
          CodebaseLockOption
lockOption <- IO CodebaseLockOption
getCodebaseLockOption
          Maybe CodebasePathOption
-> CodebaseLockOption
-> MigrationStrategy
-> ((InitResult, [Char], Codebase IO Symbol Ann) -> IO ())
-> IO ()
forall r.
Maybe CodebasePathOption
-> CodebaseLockOption
-> MigrationStrategy
-> ((InitResult, [Char], Codebase IO Symbol Ann) -> IO r)
-> IO r
getCodebaseOrExit Maybe CodebasePathOption
mCodePathOption CodebaseLockOption
lockOption (BackupStrategy -> VacuumStrategy -> MigrationStrategy
SC.MigrateAfterPrompt BackupStrategy
SC.Backup VacuumStrategy
SC.Vacuum) \(InitResult
initRes, [Char]
_, Codebase IO Symbol Ann
theCodebase) -> do
            JIT -> RuntimeHost -> (Runtimes -> IO ()) -> IO ()
forall a. JIT -> RuntimeHost -> (Runtimes -> IO a) -> IO a
withRuntimes JIT
jit RuntimeHost
RTI.Persistent \(Runtime Symbol
runtime, Runtime Symbol
sbRuntime) -> do
              ProjectPath
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 Maybe (ProjectAndBranch ProjectName ProjectBranchName)
mayStartingProject of
                  Just ProjectAndBranch ProjectName ProjectBranchName
startingProject -> do
                    Codebase IO Symbol Ann
-> Transaction (Maybe (ProjectAndBranch Project ProjectBranch))
-> IO (Maybe (ProjectAndBranch Project ProjectBranch))
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Codebase IO Symbol Ann
theCodebase (ProjectAndBranch ProjectName ProjectBranchName
-> Transaction (Maybe (ProjectAndBranch Project ProjectBranch))
ProjectUtils.getProjectAndBranchByNames ProjectAndBranch ProjectName ProjectBranchName
startingProject) IO (Maybe (ProjectAndBranch Project ProjectBranch))
-> (Maybe (ProjectAndBranch Project ProjectBranch)
    -> IO ProjectPath)
-> IO ProjectPath
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                      Maybe (ProjectAndBranch Project ProjectBranch)
Nothing -> do
                        Pretty ColorText -> IO ()
PT.putPrettyLn (Pretty ColorText -> IO ()) -> Pretty ColorText -> IO ()
forall a b. (a -> b) -> a -> b
$
                          Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
P.callout
                            Pretty ColorText
"❓"
                            ( [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
                                [ Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 Pretty ColorText
"I couldn't find the project branch: " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Text -> Pretty ColorText
forall s. IsString s => Text -> Pretty s
P.text (forall target source. From source target => source -> target
into @Text ProjectAndBranch ProjectName ProjectBranchName
startingProject)
                                ]
                            )
                        IO ProjectPath
forall a. IO a
System.exitFailure
                      Just ProjectAndBranch Project ProjectBranch
pab -> do
                        ProjectPath -> IO ProjectPath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProjectPath -> IO ProjectPath) -> ProjectPath -> IO ProjectPath
forall a b. (a -> b) -> a -> b
$ ProjectAndBranch Project ProjectBranch -> Absolute -> ProjectPath
PP.fromProjectAndBranch ProjectAndBranch Project ProjectBranch
pab Absolute
Path.Root
                  Maybe (ProjectAndBranch ProjectName ProjectBranchName)
Nothing -> do
                    Codebase IO Symbol Ann -> Transaction ProjectPath -> IO ProjectPath
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Codebase IO Symbol Ann
theCodebase Transaction ProjectPath
HasCallStack => Transaction ProjectPath
Codebase.expectCurrentProjectPath
              ProjectPathIds
currentPP <- Codebase IO Symbol Ann
-> Transaction ProjectPathIds -> IO ProjectPathIds
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Codebase IO Symbol Ann
theCodebase do
                ProjectPath -> ProjectPathIds
PP.toIds (ProjectPath -> ProjectPathIds)
-> Transaction ProjectPath -> Transaction ProjectPathIds
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Transaction ProjectPath
HasCallStack => Transaction ProjectPath
Codebase.expectCurrentProjectPath
              Signal ProjectPathIds
changeSignal <- Maybe ProjectPathIds -> IO (Signal ProjectPathIds)
forall (m :: * -> *) a. MonadIO m => Maybe a -> m (Signal a)
Signal.newSignalIO (ProjectPathIds -> Maybe ProjectPathIds
forall a. a -> Maybe a
Just ProjectPathIds
currentPP)
              let lspCheckForChanges :: ProjectPathIds -> IO ()
lspCheckForChanges = Signal ProjectPathIds -> ProjectPathIds -> IO ()
forall (m :: * -> *) a. MonadIO m => Signal a -> a -> m ()
Signal.writeSignalIO Signal ProjectPathIds
changeSignal
              -- 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
              MVar Socket
lspServerSock <- IO (MVar Socket)
forall (m :: * -> *) a. MonadIO m => m (MVar a)
UnliftIO.newEmptyMVar
              IO (Thread ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Thread ()) -> IO ())
-> (IO () -> IO (Thread ())) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scope -> IO () -> IO (Thread ())
forall a. Scope -> IO a -> IO (Thread a)
Ki.fork Scope
scope (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ LspFormattingConfig
-> Codebase IO Symbol Ann
-> Runtime Symbol
-> Signal ProjectPathIds
-> (Socket -> IO ())
-> IO ()
LSP.spawnLsp LspFormattingConfig
lspFormattingConfig Codebase IO Symbol Ann
theCodebase Runtime Symbol
runtime Signal ProjectPathIds
changeSignal (MVar Socket -> Socket -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Socket
lspServerSock)
              let isTest :: Bool
isTest = Bool
False
              let ucmVersion :: Text
ucmVersion = Version -> Text
Version.gitDescribeWithDate Version
version
              let credMan :: CredentialManager
credMan = CredentialManager
AuthN.globalCredentialManager
              AuthenticatedHttpClient
authenticatedHTTPClient <- Text -> CredentialManager -> IO AuthenticatedHttpClient
initTranscriptAuthenticatedHTTPClient Text
ucmVersion CredentialManager
credMan
              Server
mcpServerConfig <- Codebase IO Symbol Ann
-> Runtime Symbol
-> Runtime Symbol
-> Maybe [Char]
-> Text
-> AuthenticatedHttpClient
-> IO Server
MCP.initServer Codebase IO Symbol Ann
theCodebase Runtime Symbol
runtime Runtime Symbol
sbRuntime ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
currentDir) Text
ucmVersion AuthenticatedHttpClient
authenticatedHTTPClient
              Bool
-> BackendEnv
-> CodebaseServerOpts
-> Runtime Symbol
-> Codebase IO Symbol Ann
-> MCPServer
-> (Maybe BaseUrl -> IO ())
-> IO ()
forall a.
Bool
-> BackendEnv
-> CodebaseServerOpts
-> Runtime Symbol
-> Codebase IO Symbol Ann
-> MCPServer
-> (Maybe BaseUrl -> IO a)
-> IO a
Server.startServer
                Bool
isTest
                BackendEnv
Backend.BackendEnv
                CodebaseServerOpts
codebaseServerOpts
                Runtime Symbol
sbRuntime
                Codebase IO Symbol Ann
theCodebase
                (Server -> MCPServer
forall (m :: * -> *).
MonadIO m =>
Server -> Message -> m (Maybe Message)
MCP.mcpServer Server
mcpServerConfig)
                \Maybe BaseUrl
mayBaseUrl -> case ShouldExit
exitOption of
                  ShouldExit
DoNotExit -> case IsHeadless
isHeadless of
                    IsHeadless
Headless -> Maybe BaseUrl -> (BaseUrl -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe BaseUrl
mayBaseUrl \BaseUrl
baseUrl -> do
                      Pretty ColorText -> IO ()
PT.putPrettyLn (Pretty ColorText -> IO ()) -> Pretty ColorText -> IO ()
forall a b. (a -> b) -> a -> b
$
                        [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
                          [ Pretty ColorText
"I've started the Codebase API server at",
                            Text -> Pretty ColorText
forall s. IsString s => Text -> Pretty s
P.text (Text -> Pretty ColorText) -> Text -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ Service -> BaseUrl -> Text
Server.urlFor Service
Server.Api BaseUrl
baseUrl,
                            Pretty ColorText
"and the Codebase UI at",
                            Text -> Pretty ColorText
forall s. IsString s => Text -> Pretty s
P.text (Text -> Pretty ColorText) -> Text -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$
                              Service -> BaseUrl -> Text
Server.urlFor
                                ( ProjectAndBranch ProjectName ProjectBranchName
-> Absolute -> Maybe DefinitionReference -> Service
Server.ProjectBranchUI
                                    (ProjectName
-> ProjectBranchName
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch (Text -> ProjectName
UnsafeProjectName Text
"scratch") ProjectBranchName
defaultBranchName)
                                    Absolute
Path.Root
                                    Maybe DefinitionReference
forall a. Maybe a
Nothing
                                )
                                BaseUrl
baseUrl
                          ]
                      Pretty ColorText -> IO ()
PT.putPrettyLn (Pretty ColorText -> IO ()) -> Pretty ColorText -> IO ()
forall a b. (a -> b) -> a -> b
$
                        [Char] -> Pretty ColorText
forall s. IsString s => [Char] -> Pretty s
P.string [Char]
"Running the codebase manager headless with "
                          Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Int -> Pretty ColorText
forall a s. (Show a, IsString s) => a -> Pretty s
P.shown Int
GHC.Conc.numCapabilities
                          Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
" "
                          Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Int -> Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a b. Integral a => a -> b -> b -> b
plural' Int
GHC.Conc.numCapabilities Pretty ColorText
"cpu" Pretty ColorText
"cpus"
                          Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
"."
                      MVar ()
mvar <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
                      MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
mvar
                    IsHeadless
WithCLI -> do
                      Pretty ColorText -> IO ()
PT.putPrettyLn (Pretty ColorText -> IO ()) -> Pretty ColorText -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Pretty ColorText
forall s. IsString s => [Char] -> Pretty s
P.string [Char]
"Now starting the Unison Codebase Manager (UCM)..."
                      Version
-> [Char]
-> Runtime Symbol
-> Runtime Symbol
-> Codebase IO Symbol Ann
-> [Either Event Input]
-> AuthenticatedHttpClient
-> CredentialManager
-> Maybe BaseUrl
-> ProjectPathIds
-> InitResult
-> (ProjectPathIds -> IO ())
-> ShouldWatchFiles
-> IO ()
launch
                        Version
version
                        [Char]
currentDir
                        Runtime Symbol
runtime
                        Runtime Symbol
sbRuntime
                        Codebase IO Symbol Ann
theCodebase
                        []
                        AuthenticatedHttpClient
authenticatedHTTPClient
                        CredentialManager
credMan
                        Maybe BaseUrl
mayBaseUrl
                        (ProjectPath -> ProjectPathIds
PP.toIds ProjectPath
startingProjectPath)
                        InitResult
initRes
                        ProjectPathIds -> IO ()
lspCheckForChanges
                        ShouldWatchFiles
shouldWatchFiles
                      -- Close the LSP server socket so the LSP thread unblocks from
                      -- `accept` and can exit cleanly. This is necessary on Windows
                      -- where async exceptions cannot interrupt a thread blocked in
                      -- a socket accept call.
                      IO (Maybe Socket) -> (Socket -> IO ()) -> IO ()
forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM (MVar Socket -> IO (Maybe Socket)
forall (m :: * -> *) a. MonadIO m => MVar a -> m (Maybe a)
UnliftIO.tryTakeMVar MVar Socket
lspServerSock) Socket -> IO ()
Socket.close
                  ShouldExit
Exit -> IO ()
forall a. IO a
Exit.exitSuccess
  where
    -- (runtime, sandboxed runtime)
    withRuntimes :: JIT.JIT -> RTI.RuntimeHost -> (Runtimes -> IO a) -> IO a
    withRuntimes :: forall a. JIT -> RuntimeHost -> (Runtimes -> IO a) -> IO a
withRuntimes JIT
jit RuntimeHost
mode Runtimes -> IO a
action =
      JIT
-> Bool -> RuntimeHost -> Text -> (Runtime Symbol -> IO a) -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
JIT
-> Bool -> RuntimeHost -> Text -> (Runtime Symbol -> m a) -> m a
RTI.withRuntime JIT
jit Bool
False RuntimeHost
mode (Version -> Text
Version.gitDescribeWithDate Version
version) \Runtime Symbol
runtime -> do
        JIT
-> Bool -> RuntimeHost -> Text -> (Runtime Symbol -> IO a) -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
JIT
-> Bool -> RuntimeHost -> Text -> (Runtime Symbol -> m a) -> m a
RTI.withRuntime JIT
jit Bool
True RuntimeHost
mode (Version -> Text
Version.gitDescribeWithDate Version
version) \Runtime Symbol
sbRuntime ->
          Runtimes -> IO a
action (Runtime Symbol
runtime, Runtime Symbol
sbRuntime)
    initTranscriptAuthenticatedHTTPClient :: UCMVersion -> AuthN.CredentialManager -> IO AuthN.AuthenticatedHttpClient
    initTranscriptAuthenticatedHTTPClient :: Text -> CredentialManager -> IO AuthenticatedHttpClient
initTranscriptAuthenticatedHTTPClient Text
ucmVersion CredentialManager
credMan = do
      TokenProvider -> Text -> IO AuthenticatedHttpClient
forall (m :: * -> *).
MonadIO m =>
TokenProvider -> Text -> m AuthenticatedHttpClient
AuthN.newAuthenticatedHTTPClient (CredentialManager -> TokenProvider
AuthN.newTokenProvider CredentialManager
credMan) Text
ucmVersion

isExitSuccess :: SomeException -> Bool
isExitSuccess :: SomeException -> Bool
isExitSuccess =
  (Maybe ExitCode -> Maybe ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode -> Maybe ExitCode
forall a. a -> Maybe a
Just ExitCode
ExitSuccess) (Maybe ExitCode -> Bool)
-> (SomeException -> Maybe ExitCode) -> SomeException -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
fromException

-- | Set user agent and configure TLS on global http client.
-- Note that the authorized http client is distinct from the global http client.
initHTTPClient :: Version -> IO ()
initHTTPClient :: Version -> IO ()
initHTTPClient Version
version = do
  let (Text
ucmVersion, Text
_date) = Version -> (Text, Text)
Version.gitDescribe Version
version
  let userAgent :: ByteString
userAgent = Text -> ByteString
Text.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text
"UCM/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ucmVersion
  let addUserAgent :: Request -> IO Request
addUserAgent Request
req = do
        Request -> IO Request
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request -> IO Request) -> Request -> IO Request
forall a b. (a -> b) -> a -> b
$ Request
req {HTTP.requestHeaders = ("User-Agent", userAgent) : HTTP.requestHeaders req}
  let managerSettings :: ManagerSettings
managerSettings = ManagerSettings
HTTP.tlsManagerSettings {HTTP.managerModifyRequest = addUserAgent}
  Manager
manager <- ManagerSettings -> IO Manager
forall (m :: * -> *). MonadIO m => ManagerSettings -> m Manager
HTTP.newTlsManagerWith ManagerSettings
managerSettings
  Manager -> IO ()
HTTP.setGlobalManager Manager
manager

-- | Prep the codebase for transcripts, then pass the directory to the action.
-- After the action the codebase will be deleted/copied/saved as indicated.
withTranscriptDir :: Verbosity.Verbosity -> String -> TranscriptCodebaseSetup -> Maybe CodebasePathOption -> (FilePath -> IO r) -> IO (Maybe r)
withTranscriptDir :: forall r.
Verbosity
-> [Char]
-> TranscriptCodebaseSetup
-> Maybe CodebasePathOption
-> ([Char] -> IO r)
-> IO (Maybe r)
withTranscriptDir Verbosity
verbosity [Char]
progName TranscriptCodebaseSetup
codebaseSetup Maybe CodebasePathOption
mCodePathOption [Char] -> IO r
action = do
  IO (Maybe [Char], IO ())
-> ((Maybe [Char], IO ()) -> IO ())
-> ((Maybe [Char], IO ()) -> IO (Maybe r))
-> IO (Maybe r)
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
UnliftIO.bracket IO (Maybe [Char], IO ())
setup (Maybe [Char], IO ()) -> IO ()
cleanup (\(Maybe [Char]
mayDir, IO ()
_cleanup) -> Maybe [Char] -> ([Char] -> IO r) -> IO (Maybe r)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe [Char]
mayDir [Char] -> IO r
action)
  where
    setup :: IO (Maybe FilePath, IO ())
    setup :: IO (Maybe [Char], IO ())
setup = do
      case TranscriptCodebaseSetup
codebaseSetup of
        TranscriptCodebaseSetup
InPlace -> do
          -- Create the codebase/migrate it according to codebase path option
          CodebaseLockOption
lockOption <- IO CodebaseLockOption
getCodebaseLockOption
          Maybe CodebasePathOption
-> CodebaseLockOption
-> MigrationStrategy
-> ((InitResult, [Char], Codebase IO Symbol Ann) -> IO ())
-> IO ()
forall r.
Maybe CodebasePathOption
-> CodebaseLockOption
-> MigrationStrategy
-> ((InitResult, [Char], Codebase IO Symbol Ann) -> IO r)
-> IO r
getCodebaseOrExit Maybe CodebasePathOption
mCodePathOption CodebaseLockOption
lockOption (BackupStrategy -> VacuumStrategy -> MigrationStrategy
SC.MigrateAfterPrompt BackupStrategy
SC.Backup VacuumStrategy
SC.Vacuum) (((InitResult, [Char], Codebase IO Symbol Ann) -> IO ()) -> IO ())
-> ((InitResult, [Char], Codebase IO Symbol Ann) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> (InitResult, [Char], Codebase IO Symbol Ann) -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
          [Char]
path <- Maybe [Char] -> IO [Char]
forall (m :: * -> *). MonadIO m => Maybe [Char] -> m [Char]
Codebase.getCodebaseDir ((CodebasePathOption -> [Char])
-> Maybe CodebasePathOption -> Maybe [Char]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CodebasePathOption -> [Char]
codebasePathOptionToPath Maybe CodebasePathOption
mCodePathOption)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Verbosity -> Bool
Verbosity.isSilent Verbosity
verbosity) (IO () -> IO ())
-> (Pretty ColorText -> IO ()) -> Pretty ColorText -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty ColorText -> IO ()
PT.putPrettyLn (Pretty ColorText -> IO ()) -> Pretty ColorText -> IO ()
forall a b. (a -> b) -> a -> b
$
            [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
              [ Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap Pretty ColorText
"Transcript will be run in-place on the codebase at: ",
                Pretty ColorText
"",
                Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 ([Char] -> Pretty ColorText
forall s. IsString s => [Char] -> Pretty s
P.string [Char]
path)
              ]
          let after :: IO ()
after =
                do
                  Pretty ColorText -> IO ()
PT.putPrettyLn
                  (Pretty ColorText -> IO ()) -> Pretty ColorText -> IO ()
forall a b. (a -> b) -> a -> b
$ Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
P.callout
                    Pretty ColorText
"🌸"
                    ( [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
                        [ Pretty ColorText
"I've finished running the transcript(s) on the provided codebase:",
                          Pretty ColorText
"",
                          Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 ([Char] -> Pretty ColorText
forall s. IsString s => [Char] -> Pretty s
P.string [Char]
path)
                        ]
                    )
          pure ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
path, IO ()
after)
        UseTempCodebase ShouldForkCodebase
shouldFork ShouldSaveCodebase
shouldSaveCodebase -> do
          ([Char]
tmp, IO ()
cleanup) <- case ShouldSaveCodebase
shouldSaveCodebase of
            SaveCodebase (Just [Char]
path) -> do
              let after :: IO ()
after = do
                    Pretty ColorText -> IO ()
PT.putPrettyLn (Pretty ColorText -> IO ()) -> Pretty ColorText -> IO ()
forall a b. (a -> b) -> a -> b
$
                      Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
P.callout
                        Pretty ColorText
"🌸"
                        ( [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
                            [ Pretty ColorText
"I've finished running the transcript(s) in this codebase:",
                              Pretty ColorText
"",
                              Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 ([Char] -> Pretty ColorText
forall s. IsString s => [Char] -> Pretty s
P.string [Char]
path),
                              Pretty ColorText
"",
                              Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$
                                Pretty ColorText
"You can run"
                                  Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText -> Pretty ColorText
forall s. IsString s => Pretty s -> Pretty s
P.backticked ([Char] -> Pretty ColorText
forall s. IsString s => [Char] -> Pretty s
P.string [Char]
progName Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
" --codebase " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> [Char] -> Pretty ColorText
forall s. IsString s => [Char] -> Pretty s
P.string [Char]
path)
                                  Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
"to do more work with it."
                            ]
                        )
              ([Char], IO ()) -> IO ([Char], IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
path, IO ()
after)
            ShouldSaveCodebase
_ -> do
              [Char]
path <- IO [Char]
Temp.getCanonicalTemporaryDirectory IO [Char] -> ([Char] -> IO [Char]) -> IO [Char]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Char] -> [Char] -> IO [Char]
`Temp.createTempDirectory` [Char]
"transcript")
              let cleanup :: IO ()
cleanup = [Char] -> IO ()
removeDirectoryRecursive [Char]
path
              ([Char], IO ()) -> IO ([Char], IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
path, IO ()
cleanup)
          let cbInit :: Init IO Symbol Ann
cbInit = Init IO Symbol Ann
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m) =>
Init m Symbol Ann
SC.init
          case ShouldForkCodebase
shouldFork of
            ShouldForkCodebase
UseFork -> do
              -- A forked codebase does not need to Create a codebase, because it already exists
              Maybe CodebasePathOption
-> CodebaseLockOption
-> MigrationStrategy
-> ((InitResult, [Char], Codebase IO Symbol Ann) -> IO ())
-> IO ()
forall r.
Maybe CodebasePathOption
-> CodebaseLockOption
-> MigrationStrategy
-> ((InitResult, [Char], Codebase IO Symbol Ann) -> IO r)
-> IO r
getCodebaseOrExit Maybe CodebasePathOption
mCodePathOption CodebaseLockOption
SC.DontLock MigrationStrategy
SC.DontMigrate (((InitResult, [Char], Codebase IO Symbol Ann) -> IO ()) -> IO ())
-> ((InitResult, [Char], Codebase IO Symbol Ann) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> (InitResult, [Char], Codebase IO Symbol Ann) -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
              [Char]
path <- Maybe [Char] -> IO [Char]
forall (m :: * -> *). MonadIO m => Maybe [Char] -> m [Char]
Codebase.getCodebaseDir ((CodebasePathOption -> [Char])
-> Maybe CodebasePathOption -> Maybe [Char]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CodebasePathOption -> [Char]
codebasePathOptionToPath Maybe CodebasePathOption
mCodePathOption)
              ([Char]
absPath, [Char]
absTmp) <- ([Char] -> IO [Char])
-> ([Char] -> IO [Char]) -> ([Char], [Char]) -> IO ([Char], [Char])
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> (a, b) -> f (c, d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse [Char] -> IO [Char]
forall (m :: * -> *). MonadIO m => [Char] -> m [Char]
Directory.canonicalizePath [Char] -> IO [Char]
forall (m :: * -> *). MonadIO m => [Char] -> m [Char]
Directory.canonicalizePath ([Char]
path, [Char]
tmp)
              if ([Char]
absPath [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
absTmp)
                then do
                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Verbosity -> Bool
Verbosity.isSilent Verbosity
verbosity) (IO () -> IO ())
-> (Pretty ColorText -> IO ()) -> Pretty ColorText -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty ColorText -> IO ()
PT.putPrettyLn (Pretty ColorText -> IO ()) -> Pretty ColorText -> IO ()
forall a b. (a -> b) -> a -> b
$
                    Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
P.hang Pretty ColorText
"⚠️" (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$
                      [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
                        [ Pretty ColorText
"I noticed that you're forking from and saving to the same path at: " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> [Char] -> Pretty ColorText
forall s. IsString s => [Char] -> Pretty s
P.string [Char]
path,
                          Pretty ColorText
"",
                          Pretty ColorText
"I'll skip running the transcript for now in case this was a mistake.",
                          Pretty ColorText
"If this is what you meant to do, use `transcript.in-place` instead."
                        ]
                  pure (Maybe [Char]
forall a. Maybe a
Nothing, () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
                else do
                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Verbosity -> Bool
Verbosity.isSilent Verbosity
verbosity) (IO () -> IO ())
-> (Pretty ColorText -> IO ()) -> Pretty ColorText -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty ColorText -> IO ()
PT.putPrettyLn (Pretty ColorText -> IO ()) -> Pretty ColorText -> IO ()
forall a b. (a -> b) -> a -> b
$
                    [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
                      [ Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap Pretty ColorText
"Transcript will be run on a copy of the codebase at: ",
                        Pretty ColorText
"",
                        Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 ([Char] -> Pretty ColorText
forall s. IsString s => [Char] -> Pretty s
P.string [Char]
path)
                      ]
                  [Char] -> [Char] -> IO ()
Path.copyDir (Init IO Symbol Ann -> [Char] -> [Char]
forall (m :: * -> *) v a. Init m v a -> [Char] -> [Char]
CodebaseInit.codebasePath Init IO Symbol Ann
cbInit [Char]
path) (Init IO Symbol Ann -> [Char] -> [Char]
forall (m :: * -> *) v a. Init m v a -> [Char] -> [Char]
CodebaseInit.codebasePath Init IO Symbol Ann
cbInit [Char]
tmp)
                  pure ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
tmp, IO ()
cleanup)
            ShouldForkCodebase
DontFork -> do
              Pretty ColorText -> IO ()
PT.putPrettyLn (Pretty ColorText -> IO ())
-> (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap (Pretty ColorText -> IO ()) -> Pretty ColorText -> IO ()
forall a b. (a -> b) -> a -> b
$ Pretty ColorText
"Transcript will be run on a new, empty codebase."
              CodebaseLockOption
lockOption <- IO CodebaseLockOption
getCodebaseLockOption
              Init IO Symbol Ann
-> Verbosity
-> [Char]
-> [Char]
-> CodebaseLockOption
-> (Codebase IO Symbol Ann -> IO ())
-> IO ()
forall (m :: * -> *) r.
MonadIO m =>
Init m Symbol Ann
-> Verbosity
-> [Char]
-> [Char]
-> CodebaseLockOption
-> (Codebase m Symbol Ann -> m r)
-> m r
CodebaseInit.withNewUcmCodebaseOrExit Init IO Symbol Ann
cbInit Verbosity
verbosity [Char]
"main.transcript" [Char]
tmp CodebaseLockOption
lockOption (IO () -> Codebase IO Symbol Ann -> IO ()
forall a b. a -> b -> a
const (IO () -> Codebase IO Symbol Ann -> IO ())
-> IO () -> Codebase IO Symbol Ann -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
              pure ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
tmp, IO ()
cleanup)
    cleanup :: (Maybe FilePath, IO ()) -> IO ()
    cleanup :: (Maybe [Char], IO ()) -> IO ()
cleanup (Maybe [Char]
_transcriptDir, IO ()
cleanupAction) = do
      IO ()
cleanupAction

runTranscripts' ::
  JIT.JIT ->
  Version ->
  String ->
  FilePath ->
  NonEmpty MarkdownFile ->
  IO Bool
runTranscripts' :: JIT
-> Version -> [Char] -> [Char] -> NonEmpty MarkdownFile -> IO Bool
runTranscripts' JIT
jit Version
version [Char]
progName [Char]
transcriptDir NonEmpty MarkdownFile
markdownFiles = do
  [Char]
currentDir <- IO [Char]
getCurrentDirectory
  -- We don't need to create a codebase through `getCodebaseOrExit` as we've already done so previously.
  NonEmpty Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and
    (NonEmpty Bool -> Bool) -> IO (NonEmpty Bool) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CodebasePathOption
-> CodebaseLockOption
-> MigrationStrategy
-> ((InitResult, [Char], Codebase IO Symbol Ann)
    -> IO (NonEmpty Bool))
-> IO (NonEmpty Bool)
forall r.
Maybe CodebasePathOption
-> CodebaseLockOption
-> MigrationStrategy
-> ((InitResult, [Char], Codebase IO Symbol Ann) -> IO r)
-> IO r
getCodebaseOrExit
      (CodebasePathOption -> Maybe CodebasePathOption
forall a. a -> Maybe a
Just ([Char] -> CodebasePathOption
DontCreateCodebaseWhenMissing [Char]
transcriptDir))
      CodebaseLockOption
SC.BlockUntilLock
      (BackupStrategy -> VacuumStrategy -> MigrationStrategy
SC.MigrateAutomatically BackupStrategy
SC.Backup VacuumStrategy
SC.Vacuum)
      \(InitResult
_, [Char]
codebasePath, Codebase IO Symbol Ann
theCodebase) -> do
        JIT
-> Config
-> Verbosity
-> Text
-> (Runner -> IO (NonEmpty Bool))
-> IO (NonEmpty Bool)
forall (m :: * -> *) r.
MonadUnliftIO m =>
JIT -> Config -> Verbosity -> Text -> (Runner -> m r) -> m r
Transcript.withRunner
          JIT
jit
          Config
Transcript.defaultConfig
          Verbosity
Verbosity.Verbose
          (Version -> Text
Version.gitDescribeWithDate Version
version)
          \Runner
runTranscript -> do
            NonEmpty MarkdownFile
-> (MarkdownFile -> IO Bool) -> IO (NonEmpty Bool)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for NonEmpty MarkdownFile
markdownFiles ((MarkdownFile -> IO Bool) -> IO (NonEmpty Bool))
-> (MarkdownFile -> IO Bool) -> IO (NonEmpty Bool)
forall a b. (a -> b) -> a -> b
$ \(MarkdownFile [Char]
fileName) -> do
              ByteString
transcriptSrc <- [Char] -> IO ByteString
BS.readFile [Char]
fileName
              Either Error Transcript
result <- Runner
runTranscript [Char]
fileName ByteString
transcriptSrc Codebase IO Symbol Ann
theCodebase
              let outputFile :: [Char]
outputFile = [Char] -> [Char] -> [Char]
replaceExtension ([Char]
currentDir [Char] -> [Char] -> [Char]
</> [Char]
fileName) [Char]
".output.md"
              Text
output <-
                (Error -> IO Text)
-> (Transcript -> IO Text) -> Either Error Transcript -> IO Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
                  ( (IO () -> Text -> IO Text) -> (IO (), Text) -> IO Text
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry IO () -> Text -> IO Text
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
($>) ((IO (), Text) -> IO Text)
-> (Error -> (IO (), Text)) -> Error -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Pretty ColorText] -> IO ())
-> ([Pretty ColorText], Text) -> (IO (), Text)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Pretty ColorText -> IO ()
PT.putPrettyLn (Pretty ColorText -> IO ())
-> ([Pretty ColorText] -> Pretty ColorText)
-> [Pretty ColorText]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
P.callout Pretty ColorText
"❓" (Pretty ColorText -> Pretty ColorText)
-> ([Pretty ColorText] -> Pretty ColorText)
-> [Pretty ColorText]
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines) (([Pretty ColorText], Text) -> (IO (), Text))
-> (Error -> ([Pretty ColorText], Text)) -> Error -> (IO (), Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
                      Error
Transcript.PortBindingFailure ->
                        ( [Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ Pretty ColorText
"The codebase server failed to start because the chosen port was already in use."],
                          Text
"Port binding failure"
                        )
                      Transcript.ParseError ParseErrorBundle Text Void
err ->
                        let msg :: [Char]
msg = ParseErrorBundle Text Void -> [Char]
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> [Char]
MP.errorBundlePretty ParseErrorBundle Text Void
err
                         in ( [ Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$
                                  Pretty ColorText
"An error occurred while parsing the following file: " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> [Char] -> Pretty ColorText
forall s. IsString s => [Char] -> Pretty s
P.string [Char]
fileName,
                                Pretty ColorText
"",
                                Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ [Char] -> Pretty ColorText
forall s. IsString s => [Char] -> Pretty s
P.string [Char]
msg
                              ],
                              [Char] -> Text
Text.pack [Char]
msg
                            )
                      Transcript.RunFailure Transcript
msg ->
                        ( [ Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ Pretty ColorText
"An error occurred while running the following file: " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> [Char] -> Pretty ColorText
forall s. IsString s => [Char] -> Pretty s
P.string [Char]
fileName,
                            Pretty ColorText
"",
                            Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Text -> Pretty ColorText
forall s. IsString s => Text -> Pretty s
P.text (Text -> Pretty ColorText) -> Text -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ Transcript -> Text
Transcript.format Transcript
msg),
                            [Char] -> Pretty ColorText
forall s. IsString s => [Char] -> Pretty s
P.string ([Char] -> Pretty ColorText) -> [Char] -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$
                              [Char]
"Run `"
                                [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
progName
                                [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" --codebase "
                                [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
codebasePath
                                [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"` "
                                [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"to do more work with it."
                          ],
                          Transcript -> Text
Transcript.format Transcript
msg
                        )
                      Transcript.Exception SomeException
someException ->
                        ( [ Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ Pretty ColorText
"An unexpected exception occurred while running the following file: " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> [Char] -> Pretty ColorText
forall s. IsString s => [Char] -> Pretty s
P.string [Char]
fileName,
                            Pretty ColorText
"",
                            Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Text -> Pretty ColorText
forall s. IsString s => Text -> Pretty s
P.text (Text -> Pretty ColorText) -> Text -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ SomeException -> Text
forall a. Show a => a -> Text
tShow SomeException
someException)
                          ],
                          SomeException -> Text
forall a. Show a => a -> Text
tShow SomeException
someException
                        )
                  )
                  (Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> (Transcript -> Text) -> Transcript -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transcript -> Text
Transcript.format)
                  Either Error Transcript
result
              [Char] -> Text -> IO ()
writeUtf8 [Char]
outputFile Text
output
              [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"💾  Wrote " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
outputFile
              pure $ Either Error Transcript -> Bool
forall a b. Either a b -> Bool
isRight Either Error Transcript
result

runTranscripts ::
  JIT.JIT ->
  Version ->
  Verbosity.Verbosity ->
  UsageRenderer ->
  TranscriptCodebaseSetup ->
  Maybe CodebasePathOption ->
  NonEmpty String ->
  IO ()
runTranscripts :: JIT
-> Version
-> Verbosity
-> UsageRenderer
-> TranscriptCodebaseSetup
-> Maybe CodebasePathOption
-> NonEmpty [Char]
-> IO ()
runTranscripts JIT
jit Version
version Verbosity
verbosity UsageRenderer
renderUsageInfo TranscriptCodebaseSetup
codebaseSetup Maybe CodebasePathOption
mCodePathOption NonEmpty [Char]
args = do
  NonEmpty MarkdownFile
markdownFiles <- case ([Char] -> Validation [[Char]] MarkdownFile)
-> NonEmpty [Char] -> Validation [[Char]] (NonEmpty MarkdownFile)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse (([Char] -> [[Char]])
-> Validation [Char] MarkdownFile
-> Validation [[Char]] MarkdownFile
forall a b c. (a -> b) -> Validation a c -> Validation b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall (f :: * -> *) a. Applicative f => a -> f a
pure @[]) (Validation [Char] MarkdownFile
 -> Validation [[Char]] MarkdownFile)
-> ([Char] -> Validation [Char] MarkdownFile)
-> [Char]
-> Validation [[Char]] MarkdownFile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Validation [Char] MarkdownFile
markdownFile) NonEmpty [Char]
args of
    Failure [[Char]]
invalidArgs -> do
      Pretty ColorText -> IO ()
PT.putPrettyLn (Pretty ColorText -> IO ()) -> Pretty ColorText -> IO ()
forall a b. (a -> b) -> a -> b
$
        Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
P.callout
          Pretty ColorText
"❓"
          ( [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
              [ Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 Pretty ColorText
"Transcripts must have an .md or .markdown extension.",
                Pretty ColorText
"",
                [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, ListLike s Char, IsString s) =>
f (Pretty s) -> Pretty s
P.bulleted ([Pretty ColorText] -> Pretty ColorText)
-> [Pretty ColorText] -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ ([Char] -> Pretty ColorText) -> [[Char]] -> [Pretty ColorText]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pretty ColorText -> Pretty ColorText
P.bold (Pretty ColorText -> Pretty ColorText)
-> ([Char] -> Pretty ColorText) -> [Char] -> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Pretty ColorText
forall s. IsString s => [Char] -> Pretty s
P.string ([Char] -> Pretty ColorText)
-> ([Char] -> [Char]) -> [Char] -> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\n")) [[Char]]
invalidArgs
              ]
          )
      [Char] -> IO ()
putStrLn (UsageRenderer
renderUsageInfo UsageRenderer -> UsageRenderer
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"transcript")
      ExitCode -> IO (NonEmpty MarkdownFile)
forall a. ExitCode -> IO a
Exit.exitWith (Int -> ExitCode
Exit.ExitFailure Int
1)
    Success NonEmpty MarkdownFile
markdownFiles -> NonEmpty MarkdownFile -> IO (NonEmpty MarkdownFile)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty MarkdownFile
markdownFiles
  [Char]
progName <- IO [Char]
getProgName
  Bool
completed <-
    Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> IO (Maybe Bool) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity
-> [Char]
-> TranscriptCodebaseSetup
-> Maybe CodebasePathOption
-> ([Char] -> IO Bool)
-> IO (Maybe Bool)
forall r.
Verbosity
-> [Char]
-> TranscriptCodebaseSetup
-> Maybe CodebasePathOption
-> ([Char] -> IO r)
-> IO (Maybe r)
withTranscriptDir Verbosity
verbosity [Char]
progName TranscriptCodebaseSetup
codebaseSetup Maybe CodebasePathOption
mCodePathOption \[Char]
transcriptDir -> do
      JIT
-> Version -> [Char] -> [Char] -> NonEmpty MarkdownFile -> IO Bool
runTranscripts' JIT
jit Version
version [Char]
progName [Char]
transcriptDir NonEmpty MarkdownFile
markdownFiles
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
completed) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO ()
forall a. ExitCode -> IO a
Exit.exitWith (Int -> ExitCode
Exit.ExitFailure Int
1)

launch ::
  Version ->
  FilePath ->
  RTI.Runtime Symbol ->
  RTI.Runtime Symbol ->
  Codebase.Codebase IO Symbol Ann ->
  [Either Input.Event Input.Input] ->
  AuthN.AuthenticatedHttpClient ->
  AuthN.CredentialManager ->
  Maybe Server.BaseUrl ->
  PP.ProjectPathIds ->
  InitResult ->
  (PP.ProjectPathIds -> IO ()) ->
  CommandLine.ShouldWatchFiles ->
  IO ()
launch :: Version
-> [Char]
-> Runtime Symbol
-> Runtime Symbol
-> Codebase IO Symbol Ann
-> [Either Event Input]
-> AuthenticatedHttpClient
-> CredentialManager
-> Maybe BaseUrl
-> ProjectPathIds
-> InitResult
-> (ProjectPathIds -> IO ())
-> ShouldWatchFiles
-> IO ()
launch Version
version [Char]
dir Runtime Symbol
runtime Runtime Symbol
sbRuntime Codebase IO Symbol Ann
codebase [Either Event Input]
inputs AuthenticatedHttpClient
authenticatedHTTPClient CredentialManager
credMan Maybe BaseUrl
serverBaseUrl ProjectPathIds
startingPath InitResult
initResult ProjectPathIds -> IO ()
lspCheckForChanges ShouldWatchFiles
shouldWatchFiles = do
  Bool
showWelcomeHint <- Codebase IO Symbol Ann -> Transaction Bool -> IO Bool
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Codebase IO Symbol Ann
codebase Transaction Bool
Queries.doProjectsExist
  let isNewCodebase :: CodebaseInitStatus
isNewCodebase = case InitResult
initResult of
        InitResult
CreatedCodebase -> CodebaseInitStatus
NewlyCreatedCodebase
        InitResult
OpenedCodebase -> CodebaseInitStatus
PreviouslyCreatedCodebase
      (Text
ucmVersion, Text
_date) = Version -> (Text, Text)
Version.gitDescribe Version
version
      welcome :: Welcome
welcome = CodebaseInitStatus -> Text -> Bool -> Welcome
Welcome.welcome CodebaseInitStatus
isNewCodebase Text
ucmVersion Bool
showWelcomeHint
   in [Char]
-> Welcome
-> ProjectPathIds
-> [Either Event Input]
-> Runtime Symbol
-> Runtime Symbol
-> Codebase IO Symbol Ann
-> Maybe BaseUrl
-> Text
-> AuthenticatedHttpClient
-> CredentialManager
-> (ProjectPathIds -> IO ())
-> ShouldWatchFiles
-> IO ()
CommandLine.main
        [Char]
dir
        Welcome
welcome
        ProjectPathIds
startingPath
        [Either Event Input]
inputs
        Runtime Symbol
runtime
        Runtime Symbol
sbRuntime
        Codebase IO Symbol Ann
codebase
        Maybe BaseUrl
serverBaseUrl
        Text
ucmVersion
        AuthenticatedHttpClient
authenticatedHTTPClient
        CredentialManager
credMan
        ProjectPathIds -> IO ()
lspCheckForChanges
        ShouldWatchFiles
shouldWatchFiles

newtype MarkdownFile = MarkdownFile FilePath

markdownFile :: FilePath -> Validation FilePath MarkdownFile
markdownFile :: [Char] -> Validation [Char] MarkdownFile
markdownFile [Char]
md = case [Char] -> [Char]
takeExtension [Char]
md of
  [Char]
".md" -> MarkdownFile -> Validation [Char] MarkdownFile
forall e a. a -> Validation e a
Success (MarkdownFile -> Validation [Char] MarkdownFile)
-> MarkdownFile -> Validation [Char] MarkdownFile
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkdownFile
MarkdownFile [Char]
md
  [Char]
".markdown" -> MarkdownFile -> Validation [Char] MarkdownFile
forall e a. a -> Validation e a
Success (MarkdownFile -> Validation [Char] MarkdownFile)
-> MarkdownFile -> Validation [Char] MarkdownFile
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkdownFile
MarkdownFile [Char]
md
  [Char]
_ -> [Char] -> Validation [Char] MarkdownFile
forall e a. e -> Validation e a
Failure [Char]
md

isDotU :: String -> Bool
isDotU :: [Char] -> Bool
isDotU [Char]
file = [Char] -> [Char]
takeExtension [Char]
file [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
".u"

getCodebaseOrExit :: Maybe CodebasePathOption -> SC.CodebaseLockOption -> SC.MigrationStrategy -> ((InitResult, CodebasePath, Codebase IO Symbol Ann) -> IO r) -> IO r
getCodebaseOrExit :: forall r.
Maybe CodebasePathOption
-> CodebaseLockOption
-> MigrationStrategy
-> ((InitResult, [Char], Codebase IO Symbol Ann) -> IO r)
-> IO r
getCodebaseOrExit Maybe CodebasePathOption
codebasePathOption CodebaseLockOption
locking MigrationStrategy
migrationStrategy (InitResult, [Char], Codebase IO Symbol Ann) -> IO r
action = do
  CodebaseInitOptions
initOptions <- Maybe CodebasePathOption -> IO CodebaseInitOptions
argsToCodebaseInitOptions Maybe CodebasePathOption
codebasePathOption
  let cbInit :: Init IO Symbol Ann
cbInit = Init IO Symbol Ann
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m) =>
Init m Symbol Ann
SC.init
  Either ([Char], InitError) r
result <- Init IO Symbol Ann
-> [Char]
-> CodebaseInitOptions
-> CodebaseLockOption
-> MigrationStrategy
-> ((InitResult, [Char], Codebase IO Symbol Ann) -> IO r)
-> IO (Either ([Char], InitError) r)
forall (m :: * -> *) v a r.
MonadIO m =>
Init m v a
-> [Char]
-> CodebaseInitOptions
-> CodebaseLockOption
-> MigrationStrategy
-> ((InitResult, [Char], Codebase m v a) -> m r)
-> m (Either ([Char], InitError) r)
CodebaseInit.withOpenOrCreateCodebase Init IO Symbol Ann
cbInit [Char]
"main" CodebaseInitOptions
initOptions CodebaseLockOption
locking MigrationStrategy
migrationStrategy \case
    cbInit :: (InitResult, [Char], Codebase IO Symbol Ann)
cbInit@(InitResult
CreatedCodebase, [Char]
dir, Codebase IO Symbol Ann
_) -> do
      Pretty ColorText
pDir <- [Char] -> IO (Pretty ColorText)
forall {s}. IsString s => [Char] -> IO (Pretty s)
prettyDir [Char]
dir
      Pretty ColorText -> IO ()
PT.putPrettyLn' Pretty ColorText
""
      Pretty ColorText -> IO ()
PT.putPrettyLn' (Pretty ColorText -> IO ())
-> (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap (Pretty ColorText -> IO ()) -> Pretty ColorText -> IO ()
forall a b. (a -> b) -> a -> b
$ Pretty ColorText
"I created a new codebase for you at" Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText -> Pretty ColorText
P.blue Pretty ColorText
pDir
      (InitResult, [Char], Codebase IO Symbol Ann) -> IO r
action (InitResult, [Char], Codebase IO Symbol Ann)
cbInit
    cbInit :: (InitResult, [Char], Codebase IO Symbol Ann)
cbInit@(InitResult
OpenedCodebase, [Char]
_, Codebase IO Symbol Ann
_) ->
      (InitResult, [Char], Codebase IO Symbol Ann) -> IO r
action (InitResult, [Char], Codebase IO Symbol Ann)
cbInit

  case Either ([Char], InitError) r
result of
    Right r
r -> r -> IO r
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r
    Left ([Char]
dir, InitError
err) ->
      let message :: IO (Pretty ColorText)
message = do
            Pretty ColorText
pDir <- [Char] -> IO (Pretty ColorText)
forall {s}. IsString s => [Char] -> IO (Pretty s)
prettyDir [Char]
dir
            Pretty ColorText
executableName <- Text -> Pretty ColorText
forall s. IsString s => Text -> Pretty s
P.text (Text -> Pretty ColorText)
-> ([Char] -> Text) -> [Char] -> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
Text.pack ([Char] -> Pretty ColorText) -> IO [Char] -> IO (Pretty ColorText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Char]
getProgName

            case InitError
err of
              InitErrorOpen OpenCodebaseError
err ->
                case OpenCodebaseError
err of
                  OpenCodebaseError
OpenCodebaseFileLockFailed ->
                    Pretty ColorText -> IO (Pretty ColorText)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                      ( [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
                          [ Pretty ColorText
"Failed to obtain a file lock on the codebase. ",
                            Pretty ColorText
"Perhaps you are running multiple ucm processes against the same codebase."
                          ]
                      )
                  OpenCodebaseError
OpenCodebaseDoesntExist ->
                    Pretty ColorText -> IO (Pretty ColorText)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                      ( [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
                          [ Pretty ColorText
"No codebase exists in " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
pDir Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
".",
                            Pretty ColorText
"Run `" Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
executableName Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
" --codebase-create " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> [Char] -> Pretty ColorText
forall s. IsString s => [Char] -> Pretty s
P.string [Char]
dir Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
" to create one, then try again!"
                          ]
                      )
                  (OpenCodebaseUnknownSchemaVersion SchemaVersion
_) ->
                    Pretty ColorText -> IO (Pretty ColorText)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                      ( [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
                          [ Pretty ColorText
"I can't read the codebase in " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
pDir Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
" because it was constructed using a newer version of unison.",
                            Pretty ColorText
"Please upgrade your version of UCM."
                          ]
                      )
                  (OpenCodebaseRequiresMigration SchemaVersion
_ SchemaVersion
_) ->
                    Pretty ColorText -> IO (Pretty ColorText)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                      ( [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
                          [ Pretty ColorText
"The codebase is from an older version of UCM, it needs to be migrated before it can be used.",
                            Pretty ColorText
"You can migrate it by opening it in UCM, e.g. ucm -c mycodebase"
                          ]
                      )
              InitError
FoundV1Codebase ->
                Pretty ColorText -> IO (Pretty ColorText)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                  ( [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
                      [ Pretty ColorText
"Found a v1 codebase at " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
pDir Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
".",
                        Pretty ColorText
"v1 codebases are no longer supported in this version of the UCM.",
                        Pretty ColorText
"Please download version M2g of the UCM to upgrade."
                      ]
                  )
              CouldntCreateCodebase Pretty ColorText
errMessage ->
                Pretty ColorText -> IO (Pretty ColorText)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pretty ColorText
errMessage
       in do
            Pretty ColorText
msg <- IO (Pretty ColorText)
message
            Pretty ColorText -> IO ()
PT.putPrettyLn' Pretty ColorText
msg
            IO r
forall a. IO a
Exit.exitFailure
  where
    prettyDir :: [Char] -> IO (Pretty s)
prettyDir [Char]
dir = [Char] -> Pretty s
forall s. IsString s => [Char] -> Pretty s
P.string ([Char] -> Pretty s) -> IO [Char] -> IO (Pretty s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [Char]
canonicalizePath [Char]
dir

exitError :: P.Pretty P.ColorText -> IO a
exitError :: forall a. Pretty ColorText -> IO a
exitError Pretty ColorText
msg = do
  Pretty ColorText -> IO ()
PT.putPrettyLn (Pretty ColorText -> IO ()) -> Pretty ColorText -> IO ()
forall a b. (a -> b) -> a -> b
$ Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
P.callout Pretty ColorText
"⚠️" Pretty ColorText
msg
  IO a
forall a. IO a
Exit.exitFailure

argsToCodebaseInitOptions :: Maybe CodebasePathOption -> IO CodebaseInit.CodebaseInitOptions
argsToCodebaseInitOptions :: Maybe CodebasePathOption -> IO CodebaseInitOptions
argsToCodebaseInitOptions Maybe CodebasePathOption
pathOption =
  case Maybe CodebasePathOption
pathOption of
    Just (CreateCodebaseWhenMissing [Char]
path) -> CodebaseInitOptions -> IO CodebaseInitOptions
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CodebaseInitOptions -> IO CodebaseInitOptions)
-> CodebaseInitOptions -> IO CodebaseInitOptions
forall a b. (a -> b) -> a -> b
$ SpecifiedCodebase -> CodebaseInitOptions
Specified ([Char] -> SpecifiedCodebase
CreateWhenMissing [Char]
path)
    Just (DontCreateCodebaseWhenMissing [Char]
path) -> CodebaseInitOptions -> IO CodebaseInitOptions
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CodebaseInitOptions -> IO CodebaseInitOptions)
-> CodebaseInitOptions -> IO CodebaseInitOptions
forall a b. (a -> b) -> a -> b
$ SpecifiedCodebase -> CodebaseInitOptions
Specified ([Char] -> SpecifiedCodebase
DontCreateWhenMissing [Char]
path)
    Maybe CodebasePathOption
Nothing -> do [Char] -> CodebaseInitOptions
Home ([Char] -> CodebaseInitOptions)
-> IO [Char] -> IO CodebaseInitOptions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Char]
forall (m :: * -> *). MonadIO m => m [Char]
getHomeDirectory

codebasePathOptionToPath :: CodebasePathOption -> FilePath
codebasePathOptionToPath :: CodebasePathOption -> [Char]
codebasePathOptionToPath CodebasePathOption
codebasePathOption =
  case CodebasePathOption
codebasePathOption of
    CreateCodebaseWhenMissing [Char]
p -> [Char]
p
    DontCreateCodebaseWhenMissing [Char]
p -> [Char]
p

-- | With the JIT turned on (--jit or UNISON_JIT), loads LLVM now and says
-- how it went, in the two-space margin the rest of ucm's output has. When
-- it can't be loaded the program runs interpreted, as it would with the
-- JIT off. With the JIT off nothing is printed.
announceJIT :: JIT.JIT -> IO ()
announceJIT :: JIT -> IO ()
announceJIT JIT
jit = case Config -> Mode
JITConfig.mode (JIT -> Config
JIT.jitConfig JIT
jit) of
  Mode
JITConfig.Off -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Mode
_ -> do
    Bool
tty <- Handle -> IO Bool
hIsTerminalDevice Handle
stdout
    -- a progress line while LLVM loads, erased once the outcome is known
    let loading :: [Char]
loading = [Char]
"  JIT compilation requested, loading LLVM library..."
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tty (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStr [Char]
loading IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
    Maybe (Either [[Char]] [Char])
r <- JIT -> IO (Maybe (Either [[Char]] [Char]))
JIT.loadJIT JIT
jit
    -- back to the start of the line, and clear it
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tty (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStr ([Char]
"\r" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
loading) Char
' ' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\r")
    case Maybe (Either [[Char]] [Char])
r of
      Maybe (Either [[Char]] [Char])
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just (Right [Char]
_) -> [Char] -> IO ()
putStrLn [Char]
"  JIT compilation activated \x26a1\x1f680" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
      Just (Left [[Char]]
msgs) -> ([Char] -> IO ()) -> [[Char]] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Char] -> IO ()
putStrLn ([Char] -> IO ()) -> ([Char] -> [Char]) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)) [[Char]]
msgs IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout