{-# LANGUAGE DeriveAnyClass #-}

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

import CMark qualified
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.Char8 qualified as BSC
import Data.ByteString.Lazy.Char8 qualified as BL
import Data.IORef
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map qualified as Map
import Data.Sequence qualified as Seq
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Data.These (These (..))
import Data.UUID.V4 qualified as UUID
import Network.HTTP.Client qualified as HTTP
import System.FilePath ((</>))
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 (..), ProjectBranchRow (..))
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.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.FuzzySelect qualified as Fuzzy
import Unison.CommandLine.InputPattern (aliases, patternName)
import Unison.CommandLine.InputPattern qualified as IP
import Unison.CommandLine.InputPatterns qualified as IP
import Unison.CommandLine.OutputMessages (notifyNumbered, notifyUser, showIssueUrl)
import Unison.CommandLine.Welcome (asciiartUnison)
import Unison.MCP qualified as MCP
import Unison.MCP.Server qualified as MCP
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.Environment (setEnv)
import UnliftIO.STM
import Prelude hiding (readFile, writeFile)

data Config = Config
  { Config -> Width
terminalWidth :: Pretty.Width,
    -- | `Nothing` uses the default, a value overrides @$FZF_PATH@. It may be set to `"NONE"` to disable the use of FZF.
    Config -> Maybe String
fzfPath :: Maybe FilePath,
    Config -> Maybe String
credentialsFile :: Maybe FilePath,
    -- | Control additional test-related values.
    --
    --  __TODO__: This should be broken down with the individual pieces included here.
    Config -> Bool
isTest :: Bool
  }

-- | A reasonable set of defaults to use.
--
-- - render transcript errors at a width of 65 chars
-- - use @$FZF_PATH@
-- - use the default credentials path
defaultConfig :: Config
defaultConfig :: Config
defaultConfig =
  Config
    { terminalWidth :: Width
terminalWidth = Width
65,
      fzfPath :: Maybe String
fzfPath = Maybe String
forall a. Maybe a
Nothing,
      credentialsFile :: Maybe String
credentialsFile = Maybe String
forall a. Maybe a
Nothing,
      isTest :: Bool
isTest = Bool
False
    }

testConfig :: FilePath -> Config
testConfig :: String -> Config
testConfig String
tempDir =
  Config
defaultConfig
    { fzfPath = pure "NONE",
      credentialsFile = pure $ tempDir </> "credentials.json",
      isTest = True
    }

type Runner =
  -- | The name of the transcript to run.
  String ->
  -- | The contents of the transcript to run.
  ByteString ->
  Codebase IO Symbol Ann ->
  IO (Either Error Transcript)

withRunner ::
  forall m r.
  (UnliftIO.MonadUnliftIO m) =>
  -- | Whether to treat this transcript run as a transcript test, which will try to make output deterministic
  Config ->
  Verbosity ->
  UCMVersion ->
  (Runner -> m r) ->
  m r
withRunner :: forall (m :: * -> *) r.
MonadUnliftIO m =>
Config -> Verbosity -> Text -> (Runner -> m r) -> m r
withRunner Config
config Verbosity
verbosity Text
ucmVersion Runner -> m r
action = do
  credMan <- IO CredentialManager -> m CredentialManager
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CredentialManager -> m CredentialManager)
-> (Maybe String -> IO CredentialManager)
-> Maybe String
-> m CredentialManager
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> IO CredentialManager
AuthN.newCredentialManager (Maybe String -> m CredentialManager)
-> Maybe String -> m CredentialManager
forall a b. (a -> b) -> a -> b
$ Config -> Maybe String
credentialsFile Config
config
  authenticatedHTTPClient <- initTranscriptAuthenticatedHTTPClient credMan

  -- If we're in a transcript test, configure the environment to use a non-existent fzf binary
  -- so that errors are consistent.
  -- This also prevents automated transcript tests from mistakenly opening fzf and waiting for user input.
  maybe (pure ()) (liftIO . setEnv Fuzzy.fzfPathEnvVar) $ fzfPath config
  withRuntimes \Runtime Symbol
runtime Runtime Symbol
sbRuntime ->
    Runner -> m r
action \String
transcriptName Method
transcriptSrc Codebase IO Symbol Ann
codebase -> do
      let workDir :: Maybe a
workDir = Maybe a
forall a. Maybe a
Nothing
      mcpServerConfig <- Codebase IO Symbol Ann
-> Runtime Symbol
-> Runtime Symbol
-> Maybe String
-> Text
-> AuthenticatedHttpClient
-> IO Server
MCP.initServer Codebase IO Symbol Ann
codebase Runtime Symbol
runtime Runtime Symbol
sbRuntime Maybe String
forall a. Maybe a
workDir Text
ucmVersion AuthenticatedHttpClient
authenticatedHTTPClient
      Server.startServer
        (isTest config)
        Backend.BackendEnv
        Server.defaultCodebaseServerOpts
        runtime
        codebase
        (MCP.mcpServer mcpServerConfig)
        \case
          Maybe BaseUrl
Nothing -> Either Error Transcript -> IO (Either Error Transcript)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error Transcript -> IO (Either Error Transcript))
-> Either Error Transcript -> IO (Either Error Transcript)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error Transcript
forall a b. a -> Either a b
Left Error
PortBindingFailure
          Just BaseUrl
baseUrl -> do
            let baseUrlText :: Text
baseUrlText = forall a. Show a => a -> Text
tShow @Server.BaseUrl BaseUrl
baseUrl
            case (String -> Method -> Either (ParseErrorBundle Text Void) Transcript
Transcript.parse String
transcriptName Method
transcriptSrc) of
              Left ParseErrorBundle Text Void
parseError -> Either Error Transcript -> IO (Either Error Transcript)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error Transcript -> IO (Either Error Transcript))
-> Either Error Transcript -> IO (Either Error Transcript)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error Transcript
forall a b. a -> Either a b
Left (ParseErrorBundle Text Void -> Error
ParseError ParseErrorBundle Text Void
parseError)
              Right Transcript
stanzas ->
                Config
-> Verbosity
-> Codebase IO Symbol Ann
-> Runtime Symbol
-> Runtime Symbol
-> Text
-> Text
-> AuthenticatedHttpClient
-> CredentialManager
-> Transcript
-> IO (Either Error Transcript)
run
                  Config
config
                  Verbosity
verbosity
                  Codebase IO Symbol Ann
codebase
                  Runtime Symbol
runtime
                  Runtime Symbol
sbRuntime
                  Text
ucmVersion
                  Text
baseUrlText
                  AuthenticatedHttpClient
authenticatedHTTPClient
                  CredentialManager
credMan
                  Transcript
stanzas
                  IO (Either Error Transcript)
-> (IO (Either Error Transcript) -> IO (Either Error Transcript))
-> IO (Either Error Transcript)
forall a b. a -> (a -> b) -> b
& IO (Either Error Transcript) -> IO (Either Error Transcript)
forall x. IO (Either Error x) -> IO (Either Error x)
catchExceptions
  where
    catchExceptions :: forall x. IO (Either Error x) -> IO (Either Error x)
    catchExceptions :: forall x. IO (Either Error x) -> IO (Either Error x)
catchExceptions IO (Either Error x)
io =
      IO (Either Error x) -> IO (Either SomeException (Either Error x))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
UnliftIO.tryAny (IO (Either Error x)
io IO (Either Error x)
-> (Either Error x -> IO (Either Error x)) -> IO (Either Error x)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either Error x -> IO (Either Error x)
forall (m :: * -> *) a. MonadIO m => a -> m a
UnliftIO.evaluate) IO (Either SomeException (Either Error x))
-> (Either SomeException (Either Error x) -> IO (Either Error x))
-> IO (Either Error x)
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 SomeException
someException -> Either Error x -> IO (Either Error x)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error x -> IO (Either Error x))
-> Either Error x -> IO (Either Error x)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error x
forall a b. a -> Either a b
Left (SomeException -> Error
Exception SomeException
someException)
        Right Either Error x
r -> Either Error x -> IO (Either Error x)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either Error x
r
    withRuntimes :: (RTI.Runtime Symbol -> RTI.Runtime Symbol -> m a) -> m a
    withRuntimes :: forall a. (Runtime Symbol -> Runtime Symbol -> m a) -> m a
withRuntimes Runtime Symbol -> Runtime Symbol -> m a
action =
      Bool -> RuntimeHost -> Text -> (Runtime Symbol -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Bool -> RuntimeHost -> Text -> (Runtime Symbol -> m a) -> m a
RTI.withRuntime Bool
False RuntimeHost
RTI.Persistent Text
ucmVersion \Runtime Symbol
runtime ->
        Bool -> RuntimeHost -> Text -> (Runtime Symbol -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Bool -> RuntimeHost -> Text -> (Runtime Symbol -> m a) -> m a
RTI.withRuntime Bool
True RuntimeHost
RTI.Persistent Text
ucmVersion \Runtime Symbol
sbRuntime ->
          Runtime Symbol -> Runtime Symbol -> m a
action Runtime Symbol
runtime Runtime Symbol
sbRuntime
    initTranscriptAuthenticatedHTTPClient :: AuthN.CredentialManager -> m AuthN.AuthenticatedHttpClient
    initTranscriptAuthenticatedHTTPClient :: CredentialManager -> m AuthenticatedHttpClient
initTranscriptAuthenticatedHTTPClient CredentialManager
credMan = IO AuthenticatedHttpClient -> m AuthenticatedHttpClient
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AuthenticatedHttpClient -> m AuthenticatedHttpClient)
-> IO AuthenticatedHttpClient -> m AuthenticatedHttpClient
forall a b. (a -> b) -> a -> b
$ do
      let tokenProvider :: AuthN.TokenProvider
          tokenProvider :: TokenProvider
tokenProvider = CredentialManager -> TokenProvider
AuthN.newTokenProvider CredentialManager
credMan
      TokenProvider -> Text -> IO AuthenticatedHttpClient
forall (m :: * -> *).
MonadIO m =>
TokenProvider -> Text -> m AuthenticatedHttpClient
AuthN.newAuthenticatedHTTPClient TokenProvider
tokenProvider Text
ucmVersion

isGeneratedBlock :: ProcessedBlock -> Bool
isGeneratedBlock :: ProcessedBlock -> Bool
isGeneratedBlock = InfoTags () -> Bool
forall a. InfoTags a -> Bool
generated (InfoTags () -> Bool)
-> (ProcessedBlock -> InfoTags ()) -> ProcessedBlock -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessedBlock -> InfoTags ()
getCommonInfoTags

run ::
  -- | Whether to treat this transcript run as a transcript test, which will try to make output deterministic
  Config ->
  Verbosity ->
  Codebase IO Symbol Ann ->
  RTI.Runtime Symbol ->
  RTI.Runtime Symbol ->
  UCMVersion ->
  Text ->
  AuthN.AuthenticatedHttpClient ->
  AuthN.CredentialManager ->
  Transcript ->
  IO (Either Error Transcript)
run :: Config
-> Verbosity
-> Codebase IO Symbol Ann
-> Runtime Symbol
-> Runtime Symbol
-> Text
-> Text
-> AuthenticatedHttpClient
-> CredentialManager
-> Transcript
-> IO (Either Error Transcript)
run Config
config Verbosity
verbosity Codebase IO Symbol Ann
codebase Runtime Symbol
runtime Runtime Symbol
sbRuntime Text
ucmVersion Text
baseURL AuthenticatedHttpClient
authenticatedHTTPClient CredentialManager
credMan Transcript
transcript = IO Transcript -> IO (Either Error Transcript)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
UnliftIO.try do
  let behaviors :: Behaviors Identity
behaviors = Settings -> Behaviors Identity
extractBehaviors (Settings -> Behaviors Identity) -> Settings -> Behaviors Identity
forall a b. (a -> b) -> a -> b
$ Transcript -> Settings
settings Transcript
transcript
  let stanzas' :: [Either Node ProcessedBlock]
stanzas' = Transcript -> [Either Node ProcessedBlock]
stanzas Transcript
transcript
  httpManager <- ManagerSettings -> IO Manager
HTTP.newManager ManagerSettings
HTTP.defaultManagerSettings
  (initialPP, emptyCausalHashId) <-
    Codebase.runTransaction codebase . liftA2 (,) Codebase.expectCurrentProjectPath $ snd <$> Codebase.emptyCausalHash

  unless (isSilent verbosity) . putPrettyLn $
    Pretty.lines
      [ asciiartUnison,
        "",
        "Running the provided transcript file...",
        ""
      ]
  -- 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'
  inputQueue <-
    Q.prepopulatedIO . Seq.fromList $
      filter (either (const True) (not . isGeneratedBlock)) stanzas' `zip` (Just <$> [1 :: Int ..])
  -- Queue of UCM commands to run.
  -- Nothing indicates the end of a ucm block.
  cmdQueue <- Q.newIO @(Maybe UcmLine)
  -- Queue of scratch file updates triggered by UCM itself, e.g. via `edit`, `update`, etc.
  ucmScratchFileUpdatesQueue <- Q.newIO @(ScratchFileName, Text)
  ucmOutput <- newIORef mempty
  unisonFiles <- newIORef Map.empty
  out <- newIORef mempty
  currentTags <- newIORef Nothing
  isHidden <- newIORef Shown
  allowErrors <- newIORef False
  expectFailure <- newIORef False
  hasErrors <- newIORef False
  mBlock <- newIORef Nothing
  let patternMap = [(String, InputPattern)] -> Map String InputPattern
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(String, InputPattern)] -> Map String InputPattern)
-> [(String, InputPattern)] -> Map String InputPattern
forall a b. (a -> b) -> a -> b
$ (\InputPattern
p -> (InputPattern -> String
patternName InputPattern
p, InputPattern
p) (String, InputPattern)
-> [(String, InputPattern)] -> [(String, InputPattern)]
forall a. a -> [a] -> [a]
: ((,InputPattern
p) (String -> (String, InputPattern))
-> [String] -> [(String, InputPattern)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputPattern -> [String]
aliases InputPattern
p)) (InputPattern -> [(String, InputPattern)])
-> [InputPattern] -> [(String, InputPattern)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [InputPattern]
IP.validInputs
  let output' :: Bool -> Stanza -> IO ()
      output' Bool
inputEcho Either Node ProcessedBlock
msg = do
        hide <- Bool -> IO Bool
hideOutput Bool
inputEcho
        unless hide $ modifyIORef' out (<> pure msg)

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

      hideOutput :: Bool -> IO Bool
      hideOutput Bool
inputEcho = Bool -> Hidden -> Bool
hideOutput' Bool
inputEcho (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
isHidden

      output, outputEcho :: Stanza -> IO ()
      output = Bool -> Either Node ProcessedBlock -> IO ()
output' Bool
False
      outputEcho = Bool -> Either Node ProcessedBlock -> IO ()
output' Bool
True

      outputUcmLine :: UcmLine -> IO ()
      outputUcmLine UcmLine
line = do
        prev <- IORef [UcmLine] -> IO [UcmLine]
forall a. IORef a -> IO a
readIORef IORef [UcmLine]
ucmOutput
        modifyIORef' ucmOutput (<> ((if not (null prev) then pure (UcmOutputLine "\n") else mempty) <> pure line))

      outputUcmResult :: Pretty.Pretty Pretty.ColorText -> IO ()
      outputUcmResult Pretty ColorText
line = do
        hide <- Bool -> IO Bool
hideOutput Bool
False
        unless hide . outputUcmLine . UcmOutputLine $
          -- We shorten the terminal width, because "Transcript" manages a 2-space indent for output lines.
          Pretty.toPlain (terminalWidth config - 2) line

      maybeDieWithMsg :: Pretty.Pretty Pretty.ColorText -> IO ()
      maybeDieWithMsg Pretty ColorText
msg = do
        IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
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, Bool) -> IO (Bool, Bool)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((Bool -> Bool -> (Bool, Bool))
-> IO Bool -> IO Bool -> IO (Bool, Bool)
forall a b c. (a -> b -> c) -> IO a -> IO b -> IO c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
allowErrors) (IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
expectFailure)) IO (Bool, Bool) -> ((Bool, Bool) -> 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
          (Bool
False, Bool
False) -> IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> (Text -> IO ()) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
forall a. Text -> IO a
dieWithMsg (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Width -> Pretty ColorText -> Text
Pretty.toPlain (Config -> Width
terminalWidth Config
config) Pretty ColorText
msg
          (Bool
True, Bool
True) -> do
            IO ()
appendFailingStanza
            Value -> IORef (Seq (Either Node ProcessedBlock)) -> Text -> IO ()
forall b.
Value -> IORef (Seq (Either Node ProcessedBlock)) -> Text -> IO b
fixedBug (Transcript -> Value
frontmatter Transcript
transcript) IORef (Seq (Either Node ProcessedBlock))
out (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
              [Text] -> Text
Text.unlines
                [ Text
"The stanza above marked with `:error :bug` is now failing with",
                  Text
"",
                  Text
"```",
                  Width -> Pretty ColorText -> Text
Pretty.toPlain (Config -> Width
terminalWidth Config
config) Pretty ColorText
msg,
                  Text
"```",
                  Text
"",
                  Text
"so you can remove `:bug` and close any appropriate Github issues. If the error message is different \
                  \from the expected error message, open a new issue and reference it in this transcript."
                ]
          (Bool
_, Bool
_) -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      doHttpRequest :: HTTP.Request -> IO Text
      doHttpRequest Request
req = do
        resp <- Response ByteString -> ByteString
forall body. Response body -> body
HTTP.responseBody (Response ByteString -> ByteString)
-> IO (Response ByteString) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
req Manager
httpManager
        case Aeson.eitherDecode @Aeson.Value resp of
          Left String
err -> Text -> IO Text
forall a. Text -> IO a
dieWithMsg (Text -> IO Text) -> (String -> Text) -> String -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> IO Text) -> String -> IO Text
forall a b. (a -> b) -> a -> b
$ String
"Error decoding response from " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Method -> String
BSC.unpack (Request -> Method
HTTP.method Request
req)) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
          Right Value
v -> 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
            Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> (ByteString -> String) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BL.unpack (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString
prettyBytes
      apiRequest :: APIRequest -> IO [APIRequest]
      apiRequest APIRequest
req = do
        hide <- Bool -> IO Bool
hideOutput Bool
False
        case req of
          -- We just discard this, because the runner will produce new output lines.
          APIResponse {} -> [APIRequest] -> IO [APIRequest]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
          APIComment {} -> [APIRequest] -> IO [APIRequest]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([APIRequest] -> IO [APIRequest])
-> [APIRequest] -> IO [APIRequest]
forall a b. (a -> b) -> a -> b
$ APIRequest -> [APIRequest]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure APIRequest
req
          GetRequest Text
path -> do
            httpReq <- case String -> Either SomeException Request
forall (m :: * -> *). MonadThrow m => String -> m Request
HTTP.parseRequest (Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
baseURL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path) of
              Left SomeException
err -> Text -> IO Request
forall a. Text -> IO a
dieWithMsg (SomeException -> Text
forall a. Show a => a -> Text
tShow SomeException
err)
              Right Request
r -> Request -> IO Request
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
r
            respTxt <- doHttpRequest httpReq
            if hide
              then pure [req]
              else pure [req, APIResponse respTxt]
          PostRequest Text
path Text
body -> do
            httpReq <- case String -> Either SomeException Request
forall (m :: * -> *). MonadThrow m => String -> m Request
HTTP.parseRequest (Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
baseURL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path) of
              Left SomeException
err -> Text -> IO Request
forall a. Text -> IO a
dieWithMsg (SomeException -> Text
forall a. Show a => a -> Text
tShow SomeException
err)
              Right Request
r ->
                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
r
                    { HTTP.method = "POST",
                      HTTP.requestBody = HTTP.RequestBodyBS (Text.encodeUtf8 body),
                      HTTP.requestHeaders = [("Content-Type", "application/json"), ("Accept", "application/json")]
                    }
            respTxt <- doHttpRequest httpReq
            if hide
              then pure [req]
              else pure [req, APIResponse respTxt]

      endUcmBlock = 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
$ do
          tags <- IORef (Maybe (InfoTags ())) -> IO (Maybe (InfoTags ()))
forall a. IORef a -> IO a
readIORef IORef (Maybe (InfoTags ()))
currentTags
          ucmOut <- readIORef ucmOutput
          unless (null ucmOut && tags == Nothing) . outputEcho . pure $
            Ucm (fromMaybe (defaultInfoTags mempty) {generated = True} tags) ucmOut
          writeIORef ucmOutput []
          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
          scratchFileUpdates <- TQueue (Text, Text) -> STM [(Text, Text)]
forall a. TQueue a -> STM [a]
Q.flush TQueue (Text, Text)
ucmScratchFileUpdatesQueue
          -- Push them onto the front stanza queue in the correct order.
          for (reverse scratchFileUpdates) \(Text
fp, Text
contents) ->
            -- Output blocks for any scratch file updates the ucm block triggered.
            TQueue (Either Node ProcessedBlock, Maybe Int)
-> (Either Node ProcessedBlock, Maybe Int) -> STM ()
forall a. TQueue a -> a -> STM ()
Q.undequeue TQueue (Either Node ProcessedBlock, Maybe Int)
inputQueue (ProcessedBlock -> Either Node ProcessedBlock
forall a. a -> Either Node a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProcessedBlock -> Either Node ProcessedBlock)
-> ProcessedBlock -> Either Node ProcessedBlock
forall a b. (a -> b) -> a -> b
$ InfoTags (Maybe Text) -> Text -> ProcessedBlock
Unison (Maybe Text -> InfoTags (Maybe Text)
forall a. a -> InfoTags a
defaultInfoTags (Maybe Text -> InfoTags (Maybe Text))
-> Maybe Text -> InfoTags (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
fp) {generated = True} Text
contents, Maybe Int
forall a. Maybe a
Nothing)
        Cli (Either Event Input)
forall a. Cli a
Cli.returnEarlyWithoutOutput

      processUcmLine UcmLine
p =
        case UcmLine
p of
          -- We just discard this, because the runner will produce new output lines.
          UcmOutputLine {} -> Cli (Either Event Input)
forall a. Cli a
Cli.returnEarlyWithoutOutput
          UcmComment {} -> 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
$ UcmLine -> IO ()
outputUcmLine UcmLine
p
            Cli (Either Event Input)
forall a. Cli a
Cli.returnEarlyWithoutOutput
          UcmCommand UcmContext
context Text
lineTxt -> do
            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.
            maybeSwitchCommand <- case context of
              UcmContext
UcmContextEmpty -> Maybe Input -> Cli (Maybe Input)
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Input
forall a. Maybe a
Nothing
              UcmContextProject (ProjectAndBranch ProjectName
projectName ProjectBranchName
branchName) -> Transaction (Maybe Input) -> Cli (Maybe Input)
forall a. Transaction a -> Cli a
Cli.runTransaction do
                Project {projectId, name = 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 <- 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)
                        Q.insertProject projectId projectName
                        pure $ Project {projectId, name = projectName}
                      Just Project
project -> Project -> Transaction Project
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Project
project
                projectAndBranchIds <-
                  Q.loadProjectBranchByName projectId branchName >>= \case
                    Maybe ProjectBranch
Nothing -> do
                      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)
                      Q.insertProjectBranch
                        "Branch Created"
                        emptyCausalHashId
                        ProjectBranchRow {projectId, parentBranchId = Nothing, branchId, name = branchName}
                      pure (ProjectAndBranch projectId branchId)
                    Just ProjectBranch
projBranch -> ProjectAndBranch ProjectId ProjectBranchId
-> Transaction (ProjectAndBranch ProjectId ProjectBranchId)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProjectId
-> ProjectBranchId -> ProjectAndBranch ProjectId ProjectBranchId
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch ProjectBranch
projBranch.projectId ProjectBranch
projBranch.branchId)
                pure
                  if (PP.toProjectAndBranch . PP.toIds $ curPath) == projectAndBranchIds
                    then Nothing
                    else Just (ProjectSwitchI (ProjectAndBranchNames'Unambiguous (These projectName branchName)))
            case maybeSwitchCommand of
              Just Input
switchCommand -> do
                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.undequeue TQueue (Maybe UcmLine)
cmdQueue (Maybe UcmLine -> Cli ()) -> Maybe UcmLine -> Cli ()
forall a b. (a -> b) -> a -> b
$ UcmLine -> Maybe UcmLine
forall a. a -> Maybe a
Just UcmLine
p
                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
switchCommand
              Maybe Input
Nothing -> do
                case [CliArg] -> Maybe [CliArg] -> [CliArg]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [CliArg] -> [CliArg]) -> Maybe [CliArg] -> [CliArg]
forall a b. (a -> b) -> a -> b
$ String -> Maybe [CliArg]
IP.parseArgs (Text -> String
Text.unpack Text
lineTxt) of
                  [] -> Cli (Either Event Input)
forall a. Cli a
Cli.returnEarlyWithoutOutput
                  [CliArg]
args -> 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
$ UcmLine -> IO ()
outputUcmLine UcmLine
p
                    numberedArgs <- Getting NumberedArgs LoopState NumberedArgs -> Cli NumberedArgs
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting NumberedArgs LoopState NumberedArgs
#numberedArgs
                    PP.ProjectAndBranch projId branchId <-
                      PP.toProjectAndBranch . NonEmpty.head <$> use #projectPathStack
                    let 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
                    liftIO (parseInput codebase curPath getProjectRoot numberedArgs patternMap args)
                      >>= either
                        -- invalid command is treated as a failure
                        ( \ParseFailure
failure -> do
                            let msg :: Pretty ColorText
msg = ParseFailure -> Pretty ColorText
reportParseFailure ParseFailure
failure
                            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
$ Pretty ColorText -> IO ()
outputUcmResult Pretty ColorText
msg
                            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
$ Pretty ColorText -> IO ()
maybeDieWithMsg Pretty ColorText
msg
                            Cli (Either Event Input)
forall a. Cli a
Cli.returnEarlyWithoutOutput
                        )
                        -- No input received from this line, try again.
                        (maybe Cli.returnEarlyWithoutOutput $ pure . Right . snd)

      startProcessedBlock ProcessedBlock
block = case ProcessedBlock
block of
        Unison InfoTags (Maybe Text)
infoTags Text
txt -> do
          -- Open a ucm block which will contain the output from UCM after processing the `UnisonFileChanged` event.
          -- Close the ucm block after processing the UnisonFileChanged event.
          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.enqueue TQueue (Maybe UcmLine)
cmdQueue Maybe UcmLine
forall a. Maybe a
Nothing
          IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
            IORef Hidden -> Hidden -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Hidden
isHidden (Hidden -> IO ()) -> Hidden -> IO ()
forall a b. (a -> b) -> a -> b
$ (Identity (ProcessedBlock -> Hidden) -> ProcessedBlock -> Hidden
forall a. Identity a -> a
runIdentity (Identity (ProcessedBlock -> Hidden) -> ProcessedBlock -> Hidden)
-> Identity (ProcessedBlock -> Hidden) -> ProcessedBlock -> Hidden
forall a b. (a -> b) -> a -> b
$ Behaviors Identity -> Identity (ProcessedBlock -> Hidden)
forall (f :: * -> *). Behaviors f -> f (ProcessedBlock -> Hidden)
getHidden Behaviors Identity
behaviors) ProcessedBlock
block
            Either Node ProcessedBlock -> IO ()
outputEcho (Either Node ProcessedBlock -> IO ())
-> Either Node ProcessedBlock -> IO ()
forall a b. (a -> b) -> a -> b
$ ProcessedBlock -> Either Node ProcessedBlock
forall a. a -> Either Node a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessedBlock
block
            IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
allowErrors (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ InfoTags (Maybe Text) -> Bool
forall a. InfoTags a -> Bool
expectingError InfoTags (Maybe Text)
infoTags
            IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
expectFailure (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ InfoTags (Maybe Text) -> Bool
forall a. InfoTags a -> Bool
hasBug InfoTags (Maybe Text)
infoTags
          let sourceName :: Text
sourceName = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"scratch.u" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ InfoTags (Maybe Text) -> Maybe Text
forall a. InfoTags a -> a
additionalTags InfoTags (Maybe Text)
infoTags
          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
$ Text -> Text -> IO ()
updateVirtualFile Text
sourceName Text
txt
          Bool -> Cli () -> Cli ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Identity Bool -> Bool
forall a. Identity a -> a
runIdentity (Behaviors Identity -> Identity Bool
forall (f :: * -> *). Behaviors f -> f Bool
autoupdate Behaviors Identity
behaviors)) 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 Hidden -> Hidden -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Hidden
isHidden Hidden
HideAll
            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
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UcmLine -> Cli ()) -> UcmLine -> Cli ()
forall a b. (a -> b) -> a -> b
$ UcmContext -> Text -> UcmLine
UcmCommand UcmContext
UcmContextEmpty Text
"update"
            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.enqueue TQueue (Maybe UcmLine)
cmdQueue Maybe UcmLine
forall a. Maybe a
Nothing
          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))
-> (Event -> Either Event Input)
-> Event
-> Cli (Either Event Input)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Either Event Input
forall a b. a -> Either a b
Left (Event -> Cli (Either Event Input))
-> Event -> Cli (Either Event Input)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Event
UnisonFileChanged Text
sourceName Text
txt
        API InfoTags ()
infoTags [APIRequest]
apiRequests -> do
          IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
            IORef Hidden -> Hidden -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Hidden
isHidden (Hidden -> IO ()) -> Hidden -> IO ()
forall a b. (a -> b) -> a -> b
$ (Identity (ProcessedBlock -> Hidden) -> ProcessedBlock -> Hidden
forall a. Identity a -> a
runIdentity (Identity (ProcessedBlock -> Hidden) -> ProcessedBlock -> Hidden)
-> Identity (ProcessedBlock -> Hidden) -> ProcessedBlock -> Hidden
forall a b. (a -> b) -> a -> b
$ Behaviors Identity -> Identity (ProcessedBlock -> Hidden)
forall (f :: * -> *). Behaviors f -> f (ProcessedBlock -> Hidden)
getHidden Behaviors Identity
behaviors) ProcessedBlock
block
            IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
allowErrors (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ InfoTags () -> Bool
forall a. InfoTags a -> Bool
expectingError InfoTags ()
infoTags
            IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
expectFailure (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ InfoTags () -> Bool
forall a. InfoTags a -> Bool
hasBug InfoTags ()
infoTags
            Either Node ProcessedBlock -> IO ()
outputEcho (Either Node ProcessedBlock -> IO ())
-> ([[APIRequest]] -> Either Node ProcessedBlock)
-> [[APIRequest]]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessedBlock -> Either Node ProcessedBlock
forall a. a -> Either Node a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProcessedBlock -> Either Node ProcessedBlock)
-> ([[APIRequest]] -> ProcessedBlock)
-> [[APIRequest]]
-> Either Node ProcessedBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InfoTags () -> [APIRequest] -> ProcessedBlock
API InfoTags ()
infoTags ([APIRequest] -> ProcessedBlock)
-> ([[APIRequest]] -> [APIRequest])
-> [[APIRequest]]
-> ProcessedBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[APIRequest]] -> [APIRequest]
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([[APIRequest]] -> IO ()) -> IO [[APIRequest]] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (APIRequest -> IO [APIRequest])
-> [APIRequest] -> IO [[APIRequest]]
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) -> [a] -> f [b]
traverse APIRequest -> IO [APIRequest]
apiRequest [APIRequest]
apiRequests
          Cli (Either Event Input)
forall a. Cli a
Cli.returnEarlyWithoutOutput
        Ucm InfoTags ()
infoTags [UcmLine]
cmds -> do
          IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
            IORef (Maybe (InfoTags ())) -> Maybe (InfoTags ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (InfoTags ()))
currentTags (Maybe (InfoTags ()) -> IO ()) -> Maybe (InfoTags ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ InfoTags () -> Maybe (InfoTags ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InfoTags ()
infoTags
            IORef Hidden -> Hidden -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Hidden
isHidden (Hidden -> IO ()) -> Hidden -> IO ()
forall a b. (a -> b) -> a -> b
$ (Identity (ProcessedBlock -> Hidden) -> ProcessedBlock -> Hidden
forall a. Identity a -> a
runIdentity (Identity (ProcessedBlock -> Hidden) -> ProcessedBlock -> Hidden)
-> Identity (ProcessedBlock -> Hidden) -> ProcessedBlock -> Hidden
forall a b. (a -> b) -> a -> b
$ Behaviors Identity -> Identity (ProcessedBlock -> Hidden)
forall (f :: * -> *). Behaviors f -> f (ProcessedBlock -> Hidden)
getHidden Behaviors Identity
behaviors) ProcessedBlock
block
            IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
allowErrors (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ InfoTags () -> Bool
forall a. InfoTags a -> Bool
expectingError InfoTags ()
infoTags
            IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
expectFailure (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ InfoTags () -> Bool
forall a. InfoTags a -> Bool
hasBug InfoTags ()
infoTags
          (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)
forall a. Cli a
Cli.returnEarlyWithoutOutput

      showStatus Bool
alwaysShow String
indicator String
msg = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> Bool
not Bool
alwaysShow Bool -> Bool -> Bool
&& Verbosity -> Bool
Verbosity.isSilent Verbosity
verbosity) do
        IO ()
clearCurrentLine
        String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\r" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
indicator String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"   " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg
        Handle -> IO ()
IO.hFlush Handle
IO.stdout

      finishTranscript = do
        Bool -> String -> String -> IO ()
showStatus Bool
True String
"✔️" String
"Completed transcript.\n"
        Either Event Input -> IO (Either Event Input)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Event Input -> IO (Either Event Input))
-> Either Event Input -> IO (Either Event Input)
forall a b. (a -> b) -> a -> b
$ Input -> Either Event Input
forall a b. b -> Either a b
Right Input
QuitI

      processStanza Either Node ProcessedBlock
stanza Maybe Int
midx = do
        IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Cli ()) -> (String -> IO ()) -> String -> Cli ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> String -> String -> IO ()
showStatus Bool
False String
"⚙️" (String -> Cli ()) -> String -> Cli ()
forall a b. (a -> b) -> a -> b
$
          String -> (Int -> String) -> Maybe Int -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            String
"Processing UCM-generated stanza."
            (\Int
idx -> String
"Processing stanza " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
idx String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([Either Node ProcessedBlock] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either Node ProcessedBlock]
stanzas') String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".")
            Maybe Int
midx
        (Node -> Cli (Either Event Input))
-> (ProcessedBlock -> Cli (Either Event Input))
-> Either Node ProcessedBlock
-> Cli (Either Event Input)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
          (Either Node ProcessedBlock -> Cli (Either Event Input)
forall {b}. Either Node ProcessedBlock -> Cli b
bypassStanza (Either Node ProcessedBlock -> Cli (Either Event Input))
-> (Node -> Either Node ProcessedBlock)
-> Node
-> Cli (Either Event Input)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> Either Node ProcessedBlock
forall a b. a -> Either a b
Left)
          ( \ProcessedBlock
block ->
              if ProcessedBlock -> Bool
isGeneratedBlock ProcessedBlock
block
                then Either Node ProcessedBlock -> Cli (Either Event Input)
forall {b}. Either Node ProcessedBlock -> Cli b
bypassStanza (Either Node ProcessedBlock -> Cli (Either Event Input))
-> Either Node ProcessedBlock -> Cli (Either Event Input)
forall a b. (a -> b) -> a -> b
$ ProcessedBlock -> Either Node ProcessedBlock
forall a. a -> Either Node a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessedBlock
block
                else do
                  IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Cli ())
-> (Maybe ProcessedBlock -> IO ())
-> Maybe ProcessedBlock
-> Cli ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (Maybe ProcessedBlock) -> Maybe ProcessedBlock -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe ProcessedBlock)
mBlock (Maybe ProcessedBlock -> Cli ()) -> Maybe ProcessedBlock -> Cli ()
forall a b. (a -> b) -> a -> b
$ ProcessedBlock -> Maybe ProcessedBlock
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessedBlock
block
                  ProcessedBlock -> Cli (Either Event Input)
startProcessedBlock ProcessedBlock
block
          )
          Either Node ProcessedBlock
stanza

      bypassStanza Either Node ProcessedBlock
stanza = 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
$ Either Node ProcessedBlock -> IO ()
output Either Node ProcessedBlock
stanza
        Cli b
forall a. Cli a
Cli.returnEarlyWithoutOutput

      whatsNext = 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 (IO () -> Cli ()) -> IO () -> Cli ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe (InfoTags ())) -> Maybe (InfoTags ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (InfoTags ()))
currentTags Maybe (InfoTags ())
forall a. Maybe a
Nothing
        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 Hidden -> Hidden -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Hidden
isHidden Hidden
Shown
        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
allowErrors Bool
False
        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
expectFailure Bool
False
        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
False
        Cli (Either Event Input)
-> ((Either Node ProcessedBlock, Maybe Int)
    -> Cli (Either Event Input))
-> Maybe (Either Node ProcessedBlock, Maybe Int)
-> Cli (Either Event Input)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO (Either Event Input) -> Cli (Either Event Input)
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Either Event Input)
finishTranscript) ((Either Node ProcessedBlock
 -> Maybe Int -> Cli (Either Event Input))
-> (Either Node ProcessedBlock, Maybe Int)
-> Cli (Either Event Input)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Either Node ProcessedBlock -> Maybe Int -> Cli (Either Event Input)
processStanza) (Maybe (Either Node ProcessedBlock, Maybe Int)
 -> Cli (Either Event Input))
-> Cli (Maybe (Either Node ProcessedBlock, Maybe Int))
-> Cli (Either Event Input)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< STM (Maybe (Either Node ProcessedBlock, Maybe Int))
-> Cli (Maybe (Either Node ProcessedBlock, Maybe Int))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TQueue (Either Node ProcessedBlock, Maybe Int)
-> STM (Maybe (Either Node ProcessedBlock, Maybe Int))
forall a. TQueue a -> STM (Maybe a)
Q.tryDequeue TQueue (Either Node ProcessedBlock, Maybe Int)
inputQueue)

      awaitInput :: Cli (Either Event Input)
      awaitInput = Cli (Either Event Input)
-> (Maybe UcmLine -> Cli (Either Event Input))
-> Maybe (Maybe UcmLine)
-> Cli (Either Event Input)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Cli (Either Event Input)
whatsNext (Cli (Either Event Input)
-> (UcmLine -> Cli (Either Event Input))
-> Maybe UcmLine
-> Cli (Either Event Input)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Cli (Either Event Input)
endUcmBlock UcmLine -> Cli (Either Event Input)
processUcmLine) (Maybe (Maybe UcmLine) -> Cli (Either Event Input))
-> Cli (Maybe (Maybe UcmLine)) -> Cli (Either Event Input)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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)

      loadPreviousUnisonBlock Text
name =
        IO LoadSourceResult
-> (Text -> IO LoadSourceResult)
-> Maybe Text
-> IO LoadSourceResult
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          -- This lets transcripts use the `load` command, as in:
          --
          -- .> load someFile.u
          ((Text -> LoadSourceResult) -> IO Text -> IO LoadSourceResult
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> LoadSourceResult
Cli.LoadSuccess (String -> IO Text
readUtf8 (String -> IO Text) -> String -> IO Text
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
name) 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)
          (LoadSourceResult -> IO LoadSourceResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LoadSourceResult -> IO LoadSourceResult)
-> (Text -> LoadSourceResult) -> Text -> IO LoadSourceResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LoadSourceResult
Cli.LoadSuccess)
          (Maybe Text -> IO LoadSourceResult)
-> (Map Text Text -> Maybe Text)
-> Map Text Text
-> IO LoadSourceResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name
          (Map Text Text -> IO LoadSourceResult)
-> IO (Map Text Text) -> IO LoadSourceResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (Map Text Text) -> IO (Map Text Text)
forall a. IORef a -> IO a
readIORef IORef (Map Text Text)
unisonFiles

      writeSource :: ScratchFileName -> Text -> Bool -> IO ()
      writeSource Text
fp Text
contents Bool
_addFold = do
        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
isHidden
        when shouldShowSourceChanges . atomically $ Q.enqueue ucmScratchFileUpdatesQueue (fp, contents)
        updateVirtualFile fp contents

      updateVirtualFile :: ScratchFileName -> Text -> IO ()
      updateVirtualFile Text
fp = IORef (Map Text Text) -> (Map Text Text -> Map Text Text) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Map Text Text)
unisonFiles ((Map Text Text -> Map Text Text) -> IO ())
-> (Text -> Map Text Text -> Map Text Text) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
fp

      print :: Output.Output -> IO ()
      print Output
o = do
        -- NB: We have a directory, but we don’t pass it to the notifier because it’s a temp dir, and if it ends up in
        --     transcript output, it makes transcripts non-reproducible.
        msg <- Maybe String
-> (Word -> IO (Pretty ColorText))
-> Output
-> IO (Pretty ColorText)
notifyUser Maybe String
forall a. Maybe a
Nothing Word -> IO (Pretty ColorText)
forall (f :: * -> *). Applicative f => Word -> f (Pretty ColorText)
showIssueUrl Output
o
        outputUcmResult msg
        when (Output.isFailure o) $ maybeDieWithMsg msg

      printNumbered :: Output.NumberedOutput -> IO Output.NumberedArgs
      printNumbered NumberedOutput
o = do
        let (Pretty ColorText
msg, NumberedArgs
numberedArgs) = NumberedOutput -> (Pretty ColorText, NumberedArgs)
notifyNumbered NumberedOutput
o
        Pretty ColorText -> IO ()
outputUcmResult Pretty ColorText
msg
        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
$ Pretty ColorText -> IO ()
maybeDieWithMsg Pretty ColorText
msg
        NumberedArgs -> IO NumberedArgs
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NumberedArgs
numberedArgs

      -- Looks at the current stanza and decides if it is contained in the
      -- output so far. Appends it if not.
      appendFailingStanza :: IO ()
      appendFailingStanza = do
        blockOpt <- IORef (Maybe ProcessedBlock) -> IO (Maybe ProcessedBlock)
forall a. IORef a -> IO a
readIORef IORef (Maybe ProcessedBlock)
mBlock
        currentOut <- readIORef out
        maybe
          (pure ())
          (\ProcessedBlock
block -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Either Node ProcessedBlock
-> Seq (Either Node ProcessedBlock) -> Bool
forall a. Eq a => a -> Seq a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (ProcessedBlock -> Either Node ProcessedBlock
forall a. a -> Either Node a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessedBlock
block) Seq (Either Node ProcessedBlock)
currentOut) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (Seq (Either Node ProcessedBlock))
-> (Seq (Either Node ProcessedBlock)
    -> Seq (Either Node ProcessedBlock))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Seq (Either Node ProcessedBlock))
out (Seq (Either Node ProcessedBlock)
-> Seq (Either Node ProcessedBlock)
-> Seq (Either Node ProcessedBlock)
forall a. Semigroup a => a -> a -> a
<> Either Node ProcessedBlock -> Seq (Either Node ProcessedBlock)
forall a. a -> Seq a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProcessedBlock -> Either Node ProcessedBlock
forall a. a -> Either Node a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessedBlock
block)))
          blockOpt

      dieWithMsg :: forall a. Text -> IO a
      dieWithMsg Text
msg = do
        IO ()
appendFailingStanza
        Value
-> IORef (Seq (Either Node ProcessedBlock))
-> Text
-> Maybe Text
-> IO a
forall b.
Value
-> IORef (Seq (Either Node ProcessedBlock))
-> Text
-> Maybe Text
-> IO b
transcriptFailure
          (Transcript -> Value
frontmatter Transcript
transcript)
          IORef (Seq (Either Node ProcessedBlock))
out
          Text
"The transcript failed due to an error in the stanza above. The error is:"
          (Maybe Text -> IO a) -> (Text -> Maybe Text) -> Text -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          (Text -> IO a) -> Text -> IO a
forall a b. (a -> b) -> a -> b
$ Text
msg

      dieUnexpectedSuccess :: IO ()
      dieUnexpectedSuccess = do
        errOk <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
allowErrors
        expectBug <- readIORef expectFailure
        hasErr <- readIORef hasErrors
        case (errOk, expectBug, hasErr) of
          (Bool
True, Bool
False, Bool
False) -> do
            IO ()
appendFailingStanza
            Value
-> IORef (Seq (Either Node ProcessedBlock))
-> Text
-> Maybe Text
-> IO ()
forall b.
Value
-> IORef (Seq (Either Node ProcessedBlock))
-> Text
-> Maybe Text
-> IO b
transcriptFailure
              (Transcript -> Value
frontmatter Transcript
transcript)
              IORef (Seq (Either Node ProcessedBlock))
out
              Text
"The transcript was expecting an error in the stanza above, but did not encounter one."
              Maybe Text
forall a. Maybe a
Nothing
          (Bool
False, Bool
True, Bool
False) -> do
            Value -> IORef (Seq (Either Node ProcessedBlock)) -> Text -> IO ()
forall b.
Value -> IORef (Seq (Either Node ProcessedBlock)) -> Text -> IO b
fixedBug
              (Transcript -> Value
frontmatter Transcript
transcript)
              IORef (Seq (Either Node ProcessedBlock))
out
              Text
"The stanza above with `:bug` is now passing! You can remove `:bug` and close any appropriate Github \
              \issues."
          (Bool
_, Bool
_, Bool
_) -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  seedRef <- newIORef (0 :: Int)

  let env =
        Cli.Env
          { authHTTPClient :: AuthenticatedHttpClient
authHTTPClient = AuthenticatedHttpClient
authenticatedHTTPClient,
            Codebase IO Symbol Ann
codebase :: Codebase IO Symbol Ann
codebase :: Codebase IO Symbol Ann
codebase,
            credentialManager :: CredentialManager
credentialManager = CredentialManager
credMan,
            generateUniqueName :: IO UniqueName
generateUniqueName = do
              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 (Parser.uniqueBase32Namegen (Random.drgNewSeed (Random.seedFromInteger (fromIntegral i)))),
            loadSource :: Text -> IO LoadSourceResult
loadSource = Text -> IO LoadSourceResult
loadPreviousUnisonBlock,
            lspCheckForChanges :: ProjectPathG ProjectId ProjectBranchId -> IO ()
lspCheckForChanges = \ProjectPathG ProjectId ProjectBranchId
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
            Text -> Text -> Bool -> IO ()
writeSource :: Text -> Text -> Bool -> IO ()
writeSource :: Text -> Text -> Bool -> IO ()
writeSource,
            notify :: Output -> IO ()
notify = Output -> IO ()
print,
            notifyNumbered :: NumberedOutput -> IO NumberedArgs
notifyNumbered = NumberedOutput -> IO NumberedArgs
printNumbered,
            Runtime Symbol
runtime :: Runtime Symbol
runtime :: Runtime Symbol
runtime,
            sandboxedRuntime :: Runtime Symbol
sandboxedRuntime = Runtime Symbol
sbRuntime,
            serverBaseUrl :: Maybe BaseUrl
serverBaseUrl = Maybe BaseUrl
forall a. Maybe a
Nothing,
            Text
ucmVersion :: Text
ucmVersion :: Text
ucmVersion,
            isTranscriptTest :: Bool
isTranscriptTest = Config -> Bool
isTest Config
config,
            -- Transcripts don't support file watching
            watchState :: Maybe WatchState
watchState = Maybe WatchState
forall a. Maybe a
Nothing
          }

  let loop :: Cli.LoopState -> IO (Seq Stanza)
      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 (Seq (Either Node ProcessedBlock)))
-> IO (Seq (Either Node ProcessedBlock))
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) ->
            let next :: LoopState -> IO (Seq (Either Node ProcessedBlock))
next LoopState
s = LoopState -> IO (Seq (Either Node ProcessedBlock))
loop (LoopState -> IO (Seq (Either Node ProcessedBlock)))
-> LoopState -> IO (Seq (Either Node ProcessedBlock))
forall a b. (a -> b) -> a -> b
$ (Event -> LoopState)
-> (Input -> LoopState) -> Either Event Input -> LoopState
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (LoopState -> Event -> LoopState
forall a b. a -> b -> a
const LoopState
s) (\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) Either Event Input
input
             in 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 (Seq (Either Node ProcessedBlock)))
-> IO (Seq (Either Node ProcessedBlock))
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 (Seq (Either Node ProcessedBlock))
next LoopState
s2
                  (ReturnType ()
Cli.Continue, LoopState
s2) -> LoopState -> IO (Seq (Either Node ProcessedBlock))
next LoopState
s2
                  (ReturnType ()
Cli.HaltRepl, LoopState
_) -> IO (Seq (Either Node ProcessedBlock))
onHalt
          (ReturnType (Either Event Input)
Cli.Continue, LoopState
s1) -> LoopState -> IO (Seq (Either Node ProcessedBlock))
loop LoopState
s1
          (ReturnType (Either Event Input)
Cli.HaltRepl, LoopState
_) -> IO (Seq (Either Node ProcessedBlock))
onHalt
        where
          onHalt :: IO (Seq (Either Node ProcessedBlock))
onHalt = IORef (Seq (Either Node ProcessedBlock))
-> IO (Seq (Either Node ProcessedBlock))
forall a. IORef a -> IO a
readIORef IORef (Seq (Either Node ProcessedBlock))
out

  Transcript (frontmatter transcript) . toList <$> loop (Cli.loopState0 (PP.toIds initialPP))

transcriptFailure :: Aeson.Value -> IORef (Seq Stanza) -> Text -> Maybe Text -> IO b
transcriptFailure :: forall b.
Value
-> IORef (Seq (Either Node ProcessedBlock))
-> Text
-> Maybe Text
-> IO b
transcriptFailure Value
frontmatter IORef (Seq (Either Node ProcessedBlock))
out Text
heading Maybe Text
mbody = do
  texts <- IORef (Seq (Either Node ProcessedBlock))
-> IO (Seq (Either Node ProcessedBlock))
forall a. IORef a -> IO a
readIORef IORef (Seq (Either Node ProcessedBlock))
out
  UnliftIO.throwIO . RunFailure . Transcript frontmatter $
    toList texts
      <> ( Left
             <$> [ CMark.Node Nothing CMark.PARAGRAPH [CMark.Node Nothing (CMark.TEXT "🛑") []],
                   CMark.Node Nothing CMark.PARAGRAPH [CMark.Node Nothing (CMark.TEXT heading) []]
                 ]
               <> foldr ((:) . CMarkCodeBlock Nothing "") [] mbody
         )

fixedBug :: Aeson.Value -> IORef (Seq Stanza) -> Text -> IO b
fixedBug :: forall b.
Value -> IORef (Seq (Either Node ProcessedBlock)) -> Text -> IO b
fixedBug Value
frontmatter IORef (Seq (Either Node ProcessedBlock))
out Text
body = do
  texts <- IORef (Seq (Either Node ProcessedBlock))
-> IO (Seq (Either Node ProcessedBlock))
forall a. IORef a -> IO a
readIORef IORef (Seq (Either Node ProcessedBlock))
out
  -- `CMark.commonmarkToNode` returns a @DOCUMENT@, which won’t be rendered inside another document, so we strip the
  -- outer `CMark.Node`.
  let CMark.Node _ _DOCUMENT bodyNodes = CMark.commonmarkToNode [CMark.optNormalize] body
  UnliftIO.throwIO . RunFailure . Transcript frontmatter $
    toList texts
      <> ( Left
             <$> [ CMark.Node Nothing CMark.PARAGRAPH [CMark.Node Nothing (CMark.TEXT "🎉") []],
                   CMark.Node Nothing (CMark.HEADING 2) [CMark.Node Nothing (CMark.TEXT "You fixed a bug!") []]
                 ]
               <> bodyNodes
         )

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