{-# LANGUAGE DeriveAnyClass #-}

-- | Execute transcripts.
module Unison.Codebase.Transcript.Runner
  ( Error (..),
    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.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.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 :: String
accessTokenEnvVarKey = String
"UNISON_SHARE_ACCESS_TOKEN"

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

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 -> Text -> String -> (Runner -> m r) -> m r
withRunner Bool
isTest Verbosity
verbosity Text
ucmVersion String
nrtp Runner -> m r
action =
  String
-> (Runtime Symbol -> Runtime Symbol -> Runtime Symbol -> m r)
-> m r
forall a.
String
-> (Runtime Symbol -> Runtime Symbol -> Runtime Symbol -> m a)
-> m a
withRuntimes String
nrtp \Runtime Symbol
runtime Runtime Symbol
sbRuntime Runtime Symbol
nRuntime ->
    Runner -> m r
action \String
transcriptName Text
transcriptSrc (String
codebaseDir, Codebase IO Symbol Ann
codebase) ->
      BackendEnv
-> CodebaseServerOpts
-> Runtime Symbol
-> Codebase IO Symbol Ann
-> (BaseUrl
    -> IO (Either Error (Seq (Either Node ProcessedBlock))))
-> IO (Either Error (Seq (Either Node ProcessedBlock)))
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 ->
          (ParseErrorBundle Text Void
 -> IO (Either Error (Seq (Either Node ProcessedBlock))))
-> ([Either Node ProcessedBlock]
    -> IO (Either Error (Seq (Either Node ProcessedBlock))))
-> Either (ParseErrorBundle Text Void) [Either Node ProcessedBlock]
-> IO (Either Error (Seq (Either Node ProcessedBlock)))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
            (Either Error (Seq (Either Node ProcessedBlock))
-> IO (Either Error (Seq (Either Node ProcessedBlock)))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error (Seq (Either Node ProcessedBlock))
 -> IO (Either Error (Seq (Either Node ProcessedBlock))))
-> (ParseErrorBundle Text Void
    -> Either Error (Seq (Either Node ProcessedBlock)))
-> ParseErrorBundle Text Void
-> IO (Either Error (Seq (Either Node ProcessedBlock)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Either Error (Seq (Either Node ProcessedBlock))
forall a b. a -> Either a b
Left (Error -> Either Error (Seq (Either Node ProcessedBlock)))
-> (ParseErrorBundle Text Void -> Error)
-> ParseErrorBundle Text Void
-> Either Error (Seq (Either Node ProcessedBlock))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text Void -> Error
ParseError)
            (Bool
-> Verbosity
-> String
-> Codebase IO Symbol Ann
-> Runtime Symbol
-> Runtime Symbol
-> Runtime Symbol
-> Text
-> Text
-> [Either Node ProcessedBlock]
-> IO (Either Error (Seq (Either Node ProcessedBlock)))
run Bool
isTest Verbosity
verbosity String
codebaseDir Codebase IO Symbol Ann
codebase Runtime Symbol
runtime Runtime Symbol
sbRuntime Runtime Symbol
nRuntime Text
ucmVersion (Text
 -> [Either Node ProcessedBlock]
 -> IO (Either Error (Seq (Either Node ProcessedBlock))))
-> Text
-> [Either Node ProcessedBlock]
-> IO (Either Error (Seq (Either Node ProcessedBlock)))
forall a b. (a -> b) -> a -> b
$ BaseUrl -> Text
forall a. Show a => a -> Text
tShow BaseUrl
baseUrl)
            (Either (ParseErrorBundle Text Void) [Either Node ProcessedBlock]
 -> IO (Either Error (Seq (Either Node ProcessedBlock))))
-> Either (ParseErrorBundle Text Void) [Either Node ProcessedBlock]
-> IO (Either Error (Seq (Either Node ProcessedBlock)))
forall a b. (a -> b) -> a -> b
$ String
-> Text
-> Either (ParseErrorBundle Text Void) [Either Node ProcessedBlock]
Transcript.stanzas String
transcriptName Text
transcriptSrc
  where
    withRuntimes ::
      FilePath -> (Runtime.Runtime Symbol -> Runtime.Runtime Symbol -> Runtime.Runtime Symbol -> m a) -> m a
    withRuntimes :: forall a.
String
-> (Runtime Symbol -> Runtime Symbol -> Runtime Symbol -> m a)
-> m a
withRuntimes String
nrtp Runtime Symbol -> 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 -> 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 (Text -> String -> IO (Runtime Symbol)
RTI.startNativeRuntime Text
ucmVersion String
nrtp)

isGeneratedBlock :: ProcessedBlock -> Bool
isGeneratedBlock :: ProcessedBlock -> Bool
isGeneratedBlock = \case
  Ucm InfoTags {Bool
generated :: Bool
$sel:generated:InfoTags :: forall a. InfoTags a -> Bool
generated} [UcmLine]
_ -> Bool
generated
  Unison InfoTags {Bool
$sel:generated:InfoTags :: forall a. InfoTags a -> Bool
generated :: Bool
generated} Text
_ -> Bool
generated
  API InfoTags {Bool
$sel:generated:InfoTags :: forall a. InfoTags a -> Bool
generated :: Bool
generated} [APIRequest]
_ -> Bool
generated

run ::
  -- | Whether to treat this transcript run as a transcript test, which will try to make output deterministic
  Bool ->
  Verbosity ->
  FilePath ->
  Codebase IO Symbol Ann ->
  Runtime.Runtime Symbol ->
  Runtime.Runtime Symbol ->
  Runtime.Runtime Symbol ->
  UCMVersion ->
  Text ->
  [Stanza] ->
  IO (Either Error (Seq Stanza))
run :: Bool
-> Verbosity
-> String
-> Codebase IO Symbol Ann
-> Runtime Symbol
-> Runtime Symbol
-> Runtime Symbol
-> Text
-> Text
-> [Either Node ProcessedBlock]
-> IO (Either Error (Seq (Either Node ProcessedBlock)))
run Bool
isTest Verbosity
verbosity String
dir Codebase IO Symbol Ann
codebase Runtime Symbol
runtime Runtime Symbol
sbRuntime Runtime Symbol
nRuntime Text
ucmVersion Text
baseURL [Either Node ProcessedBlock]
stanzas = IO (Seq (Either Node ProcessedBlock))
-> IO (Either Error (Seq (Either Node ProcessedBlock)))
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 (Transaction (ProjectPath, CausalHashId)
 -> IO (ProjectPath, CausalHashId))
-> (Transaction CausalHashId
    -> Transaction (ProjectPath, CausalHashId))
-> Transaction CausalHashId
-> IO (ProjectPath, CausalHashId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProjectPath -> CausalHashId -> (ProjectPath, CausalHashId))
-> Transaction ProjectPath
-> Transaction CausalHashId
-> Transaction (ProjectPath, CausalHashId)
forall a b c.
(a -> b -> c) -> Transaction a -> Transaction b -> Transaction c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) Transaction ProjectPath
HasCallStack => Transaction ProjectPath
Codebase.expectCurrentProjectPath (Transaction CausalHashId -> IO (ProjectPath, CausalHashId))
-> Transaction CausalHashId -> IO (ProjectPath, CausalHashId)
forall a b. (a -> b) -> a -> b
$ (CausalHash, CausalHashId) -> CausalHashId
forall a b. (a, b) -> b
snd ((CausalHash, CausalHashId) -> CausalHashId)
-> Transaction (CausalHash, CausalHashId)
-> Transaction CausalHashId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Transaction (CausalHash, CausalHashId)
Codebase.emptyCausalHash

  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 Text
mayShareAccessToken <- (String -> Text) -> Maybe String -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
Text.pack (Maybe String -> Maybe Text)
-> IO (Maybe String) -> IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
accessTokenEnvVarKey
  CredentialManager
credMan <- IO CredentialManager
forall (m :: * -> *). MonadIO m => m CredentialManager
AuthN.newCredentialManager
  let tokenProvider :: AuthN.TokenProvider
      tokenProvider :: TokenProvider
tokenProvider =
        TokenProvider
-> (Text -> TokenProvider) -> Maybe Text -> TokenProvider
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          (CredentialManager -> TokenProvider
AuthN.newTokenProvider CredentialManager
credMan)
          (\Text
accessToken CodeserverId
_codeserverID -> Either CredentialFailure Text -> IO (Either CredentialFailure Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CredentialFailure Text
 -> IO (Either CredentialFailure Text))
-> Either CredentialFailure Text
-> IO (Either CredentialFailure Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either CredentialFailure Text
forall a b. b -> Either a b
Right Text
accessToken)
          Maybe Text
mayShareAccessToken
  -- 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 (Either Node ProcessedBlock, Maybe Int)
inputQueue <-
    Seq (Either Node ProcessedBlock, Maybe Int)
-> IO (TQueue (Either Node ProcessedBlock, Maybe Int))
forall a (m :: * -> *). MonadIO m => Seq a -> m (TQueue a)
Q.prepopulatedIO (Seq (Either Node ProcessedBlock, Maybe Int)
 -> IO (TQueue (Either Node ProcessedBlock, Maybe Int)))
-> ([(Either Node ProcessedBlock, Maybe Int)]
    -> Seq (Either Node ProcessedBlock, Maybe Int))
-> [(Either Node ProcessedBlock, Maybe Int)]
-> IO (TQueue (Either Node ProcessedBlock, Maybe Int))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Either Node ProcessedBlock, Maybe Int)]
-> Seq (Either Node ProcessedBlock, Maybe Int)
forall a. [a] -> Seq a
Seq.fromList ([(Either Node ProcessedBlock, Maybe Int)]
 -> IO (TQueue (Either Node ProcessedBlock, Maybe Int)))
-> [(Either Node ProcessedBlock, Maybe Int)]
-> IO (TQueue (Either Node ProcessedBlock, Maybe Int))
forall a b. (a -> b) -> a -> b
$
      (Either Node ProcessedBlock -> Bool)
-> [Either Node ProcessedBlock] -> [Either Node ProcessedBlock]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Node -> Bool)
-> (ProcessedBlock -> Bool) -> Either Node ProcessedBlock -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> Node -> Bool
forall a b. a -> b -> a
const Bool
True) (Bool -> Bool
not (Bool -> Bool)
-> (ProcessedBlock -> Bool) -> ProcessedBlock -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessedBlock -> Bool
isGeneratedBlock)) [Either Node ProcessedBlock]
stanzas [Either Node ProcessedBlock]
-> [Maybe Int] -> [(Either Node ProcessedBlock, 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 ..])
  -- 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 (Text, Text)
ucmScratchFileUpdatesQueue <- forall a (m :: * -> *). MonadIO m => m (TQueue a)
Q.newIO @(ScratchFileName, Text)
  IORef [UcmLine]
ucmOutput <- [UcmLine] -> IO (IORef [UcmLine])
forall a. a -> IO (IORef a)
newIORef [UcmLine]
forall a. Monoid a => a
mempty
  IORef (Map Text Text)
unisonFiles <- Map Text Text -> IO (IORef (Map Text Text))
forall a. a -> IO (IORef a)
newIORef Map Text Text
forall k a. Map k a
Map.empty
  IORef (Seq (Either Node ProcessedBlock))
out <- Seq (Either Node ProcessedBlock)
-> IO (IORef (Seq (Either Node ProcessedBlock)))
forall a. a -> IO (IORef a)
newIORef Seq (Either Node ProcessedBlock)
forall a. Monoid a => a
mempty
  IORef (Maybe (InfoTags ()))
currentTags <- Maybe (InfoTags ()) -> IO (IORef (Maybe (InfoTags ())))
forall a. a -> IO (IORef a)
newIORef Maybe (InfoTags ())
forall a. Maybe a
Nothing
  IORef Hidden
isHidden <- 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
expectFailure <- 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 ProcessedBlock)
mBlock <- Maybe ProcessedBlock -> IO (IORef (Maybe ProcessedBlock))
forall a. a -> IO (IORef a)
newIORef Maybe ProcessedBlock
forall a. Maybe a
Nothing
  let patternMap :: Map String InputPattern
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]
validInputs
  let output' :: Bool -> Stanza -> IO ()
      output' :: Bool -> Either Node ProcessedBlock -> IO ()
output' Bool
inputEcho Either Node ProcessedBlock
msg = do
        Bool
hide <- Bool -> IO Bool
hideOutput Bool
inputEcho
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hide (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 Either Node ProcessedBlock
msg)

      hideOutput' :: Bool -> Hidden -> Bool
      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 -> 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 :: Either Node ProcessedBlock -> IO ()
output = Bool -> Either Node ProcessedBlock -> IO ()
output' Bool
False
      outputEcho :: Either Node ProcessedBlock -> IO ()
outputEcho = Bool -> Either Node ProcessedBlock -> IO ()
output' Bool
True

      outputUcmLine :: UcmLine -> IO ()
      outputUcmLine :: UcmLine -> IO ()
outputUcmLine UcmLine
line = do
        [UcmLine]
prev <- IORef [UcmLine] -> IO [UcmLine]
forall a. IORef a -> IO a
readIORef IORef [UcmLine]
ucmOutput
        IORef [UcmLine] -> ([UcmLine] -> [UcmLine]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [UcmLine]
ucmOutput ([UcmLine] -> [UcmLine] -> [UcmLine]
forall a. Semigroup a => a -> a -> a
<> ((if Bool -> Bool
not ([UcmLine] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UcmLine]
prev) then UcmLine -> [UcmLine]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> UcmLine
UcmOutputLine Text
"\n") else [UcmLine]
forall a. Monoid a => a
mempty) [UcmLine] -> [UcmLine] -> [UcmLine]
forall a. Semigroup a => a -> a -> a
<> UcmLine -> [UcmLine]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure UcmLine
line))

      outputUcmResult :: Pretty.Pretty Pretty.ColorText -> IO ()
      outputUcmResult :: Pretty ColorText -> IO ()
outputUcmResult Pretty ColorText
line = do
        Bool
hide <- Bool -> IO Bool
hideOutput Bool
False
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hide (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UcmLine -> IO ()
outputUcmLine (UcmLine -> IO ()) -> (String -> UcmLine) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> UcmLine
UcmOutputLine (Text -> UcmLine) -> (String -> Text) -> String -> UcmLine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          -- We shorten the terminal width, because "Transcript" manages a 2-space indent for output lines.
          Width -> Pretty ColorText -> String
Pretty.toPlain (Width
terminalWidth Width -> Width -> Width
forall a. Num a => a -> a -> a
- Width
2) Pretty ColorText
line

      maybeDieWithMsg :: Pretty.Pretty Pretty.ColorText -> IO ()
      maybeDieWithMsg :: 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 ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
forall a. String -> IO a
dieWithMsg (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Width -> Pretty ColorText -> String
Pretty.toPlain Width
terminalWidth Pretty ColorText
msg
          (Bool
True, Bool
True) -> do
            IO ()
appendFailingStanza
            IORef (Seq (Either Node ProcessedBlock)) -> Text -> IO ()
forall b. IORef (Seq (Either Node ProcessedBlock)) -> Text -> IO b
fixedBug 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
"```",
                  String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Width -> Pretty ColorText -> String
Pretty.toPlain Width
terminalWidth 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 ()

      apiRequest :: APIRequest -> IO [APIRequest]
      apiRequest :: APIRequest -> IO [APIRequest]
apiRequest APIRequest
req = do
        Bool
hide <- Bool -> IO Bool
hideOutput Bool
False
        case APIRequest
req of
          -- We just discard this, because the runner will produce new output lines.
          APIResponseLine {} -> [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 ->
            (SomeException -> IO [APIRequest])
-> (Request -> IO [APIRequest])
-> Either SomeException Request
-> IO [APIRequest]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
              (([] [APIRequest] -> IO () -> IO [APIRequest]
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (IO () -> IO [APIRequest])
-> (SomeException -> IO ()) -> SomeException -> IO [APIRequest]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty ColorText -> IO ()
maybeDieWithMsg (Pretty ColorText -> IO ())
-> (SomeException -> Pretty ColorText) -> SomeException -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
Pretty.string (String -> Pretty ColorText)
-> (SomeException -> String) -> SomeException -> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show)
              ( (String -> IO [APIRequest])
-> (Value -> IO [APIRequest])
-> Either String Value
-> IO [APIRequest]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
                  ( ([] [APIRequest] -> IO () -> IO [APIRequest]
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$)
                      (IO () -> IO [APIRequest])
-> (String -> IO ()) -> String -> IO [APIRequest]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty ColorText -> IO ()
maybeDieWithMsg
                      (Pretty ColorText -> IO ())
-> (String -> Pretty ColorText) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Pretty ColorText
"Error decoding response from " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Text -> Pretty ColorText
forall s. IsString s => Text -> Pretty s
Pretty.text Text
path Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
": ") Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<>)
                      (Pretty ColorText -> Pretty ColorText)
-> (String -> Pretty ColorText) -> String -> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
Pretty.string
                  )
                  ( \(Value
v :: Aeson.Value) ->
                      [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
$
                        if Bool
hide
                          then [APIRequest
req]
                          else
                            [ APIRequest
req,
                              Text -> APIRequest
APIResponseLine (Text -> APIRequest)
-> (ByteString -> Text) -> ByteString -> APIRequest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> APIRequest) -> ByteString -> APIRequest
forall a b. (a -> b) -> a -> b
$
                                Config -> Value -> ByteString
forall a. ToJSON a => Config -> a -> ByteString
Aeson.encodePretty' (Config
Aeson.defConfig {Aeson.confCompare = compare}) Value
v
                            ]
                  )
                  (Either String Value -> IO [APIRequest])
-> (Response ByteString -> Either String Value)
-> Response ByteString
-> IO [APIRequest]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode
                  (ByteString -> Either String Value)
-> (Response ByteString -> ByteString)
-> Response ByteString
-> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response ByteString -> ByteString
forall body. Response body -> body
HTTP.responseBody
                  (Response ByteString -> IO [APIRequest])
-> (Request -> IO (Response ByteString))
-> Request
-> IO [APIRequest]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (Request -> Manager -> IO (Response ByteString))
-> Manager -> Request -> IO (Response ByteString)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Manager
httpManager
              )
              (Either SomeException Request -> IO [APIRequest])
-> (Text -> Either SomeException Request)
-> Text
-> IO [APIRequest]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either SomeException Request
forall (m :: * -> *). MonadThrow m => String -> m Request
HTTP.parseRequest
              (String -> Either SomeException Request)
-> (Text -> String) -> Text -> Either SomeException Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack
              (Text -> IO [APIRequest]) -> Text -> IO [APIRequest]
forall a b. (a -> b) -> a -> b
$ Text
baseURL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path

      endUcmBlock :: Cli (Either Event Input)
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
          Maybe (InfoTags ())
tags <- IORef (Maybe (InfoTags ())) -> IO (Maybe (InfoTags ()))
forall a. IORef a -> IO a
readIORef IORef (Maybe (InfoTags ()))
currentTags
          [UcmLine]
ucmOut <- IORef [UcmLine] -> IO [UcmLine]
forall a. IORef a -> IO a
readIORef IORef [UcmLine]
ucmOutput
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([UcmLine] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UcmLine]
ucmOut Bool -> Bool -> Bool
&& Maybe (InfoTags ())
tags Maybe (InfoTags ()) -> Maybe (InfoTags ()) -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe (InfoTags ())
forall a. Maybe a
Nothing) (IO () -> IO ())
-> (ProcessedBlock -> IO ()) -> ProcessedBlock -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Node ProcessedBlock -> IO ()
outputEcho (Either Node ProcessedBlock -> IO ())
-> (ProcessedBlock -> Either Node ProcessedBlock)
-> ProcessedBlock
-> 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 -> IO ()) -> ProcessedBlock -> IO ()
forall a b. (a -> b) -> a -> b
$
            InfoTags () -> [UcmLine] -> ProcessedBlock
Ucm (InfoTags () -> Maybe (InfoTags ()) -> InfoTags ()
forall a. a -> Maybe a -> a
fromMaybe InfoTags ()
forall a. Monoid a => InfoTags a
defaultInfoTags' {generated = True} Maybe (InfoTags ())
tags) [UcmLine]
ucmOut
          IORef [UcmLine] -> [UcmLine] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [UcmLine]
ucmOutput []
          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
          [(Text, Text)]
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.
          [(Text, Text)] -> ((Text, Text) -> STM ()) -> STM [()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a]
reverse [(Text, Text)]
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 -> Cli (Either Event Input)
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
            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 =>
Text -> CausalHashId -> ProjectBranch -> Transaction ()
Text -> CausalHashId -> ProjectBranch -> Transaction ()
Q.insertProjectBranch Text
"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 ())
-> (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
                pure $ Input -> Either Event Input
forall a b. b -> Either a b
Right Input
switchCommand
              Maybe Input
Nothing -> do
                case String -> [String]
words (String -> [String]) -> (Text -> String) -> Text -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack (Text -> [String]) -> Text -> [String]
forall a b. (a -> b) -> a -> b
$ Text
lineTxt of
                  [] -> Cli (Either Event Input)
forall a. Cli a
Cli.returnEarlyWithoutOutput
                  [String]
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
                    [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 String InputPattern
-> [String]
-> IO (Either (Pretty ColorText) (Maybe (Arguments, Input)))
parseInput Codebase IO Symbol Ann
codebase ProjectPath
curPath IO (Branch IO)
getProjectRoot [StructuredArgument]
numberedArgs Map String InputPattern
patternMap [String]
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
>>= (Pretty ColorText -> Cli (Either Event Input))
-> (Maybe (Arguments, Input) -> Cli (Either Event Input))
-> Either (Pretty ColorText) (Maybe (Arguments, Input))
-> Cli (Either Event Input)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
                        -- invalid command is treated as a failure
                        ( \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
$ 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.
                        (Cli (Either Event Input)
-> ((Arguments, Input) -> Cli (Either Event Input))
-> Maybe (Arguments, Input)
-> Cli (Either Event Input)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Cli (Either Event Input)
forall a. Cli a
Cli.returnEarlyWithoutOutput (((Arguments, Input) -> Cli (Either Event Input))
 -> Maybe (Arguments, Input) -> Cli (Either Event Input))
-> ((Arguments, Input) -> Cli (Either Event Input))
-> Maybe (Arguments, Input)
-> Cli (Either Event Input)
forall a b. (a -> b) -> a -> b
$ 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))
-> ((Arguments, Input) -> Either Event Input)
-> (Arguments, Input)
-> Cli (Either Event Input)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> Either Event Input
forall a b. b -> Either a b
Right (Input -> Either Event Input)
-> ((Arguments, Input) -> Input)
-> (Arguments, Input)
-> Either Event Input
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Arguments, Input) -> Input
forall a b. (a, b) -> b
snd)

      startProcessedBlock :: ProcessedBlock -> Cli (Either Event Input)
startProcessedBlock ProcessedBlock
block = case ProcessedBlock
block of
        Unison InfoTags (Maybe Text)
infoTags Text
txt -> 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
$ InfoTags (Maybe Text) -> Hidden
forall a. InfoTags a -> Hidden
hidden InfoTags (Maybe Text)
infoTags
            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
          -- 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 ())
-> (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 :: 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
          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
$ InfoTags () -> Hidden
forall a. InfoTags a -> Hidden
hidden InfoTags ()
infoTags
            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
$ InfoTags () -> Hidden
forall a. InfoTags a -> Hidden
hidden InfoTags ()
infoTags
            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
            IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
hasErrors Bool
False
          (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 -> String -> String -> IO ()
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 :: IO (Either Event Input)
finishTranscript = do
        Bool -> String -> String -> IO ()
showStatus Bool
True String
"✔️" String
"Completed transcript.\n"
        pure $ Input -> Either Event Input
forall a b. b -> Either a b
Right Input
QuitI

      processStanza :: Either Node ProcessedBlock -> Maybe Int -> Cli (Either Event Input)
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 -> Cli b
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 :: Cli (Either Event Input)
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
        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)
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 -> IO LoadSourceResult
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 -> Text -> Bool -> IO ()
writeSource Text
fp Text
contents Bool
_addFold = 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
isHidden
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldShowSourceChanges (IO () -> IO ()) -> (STM () -> IO ()) -> STM () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue (Text, Text) -> (Text, Text) -> STM ()
forall a. TQueue a -> a -> STM ()
Q.enqueue TQueue (Text, Text)
ucmScratchFileUpdatesQueue (Text
fp, Text
contents)
        Text -> Text -> IO ()
updateVirtualFile Text
fp Text
contents

      updateVirtualFile :: ScratchFileName -> Text -> IO ()
      updateVirtualFile :: Text -> 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 -> IO ()
print Output
o = do
        Pretty ColorText
msg <- String -> Output -> IO (Pretty ColorText)
notifyUser String
dir Output
o
        Pretty ColorText -> IO ()
outputUcmResult Pretty ColorText
msg
        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
$ Pretty ColorText -> IO ()
maybeDieWithMsg Pretty ColorText
msg

      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
        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
        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 ProcessedBlock
blockOpt <- IORef (Maybe ProcessedBlock) -> IO (Maybe ProcessedBlock)
forall a. IORef a -> IO a
readIORef IORef (Maybe ProcessedBlock)
mBlock
        Seq (Either Node ProcessedBlock)
currentOut <- IORef (Seq (Either Node ProcessedBlock))
-> IO (Seq (Either Node ProcessedBlock))
forall a. IORef a -> IO a
readIORef IORef (Seq (Either Node ProcessedBlock))
out
        IO () -> (ProcessedBlock -> IO ()) -> Maybe ProcessedBlock -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
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)))
          Maybe ProcessedBlock
blockOpt

      dieWithMsg :: forall a. String -> IO a
      dieWithMsg :: forall a. String -> IO a
dieWithMsg String
msg = do
        IO ()
appendFailingStanza
        IORef (Seq (Either Node ProcessedBlock))
-> Text -> Maybe Text -> IO a
forall b.
IORef (Seq (Either Node ProcessedBlock))
-> Text -> Maybe Text -> IO b
transcriptFailure 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
$
          String -> Text
Text.pack String
msg

      dieUnexpectedSuccess :: IO ()
      dieUnexpectedSuccess :: IO ()
dieUnexpectedSuccess = do
        Bool
errOk <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
allowErrors
        Bool
expectBug <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
expectFailure
        Bool
hasErr <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
hasErrors
        case (Bool
errOk, Bool
expectBug, Bool
hasErr) of
          (Bool
True, Bool
False, Bool
False) -> do
            IO ()
appendFailingStanza
            IORef (Seq (Either Node ProcessedBlock))
-> Text -> Maybe Text -> IO ()
forall b.
IORef (Seq (Either Node ProcessedBlock))
-> Text -> Maybe Text -> IO b
transcriptFailure
              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
            IORef (Seq (Either Node ProcessedBlock)) -> Text -> IO ()
forall b. IORef (Seq (Either Node ProcessedBlock)) -> Text -> IO b
fixedBug
              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 ()

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

  IORef Int
seedRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)

  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 :: Text -> IO LoadSourceResult
loadSource = Text -> IO LoadSourceResult
loadPreviousUnisonBlock,
            Text -> Text -> Bool -> IO ()
writeSource :: Text -> Text -> Bool -> IO ()
$sel:writeSource:Env :: Text -> Text -> Bool -> IO ()
writeSource,
            $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,
            Text
ucmVersion :: Text
$sel:ucmVersion:Env :: Text
ucmVersion,
            $sel:isTranscriptTest:Env :: Bool
isTranscriptTest = Bool
isTest
          }

  let loop :: Cli.LoopState -> IO (Seq Stanza)
      loop :: LoopState -> IO (Seq (Either Node ProcessedBlock))
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

  LoopState -> IO (Seq (Either Node ProcessedBlock))
loop (ProjectPathG ProjectId ProjectBranchId -> LoopState
Cli.loopState0 (ProjectPath -> ProjectPathG ProjectId ProjectBranchId
PP.toIds ProjectPath
initialPP))

transcriptFailure :: IORef (Seq Stanza) -> Text -> Maybe Text -> IO b
transcriptFailure :: forall b.
IORef (Seq (Either Node ProcessedBlock))
-> Text -> Maybe Text -> IO b
transcriptFailure IORef (Seq (Either Node ProcessedBlock))
out Text
heading Maybe Text
mbody = do
  Seq (Either Node ProcessedBlock)
texts <- IORef (Seq (Either Node ProcessedBlock))
-> IO (Seq (Either Node ProcessedBlock))
forall a. IORef a -> IO a
readIORef IORef (Seq (Either Node ProcessedBlock))
out
  Error -> IO b
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UnliftIO.throwIO (Error -> IO b)
-> (Seq (Either Node ProcessedBlock) -> Error)
-> Seq (Either Node ProcessedBlock)
-> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq (Either Node ProcessedBlock) -> Error
RunFailure (Seq (Either Node ProcessedBlock) -> IO b)
-> Seq (Either Node ProcessedBlock) -> IO b
forall a b. (a -> b) -> a -> b
$
    Seq (Either Node ProcessedBlock)
texts
      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
Seq.fromList
        ( Node -> Either Node ProcessedBlock
forall a b. a -> Either a b
Left
            (Node -> Either Node ProcessedBlock)
-> [Node] -> [Either Node ProcessedBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ Maybe PosInfo -> NodeType -> [Node] -> Node
CMark.Node Maybe PosInfo
forall a. Maybe a
Nothing NodeType
CMark.PARAGRAPH [Maybe PosInfo -> NodeType -> [Node] -> Node
CMark.Node Maybe PosInfo
forall a. Maybe a
Nothing (Text -> NodeType
CMark.TEXT Text
"🛑") []],
                  Maybe PosInfo -> NodeType -> [Node] -> Node
CMark.Node Maybe PosInfo
forall a. Maybe a
Nothing NodeType
CMark.PARAGRAPH [Maybe PosInfo -> NodeType -> [Node] -> Node
CMark.Node Maybe PosInfo
forall a. Maybe a
Nothing (Text -> NodeType
CMark.TEXT Text
heading) []]
                ]
              [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> (Text -> [Node] -> [Node]) -> [Node] -> Maybe Text -> [Node]
forall a b. (a -> b -> b) -> b -> Maybe a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((:) (Node -> [Node] -> [Node])
-> (Text -> Node) -> Text -> [Node] -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe PosInfo -> Text -> Text -> Node
CMarkCodeBlock Maybe PosInfo
forall a. Maybe a
Nothing Text
"") [] Maybe Text
mbody
        )

fixedBug :: IORef (Seq Stanza) -> Text -> IO b
fixedBug :: forall b. IORef (Seq (Either Node ProcessedBlock)) -> Text -> IO b
fixedBug IORef (Seq (Either Node ProcessedBlock))
out Text
body = do
  Seq (Either Node ProcessedBlock)
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 Maybe PosInfo
_ NodeType
_DOCUMENT [Node]
bodyNodes = [CMarkOption] -> Text -> Node
CMark.commonmarkToNode [CMarkOption
CMark.optNormalize] Text
body
  Error -> IO b
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UnliftIO.throwIO (Error -> IO b)
-> (Seq (Either Node ProcessedBlock) -> Error)
-> Seq (Either Node ProcessedBlock)
-> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq (Either Node ProcessedBlock) -> Error
RunFailure (Seq (Either Node ProcessedBlock) -> IO b)
-> Seq (Either Node ProcessedBlock) -> IO b
forall a b. (a -> b) -> a -> b
$
    Seq (Either Node ProcessedBlock)
texts
      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
Seq.fromList
        ( Node -> Either Node ProcessedBlock
forall a b. a -> Either a b
Left
            (Node -> Either Node ProcessedBlock)
-> [Node] -> [Either Node ProcessedBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ Maybe PosInfo -> NodeType -> [Node] -> Node
CMark.Node Maybe PosInfo
forall a. Maybe a
Nothing NodeType
CMark.PARAGRAPH [Maybe PosInfo -> NodeType -> [Node] -> Node
CMark.Node Maybe PosInfo
forall a. Maybe a
Nothing (Text -> NodeType
CMark.TEXT Text
"🎉") []],
                  Maybe PosInfo -> NodeType -> [Node] -> Node
CMark.Node Maybe PosInfo
forall a. Maybe a
Nothing (Int -> NodeType
CMark.HEADING Int
2) [Maybe PosInfo -> NodeType -> [Node] -> Node
CMark.Node Maybe PosInfo
forall a. Maybe a
Nothing (Text -> NodeType
CMark.TEXT Text
"You fixed a bug!") []]
                ]
              [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [Node]
bodyNodes
        )

data Error
  = ParseError (P.ParseErrorBundle Text Void)
  | RunFailure (Seq Stanza)
  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)
-> Exception Error
SomeException -> Maybe Error
Error -> String
Error -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: Error -> SomeException
toException :: Error -> SomeException
$cfromException :: SomeException -> Maybe Error
fromException :: SomeException -> Maybe Error
$cdisplayException :: Error -> String
displayException :: Error -> String
Exception)