{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}

module Unison.Main
  ( main,
  )
where

import ArgParse
  ( CodebasePathOption (..),
    Command (Init, Launch, PrintVersion, Run, Transcript),
    GlobalOptions (..),
    IsHeadless (Headless, WithCLI),
    RunSource (..),
    ShouldExit (DoNotExit, Exit),
    ShouldForkCodebase (..),
    ShouldSaveCodebase (..),
    UsageRenderer,
    parseCLIArgs,
  )
import Compat (defaultInterruptHandler, withInterruptHandler)
import Control.Concurrent (newEmptyMVar, runInUnboundThread, takeMVar)
import Control.Exception (displayException, evaluate)
import Data.ByteString.Lazy qualified as BL
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 Stats (recordRtsStats)
import System.Directory
  ( canonicalizePath,
    exeExtension,
    getCurrentDirectory,
    removeDirectoryRecursive,
  )
import System.Environment (getExecutablePath, getProgName, withArgs)
import System.Exit qualified as Exit
import System.Exit qualified as System
import System.FilePath
  ( replaceExtension,
    takeDirectory,
    takeExtension,
    (<.>),
    (</>),
  )
import System.IO (stderr)
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.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.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 qualified as Rt
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.Types qualified as CommandLine
import Unison.CommandLine.Welcome (CodebaseInitStatus (..))
import Unison.CommandLine.Welcome qualified as Welcome
import Unison.Core.Project (ProjectAndBranch (..), ProjectBranchName (..), ProjectName (..))
import Unison.LSP qualified as LSP
import Unison.LSP.Util.Signal qualified as Signal
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import Unison.PrettyTerminal qualified as PT
import Unison.Runtime.Exception (RuntimeExn (..))
import Unison.Runtime.Interface qualified as RTI
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.Directory (getHomeDirectory)

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

fixNativeRuntimePath :: Maybe FilePath -> IO FilePath
fixNativeRuntimePath :: Maybe String -> IO String
fixNativeRuntimePath Maybe String
override = do
  String
ucm <- IO String
getExecutablePath
  let ucr :: String
ucr = String -> String
takeDirectory String
ucm String -> String -> String
</> String
"runtime" String -> String -> String
</> String
"unison-runtime" String -> String -> String
<.> String
exeExtension
  String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
ucr String -> String
forall a. a -> a
id Maybe String
override

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.
  (SomeException -> IO ()) -> IO ()
setUncaughtExceptionHandler \SomeException
exception -> do
    let shown :: Text
shown = SomeException -> Text
forall a. Show a => a -> Text
tShow SomeException
exception
    let displayed :: Text
displayed = String -> Text
Text.pack (SomeException -> String
forall e. Exception e => e -> String
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 []
      ]

  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)
      String
progName <- IO String
getProgName
      -- hSetBuffering stdout NoBuffering -- cool
      (Maybe String -> String
renderUsageInfo, GlobalOptions
globalOptions, Command
command) <- String
-> String -> IO (Maybe String -> String, GlobalOptions, Command)
parseCLIArgs String
progName (Text -> String
Text.unpack (Version -> Text
Version.gitDescribeWithDate Version
version))
      String
nrtp <- Maybe String -> IO String
fixNativeRuntimePath (GlobalOptions -> Maybe String
nativeRuntimePath GlobalOptions
globalOptions)
      let GlobalOptions {$sel:codebasePathOption:GlobalOptions :: GlobalOptions -> Maybe CodebasePathOption
codebasePathOption = Maybe CodebasePathOption
mCodePathOption, ShouldExit
exitOption :: ShouldExit
$sel:exitOption:GlobalOptions :: GlobalOptions -> ShouldExit
exitOption, LspFormattingConfig
lspFormattingConfig :: LspFormattingConfig
$sel:lspFormattingConfig:GlobalOptions :: GlobalOptions -> LspFormattingConfig
lspFormattingConfig} = GlobalOptions
globalOptions
      String
currentDir <- IO String
getCurrentDirectory
      case Command
command of
        Command
PrintVersion ->
          Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
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
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) [String]
args -> do
          Maybe CodebasePathOption
-> MigrationStrategy
-> ((InitResult, String, Codebase IO Symbol Ann) -> IO ())
-> IO ()
forall r.
Maybe CodebasePathOption
-> MigrationStrategy
-> ((InitResult, String, Codebase IO Symbol Ann) -> IO r)
-> IO r
getCodebaseOrExit Maybe CodebasePathOption
mCodePathOption (BackupStrategy -> VacuumStrategy -> MigrationStrategy
SC.MigrateAutomatically BackupStrategy
SC.Backup VacuumStrategy
SC.Vacuum) \(InitResult
_, String
_, Codebase IO Symbol Ann
theCodebase) -> do
            Bool -> RuntimeHost -> Text -> (Runtime Symbol -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
Bool -> RuntimeHost -> Text -> (Runtime Symbol -> m a) -> m a
RTI.withRuntime Bool
False RuntimeHost
RTI.OneOff (Version -> Text
Version.gitDescribeWithDate Version
version) \Runtime Symbol
runtime -> do
              [String]
-> IO (Either (Pretty ColorText) ())
-> IO (Either (Pretty ColorText) ())
forall a. [String] -> IO a -> IO a
withArgs [String]
args (Codebase IO Symbol Ann
-> Runtime Symbol
-> ProjectPathNames
-> IO (Either (Pretty ColorText) ())
execute Codebase IO Symbol Ann
theCodebase Runtime Symbol
runtime ProjectPathNames
mainName) IO (Either (Pretty ColorText) ())
-> (Either (Pretty ColorText) () -> 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 Pretty ColorText
err -> Pretty ColorText -> IO ()
forall a. Pretty ColorText -> IO a
exitError Pretty ColorText
err
                Right () -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Run (RunFromFile String
file HashQualified Name
mainName) [String]
args
          | Bool -> Bool
not (String -> Bool
isDotU String
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 <- String -> IO (Either IOException Text)
safeReadUtf8 String
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
-> MigrationStrategy
-> ((InitResult, String, Codebase IO Symbol Ann) -> IO ())
-> IO ()
forall r.
Maybe CodebasePathOption
-> MigrationStrategy
-> ((InitResult, String, Codebase IO Symbol Ann) -> IO r)
-> IO r
getCodebaseOrExit Maybe CodebasePathOption
mCodePathOption (BackupStrategy -> VacuumStrategy -> MigrationStrategy
SC.MigrateAutomatically BackupStrategy
SC.Backup VacuumStrategy
SC.Vacuum) \(InitResult
initRes, String
_, Codebase IO Symbol Ann
theCodebase) -> do
                    String -> RuntimeHost -> (Runtimes -> IO ()) -> IO ()
forall a. String -> RuntimeHost -> (Runtimes -> IO a) -> IO a
withRuntimes String
nrtp RuntimeHost
RTI.OneOff \(Runtime Symbol
rt, Runtime Symbol
sbrt, Runtime Symbol
nrt) -> do
                      let fileEvent :: Event
fileEvent = Text -> Text -> Event
Input.UnisonFileChanged (String -> Text
Text.pack String
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
                      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
-> String
-> Runtime Symbol
-> Runtime Symbol
-> Runtime Symbol
-> Codebase IO Symbol Ann
-> [Either Event Input]
-> Maybe BaseUrl
-> ProjectPathIds
-> InitResult
-> (ProjectPathIds -> IO ())
-> ShouldWatchFiles
-> IO ()
launch
                        Version
version
                        String
currentDir
                        Runtime Symbol
rt
                        Runtime Symbol
sbrt
                        Runtime Symbol
nrt
                        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
$ HashQualified Name -> [String] -> Input
Input.ExecuteI HashQualified Name
mainName [String]
args, Input -> Either Event Input
forall a b. b -> Either a b
Right Input
Input.QuitI]
                        Maybe BaseUrl
forall a. Maybe a
serverUrl
                        (ProjectPath -> ProjectPathIds
PP.toIds ProjectPath
startProjectPath)
                        InitResult
initRes
                        ProjectPathIds -> IO ()
forall {f :: * -> *} {p}. Applicative f => p -> f ()
noOpCheckForChanges
                        ShouldWatchFiles
CommandLine.ShouldNotWatchFiles
        Run (RunFromPipe HashQualified Name
mainName) [String]
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
-> MigrationStrategy
-> ((InitResult, String, Codebase IO Symbol Ann) -> IO ())
-> IO ()
forall r.
Maybe CodebasePathOption
-> MigrationStrategy
-> ((InitResult, String, Codebase IO Symbol Ann) -> IO r)
-> IO r
getCodebaseOrExit Maybe CodebasePathOption
mCodePathOption (BackupStrategy -> VacuumStrategy -> MigrationStrategy
SC.MigrateAutomatically BackupStrategy
SC.Backup VacuumStrategy
SC.Vacuum) \(InitResult
initRes, String
_, Codebase IO Symbol Ann
theCodebase) -> do
                String -> RuntimeHost -> (Runtimes -> IO ()) -> IO ()
forall a. String -> RuntimeHost -> (Runtimes -> IO a) -> IO a
withRuntimes String
nrtp RuntimeHost
RTI.OneOff \(Runtime Symbol
rt, Runtime Symbol
sbrt, Runtime Symbol
nrt) -> do
                  let fileEvent :: Event
fileEvent = Text -> Text -> Event
Input.UnisonFileChanged (String -> Text
Text.pack String
"<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
                  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
-> String
-> Runtime Symbol
-> Runtime Symbol
-> Runtime Symbol
-> Codebase IO Symbol Ann
-> [Either Event Input]
-> Maybe BaseUrl
-> ProjectPathIds
-> InitResult
-> (ProjectPathIds -> IO ())
-> ShouldWatchFiles
-> IO ()
launch
                    Version
version
                    String
currentDir
                    Runtime Symbol
rt
                    Runtime Symbol
sbrt
                    Runtime Symbol
nrt
                    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
$ HashQualified Name -> [String] -> Input
Input.ExecuteI HashQualified Name
mainName [String]
args, Input -> Either Event Input
forall a b. b -> Either a b
Right Input
Input.QuitI]
                    Maybe BaseUrl
forall a. Maybe a
serverUrl
                    (ProjectPath -> ProjectPathIds
PP.toIds ProjectPath
startProjectPath)
                    InitResult
initRes
                    ProjectPathIds -> IO ()
forall {f :: * -> *} {p}. Applicative f => p -> f ()
noOpCheckForChanges
                    ShouldWatchFiles
CommandLine.ShouldNotWatchFiles
        Run (RunCompiled String
file) [String]
args ->
          String -> IO ByteString
BL.readFile String
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 String (Text, Text, CombIx, StoredCache))
-> IO
     (Either
        RuntimeExn (Either String (Text, Text, CombIx, StoredCache)))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (Either String (Text, Text, CombIx, StoredCache)
-> IO (Either String (Text, Text, CombIx, StoredCache))
forall a. a -> IO a
evaluate (Either String (Text, Text, CombIx, StoredCache)
 -> IO (Either String (Text, Text, CombIx, StoredCache)))
-> Either String (Text, Text, CombIx, StoredCache)
-> IO (Either String (Text, Text, CombIx, StoredCache))
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String (Text, Text, CombIx, StoredCache)
RTI.decodeStandalone ByteString
bs) IO
  (Either
     RuntimeExn (Either String (Text, Text, CombIx, StoredCache)))
-> (Either
      RuntimeExn (Either String (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 (PE CallStack
_cs Pretty ColorText
err) -> do
                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
forall a b. (a -> b) -> a -> b
$ Pretty ColorText
err
                  ]
              Right (Left String
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
$ String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string String
err
                  ]
              Left RuntimeExn
_ -> do
                Pretty ColorText -> IO ()
forall a. Pretty ColorText -> IO a
exitError (Pretty ColorText -> IO ())
-> (Text -> Pretty ColorText) -> Text -> 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 -> 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 -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
                  Text
"I was unable to parse this file as a compiled\
                  \ program. The parser generated an unrecognized error."
              Right (Right (Text
v, Text
rf, CombIx
combIx, StoredCache
sto))
                | Bool -> Bool
not Bool
vmatch -> IO ()
mismatchMsg
                | Bool
otherwise ->
                    [String]
-> IO (Either (Pretty ColorText) ())
-> IO (Either (Pretty ColorText) ())
forall a. [String] -> IO a -> IO a
withArgs [String]
args (Bool -> StoredCache -> CombIx -> IO (Either (Pretty ColorText) ())
RTI.runStandalone Bool
False StoredCache
sto CombIx
combIx) IO (Either (Pretty ColorText) ())
-> (Either (Pretty ColorText) () -> 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 Pretty ColorText
err -> Pretty ColorText -> IO ()
forall a. Pretty ColorText -> IO a
exitError Pretty ColorText
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 :: String
ifile
                    | Char
'c' : Char
'u' : Char
'.' : String
rest <- String -> String
forall a. [a] -> [a]
reverse String
file = String -> String
forall a. [a] -> [a]
reverse String
rest
                    | Bool
otherwise = String
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
<> String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string String
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 ShouldForkCodebase
shouldFork ShouldSaveCodebase
shouldSaveCodebase Maybe RtsStatsPath
mrtsStatsFp NonEmpty String
transcriptFiles -> do
          let action :: IO ()
action = Version
-> Verbosity
-> (Maybe String -> String)
-> ShouldForkCodebase
-> ShouldSaveCodebase
-> Maybe CodebasePathOption
-> String
-> NonEmpty String
-> IO ()
runTranscripts Version
version Verbosity
Verbosity.Verbose Maybe String -> String
renderUsageInfo ShouldForkCodebase
shouldFork ShouldSaveCodebase
shouldSaveCodebase Maybe CodebasePathOption
mCodePathOption String
nrtp NonEmpty String
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
          Maybe CodebasePathOption
-> MigrationStrategy
-> ((InitResult, String, Codebase IO Symbol Ann) -> IO ())
-> IO ()
forall r.
Maybe CodebasePathOption
-> MigrationStrategy
-> ((InitResult, String, Codebase IO Symbol Ann) -> IO r)
-> IO r
getCodebaseOrExit Maybe CodebasePathOption
mCodePathOption (BackupStrategy -> VacuumStrategy -> MigrationStrategy
SC.MigrateAfterPrompt BackupStrategy
SC.Backup VacuumStrategy
SC.Vacuum) \(InitResult
initRes, String
_, Codebase IO Symbol Ann
theCodebase) -> do
            String -> RuntimeHost -> (Runtimes -> IO ()) -> IO ()
forall a. String -> RuntimeHost -> (Runtimes -> IO a) -> IO a
withRuntimes String
nrtp RuntimeHost
RTI.Persistent \(Runtime Symbol
runtime, Runtime Symbol
sbRuntime, Runtime Symbol
nRuntime) -> 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.absoluteEmpty
                  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 ProjectPathIds
pp = Signal ProjectPathIds -> ProjectPathIds -> IO ()
forall (m :: * -> *) a. MonadIO m => Signal a -> a -> m ()
Signal.writeSignalIO Signal ProjectPathIds
changeSignal ProjectPathIds
pp
              -- 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
              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
-> IO ()
LSP.spawnLsp LspFormattingConfig
lspFormattingConfig Codebase IO Symbol Ann
theCodebase Runtime Symbol
runtime Signal ProjectPathIds
changeSignal
              BackendEnv
-> CodebaseServerOpts
-> Runtime Symbol
-> Codebase IO Symbol Ann
-> (BaseUrl -> IO ())
-> IO ()
forall a.
BackendEnv
-> CodebaseServerOpts
-> Runtime Symbol
-> Codebase IO Symbol Ann
-> (BaseUrl -> IO a)
-> IO a
Server.startServer (Backend.BackendEnv {$sel:useNamesIndex:BackendEnv :: Bool
Backend.useNamesIndex = Bool
False}) CodebaseServerOpts
codebaseServerOpts Runtime Symbol
sbRuntime Codebase IO Symbol Ann
theCodebase ((BaseUrl -> IO ()) -> IO ()) -> (BaseUrl -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \BaseUrl
baseUrl -> do
                case ShouldExit
exitOption of
                  ShouldExit
DoNotExit -> do
                    case IsHeadless
isHeadless of
                      IsHeadless
Headless -> 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") (Text -> ProjectBranchName
UnsafeProjectBranchName Text
"main")) Absolute
Path.absoluteEmpty 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
$
                          String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string String
"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
$ String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string String
"Now starting the Unison Codebase Manager (UCM)..."

                        Version
-> String
-> Runtime Symbol
-> Runtime Symbol
-> Runtime Symbol
-> Codebase IO Symbol Ann
-> [Either Event Input]
-> Maybe BaseUrl
-> ProjectPathIds
-> InitResult
-> (ProjectPathIds -> IO ())
-> ShouldWatchFiles
-> IO ()
launch
                          Version
version
                          String
currentDir
                          Runtime Symbol
runtime
                          Runtime Symbol
sbRuntime
                          Runtime Symbol
nRuntime
                          Codebase IO Symbol Ann
theCodebase
                          []
                          (BaseUrl -> Maybe BaseUrl
forall a. a -> Maybe a
Just BaseUrl
baseUrl)
                          (ProjectPath -> ProjectPathIds
PP.toIds ProjectPath
startingProjectPath)
                          InitResult
initRes
                          ProjectPathIds -> IO ()
lspCheckForChanges
                          ShouldWatchFiles
shouldWatchFiles
                  ShouldExit
Exit -> do IO ()
forall a. IO a
Exit.exitSuccess
  where
    -- (runtime, sandboxed runtime)
    withRuntimes :: FilePath -> RTI.RuntimeHost -> (Runtimes -> IO a) -> IO a
    withRuntimes :: forall a. String -> RuntimeHost -> (Runtimes -> IO a) -> IO a
withRuntimes String
nrtp RuntimeHost
mode Runtimes -> IO a
action =
      Bool -> RuntimeHost -> Text -> (Runtime Symbol -> IO a) -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Bool -> RuntimeHost -> Text -> (Runtime Symbol -> m a) -> m a
RTI.withRuntime Bool
False RuntimeHost
mode (Version -> Text
Version.gitDescribeWithDate Version
version) \Runtime Symbol
runtime -> do
        Bool -> RuntimeHost -> Text -> (Runtime Symbol -> IO a) -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Bool -> RuntimeHost -> Text -> (Runtime Symbol -> m a) -> m a
RTI.withRuntime Bool
True RuntimeHost
mode (Version -> Text
Version.gitDescribeWithDate Version
version) \Runtime Symbol
sbRuntime ->
          Runtimes -> IO a
action (Runtimes -> IO a)
-> (Runtime Symbol -> Runtimes) -> Runtime Symbol -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Runtime Symbol
runtime,Runtime Symbol
sbRuntime,)
            -- startNativeRuntime saves the path to `unison-runtime`
            (Runtime Symbol -> IO a) -> IO (Runtime Symbol) -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> String -> IO (Runtime Symbol)
RTI.startNativeRuntime (Version -> Text
Version.gitDescribeWithDate Version
version) String
nrtp

-- | 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

prepareTranscriptDir :: Verbosity.Verbosity -> ShouldForkCodebase -> Maybe CodebasePathOption -> ShouldSaveCodebase -> IO FilePath
prepareTranscriptDir :: Verbosity
-> ShouldForkCodebase
-> Maybe CodebasePathOption
-> ShouldSaveCodebase
-> IO String
prepareTranscriptDir Verbosity
verbosity ShouldForkCodebase
shouldFork Maybe CodebasePathOption
mCodePathOption ShouldSaveCodebase
shouldSaveCodebase = do
  String
tmp <- case ShouldSaveCodebase
shouldSaveCodebase of
    SaveCodebase (Just String
path) -> String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
path
    ShouldSaveCodebase
_ -> IO String
Temp.getCanonicalTemporaryDirectory IO String -> (String -> IO String) -> IO String
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> String -> IO String
`Temp.createTempDirectory` String
"transcript")
  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
-> MigrationStrategy
-> ((InitResult, String, Codebase IO Symbol Ann) -> IO ())
-> IO ()
forall r.
Maybe CodebasePathOption
-> MigrationStrategy
-> ((InitResult, String, Codebase IO Symbol Ann) -> IO r)
-> IO r
getCodebaseOrExit Maybe CodebasePathOption
mCodePathOption (BackupStrategy -> VacuumStrategy -> MigrationStrategy
SC.MigrateAutomatically BackupStrategy
SC.Backup VacuumStrategy
SC.Vacuum) (((InitResult, String, Codebase IO Symbol Ann) -> IO ()) -> IO ())
-> ((InitResult, String, Codebase IO Symbol Ann) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> (InitResult, String, 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 ())
      String
path <- Maybe String -> IO String
forall (m :: * -> *). MonadIO m => Maybe String -> m String
Codebase.getCodebaseDir ((CodebasePathOption -> String)
-> Maybe CodebasePathOption -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CodebasePathOption -> String
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 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 (String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string String
path)
          ]
      String -> String -> IO ()
Path.copyDir (Init IO Symbol Ann -> String -> String
forall (m :: * -> *) v a. Init m v a -> String -> String
CodebaseInit.codebasePath Init IO Symbol Ann
cbInit String
path) (Init IO Symbol Ann -> String -> String
forall (m :: * -> *) v a. Init m v a -> String -> String
CodebaseInit.codebasePath Init IO Symbol Ann
cbInit String
tmp)
    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."
      Init IO Symbol Ann
-> Verbosity
-> String
-> String
-> CodebaseLockOption
-> (Codebase IO Symbol Ann -> IO ())
-> IO ()
forall (m :: * -> *) r.
MonadIO m =>
Init m Symbol Ann
-> Verbosity
-> String
-> String
-> CodebaseLockOption
-> (Codebase m Symbol Ann -> m r)
-> m r
CodebaseInit.withNewUcmCodebaseOrExit Init IO Symbol Ann
cbInit Verbosity
verbosity String
"main.transcript" String
tmp CodebaseLockOption
SC.DoLock (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 String
tmp

runTranscripts' ::
  Version ->
  String ->
  FilePath ->
  FilePath ->
  NonEmpty MarkdownFile ->
  IO Bool
runTranscripts' :: Version
-> String -> String -> String -> NonEmpty MarkdownFile -> IO Bool
runTranscripts' Version
version String
progName String
nativeRtp String
transcriptDir NonEmpty MarkdownFile
markdownFiles = do
  String
currentDir <- IO String
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
-> MigrationStrategy
-> ((InitResult, String, Codebase IO Symbol Ann)
    -> IO (NonEmpty Bool))
-> IO (NonEmpty Bool)
forall r.
Maybe CodebasePathOption
-> MigrationStrategy
-> ((InitResult, String, Codebase IO Symbol Ann) -> IO r)
-> IO r
getCodebaseOrExit
      (CodebasePathOption -> Maybe CodebasePathOption
forall a. a -> Maybe a
Just (String -> CodebasePathOption
DontCreateCodebaseWhenMissing String
transcriptDir))
      (BackupStrategy -> VacuumStrategy -> MigrationStrategy
SC.MigrateAutomatically BackupStrategy
SC.Backup VacuumStrategy
SC.Vacuum)
      \(InitResult
_, String
codebasePath, Codebase IO Symbol Ann
theCodebase) -> do
        let isTest :: Bool
isTest = Bool
False
        Bool
-> Verbosity
-> Text
-> String
-> (Runner -> IO (NonEmpty Bool))
-> IO (NonEmpty Bool)
forall (m :: * -> *) r.
MonadUnliftIO m =>
Bool -> Verbosity -> Text -> String -> (Runner -> m r) -> m r
Transcript.withRunner
          Bool
isTest
          Verbosity
Verbosity.Verbose
          (Version -> Text
Version.gitDescribeWithDate Version
version)
          String
nativeRtp
          \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 String
fileName) -> do
              Text
transcriptSrc <- String -> IO Text
readUtf8 String
fileName
              Either Error (Seq Stanza)
result <- Runner
runTranscript String
fileName Text
transcriptSrc (String
codebasePath, Codebase IO Symbol Ann
theCodebase)
              let outputFile :: String
outputFile = String -> String -> String
replaceExtension (String
currentDir String -> String -> String
</> String
fileName) String
".output.md"
              Text
output <-
                (Error -> IO Text)
-> (Seq Stanza -> IO Text) -> Either Error (Seq Stanza) -> 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
                      Transcript.ParseError ParseErrorBundle Text Void
err ->
                        let msg :: String
msg = ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
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
<> String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string String
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
$ String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string String
msg
                              ],
                              String -> Text
Text.pack String
msg
                            )
                      Transcript.RunFailure Seq Stanza
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
<> String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string String
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)
-> ([Stanza] -> Text) -> [Stanza] -> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Stanza] -> Text
Transcript.formatStanzas ([Stanza] -> Pretty ColorText) -> [Stanza] -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ Seq Stanza -> [Stanza]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Stanza
msg),
                            String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string (String -> Pretty ColorText) -> String -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$
                              String
"Run `"
                                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
progName
                                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" --codebase "
                                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
codebasePath
                                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"` "
                                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"to do more work with it."
                          ],
                          [Stanza] -> Text
Transcript.formatStanzas ([Stanza] -> Text) -> [Stanza] -> Text
forall a b. (a -> b) -> a -> b
$ Seq Stanza -> [Stanza]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Stanza
msg
                        )
                  )
                  (Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> (Seq Stanza -> Text) -> Seq Stanza -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Stanza] -> Text
Transcript.formatStanzas ([Stanza] -> Text)
-> (Seq Stanza -> [Stanza]) -> Seq Stanza -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq Stanza -> [Stanza]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList)
                  Either Error (Seq Stanza)
result
              String -> Text -> IO ()
writeUtf8 String
outputFile Text
output
              String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"💾  Wrote " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
outputFile
              pure $ Either Error (Seq Stanza) -> Bool
forall a b. Either a b -> Bool
isRight Either Error (Seq Stanza)
result

runTranscripts ::
  Version ->
  Verbosity.Verbosity ->
  UsageRenderer ->
  ShouldForkCodebase ->
  ShouldSaveCodebase ->
  Maybe CodebasePathOption ->
  FilePath ->
  NonEmpty String ->
  IO ()
runTranscripts :: Version
-> Verbosity
-> (Maybe String -> String)
-> ShouldForkCodebase
-> ShouldSaveCodebase
-> Maybe CodebasePathOption
-> String
-> NonEmpty String
-> IO ()
runTranscripts Version
version Verbosity
verbosity Maybe String -> String
renderUsageInfo ShouldForkCodebase
shouldFork ShouldSaveCodebase
shouldSaveTempCodebase Maybe CodebasePathOption
mCodePathOption String
nativeRtp NonEmpty String
args = do
  NonEmpty MarkdownFile
markdownFiles <- case (String -> Validation [String] MarkdownFile)
-> NonEmpty String -> Validation [String] (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 ((String -> [String])
-> Validation String MarkdownFile
-> Validation [String] 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 String MarkdownFile
 -> Validation [String] MarkdownFile)
-> (String -> Validation String MarkdownFile)
-> String
-> Validation [String] MarkdownFile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Validation String MarkdownFile
markdownFile) NonEmpty String
args of
    Failure [String]
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
$ (String -> Pretty ColorText) -> [String] -> [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)
-> (String -> Pretty ColorText) -> String -> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string (String -> Pretty ColorText)
-> (String -> String) -> String -> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n")) [String]
invalidArgs
              ]
          )
      String -> IO ()
putStrLn (Maybe String -> String
renderUsageInfo (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
"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
  String
progName <- IO String
getProgName
  String
transcriptDir <- Verbosity
-> ShouldForkCodebase
-> Maybe CodebasePathOption
-> ShouldSaveCodebase
-> IO String
prepareTranscriptDir Verbosity
verbosity ShouldForkCodebase
shouldFork Maybe CodebasePathOption
mCodePathOption ShouldSaveCodebase
shouldSaveTempCodebase
  Bool
completed <-
    Version
-> String -> String -> String -> NonEmpty MarkdownFile -> IO Bool
runTranscripts' Version
version String
progName String
nativeRtp String
transcriptDir NonEmpty MarkdownFile
markdownFiles
  case ShouldSaveCodebase
shouldSaveTempCodebase of
    ShouldSaveCodebase
DontSaveCodebase -> String -> IO ()
removeDirectoryRecursive String
transcriptDir
    SaveCodebase Maybe String
_ ->
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
completed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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 (String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string String
transcriptDir),
                  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 (String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string String
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
<> String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string String
transcriptDir)
                      Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
"to do more work with it."
                ]
            )
  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 ->
  Rt.Runtime Symbol ->
  Rt.Runtime Symbol ->
  Rt.Runtime Symbol ->
  Codebase.Codebase IO Symbol Ann ->
  [Either Input.Event Input.Input] ->
  Maybe Server.BaseUrl ->
  PP.ProjectPathIds ->
  InitResult ->
  (PP.ProjectPathIds -> IO ()) ->
  CommandLine.ShouldWatchFiles ->
  IO ()
launch :: Version
-> String
-> Runtime Symbol
-> Runtime Symbol
-> Runtime Symbol
-> Codebase IO Symbol Ann
-> [Either Event Input]
-> Maybe BaseUrl
-> ProjectPathIds
-> InitResult
-> (ProjectPathIds -> IO ())
-> ShouldWatchFiles
-> IO ()
launch Version
version String
dir Runtime Symbol
runtime Runtime Symbol
sbRuntime Runtime Symbol
nRuntime Codebase IO Symbol Ann
codebase [Either Event Input]
inputs 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 String
-> Welcome
-> ProjectPathIds
-> [Either Event Input]
-> Runtime Symbol
-> Runtime Symbol
-> Runtime Symbol
-> Codebase IO Symbol Ann
-> Maybe BaseUrl
-> Text
-> (ProjectPathIds -> IO ())
-> ShouldWatchFiles
-> IO ()
CommandLine.main
        String
dir
        Welcome
welcome
        ProjectPathIds
startingPath
        [Either Event Input]
inputs
        Runtime Symbol
runtime
        Runtime Symbol
sbRuntime
        Runtime Symbol
nRuntime
        Codebase IO Symbol Ann
codebase
        Maybe BaseUrl
serverBaseUrl
        Text
ucmVersion
        ProjectPathIds -> IO ()
lspCheckForChanges
        ShouldWatchFiles
shouldWatchFiles

newtype MarkdownFile = MarkdownFile FilePath

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

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

getCodebaseOrExit :: Maybe CodebasePathOption -> SC.MigrationStrategy -> ((InitResult, CodebasePath, Codebase IO Symbol Ann) -> IO r) -> IO r
getCodebaseOrExit :: forall r.
Maybe CodebasePathOption
-> MigrationStrategy
-> ((InitResult, String, Codebase IO Symbol Ann) -> IO r)
-> IO r
getCodebaseOrExit Maybe CodebasePathOption
codebasePathOption MigrationStrategy
migrationStrategy (InitResult, String, 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 (String, InitError) r
result <- Init IO Symbol Ann
-> String
-> CodebaseInitOptions
-> CodebaseLockOption
-> MigrationStrategy
-> ((InitResult, String, Codebase IO Symbol Ann) -> IO r)
-> IO (Either (String, InitError) r)
forall (m :: * -> *) v a r.
MonadIO m =>
Init m v a
-> String
-> CodebaseInitOptions
-> CodebaseLockOption
-> MigrationStrategy
-> ((InitResult, String, Codebase m v a) -> m r)
-> m (Either (String, InitError) r)
CodebaseInit.withOpenOrCreateCodebase Init IO Symbol Ann
cbInit String
"main" CodebaseInitOptions
initOptions CodebaseLockOption
SC.DoLock MigrationStrategy
migrationStrategy \case
    cbInit :: (InitResult, String, Codebase IO Symbol Ann)
cbInit@(InitResult
CreatedCodebase, String
dir, Codebase IO Symbol Ann
_) -> do
      Pretty ColorText
pDir <- String -> IO (Pretty ColorText)
forall {s}. IsString s => String -> IO (Pretty s)
prettyDir String
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, String, Codebase IO Symbol Ann) -> IO r
action (InitResult, String, Codebase IO Symbol Ann)
cbInit
    cbInit :: (InitResult, String, Codebase IO Symbol Ann)
cbInit@(InitResult
OpenedCodebase, String
_, Codebase IO Symbol Ann
_) ->
      (InitResult, String, Codebase IO Symbol Ann) -> IO r
action (InitResult, String, Codebase IO Symbol Ann)
cbInit

  case Either (String, 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 (String
dir, InitError
err) ->
      let message :: IO (Pretty ColorText)
message = do
            Pretty ColorText
pDir <- String -> IO (Pretty ColorText)
forall {s}. IsString s => String -> IO (Pretty s)
prettyDir String
dir
            Pretty ColorText
executableName <- Text -> Pretty ColorText
forall s. IsString s => Text -> Pretty s
P.text (Text -> Pretty ColorText)
-> (String -> Text) -> String -> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Pretty ColorText) -> IO String -> IO (Pretty ColorText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
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
<> String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string String
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 :: String -> IO (Pretty s)
prettyDir String
dir = String -> Pretty s
forall s. IsString s => String -> Pretty s
P.string (String -> Pretty s) -> IO String -> IO (Pretty s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
canonicalizePath String
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 String
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 (String -> SpecifiedCodebase
CreateWhenMissing String
path)
    Just (DontCreateCodebaseWhenMissing String
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 (String -> SpecifiedCodebase
DontCreateWhenMissing String
path)
    Maybe CodebasePathOption
Nothing -> do String -> CodebaseInitOptions
Home (String -> CodebaseInitOptions)
-> IO String -> IO CodebaseInitOptions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
forall (m :: * -> *). MonadIO m => m String
getHomeDirectory

codebasePathOptionToPath :: CodebasePathOption -> FilePath
codebasePathOptionToPath :: CodebasePathOption -> String
codebasePathOptionToPath CodebasePathOption
codebasePathOption =
  case CodebasePathOption
codebasePathOption of
    CreateCodebaseWhenMissing String
p -> String
p
    DontCreateCodebaseWhenMissing String
p -> String
p