{-# LANGUAGE DeriveAnyClass #-}

-- | Execute transcripts.
module Unison.Codebase.Transcript.Runner
  ( Error (..),
    Runner,
    withRunner,
  )
where

import Control.Lens (use, (?~))
import Crypto.Random qualified as Random
import Data.Aeson qualified as Aeson
import Data.Aeson.Encode.Pretty qualified as Aeson
import Data.ByteString.Lazy.Char8 qualified as BL
import Data.IORef
import Data.List (isSubsequenceOf)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map qualified as Map
import Data.Text qualified as Text
import Data.These (These (..))
import Data.UUID.V4 qualified as UUID
import Network.HTTP.Client qualified as HTTP
import System.Environment (lookupEnv)
import System.IO qualified as IO
import Text.Megaparsec qualified as P
import U.Codebase.Sqlite.DbId qualified as Db
import U.Codebase.Sqlite.Project (Project (..))
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.Queries qualified as Q
import Unison.Auth.CredentialManager qualified as AuthN
import Unison.Auth.HTTPClient qualified as AuthN
import Unison.Auth.Tokens qualified as AuthN
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Codebase (Codebase)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Editor.HandleInput qualified as HandleInput
import Unison.Codebase.Editor.Input (Event (UnisonFileChanged), Input (..))
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Editor.UCMVersion (UCMVersion)
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.Runtime qualified as Runtime
import Unison.Codebase.Transcript
import Unison.Codebase.Transcript.Parser qualified as Transcript
import Unison.Codebase.Verbosity (Verbosity, isSilent)
import Unison.Codebase.Verbosity qualified as Verbosity
import Unison.CommandLine
import Unison.CommandLine.InputPattern (InputPattern (aliases, patternName))
import Unison.CommandLine.InputPatterns (validInputs)
import Unison.CommandLine.OutputMessages (notifyNumbered, notifyUser)
import Unison.CommandLine.Welcome (asciiartUnison)
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import Unison.PrettyTerminal
import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (ProjectAndBranchNames'Unambiguous))
import Unison.Runtime.Interface qualified as RTI
import Unison.Server.Backend qualified as Backend
import Unison.Server.CodebaseServer qualified as Server
import Unison.Sqlite qualified as Sqlite
import Unison.Symbol (Symbol)
import Unison.Syntax.Parser qualified as Parser
import Unison.Util.Pretty qualified as Pretty
import Unison.Util.TQueue qualified as Q
import UnliftIO qualified
import UnliftIO.STM
import Prelude hiding (readFile, writeFile)

-- | Render transcript errors at a width of 65 chars.
terminalWidth :: Pretty.Width
terminalWidth :: Width
terminalWidth = Width
65

-- | If provided, this access token will be used on all
-- requests which use the Authenticated HTTP Client; i.e. all codeserver interactions.
--
-- It's useful in scripted contexts or when running transcripts against a codeserver.
accessTokenEnvVarKey :: String
accessTokenEnvVarKey :: [Char]
accessTokenEnvVarKey = [Char]
"UNISON_SHARE_ACCESS_TOKEN"

type Runner =
  String ->
  Text ->
  (FilePath, Codebase IO Symbol Ann) ->
  IO (Either Error Text)

withRunner ::
  forall m r.
  (UnliftIO.MonadUnliftIO m) =>
  -- | Whether to treat this transcript run as a transcript test, which will try to make output deterministic
  Bool ->
  Verbosity ->
  UCMVersion ->
  FilePath ->
  (Runner -> m r) ->
  m r
withRunner :: forall (m :: * -> *) r.
MonadUnliftIO m =>
Bool
-> Verbosity -> ScratchFileName -> [Char] -> (Runner -> m r) -> m r
withRunner Bool
isTest Verbosity
verbosity ScratchFileName
ucmVersion [Char]
nrtp Runner -> m r
action = do
  [Char]
-> (Runtime Symbol -> Runtime Symbol -> Runtime Symbol -> m r)
-> m r
forall a.
[Char]
-> (Runtime Symbol -> Runtime Symbol -> Runtime Symbol -> m a)
-> m a
withRuntimes [Char]
nrtp \Runtime Symbol
runtime Runtime Symbol
sbRuntime Runtime Symbol
nRuntime -> do
    Runner -> m r
action \[Char]
transcriptName ScratchFileName
transcriptSrc ([Char]
codebaseDir, Codebase IO Symbol Ann
codebase) -> do
      BackendEnv
-> CodebaseServerOpts
-> Runtime Symbol
-> Codebase IO Symbol Ann
-> (BaseUrl -> IO (Either Error ScratchFileName))
-> IO (Either Error ScratchFileName)
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
Server.defaultCodebaseServerOpts Runtime Symbol
runtime Codebase IO Symbol Ann
codebase \BaseUrl
baseUrl -> do
        let parsed :: Either (ParseErrorBundle ScratchFileName Void) [Stanza]
parsed = [Char]
-> ScratchFileName
-> Either (ParseErrorBundle ScratchFileName Void) [Stanza]
Transcript.stanzas [Char]
transcriptName ScratchFileName
transcriptSrc
        Either
  (ParseErrorBundle ScratchFileName Void)
  (Either Error ScratchFileName)
result <- Either (ParseErrorBundle ScratchFileName Void) [Stanza]
-> ([Stanza] -> IO (Either Error ScratchFileName))
-> IO
     (Either
        (ParseErrorBundle ScratchFileName Void)
        (Either Error ScratchFileName))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Either (ParseErrorBundle ScratchFileName Void) [Stanza]
parsed \[Stanza]
stanzas -> do
          IO (Either Error ScratchFileName)
-> IO (Either Error ScratchFileName)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Error ScratchFileName)
 -> IO (Either Error ScratchFileName))
-> IO (Either Error ScratchFileName)
-> IO (Either Error ScratchFileName)
forall a b. (a -> b) -> a -> b
$ Bool
-> Verbosity
-> [Char]
-> [Stanza]
-> Codebase IO Symbol Ann
-> Runtime Symbol
-> Runtime Symbol
-> Runtime Symbol
-> ScratchFileName
-> ScratchFileName
-> IO (Either Error ScratchFileName)
run Bool
isTest Verbosity
verbosity [Char]
codebaseDir [Stanza]
stanzas Codebase IO Symbol Ann
codebase Runtime Symbol
runtime Runtime Symbol
sbRuntime Runtime Symbol
nRuntime ScratchFileName
ucmVersion (BaseUrl -> ScratchFileName
forall a. Show a => a -> ScratchFileName
tShow BaseUrl
baseUrl)
        Either Error ScratchFileName -> IO (Either Error ScratchFileName)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error ScratchFileName -> IO (Either Error ScratchFileName))
-> (Either Error (Either Error ScratchFileName)
    -> Either Error ScratchFileName)
-> Either Error (Either Error ScratchFileName)
-> IO (Either Error ScratchFileName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Error (Either Error ScratchFileName)
-> Either Error ScratchFileName
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Either Error (Either Error ScratchFileName)
 -> IO (Either Error ScratchFileName))
-> Either Error (Either Error ScratchFileName)
-> IO (Either Error ScratchFileName)
forall a b. (a -> b) -> a -> b
$ (ParseErrorBundle ScratchFileName Void -> Error)
-> Either
     (ParseErrorBundle ScratchFileName Void)
     (Either Error ScratchFileName)
-> Either Error (Either Error ScratchFileName)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseErrorBundle ScratchFileName Void -> Error
ParseError Either
  (ParseErrorBundle ScratchFileName Void)
  (Either Error ScratchFileName)
result
  where
    withRuntimes ::
      FilePath -> (Runtime.Runtime Symbol -> Runtime.Runtime Symbol -> Runtime.Runtime Symbol -> m a) -> m a
    withRuntimes :: forall a.
[Char]
-> (Runtime Symbol -> Runtime Symbol -> Runtime Symbol -> m a)
-> m a
withRuntimes [Char]
nrtp Runtime Symbol -> Runtime Symbol -> Runtime Symbol -> m a
action =
      Bool
-> RuntimeHost -> ScratchFileName -> (Runtime Symbol -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Bool
-> RuntimeHost -> ScratchFileName -> (Runtime Symbol -> m a) -> m a
RTI.withRuntime Bool
False RuntimeHost
RTI.Persistent ScratchFileName
ucmVersion \Runtime Symbol
runtime -> do
        Bool
-> RuntimeHost -> ScratchFileName -> (Runtime Symbol -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Bool
-> RuntimeHost -> ScratchFileName -> (Runtime Symbol -> m a) -> m a
RTI.withRuntime Bool
True RuntimeHost
RTI.Persistent ScratchFileName
ucmVersion \Runtime Symbol
sbRuntime -> do
          Runtime Symbol -> Runtime Symbol -> Runtime Symbol -> m a
action Runtime Symbol
runtime Runtime Symbol
sbRuntime
            (Runtime Symbol -> m a) -> m (Runtime Symbol) -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Runtime Symbol) -> m (Runtime Symbol)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ScratchFileName -> [Char] -> IO (Runtime Symbol)
RTI.startNativeRuntime ScratchFileName
ucmVersion [Char]
nrtp)

run ::
  -- | Whether to treat this transcript run as a transcript test, which will try to make output deterministic
  Bool ->
  Verbosity ->
  FilePath ->
  [Stanza] ->
  Codebase IO Symbol Ann ->
  Runtime.Runtime Symbol ->
  Runtime.Runtime Symbol ->
  Runtime.Runtime Symbol ->
  UCMVersion ->
  Text ->
  IO (Either Error Text)
run :: Bool
-> Verbosity
-> [Char]
-> [Stanza]
-> Codebase IO Symbol Ann
-> Runtime Symbol
-> Runtime Symbol
-> Runtime Symbol
-> ScratchFileName
-> ScratchFileName
-> IO (Either Error ScratchFileName)
run Bool
isTest Verbosity
verbosity [Char]
dir [Stanza]
stanzas Codebase IO Symbol Ann
codebase Runtime Symbol
runtime Runtime Symbol
sbRuntime Runtime Symbol
nRuntime ScratchFileName
ucmVersion ScratchFileName
baseURL = IO ScratchFileName -> IO (Either Error ScratchFileName)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
UnliftIO.try do
  Manager
httpManager <- ManagerSettings -> IO Manager
HTTP.newManager ManagerSettings
HTTP.defaultManagerSettings
  (ProjectPath
initialPP, CausalHashId
emptyCausalHashId) <- Codebase IO Symbol Ann
-> Transaction (ProjectPath, CausalHashId)
-> IO (ProjectPath, CausalHashId)
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Codebase IO Symbol Ann
codebase do
    (CausalHash
_, CausalHashId
emptyCausalHashId) <- Transaction (CausalHash, CausalHashId)
Codebase.emptyCausalHash
    ProjectPath
initialPP <- Transaction ProjectPath
HasCallStack => Transaction ProjectPath
Codebase.expectCurrentProjectPath
    pure (ProjectPath
initialPP, CausalHashId
emptyCausalHashId)

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Verbosity -> Bool
isSilent Verbosity
verbosity) (IO () -> IO ())
-> (Pretty ColorText -> IO ()) -> Pretty ColorText -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty ColorText -> IO ()
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
Pretty.lines
      [ Pretty ColorText
asciiartUnison,
        Pretty ColorText
"",
        Pretty ColorText
"Running the provided transcript file...",
        Pretty ColorText
""
      ]
  Maybe ScratchFileName
mayShareAccessToken <- ([Char] -> ScratchFileName)
-> Maybe [Char] -> Maybe ScratchFileName
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> ScratchFileName
Text.pack (Maybe [Char] -> Maybe ScratchFileName)
-> IO (Maybe [Char]) -> IO (Maybe ScratchFileName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
accessTokenEnvVarKey
  CredentialManager
credMan <- IO CredentialManager
forall (m :: * -> *). MonadIO m => m CredentialManager
AuthN.newCredentialManager
  let tokenProvider :: AuthN.TokenProvider
      tokenProvider :: TokenProvider
tokenProvider =
        case Maybe ScratchFileName
mayShareAccessToken of
          Maybe ScratchFileName
Nothing -> do
            CredentialManager -> TokenProvider
AuthN.newTokenProvider CredentialManager
credMan
          Just ScratchFileName
accessToken ->
            \CodeserverId
_codeserverID -> Either CredentialFailure ScratchFileName
-> IO (Either CredentialFailure ScratchFileName)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CredentialFailure ScratchFileName
 -> IO (Either CredentialFailure ScratchFileName))
-> Either CredentialFailure ScratchFileName
-> IO (Either CredentialFailure ScratchFileName)
forall a b. (a -> b) -> a -> b
$ ScratchFileName -> Either CredentialFailure ScratchFileName
forall a b. b -> Either a b
Right ScratchFileName
accessToken
  IORef Int
seedRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
  -- Queue of Stanzas and Just index, or Nothing if the stanza was programmatically generated
  -- e.g. a unison-file update by a command like 'edit'
  TQueue (Stanza, Maybe Int)
inputQueue <- forall a (m :: * -> *). MonadIO m => m (TQueue a)
Q.newIO @(Stanza, Maybe Int)
  -- Queue of UCM commands to run.
  -- Nothing indicates the end of a ucm block.
  TQueue (Maybe UcmLine)
cmdQueue <- forall a (m :: * -> *). MonadIO m => m (TQueue a)
Q.newIO @(Maybe UcmLine)
  -- Queue of scratch file updates triggered by UCM itself, e.g. via `edit`, `update`, etc.
  TQueue (ScratchFileName, ScratchFileName)
ucmScratchFileUpdatesQueue <- forall a (m :: * -> *). MonadIO m => m (TQueue a)
Q.newIO @(ScratchFileName, Text)
  IORef (Map ScratchFileName ScratchFileName)
unisonFiles <- Map ScratchFileName ScratchFileName
-> IO (IORef (Map ScratchFileName ScratchFileName))
forall a. a -> IO (IORef a)
newIORef Map ScratchFileName ScratchFileName
forall k a. Map k a
Map.empty
  IORef (Seq [Char])
out <- Seq [Char] -> IO (IORef (Seq [Char]))
forall a. a -> IO (IORef a)
newIORef Seq [Char]
forall a. Monoid a => a
mempty
  IORef Hidden
hidden <- Hidden -> IO (IORef Hidden)
forall a. a -> IO (IORef a)
newIORef Hidden
Shown
  IORef Bool
allowErrors <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
  IORef Bool
hasErrors <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
  IORef (Maybe (Stanza, Maybe Int))
mStanza <- Maybe (Stanza, Maybe Int) -> IO (IORef (Maybe (Stanza, Maybe Int)))
forall a. a -> IO (IORef a)
newIORef Maybe (Stanza, Maybe Int)
forall a. Maybe a
Nothing
  ((Stanza, Maybe Int) -> IO ()) -> [(Stanza, Maybe Int)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ())
-> ((Stanza, Maybe Int) -> STM ()) -> (Stanza, Maybe Int) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TQueue (Stanza, Maybe Int) -> (Stanza, Maybe Int) -> STM ()
forall a. TQueue a -> a -> STM ()
Q.enqueue TQueue (Stanza, Maybe Int)
inputQueue) ([Stanza]
stanzas [Stanza] -> [Maybe Int] -> [(Stanza, Maybe Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> [Int] -> [Maybe Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
1 :: Int ..]))
  let patternMap :: Map [Char] InputPattern
patternMap =
        [([Char], InputPattern)] -> Map [Char] InputPattern
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([([Char], InputPattern)] -> Map [Char] InputPattern)
-> [([Char], InputPattern)] -> Map [Char] InputPattern
forall a b. (a -> b) -> a -> b
$
          [InputPattern]
validInputs
            [InputPattern]
-> (InputPattern -> [([Char], InputPattern)])
-> [([Char], InputPattern)]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\InputPattern
p -> (InputPattern -> [Char]
patternName InputPattern
p, InputPattern
p) ([Char], InputPattern)
-> [([Char], InputPattern)] -> [([Char], InputPattern)]
forall a. a -> [a] -> [a]
: ((,InputPattern
p) ([Char] -> ([Char], InputPattern))
-> [[Char]] -> [([Char], InputPattern)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputPattern -> [[Char]]
aliases InputPattern
p))
  let output' :: Bool -> String -> IO ()
      output' :: Bool -> [Char] -> IO ()
output' Bool
inputEcho [Char]
msg = do
        Hidden
hide <- IORef Hidden -> IO Hidden
forall a. IORef a -> IO a
readIORef IORef Hidden
hidden
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> Hidden -> Bool
hideOutput Bool
inputEcho Hidden
hide) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (Seq [Char]) -> (Seq [Char] -> Seq [Char]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Seq [Char])
out (\Seq [Char]
acc -> Seq [Char]
acc Seq [Char] -> Seq [Char] -> Seq [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Seq [Char]
forall a. a -> Seq a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
msg)

      hideOutput :: Bool -> Hidden -> Bool
      hideOutput :: Bool -> Hidden -> Bool
hideOutput Bool
inputEcho = \case
        Hidden
Shown -> Bool
False
        Hidden
HideOutput -> Bool
True Bool -> Bool -> Bool
&& (Bool -> Bool
not Bool
inputEcho)
        Hidden
HideAll -> Bool
True

      output, outputEcho :: String -> IO ()
      output :: [Char] -> IO ()
output = Bool -> [Char] -> IO ()
output' Bool
False
      outputEcho :: [Char] -> IO ()
outputEcho = Bool -> [Char] -> IO ()
output' Bool
True

      apiRequest :: APIRequest -> IO ()
      apiRequest :: APIRequest -> IO ()
apiRequest APIRequest
req = do
        [Char] -> IO ()
output ([Char] -> IO ())
-> (ScratchFileName -> [Char]) -> ScratchFileName -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScratchFileName -> [Char]
Text.unpack (ScratchFileName -> IO ()) -> ScratchFileName -> IO ()
forall a b. (a -> b) -> a -> b
$ APIRequest -> ScratchFileName
Transcript.formatAPIRequest APIRequest
req ScratchFileName -> ScratchFileName -> ScratchFileName
forall a. Semigroup a => a -> a -> a
<> ScratchFileName
"\n"
        case APIRequest
req of
          APIComment {} -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          GetRequest ScratchFileName
path -> do
            Request
req <- case [Char] -> Either SomeException Request
forall (m :: * -> *). MonadThrow m => [Char] -> m Request
HTTP.parseRequest (ScratchFileName -> [Char]
Text.unpack (ScratchFileName -> [Char]) -> ScratchFileName -> [Char]
forall a b. (a -> b) -> a -> b
$ ScratchFileName
baseURL ScratchFileName -> ScratchFileName -> ScratchFileName
forall a. Semigroup a => a -> a -> a
<> ScratchFileName
path) of
              Left SomeException
err -> [Char] -> IO Request
forall a. [Char] -> IO a
dieWithMsg (SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
err)
              Right Request
req -> Request -> IO Request
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
req
            Response ByteString
respBytes <- Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
req Manager
httpManager
            case ByteString -> Either [Char] Value
forall a. FromJSON a => ByteString -> Either [Char] a
Aeson.eitherDecode (Response ByteString -> ByteString
forall body. Response body -> body
HTTP.responseBody Response ByteString
respBytes) of
              Right (Value
v :: Aeson.Value) -> do
                let prettyBytes :: ByteString
prettyBytes = Config -> Value -> ByteString
forall a. ToJSON a => Config -> a -> ByteString
Aeson.encodePretty' (Config
Aeson.defConfig {Aeson.confCompare = compare}) Value
v
                [Char] -> IO ()
output ([Char] -> IO ()) -> (ByteString -> [Char]) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\n") ([Char] -> [Char])
-> (ByteString -> [Char]) -> ByteString -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
BL.unpack (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
prettyBytes
              Left [Char]
err -> [Char] -> IO ()
forall a. [Char] -> IO a
dieWithMsg ([Char]
"Error decoding response from " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ScratchFileName -> [Char]
Text.unpack ScratchFileName
path [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
err)

      awaitInput :: Cli (Either Event Input)
      awaitInput :: Cli (Either Event Input)
awaitInput = do
        Maybe (Maybe UcmLine)
cmd <- STM (Maybe (Maybe UcmLine)) -> Cli (Maybe (Maybe UcmLine))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TQueue (Maybe UcmLine) -> STM (Maybe (Maybe UcmLine))
forall a. TQueue a -> STM (Maybe a)
Q.tryDequeue TQueue (Maybe UcmLine)
cmdQueue)
        case Maybe (Maybe UcmLine)
cmd of
          -- end of ucm block
          Just Maybe UcmLine
Nothing -> do
            IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ()
output [Char]
"\n```\n")
            IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
dieUnexpectedSuccess
            STM () -> Cli ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> Cli ()) -> STM () -> Cli ()
forall a b. (a -> b) -> a -> b
$ STM [()] -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM [()] -> STM ()) -> STM [()] -> STM ()
forall a b. (a -> b) -> a -> b
$ do
              [(ScratchFileName, ScratchFileName)]
scratchFileUpdates <- TQueue (ScratchFileName, ScratchFileName)
-> STM [(ScratchFileName, ScratchFileName)]
forall a. TQueue a -> STM [a]
Q.flush TQueue (ScratchFileName, ScratchFileName)
ucmScratchFileUpdatesQueue
              -- Push them onto the front stanza queue in the correct order.
              [(ScratchFileName, ScratchFileName)]
-> ((ScratchFileName, ScratchFileName) -> STM ()) -> STM [()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([(ScratchFileName, ScratchFileName)]
-> [(ScratchFileName, ScratchFileName)]
forall a. [a] -> [a]
reverse [(ScratchFileName, ScratchFileName)]
scratchFileUpdates) \(ScratchFileName
fp, ScratchFileName
contents) -> do
                let fenceDescription :: ScratchFileName
fenceDescription = ScratchFileName
"unison:added-by-ucm " ScratchFileName -> ScratchFileName -> ScratchFileName
forall a. Semigroup a => a -> a -> a
<> ScratchFileName
fp
                -- Output blocks for any scratch file updates the ucm block triggered.
                TQueue (Stanza, Maybe Int) -> (Stanza, Maybe Int) -> STM ()
forall a. TQueue a -> a -> STM ()
Q.undequeue TQueue (Stanza, Maybe Int)
inputQueue (Node -> Stanza
forall a b. a -> Either a b
Left (Node -> Stanza) -> Node -> Stanza
forall a b. (a -> b) -> a -> b
$ Maybe PosInfo -> ScratchFileName -> ScratchFileName -> Node
CMarkCodeBlock Maybe PosInfo
forall a. Maybe a
Nothing ScratchFileName
fenceDescription ScratchFileName
contents, Maybe Int
forall a. Maybe a
Nothing)
            Cli (Either Event Input)
awaitInput
          -- ucm command to run
          Just (Just UcmLine
ucmLine) -> do
            case UcmLine
ucmLine of
              p :: UcmLine
p@(UcmComment {}) -> do
                IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Cli ())
-> (ScratchFileName -> IO ()) -> ScratchFileName -> Cli ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
output ([Char] -> IO ())
-> (ScratchFileName -> [Char]) -> ScratchFileName -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScratchFileName -> [Char]
Text.unpack (ScratchFileName -> Cli ()) -> ScratchFileName -> Cli ()
forall a b. (a -> b) -> a -> b
$ ScratchFileName
"\n" ScratchFileName -> ScratchFileName -> ScratchFileName
forall a. Semigroup a => a -> a -> a
<> UcmLine -> ScratchFileName
Transcript.formatUcmLine UcmLine
p
                Cli (Either Event Input)
awaitInput
              p :: UcmLine
p@(UcmCommand UcmContext
context ScratchFileName
lineTxt) -> do
                ProjectPath
curPath <- Cli ProjectPath
Cli.getCurrentProjectPath
                -- We're either going to run the command now (because we're in the right context), else we'll switch to
                -- the right context first, then run the command next.
                Maybe Input
maybeSwitchCommand <-
                  case UcmContext
context of
                    UcmContextProject (ProjectAndBranch ProjectName
projectName ProjectBranchName
branchName) -> Transaction (Maybe Input) -> Cli (Maybe Input)
forall a. Transaction a -> Cli a
Cli.runTransaction do
                      Project {ProjectId
projectId :: ProjectId
$sel:projectId:Project :: Project -> ProjectId
projectId, $sel:name:Project :: Project -> ProjectName
name = ProjectName
projectName} <-
                        ProjectName -> Transaction (Maybe Project)
Q.loadProjectByName ProjectName
projectName
                          Transaction (Maybe Project)
-> (Maybe Project -> Transaction Project) -> Transaction Project
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                            Maybe Project
Nothing -> do
                              ProjectId
projectId <- IO ProjectId -> Transaction ProjectId
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (UUID -> ProjectId
Db.ProjectId (UUID -> ProjectId) -> IO UUID -> IO ProjectId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID
UUID.nextRandom)
                              ProjectId -> ProjectName -> Transaction ()
Q.insertProject ProjectId
projectId ProjectName
projectName
                              pure $ Project {ProjectId
$sel:projectId:Project :: ProjectId
projectId :: ProjectId
projectId, $sel:name:Project :: ProjectName
name = ProjectName
projectName}
                            Just Project
project -> Project -> Transaction Project
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Project
project
                      ProjectBranch
projectBranch <-
                        ProjectId -> ProjectBranchName -> Transaction (Maybe ProjectBranch)
Q.loadProjectBranchByName ProjectId
projectId ProjectBranchName
branchName Transaction (Maybe ProjectBranch)
-> (Maybe ProjectBranch -> Transaction ProjectBranch)
-> Transaction ProjectBranch
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                          Maybe ProjectBranch
Nothing -> do
                            ProjectBranchId
branchId <- IO ProjectBranchId -> Transaction ProjectBranchId
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (UUID -> ProjectBranchId
Db.ProjectBranchId (UUID -> ProjectBranchId) -> IO UUID -> IO ProjectBranchId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID
UUID.nextRandom)
                            let projectBranch :: ProjectBranch
projectBranch = ProjectBranch {ProjectId
projectId :: ProjectId
$sel:projectId:ProjectBranch :: ProjectId
projectId, $sel:parentBranchId:ProjectBranch :: Maybe ProjectBranchId
parentBranchId = Maybe ProjectBranchId
forall a. Maybe a
Nothing, ProjectBranchId
branchId :: ProjectBranchId
$sel:branchId:ProjectBranch :: ProjectBranchId
branchId, $sel:name:ProjectBranch :: ProjectBranchName
name = ProjectBranchName
branchName}
                            HasCallStack =>
ScratchFileName -> CausalHashId -> ProjectBranch -> Transaction ()
ScratchFileName -> CausalHashId -> ProjectBranch -> Transaction ()
Q.insertProjectBranch ScratchFileName
"Branch Created" CausalHashId
emptyCausalHashId ProjectBranch
projectBranch
                            pure ProjectBranch
projectBranch
                          Just ProjectBranch
projBranch -> ProjectBranch -> Transaction ProjectBranch
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectBranch
projBranch
                      let projectAndBranchIds :: ProjectAndBranch ProjectId ProjectBranchId
projectAndBranchIds = ProjectId
-> ProjectBranchId -> ProjectAndBranch ProjectId ProjectBranchId
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch ProjectBranch
projectBranch.projectId ProjectBranch
projectBranch.branchId
                      Maybe Input -> Transaction (Maybe Input)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                        if (ProjectPathG ProjectId ProjectBranchId
-> ProjectAndBranch ProjectId ProjectBranchId
forall p b. ProjectPathG p b -> ProjectAndBranch p b
PP.toProjectAndBranch (ProjectPathG ProjectId ProjectBranchId
 -> ProjectAndBranch ProjectId ProjectBranchId)
-> (ProjectPath -> ProjectPathG ProjectId ProjectBranchId)
-> ProjectPath
-> ProjectAndBranch ProjectId ProjectBranchId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPath -> ProjectPathG ProjectId ProjectBranchId
PP.toIds (ProjectPath -> ProjectAndBranch ProjectId ProjectBranchId)
-> ProjectPath -> ProjectAndBranch ProjectId ProjectBranchId
forall a b. (a -> b) -> a -> b
$ ProjectPath
curPath) ProjectAndBranch ProjectId ProjectBranchId
-> ProjectAndBranch ProjectId ProjectBranchId -> Bool
forall a. Eq a => a -> a -> Bool
== ProjectAndBranch ProjectId ProjectBranchId
projectAndBranchIds
                          then Maybe Input
forall a. Maybe a
Nothing
                          else Input -> Maybe Input
forall a. a -> Maybe a
Just (ProjectAndBranchNames -> Input
ProjectSwitchI (These ProjectName ProjectBranchName -> ProjectAndBranchNames
ProjectAndBranchNames'Unambiguous (ProjectName
-> ProjectBranchName -> These ProjectName ProjectBranchName
forall a b. a -> b -> These a b
These ProjectName
projectName ProjectBranchName
branchName)))
                case Maybe Input
maybeSwitchCommand of
                  Just Input
switchCommand -> do
                    STM () -> Cli ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> Cli ()) -> STM () -> Cli ()
forall a b. (a -> b) -> a -> b
$ TQueue (Maybe UcmLine) -> Maybe UcmLine -> STM ()
forall a. TQueue a -> a -> STM ()
Q.undequeue TQueue (Maybe UcmLine)
cmdQueue (UcmLine -> Maybe UcmLine
forall a. a -> Maybe a
Just UcmLine
p)
                    pure (Input -> Either Event Input
forall a b. b -> Either a b
Right Input
switchCommand)
                  Maybe Input
Nothing -> do
                    case [Char] -> [[Char]]
words ([Char] -> [[Char]])
-> (ScratchFileName -> [Char]) -> ScratchFileName -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScratchFileName -> [Char]
Text.unpack (ScratchFileName -> [[Char]]) -> ScratchFileName -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ScratchFileName
lineTxt of
                      [] -> Cli (Either Event Input)
awaitInput
                      [[Char]]
args -> do
                        IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Cli ())
-> (ScratchFileName -> IO ()) -> ScratchFileName -> Cli ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
output ([Char] -> IO ())
-> (ScratchFileName -> [Char]) -> ScratchFileName -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScratchFileName -> [Char]
Text.unpack (ScratchFileName -> Cli ()) -> ScratchFileName -> Cli ()
forall a b. (a -> b) -> a -> b
$ ScratchFileName
"\n" ScratchFileName -> ScratchFileName -> ScratchFileName
forall a. Semigroup a => a -> a -> a
<> UcmLine -> ScratchFileName
Transcript.formatUcmLine UcmLine
p ScratchFileName -> ScratchFileName -> ScratchFileName
forall a. Semigroup a => a -> a -> a
<> ScratchFileName
"\n"
                        [StructuredArgument]
numberedArgs <- Getting [StructuredArgument] LoopState [StructuredArgument]
-> Cli [StructuredArgument]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting [StructuredArgument] LoopState [StructuredArgument]
#numberedArgs
                        PP.ProjectAndBranch ProjectId
projId ProjectBranchId
branchId <- ProjectPathG ProjectId ProjectBranchId
-> ProjectAndBranch ProjectId ProjectBranchId
forall p b. ProjectPathG p b -> ProjectAndBranch p b
PP.toProjectAndBranch (ProjectPathG ProjectId ProjectBranchId
 -> ProjectAndBranch ProjectId ProjectBranchId)
-> (NonEmpty (ProjectPathG ProjectId ProjectBranchId)
    -> ProjectPathG ProjectId ProjectBranchId)
-> NonEmpty (ProjectPathG ProjectId ProjectBranchId)
-> ProjectAndBranch ProjectId ProjectBranchId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (ProjectPathG ProjectId ProjectBranchId)
-> ProjectPathG ProjectId ProjectBranchId
forall a. NonEmpty a -> a
NonEmpty.head (NonEmpty (ProjectPathG ProjectId ProjectBranchId)
 -> ProjectAndBranch ProjectId ProjectBranchId)
-> Cli (NonEmpty (ProjectPathG ProjectId ProjectBranchId))
-> Cli (ProjectAndBranch ProjectId ProjectBranchId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (NonEmpty (ProjectPathG ProjectId ProjectBranchId))
  LoopState
  (NonEmpty (ProjectPathG ProjectId ProjectBranchId))
-> Cli (NonEmpty (ProjectPathG ProjectId ProjectBranchId))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (NonEmpty (ProjectPathG ProjectId ProjectBranchId))
  LoopState
  (NonEmpty (ProjectPathG ProjectId ProjectBranchId))
#projectPathStack
                        let getProjectRoot :: IO (Branch IO)
getProjectRoot = IO (Branch IO) -> IO (Branch IO)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Branch IO) -> IO (Branch IO))
-> IO (Branch IO) -> IO (Branch IO)
forall a b. (a -> b) -> a -> b
$ Codebase IO Symbol Ann
-> ProjectId -> ProjectBranchId -> IO (Branch IO)
forall (m :: * -> *) v a.
MonadIO m =>
Codebase m v a -> ProjectId -> ProjectBranchId -> m (Branch m)
Codebase.expectProjectBranchRoot Codebase IO Symbol Ann
codebase ProjectId
projId ProjectBranchId
branchId
                        IO (Either (Pretty ColorText) (Maybe (Arguments, Input)))
-> Cli (Either (Pretty ColorText) (Maybe (Arguments, Input)))
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Codebase IO Symbol Ann
-> ProjectPath
-> IO (Branch IO)
-> [StructuredArgument]
-> Map [Char] InputPattern
-> [[Char]]
-> IO (Either (Pretty ColorText) (Maybe (Arguments, Input)))
parseInput Codebase IO Symbol Ann
codebase ProjectPath
curPath IO (Branch IO)
getProjectRoot [StructuredArgument]
numberedArgs Map [Char] InputPattern
patternMap [[Char]]
args) Cli (Either (Pretty ColorText) (Maybe (Arguments, Input)))
-> (Either (Pretty ColorText) (Maybe (Arguments, Input))
    -> Cli (Either Event Input))
-> Cli (Either Event Input)
forall a b. Cli a -> (a -> Cli b) -> Cli b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                          -- invalid command is treated as a failure
                          Left Pretty ColorText
msg -> do
                            IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Cli ()) -> IO () -> Cli ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
hasErrors Bool
True
                            IO Bool -> Cli Bool
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
allowErrors) Cli Bool
-> (Bool -> Cli (Either Event Input)) -> Cli (Either Event Input)
forall a b. Cli a -> (a -> Cli b) -> Cli b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                              Bool
True -> do
                                IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ()
output ([Char] -> IO ())
-> (Pretty ColorText -> [Char]) -> Pretty ColorText -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Width -> Pretty ColorText -> [Char]
Pretty.toPlain Width
terminalWidth (Pretty ColorText -> IO ()) -> Pretty ColorText -> IO ()
forall a b. (a -> b) -> a -> b
$ (Pretty ColorText
"\n" Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
msg Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
"\n"))
                                Cli (Either Event Input)
awaitInput
                              Bool
False -> do
                                IO (Either Event Input) -> Cli (Either Event Input)
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO (Either Event Input)
forall a. [Char] -> IO a
dieWithMsg ([Char] -> IO (Either Event Input))
-> [Char] -> IO (Either Event Input)
forall a b. (a -> b) -> a -> b
$ Width -> Pretty ColorText -> [Char]
Pretty.toPlain Width
terminalWidth Pretty ColorText
msg)
                          -- No input received from this line, try again.
                          Right Maybe (Arguments, Input)
Nothing -> Cli (Either Event Input)
awaitInput
                          Right (Just (Arguments
_expandedArgs, Input
input)) -> Either Event Input -> Cli (Either Event Input)
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Event Input -> Cli (Either Event Input))
-> Either Event Input -> Cli (Either Event Input)
forall a b. (a -> b) -> a -> b
$ Input -> Either Event Input
forall a b. b -> Either a b
Right Input
input
          Maybe (Maybe UcmLine)
Nothing -> do
            IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
dieUnexpectedSuccess)
            IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Hidden -> Hidden -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Hidden
hidden Hidden
Shown)
            IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
allowErrors Bool
False)
            Maybe (Stanza, Maybe Int)
maybeStanza <- STM (Maybe (Stanza, Maybe Int)) -> Cli (Maybe (Stanza, Maybe Int))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TQueue (Stanza, Maybe Int) -> STM (Maybe (Stanza, Maybe Int))
forall a. TQueue a -> STM (Maybe a)
Q.tryDequeue TQueue (Stanza, Maybe Int)
inputQueue)
            ()
_ <- IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe (Stanza, Maybe Int))
-> Maybe (Stanza, Maybe Int) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (Stanza, Maybe Int))
mStanza Maybe (Stanza, Maybe Int)
maybeStanza)
            case Maybe (Stanza, Maybe Int)
maybeStanza of
              Maybe (Stanza, Maybe Int)
Nothing -> IO (Either Event Input) -> Cli (Either Event Input)
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
                IO ()
clearCurrentLine
                [Char] -> IO ()
putStrLn [Char]
"\r✔️   Completed transcript."
                pure $ Input -> Either Event Input
forall a b. b -> Either a b
Right Input
QuitI
              Just (Stanza
s, Maybe Int
midx) -> do
                Bool -> Cli () -> Cli ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Verbosity -> Bool
Verbosity.isSilent Verbosity
verbosity) (Cli () -> Cli ()) -> (IO () -> Cli ()) -> IO () -> Cli ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Cli ()) -> IO () -> Cli ()
forall a b. (a -> b) -> a -> b
$ do
                  IO ()
clearCurrentLine
                  [Char] -> IO ()
putStr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
                    [Char] -> (Int -> [Char]) -> Maybe Int -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                      [Char]
"\r⏩   Skipping non-executable Markdown block."
                      ( \Int
idx ->
                          [Char]
"\r⚙️   Processing stanza "
                            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
idx
                            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" of "
                            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([Stanza] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Stanza]
stanzas)
                            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"."
                      )
                      Maybe Int
midx
                  Handle -> IO ()
IO.hFlush Handle
IO.stdout
                (Node -> Cli (Either Event Input))
-> (ProcessedBlock -> Cli (Either Event Input))
-> Stanza
-> Cli (Either Event Input)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
                  ( \Node
node -> do
                      IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Cli ())
-> (ScratchFileName -> IO ()) -> ScratchFileName -> Cli ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
output ([Char] -> IO ())
-> (ScratchFileName -> [Char]) -> ScratchFileName -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScratchFileName -> [Char]
Text.unpack (ScratchFileName -> Cli ()) -> ScratchFileName -> Cli ()
forall a b. (a -> b) -> a -> b
$ Node -> ScratchFileName
Transcript.formatNode Node
node
                      Cli (Either Event Input)
awaitInput
                  )
                  ( \ProcessedBlock
block -> case ProcessedBlock
block of
                      Unison Hidden
hide Bool
errOk Maybe ScratchFileName
filename ScratchFileName
txt -> do
                        IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Hidden -> Hidden -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Hidden
hidden Hidden
hide)
                        IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Cli ())
-> (ScratchFileName -> IO ()) -> ScratchFileName -> Cli ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
outputEcho ([Char] -> IO ())
-> (ScratchFileName -> [Char]) -> ScratchFileName -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScratchFileName -> [Char]
Text.unpack (ScratchFileName -> Cli ()) -> ScratchFileName -> Cli ()
forall a b. (a -> b) -> a -> b
$ ProcessedBlock -> ScratchFileName
Transcript.formatProcessedBlock ProcessedBlock
block
                        IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
allowErrors Bool
errOk)
                        -- Open a ucm block which will contain the output from UCM
                        -- after processing the UnisonFileChanged event.
                        IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ()
output [Char]
"``` ucm\n")
                        -- Close the ucm block after processing the UnisonFileChanged event.
                        STM () -> Cli ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> Cli ())
-> (Maybe UcmLine -> STM ()) -> Maybe UcmLine -> Cli ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TQueue (Maybe UcmLine) -> Maybe UcmLine -> STM ()
forall a. TQueue a -> a -> STM ()
Q.enqueue TQueue (Maybe UcmLine)
cmdQueue (Maybe UcmLine -> Cli ()) -> Maybe UcmLine -> Cli ()
forall a b. (a -> b) -> a -> b
$ Maybe UcmLine
forall a. Maybe a
Nothing
                        let sourceName :: ScratchFileName
sourceName = ScratchFileName -> Maybe ScratchFileName -> ScratchFileName
forall a. a -> Maybe a -> a
fromMaybe ScratchFileName
"scratch.u" Maybe ScratchFileName
filename
                        IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Cli ()) -> IO () -> Cli ()
forall a b. (a -> b) -> a -> b
$ ScratchFileName -> ScratchFileName -> IO ()
updateVirtualFile ScratchFileName
sourceName ScratchFileName
txt
                        pure $ Event -> Either Event Input
forall a b. a -> Either a b
Left (ScratchFileName -> ScratchFileName -> Event
UnisonFileChanged ScratchFileName
sourceName ScratchFileName
txt)
                      API [APIRequest]
apiRequests -> do
                        IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ()
output [Char]
"``` api\n")
                        IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([APIRequest] -> (APIRequest -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [APIRequest]
apiRequests APIRequest -> IO ()
apiRequest)
                        IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ()
output [Char]
"```\n\n")
                        Cli (Either Event Input)
awaitInput
                      Ucm Hidden
hide Bool
errOk [UcmLine]
cmds -> do
                        IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Hidden -> Hidden -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Hidden
hidden Hidden
hide)
                        IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
allowErrors Bool
errOk)
                        IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
hasErrors Bool
False)
                        IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ()
output [Char]
"``` ucm")
                        (UcmLine -> Cli ()) -> [UcmLine] -> Cli ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (STM () -> Cli ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> Cli ()) -> (UcmLine -> STM ()) -> UcmLine -> Cli ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TQueue (Maybe UcmLine) -> Maybe UcmLine -> STM ()
forall a. TQueue a -> a -> STM ()
Q.enqueue TQueue (Maybe UcmLine)
cmdQueue (Maybe UcmLine -> STM ())
-> (UcmLine -> Maybe UcmLine) -> UcmLine -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UcmLine -> Maybe UcmLine
forall a. a -> Maybe a
Just) [UcmLine]
cmds
                        STM () -> Cli ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> Cli ())
-> (Maybe UcmLine -> STM ()) -> Maybe UcmLine -> Cli ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TQueue (Maybe UcmLine) -> Maybe UcmLine -> STM ()
forall a. TQueue a -> a -> STM ()
Q.enqueue TQueue (Maybe UcmLine)
cmdQueue (Maybe UcmLine -> Cli ()) -> Maybe UcmLine -> Cli ()
forall a b. (a -> b) -> a -> b
$ Maybe UcmLine
forall a. Maybe a
Nothing
                        Cli (Either Event Input)
awaitInput
                  )
                  Stanza
s

      loadPreviousUnisonBlock :: ScratchFileName -> IO LoadSourceResult
loadPreviousUnisonBlock ScratchFileName
name = do
        Map ScratchFileName ScratchFileName
ufs <- IORef (Map ScratchFileName ScratchFileName)
-> IO (Map ScratchFileName ScratchFileName)
forall a. IORef a -> IO a
readIORef IORef (Map ScratchFileName ScratchFileName)
unisonFiles
        case ScratchFileName
-> Map ScratchFileName ScratchFileName -> Maybe ScratchFileName
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScratchFileName
name Map ScratchFileName ScratchFileName
ufs of
          Just ScratchFileName
uf ->
            LoadSourceResult -> IO LoadSourceResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScratchFileName -> LoadSourceResult
Cli.LoadSuccess ScratchFileName
uf)
          Maybe ScratchFileName
Nothing ->
            -- This lets transcripts use the `load` command, as in:
            --
            -- .> load someFile.u
            --
            -- Important for Unison syntax that can't be embedded in
            -- transcripts (like docs, which use ``` in their syntax).
            let f :: IO LoadSourceResult
f = ScratchFileName -> LoadSourceResult
Cli.LoadSuccess (ScratchFileName -> LoadSourceResult)
-> IO ScratchFileName -> IO LoadSourceResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO ScratchFileName
readUtf8 (ScratchFileName -> [Char]
Text.unpack ScratchFileName
name)
             in IO LoadSourceResult
f IO LoadSourceResult -> IO LoadSourceResult -> IO LoadSourceResult
forall a. IO a -> IO a -> IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> LoadSourceResult -> IO LoadSourceResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoadSourceResult
Cli.InvalidSourceNameError

      writeSourceFile :: ScratchFileName -> Text -> IO ()
      writeSourceFile :: ScratchFileName -> ScratchFileName -> IO ()
writeSourceFile ScratchFileName
fp ScratchFileName
contents = do
        Bool
shouldShowSourceChanges <- (Hidden -> Hidden -> Bool
forall a. Eq a => a -> a -> Bool
== Hidden
Shown) (Hidden -> Bool) -> IO Hidden -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Hidden -> IO Hidden
forall a. IORef a -> IO a
readIORef IORef Hidden
hidden
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldShowSourceChanges (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TQueue (ScratchFileName, ScratchFileName)
-> (ScratchFileName, ScratchFileName) -> STM ()
forall a. TQueue a -> a -> STM ()
Q.enqueue TQueue (ScratchFileName, ScratchFileName)
ucmScratchFileUpdatesQueue (ScratchFileName
fp, ScratchFileName
contents))
        ScratchFileName -> ScratchFileName -> IO ()
updateVirtualFile ScratchFileName
fp ScratchFileName
contents

      updateVirtualFile :: ScratchFileName -> Text -> IO ()
      updateVirtualFile :: ScratchFileName -> ScratchFileName -> IO ()
updateVirtualFile ScratchFileName
fp ScratchFileName
contents = do
        IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Map ScratchFileName ScratchFileName)
-> (Map ScratchFileName ScratchFileName
    -> Map ScratchFileName ScratchFileName)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Map ScratchFileName ScratchFileName)
unisonFiles (ScratchFileName
-> ScratchFileName
-> Map ScratchFileName ScratchFileName
-> Map ScratchFileName ScratchFileName
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ScratchFileName
fp ScratchFileName
contents))

      print :: Output.Output -> IO ()
      print :: Output -> IO ()
print Output
o = do
        Pretty ColorText
msg <- [Char] -> Output -> IO (Pretty ColorText)
notifyUser [Char]
dir Output
o
        Bool
errOk <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
allowErrors
        let rendered :: [Char]
rendered = Width -> Pretty ColorText -> [Char]
Pretty.toPlain Width
terminalWidth (Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
Pretty.border Width
2 Pretty ColorText
msg)
        [Char] -> IO ()
output [Char]
rendered
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Output -> Bool
Output.isFailure Output
o) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          if Bool
errOk
            then IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
hasErrors Bool
True
            else [Char] -> IO ()
forall a. [Char] -> IO a
dieWithMsg [Char]
rendered

      printNumbered :: Output.NumberedOutput -> IO Output.NumberedArgs
      printNumbered :: NumberedOutput -> IO [StructuredArgument]
printNumbered NumberedOutput
o = do
        let (Pretty ColorText
msg, [StructuredArgument]
numberedArgs) = NumberedOutput -> (Pretty ColorText, [StructuredArgument])
notifyNumbered NumberedOutput
o
        Bool
errOk <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
allowErrors
        let rendered :: [Char]
rendered = Width -> Pretty ColorText -> [Char]
Pretty.toPlain Width
terminalWidth (Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
Pretty.border Width
2 Pretty ColorText
msg)
        [Char] -> IO ()
output [Char]
rendered
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NumberedOutput -> Bool
Output.isNumberedFailure NumberedOutput
o) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          if Bool
errOk
            then IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
hasErrors Bool
True
            else [Char] -> IO ()
forall a. [Char] -> IO a
dieWithMsg [Char]
rendered
        pure [StructuredArgument]
numberedArgs

      -- Looks at the current stanza and decides if it is contained in the
      -- output so far. Appends it if not.
      appendFailingStanza :: IO ()
      appendFailingStanza :: IO ()
appendFailingStanza = do
        Maybe (Stanza, Maybe Int)
stanzaOpt <- IORef (Maybe (Stanza, Maybe Int)) -> IO (Maybe (Stanza, Maybe Int))
forall a. IORef a -> IO a
readIORef IORef (Maybe (Stanza, Maybe Int))
mStanza
        Seq [Char]
currentOut <- IORef (Seq [Char]) -> IO (Seq [Char])
forall a. IORef a -> IO a
readIORef IORef (Seq [Char])
out
        let stnz :: [Char]
stnz = [Char]
-> ((Stanza, Maybe Int) -> [Char])
-> Maybe (Stanza, Maybe Int)
-> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (ScratchFileName -> [Char]
Text.unpack (ScratchFileName -> [Char])
-> ((Stanza, Maybe Int) -> ScratchFileName)
-> (Stanza, Maybe Int)
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stanza -> ScratchFileName
Transcript.formatStanza (Stanza -> ScratchFileName)
-> ((Stanza, Maybe Int) -> Stanza)
-> (Stanza, Maybe Int)
-> ScratchFileName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stanza, Maybe Int) -> Stanza
forall a b. (a, b) -> a
fst) Maybe (Stanza, Maybe Int)
stanzaOpt
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Char]
stnz [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSubsequenceOf` Seq [Char] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Seq [Char]
currentOut) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          IORef (Seq [Char]) -> (Seq [Char] -> Seq [Char]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Seq [Char])
out (\Seq [Char]
acc -> Seq [Char]
acc Seq [Char] -> Seq [Char] -> Seq [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Seq [Char]
forall a. a -> Seq a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
stnz)

      -- output ``` and new lines then call transcriptFailure
      dieWithMsg :: forall a. String -> IO a
      dieWithMsg :: forall a. [Char] -> IO a
dieWithMsg [Char]
msg = do
        [Char] -> IO ()
output [Char]
"\n```\n\n"
        IO ()
appendFailingStanza
        IORef (Seq [Char]) -> ScratchFileName -> IO a
forall b. IORef (Seq [Char]) -> ScratchFileName -> IO b
transcriptFailure IORef (Seq [Char])
out (ScratchFileName -> IO a) -> ScratchFileName -> IO a
forall a b. (a -> b) -> a -> b
$
          ScratchFileName
"The transcript failed due to an error in the stanza above. The error is:\n\n" ScratchFileName -> ScratchFileName -> ScratchFileName
forall a. Semigroup a => a -> a -> a
<> [Char] -> ScratchFileName
Text.pack [Char]
msg

      dieUnexpectedSuccess :: IO ()
      dieUnexpectedSuccess :: IO ()
dieUnexpectedSuccess = do
        Bool
errOk <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
allowErrors
        Bool
hasErr <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
hasErrors
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
errOk Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
hasErr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          [Char] -> IO ()
output [Char]
"\n```\n\n"
          IO ()
appendFailingStanza
          IORef (Seq [Char]) -> ScratchFileName -> IO ()
forall b. IORef (Seq [Char]) -> ScratchFileName -> IO b
transcriptFailure IORef (Seq [Char])
out ScratchFileName
"The transcript was expecting an error in the stanza above, but did not encounter one."

  AuthenticatedHttpClient
authenticatedHTTPClient <- TokenProvider -> ScratchFileName -> IO AuthenticatedHttpClient
forall (m :: * -> *).
MonadIO m =>
TokenProvider -> ScratchFileName -> m AuthenticatedHttpClient
AuthN.newAuthenticatedHTTPClient TokenProvider
tokenProvider ScratchFileName
ucmVersion

  let env :: Env
env =
        Cli.Env
          { $sel:authHTTPClient:Env :: AuthenticatedHttpClient
authHTTPClient = AuthenticatedHttpClient
authenticatedHTTPClient,
            Codebase IO Symbol Ann
codebase :: Codebase IO Symbol Ann
$sel:codebase:Env :: Codebase IO Symbol Ann
codebase,
            $sel:credentialManager:Env :: CredentialManager
credentialManager = CredentialManager
credMan,
            $sel:generateUniqueName:Env :: IO UniqueName
generateUniqueName = do
              Int
i <- IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
seedRef \Int
i -> let !i' :: Int
i' = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 in (Int
i', Int
i)
              pure (ChaChaDRG -> UniqueName
forall gen. DRG gen => gen -> UniqueName
Parser.uniqueBase32Namegen (Seed -> ChaChaDRG
Random.drgNewSeed (Integer -> Seed
Random.seedFromInteger (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)))),
            $sel:loadSource:Env :: ScratchFileName -> IO LoadSourceResult
loadSource = ScratchFileName -> IO LoadSourceResult
loadPreviousUnisonBlock,
            $sel:writeSource:Env :: ScratchFileName -> ScratchFileName -> IO ()
writeSource = ScratchFileName -> ScratchFileName -> IO ()
writeSourceFile,
            $sel:notify:Env :: Output -> IO ()
notify = Output -> IO ()
print,
            $sel:notifyNumbered:Env :: NumberedOutput -> IO [StructuredArgument]
notifyNumbered = NumberedOutput -> IO [StructuredArgument]
printNumbered,
            Runtime Symbol
runtime :: Runtime Symbol
$sel:runtime:Env :: Runtime Symbol
runtime,
            $sel:sandboxedRuntime:Env :: Runtime Symbol
sandboxedRuntime = Runtime Symbol
sbRuntime,
            $sel:nativeRuntime:Env :: Runtime Symbol
nativeRuntime = Runtime Symbol
nRuntime,
            $sel:serverBaseUrl:Env :: Maybe BaseUrl
serverBaseUrl = Maybe BaseUrl
forall a. Maybe a
Nothing,
            ScratchFileName
ucmVersion :: ScratchFileName
$sel:ucmVersion:Env :: ScratchFileName
ucmVersion,
            $sel:isTranscriptTest:Env :: Bool
isTranscriptTest = Bool
isTest
          }

  let loop :: Cli.LoopState -> IO Text
      loop :: LoopState -> IO ScratchFileName
loop LoopState
s0 = do
        Env
-> LoopState
-> Cli (Either Event Input)
-> IO (ReturnType (Either Event Input), LoopState)
forall a. Env -> LoopState -> Cli a -> IO (ReturnType a, LoopState)
Cli.runCli Env
env LoopState
s0 Cli (Either Event Input)
awaitInput IO (ReturnType (Either Event Input), LoopState)
-> ((ReturnType (Either Event Input), LoopState)
    -> IO ScratchFileName)
-> IO ScratchFileName
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          (Cli.Success Either Event Input
input, LoopState
s1) -> do
            let next :: LoopState -> IO ScratchFileName
next LoopState
s =
                  LoopState -> IO ScratchFileName
loop case Either Event Input
input of
                    Left Event
_ -> LoopState
s
                    Right Input
inp -> LoopState
s LoopState -> (LoopState -> LoopState) -> LoopState
forall a b. a -> (a -> b) -> b
& ASetter LoopState LoopState (Maybe Input) (Maybe Input)
#lastInput ASetter LoopState LoopState (Maybe Input) (Maybe Input)
-> Input -> LoopState -> LoopState
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Input
inp
            Env -> LoopState -> Cli () -> IO (ReturnType (), LoopState)
forall a. Env -> LoopState -> Cli a -> IO (ReturnType a, LoopState)
Cli.runCli Env
env LoopState
s1 (Either Event Input -> Cli ()
HandleInput.loop Either Event Input
input) IO (ReturnType (), LoopState)
-> ((ReturnType (), LoopState) -> IO ScratchFileName)
-> IO ScratchFileName
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              (Cli.Success (), LoopState
s2) -> LoopState -> IO ScratchFileName
next LoopState
s2
              (ReturnType ()
Cli.Continue, LoopState
s2) -> LoopState -> IO ScratchFileName
next LoopState
s2
              (ReturnType ()
Cli.HaltRepl, LoopState
_) -> IO ScratchFileName
onHalt
          (ReturnType (Either Event Input)
Cli.Continue, LoopState
s1) -> LoopState -> IO ScratchFileName
loop LoopState
s1
          (ReturnType (Either Event Input)
Cli.HaltRepl, LoopState
_) -> IO ScratchFileName
onHalt
        where
          onHalt :: IO ScratchFileName
onHalt = do
            Seq [Char]
texts <- IORef (Seq [Char]) -> IO (Seq [Char])
forall a. IORef a -> IO a
readIORef IORef (Seq [Char])
out
            pure $ [ScratchFileName] -> ScratchFileName
Text.concat ([Char] -> ScratchFileName
Text.pack ([Char] -> ScratchFileName) -> [[Char]] -> [ScratchFileName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq [Char] -> [[Char]]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq [Char]
texts :: Seq String))

  LoopState -> IO ScratchFileName
loop (ProjectPathG ProjectId ProjectBranchId -> LoopState
Cli.loopState0 (ProjectPath -> ProjectPathG ProjectId ProjectBranchId
PP.toIds ProjectPath
initialPP))

transcriptFailure :: IORef (Seq String) -> Text -> IO b
transcriptFailure :: forall b. IORef (Seq [Char]) -> ScratchFileName -> IO b
transcriptFailure IORef (Seq [Char])
out ScratchFileName
msg = do
  Seq [Char]
texts <- IORef (Seq [Char]) -> IO (Seq [Char])
forall a. IORef a -> IO a
readIORef IORef (Seq [Char])
out
  Error -> IO b
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UnliftIO.throwIO (Error -> IO b)
-> (ScratchFileName -> Error) -> ScratchFileName -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScratchFileName -> Error
RunFailure (ScratchFileName -> IO b) -> ScratchFileName -> IO b
forall a b. (a -> b) -> a -> b
$ [ScratchFileName] -> ScratchFileName
forall a. Monoid a => [a] -> a
mconcat ([Char] -> ScratchFileName
Text.pack ([Char] -> ScratchFileName) -> [[Char]] -> [ScratchFileName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq [Char] -> [[Char]]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq [Char]
texts) ScratchFileName -> ScratchFileName -> ScratchFileName
forall a. Semigroup a => a -> a -> a
<> ScratchFileName
"\n\n\128721\n\n" ScratchFileName -> ScratchFileName -> ScratchFileName
forall a. Semigroup a => a -> a -> a
<> ScratchFileName
msg ScratchFileName -> ScratchFileName -> ScratchFileName
forall a. Semigroup a => a -> a -> a
<> ScratchFileName
"\n"

data Error
  = ParseError (P.ParseErrorBundle Text Void)
  | RunFailure Text
  deriving stock (Int -> Error -> [Char] -> [Char]
[Error] -> [Char] -> [Char]
Error -> [Char]
(Int -> Error -> [Char] -> [Char])
-> (Error -> [Char]) -> ([Error] -> [Char] -> [Char]) -> Show Error
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Error -> [Char] -> [Char]
showsPrec :: Int -> Error -> [Char] -> [Char]
$cshow :: Error -> [Char]
show :: Error -> [Char]
$cshowList :: [Error] -> [Char] -> [Char]
showList :: [Error] -> [Char] -> [Char]
Show)
  deriving anyclass (Show Error
Typeable Error
(Typeable Error, Show Error) =>
(Error -> SomeException)
-> (SomeException -> Maybe Error)
-> (Error -> [Char])
-> Exception Error
SomeException -> Maybe Error
Error -> [Char]
Error -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> [Char]) -> Exception e
$ctoException :: Error -> SomeException
toException :: Error -> SomeException
$cfromException :: SomeException -> Maybe Error
fromException :: SomeException -> Maybe Error
$cdisplayException :: Error -> [Char]
displayException :: Error -> [Char]
Exception)