{-# LANGUAGE DeriveAnyClass #-}
module Unison.Codebase.Transcript.Runner
( Error (..),
Runner,
withRunner,
)
where
import Control.Lens (use, (?~))
import Crypto.Random qualified as Random
import Data.Aeson qualified as Aeson
import Data.Aeson.Encode.Pretty qualified as Aeson
import Data.ByteString.Lazy.Char8 qualified as BL
import Data.IORef
import Data.List (isSubsequenceOf)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map qualified as Map
import Data.Text qualified as Text
import Data.These (These (..))
import Data.UUID.V4 qualified as UUID
import Network.HTTP.Client qualified as HTTP
import System.Environment (lookupEnv)
import System.IO qualified as IO
import Text.Megaparsec qualified as P
import U.Codebase.Sqlite.DbId qualified as Db
import U.Codebase.Sqlite.Project (Project (..))
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.Queries qualified as Q
import Unison.Auth.CredentialManager qualified as AuthN
import Unison.Auth.HTTPClient qualified as AuthN
import Unison.Auth.Tokens qualified as AuthN
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Codebase (Codebase)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Editor.HandleInput qualified as HandleInput
import Unison.Codebase.Editor.Input (Event (UnisonFileChanged), Input (..))
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Editor.UCMVersion (UCMVersion)
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.Runtime qualified as Runtime
import Unison.Codebase.Transcript
import Unison.Codebase.Transcript.Parser qualified as Transcript
import Unison.Codebase.Verbosity (Verbosity, isSilent)
import Unison.Codebase.Verbosity qualified as Verbosity
import Unison.CommandLine
import Unison.CommandLine.InputPattern (InputPattern (aliases, patternName))
import Unison.CommandLine.InputPatterns (validInputs)
import Unison.CommandLine.OutputMessages (notifyNumbered, notifyUser)
import Unison.CommandLine.Welcome (asciiartUnison)
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import Unison.PrettyTerminal
import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (ProjectAndBranchNames'Unambiguous))
import Unison.Runtime.Interface qualified as RTI
import Unison.Server.Backend qualified as Backend
import Unison.Server.CodebaseServer qualified as Server
import Unison.Sqlite qualified as Sqlite
import Unison.Symbol (Symbol)
import Unison.Syntax.Parser qualified as Parser
import Unison.Util.Pretty qualified as Pretty
import Unison.Util.TQueue qualified as Q
import UnliftIO qualified
import UnliftIO.STM
import Prelude hiding (readFile, writeFile)
terminalWidth :: Pretty.Width
terminalWidth :: Width
terminalWidth = Width
65
accessTokenEnvVarKey :: String
accessTokenEnvVarKey :: [Char]
accessTokenEnvVarKey = [Char]
"UNISON_SHARE_ACCESS_TOKEN"
type Runner =
String ->
Text ->
(FilePath, Codebase IO Symbol Ann) ->
IO (Either Error Text)
withRunner ::
forall m r.
(UnliftIO.MonadUnliftIO m) =>
Bool ->
Verbosity ->
UCMVersion ->
FilePath ->
(Runner -> m r) ->
m r
withRunner :: forall (m :: * -> *) r.
MonadUnliftIO m =>
Bool
-> Verbosity -> ScratchFileName -> [Char] -> (Runner -> m r) -> m r
withRunner Bool
isTest Verbosity
verbosity ScratchFileName
ucmVersion [Char]
nrtp Runner -> m r
action = do
[Char]
-> (Runtime Symbol -> Runtime Symbol -> Runtime Symbol -> m r)
-> m r
forall a.
[Char]
-> (Runtime Symbol -> Runtime Symbol -> Runtime Symbol -> m a)
-> m a
withRuntimes [Char]
nrtp \Runtime Symbol
runtime Runtime Symbol
sbRuntime Runtime Symbol
nRuntime -> do
Runner -> m r
action \[Char]
transcriptName ScratchFileName
transcriptSrc ([Char]
codebaseDir, Codebase IO Symbol Ann
codebase) -> do
BackendEnv
-> CodebaseServerOpts
-> Runtime Symbol
-> Codebase IO Symbol Ann
-> (BaseUrl -> IO (Either Error ScratchFileName))
-> IO (Either Error ScratchFileName)
forall a.
BackendEnv
-> CodebaseServerOpts
-> Runtime Symbol
-> Codebase IO Symbol Ann
-> (BaseUrl -> IO a)
-> IO a
Server.startServer (Backend.BackendEnv {$sel:useNamesIndex:BackendEnv :: Bool
Backend.useNamesIndex = Bool
False}) CodebaseServerOpts
Server.defaultCodebaseServerOpts Runtime Symbol
runtime Codebase IO Symbol Ann
codebase \BaseUrl
baseUrl -> do
let parsed :: Either (ParseErrorBundle ScratchFileName Void) [Stanza]
parsed = [Char]
-> ScratchFileName
-> Either (ParseErrorBundle ScratchFileName Void) [Stanza]
Transcript.stanzas [Char]
transcriptName ScratchFileName
transcriptSrc
Either
(ParseErrorBundle ScratchFileName Void)
(Either Error ScratchFileName)
result <- Either (ParseErrorBundle ScratchFileName Void) [Stanza]
-> ([Stanza] -> IO (Either Error ScratchFileName))
-> IO
(Either
(ParseErrorBundle ScratchFileName Void)
(Either Error ScratchFileName))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Either (ParseErrorBundle ScratchFileName Void) [Stanza]
parsed \[Stanza]
stanzas -> do
IO (Either Error ScratchFileName)
-> IO (Either Error ScratchFileName)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Error ScratchFileName)
-> IO (Either Error ScratchFileName))
-> IO (Either Error ScratchFileName)
-> IO (Either Error ScratchFileName)
forall a b. (a -> b) -> a -> b
$ Bool
-> Verbosity
-> [Char]
-> [Stanza]
-> Codebase IO Symbol Ann
-> Runtime Symbol
-> Runtime Symbol
-> Runtime Symbol
-> ScratchFileName
-> ScratchFileName
-> IO (Either Error ScratchFileName)
run Bool
isTest Verbosity
verbosity [Char]
codebaseDir [Stanza]
stanzas Codebase IO Symbol Ann
codebase Runtime Symbol
runtime Runtime Symbol
sbRuntime Runtime Symbol
nRuntime ScratchFileName
ucmVersion (BaseUrl -> ScratchFileName
forall a. Show a => a -> ScratchFileName
tShow BaseUrl
baseUrl)
Either Error ScratchFileName -> IO (Either Error ScratchFileName)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error ScratchFileName -> IO (Either Error ScratchFileName))
-> (Either Error (Either Error ScratchFileName)
-> Either Error ScratchFileName)
-> Either Error (Either Error ScratchFileName)
-> IO (Either Error ScratchFileName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Error (Either Error ScratchFileName)
-> Either Error ScratchFileName
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Either Error (Either Error ScratchFileName)
-> IO (Either Error ScratchFileName))
-> Either Error (Either Error ScratchFileName)
-> IO (Either Error ScratchFileName)
forall a b. (a -> b) -> a -> b
$ (ParseErrorBundle ScratchFileName Void -> Error)
-> Either
(ParseErrorBundle ScratchFileName Void)
(Either Error ScratchFileName)
-> Either Error (Either Error ScratchFileName)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseErrorBundle ScratchFileName Void -> Error
ParseError Either
(ParseErrorBundle ScratchFileName Void)
(Either Error ScratchFileName)
result
where
withRuntimes ::
FilePath -> (Runtime.Runtime Symbol -> Runtime.Runtime Symbol -> Runtime.Runtime Symbol -> m a) -> m a
withRuntimes :: forall a.
[Char]
-> (Runtime Symbol -> Runtime Symbol -> Runtime Symbol -> m a)
-> m a
withRuntimes [Char]
nrtp Runtime Symbol -> Runtime Symbol -> Runtime Symbol -> m a
action =
Bool
-> RuntimeHost -> ScratchFileName -> (Runtime Symbol -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Bool
-> RuntimeHost -> ScratchFileName -> (Runtime Symbol -> m a) -> m a
RTI.withRuntime Bool
False RuntimeHost
RTI.Persistent ScratchFileName
ucmVersion \Runtime Symbol
runtime -> do
Bool
-> RuntimeHost -> ScratchFileName -> (Runtime Symbol -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Bool
-> RuntimeHost -> ScratchFileName -> (Runtime Symbol -> m a) -> m a
RTI.withRuntime Bool
True RuntimeHost
RTI.Persistent ScratchFileName
ucmVersion \Runtime Symbol
sbRuntime -> do
Runtime Symbol -> Runtime Symbol -> Runtime Symbol -> m a
action Runtime Symbol
runtime Runtime Symbol
sbRuntime
(Runtime Symbol -> m a) -> m (Runtime Symbol) -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Runtime Symbol) -> m (Runtime Symbol)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ScratchFileName -> [Char] -> IO (Runtime Symbol)
RTI.startNativeRuntime ScratchFileName
ucmVersion [Char]
nrtp)
run ::
Bool ->
Verbosity ->
FilePath ->
[Stanza] ->
Codebase IO Symbol Ann ->
Runtime.Runtime Symbol ->
Runtime.Runtime Symbol ->
Runtime.Runtime Symbol ->
UCMVersion ->
Text ->
IO (Either Error Text)
run :: Bool
-> Verbosity
-> [Char]
-> [Stanza]
-> Codebase IO Symbol Ann
-> Runtime Symbol
-> Runtime Symbol
-> Runtime Symbol
-> ScratchFileName
-> ScratchFileName
-> IO (Either Error ScratchFileName)
run Bool
isTest Verbosity
verbosity [Char]
dir [Stanza]
stanzas Codebase IO Symbol Ann
codebase Runtime Symbol
runtime Runtime Symbol
sbRuntime Runtime Symbol
nRuntime ScratchFileName
ucmVersion ScratchFileName
baseURL = IO ScratchFileName -> IO (Either Error ScratchFileName)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
UnliftIO.try do
Manager
httpManager <- ManagerSettings -> IO Manager
HTTP.newManager ManagerSettings
HTTP.defaultManagerSettings
(ProjectPath
initialPP, CausalHashId
emptyCausalHashId) <- Codebase IO Symbol Ann
-> Transaction (ProjectPath, CausalHashId)
-> IO (ProjectPath, CausalHashId)
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Codebase IO Symbol Ann
codebase do
(CausalHash
_, CausalHashId
emptyCausalHashId) <- Transaction (CausalHash, CausalHashId)
Codebase.emptyCausalHash
ProjectPath
initialPP <- Transaction ProjectPath
HasCallStack => Transaction ProjectPath
Codebase.expectCurrentProjectPath
pure (ProjectPath
initialPP, CausalHashId
emptyCausalHashId)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Verbosity -> Bool
isSilent Verbosity
verbosity) (IO () -> IO ())
-> (Pretty ColorText -> IO ()) -> Pretty ColorText -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty ColorText -> IO ()
putPrettyLn (Pretty ColorText -> IO ()) -> Pretty ColorText -> IO ()
forall a b. (a -> b) -> a -> b
$
[Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
Pretty.lines
[ Pretty ColorText
asciiartUnison,
Pretty ColorText
"",
Pretty ColorText
"Running the provided transcript file...",
Pretty ColorText
""
]
Maybe ScratchFileName
mayShareAccessToken <- ([Char] -> ScratchFileName)
-> Maybe [Char] -> Maybe ScratchFileName
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> ScratchFileName
Text.pack (Maybe [Char] -> Maybe ScratchFileName)
-> IO (Maybe [Char]) -> IO (Maybe ScratchFileName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
accessTokenEnvVarKey
CredentialManager
credMan <- IO CredentialManager
forall (m :: * -> *). MonadIO m => m CredentialManager
AuthN.newCredentialManager
let tokenProvider :: AuthN.TokenProvider
tokenProvider :: TokenProvider
tokenProvider =
case Maybe ScratchFileName
mayShareAccessToken of
Maybe ScratchFileName
Nothing -> do
CredentialManager -> TokenProvider
AuthN.newTokenProvider CredentialManager
credMan
Just ScratchFileName
accessToken ->
\CodeserverId
_codeserverID -> Either CredentialFailure ScratchFileName
-> IO (Either CredentialFailure ScratchFileName)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CredentialFailure ScratchFileName
-> IO (Either CredentialFailure ScratchFileName))
-> Either CredentialFailure ScratchFileName
-> IO (Either CredentialFailure ScratchFileName)
forall a b. (a -> b) -> a -> b
$ ScratchFileName -> Either CredentialFailure ScratchFileName
forall a b. b -> Either a b
Right ScratchFileName
accessToken
IORef Int
seedRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
TQueue (Stanza, Maybe Int)
inputQueue <- forall a (m :: * -> *). MonadIO m => m (TQueue a)
Q.newIO @(Stanza, Maybe Int)
TQueue (Maybe UcmLine)
cmdQueue <- forall a (m :: * -> *). MonadIO m => m (TQueue a)
Q.newIO @(Maybe UcmLine)
TQueue (ScratchFileName, ScratchFileName)
ucmScratchFileUpdatesQueue <- forall a (m :: * -> *). MonadIO m => m (TQueue a)
Q.newIO @(ScratchFileName, Text)
IORef (Map ScratchFileName ScratchFileName)
unisonFiles <- Map ScratchFileName ScratchFileName
-> IO (IORef (Map ScratchFileName ScratchFileName))
forall a. a -> IO (IORef a)
newIORef Map ScratchFileName ScratchFileName
forall k a. Map k a
Map.empty
IORef (Seq [Char])
out <- Seq [Char] -> IO (IORef (Seq [Char]))
forall a. a -> IO (IORef a)
newIORef Seq [Char]
forall a. Monoid a => a
mempty
IORef Hidden
hidden <- Hidden -> IO (IORef Hidden)
forall a. a -> IO (IORef a)
newIORef Hidden
Shown
IORef Bool
allowErrors <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
IORef Bool
hasErrors <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
IORef (Maybe (Stanza, Maybe Int))
mStanza <- Maybe (Stanza, Maybe Int) -> IO (IORef (Maybe (Stanza, Maybe Int)))
forall a. a -> IO (IORef a)
newIORef Maybe (Stanza, Maybe Int)
forall a. Maybe a
Nothing
((Stanza, Maybe Int) -> IO ()) -> [(Stanza, Maybe Int)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ())
-> ((Stanza, Maybe Int) -> STM ()) -> (Stanza, Maybe Int) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TQueue (Stanza, Maybe Int) -> (Stanza, Maybe Int) -> STM ()
forall a. TQueue a -> a -> STM ()
Q.enqueue TQueue (Stanza, Maybe Int)
inputQueue) ([Stanza]
stanzas [Stanza] -> [Maybe Int] -> [(Stanza, Maybe Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> [Int] -> [Maybe Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
1 :: Int ..]))
let patternMap :: Map [Char] InputPattern
patternMap =
[([Char], InputPattern)] -> Map [Char] InputPattern
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([([Char], InputPattern)] -> Map [Char] InputPattern)
-> [([Char], InputPattern)] -> Map [Char] InputPattern
forall a b. (a -> b) -> a -> b
$
[InputPattern]
validInputs
[InputPattern]
-> (InputPattern -> [([Char], InputPattern)])
-> [([Char], InputPattern)]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\InputPattern
p -> (InputPattern -> [Char]
patternName InputPattern
p, InputPattern
p) ([Char], InputPattern)
-> [([Char], InputPattern)] -> [([Char], InputPattern)]
forall a. a -> [a] -> [a]
: ((,InputPattern
p) ([Char] -> ([Char], InputPattern))
-> [[Char]] -> [([Char], InputPattern)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputPattern -> [[Char]]
aliases InputPattern
p))
let output' :: Bool -> String -> IO ()
output' :: Bool -> [Char] -> IO ()
output' Bool
inputEcho [Char]
msg = do
Hidden
hide <- IORef Hidden -> IO Hidden
forall a. IORef a -> IO a
readIORef IORef Hidden
hidden
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> Hidden -> Bool
hideOutput Bool
inputEcho Hidden
hide) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (Seq [Char]) -> (Seq [Char] -> Seq [Char]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Seq [Char])
out (\Seq [Char]
acc -> Seq [Char]
acc Seq [Char] -> Seq [Char] -> Seq [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Seq [Char]
forall a. a -> Seq a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
msg)
hideOutput :: Bool -> Hidden -> Bool
hideOutput :: Bool -> Hidden -> Bool
hideOutput Bool
inputEcho = \case
Hidden
Shown -> Bool
False
Hidden
HideOutput -> Bool
True Bool -> Bool -> Bool
&& (Bool -> Bool
not Bool
inputEcho)
Hidden
HideAll -> Bool
True
output, outputEcho :: String -> IO ()
output :: [Char] -> IO ()
output = Bool -> [Char] -> IO ()
output' Bool
False
outputEcho :: [Char] -> IO ()
outputEcho = Bool -> [Char] -> IO ()
output' Bool
True
apiRequest :: APIRequest -> IO ()
apiRequest :: APIRequest -> IO ()
apiRequest APIRequest
req = do
[Char] -> IO ()
output ([Char] -> IO ())
-> (ScratchFileName -> [Char]) -> ScratchFileName -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScratchFileName -> [Char]
Text.unpack (ScratchFileName -> IO ()) -> ScratchFileName -> IO ()
forall a b. (a -> b) -> a -> b
$ APIRequest -> ScratchFileName
Transcript.formatAPIRequest APIRequest
req ScratchFileName -> ScratchFileName -> ScratchFileName
forall a. Semigroup a => a -> a -> a
<> ScratchFileName
"\n"
case APIRequest
req of
APIComment {} -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
GetRequest ScratchFileName
path -> do
Request
req <- case [Char] -> Either SomeException Request
forall (m :: * -> *). MonadThrow m => [Char] -> m Request
HTTP.parseRequest (ScratchFileName -> [Char]
Text.unpack (ScratchFileName -> [Char]) -> ScratchFileName -> [Char]
forall a b. (a -> b) -> a -> b
$ ScratchFileName
baseURL ScratchFileName -> ScratchFileName -> ScratchFileName
forall a. Semigroup a => a -> a -> a
<> ScratchFileName
path) of
Left SomeException
err -> [Char] -> IO Request
forall a. [Char] -> IO a
dieWithMsg (SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
err)
Right Request
req -> Request -> IO Request
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
req
Response ByteString
respBytes <- Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
req Manager
httpManager
case ByteString -> Either [Char] Value
forall a. FromJSON a => ByteString -> Either [Char] a
Aeson.eitherDecode (Response ByteString -> ByteString
forall body. Response body -> body
HTTP.responseBody Response ByteString
respBytes) of
Right (Value
v :: Aeson.Value) -> do
let prettyBytes :: ByteString
prettyBytes = Config -> Value -> ByteString
forall a. ToJSON a => Config -> a -> ByteString
Aeson.encodePretty' (Config
Aeson.defConfig {Aeson.confCompare = compare}) Value
v
[Char] -> IO ()
output ([Char] -> IO ()) -> (ByteString -> [Char]) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\n") ([Char] -> [Char])
-> (ByteString -> [Char]) -> ByteString -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
BL.unpack (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
prettyBytes
Left [Char]
err -> [Char] -> IO ()
forall a. [Char] -> IO a
dieWithMsg ([Char]
"Error decoding response from " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ScratchFileName -> [Char]
Text.unpack ScratchFileName
path [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
err)
awaitInput :: Cli (Either Event Input)
awaitInput :: Cli (Either Event Input)
awaitInput = do
Maybe (Maybe UcmLine)
cmd <- STM (Maybe (Maybe UcmLine)) -> Cli (Maybe (Maybe UcmLine))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TQueue (Maybe UcmLine) -> STM (Maybe (Maybe UcmLine))
forall a. TQueue a -> STM (Maybe a)
Q.tryDequeue TQueue (Maybe UcmLine)
cmdQueue)
case Maybe (Maybe UcmLine)
cmd of
Just Maybe UcmLine
Nothing -> do
IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ()
output [Char]
"\n```\n")
IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
dieUnexpectedSuccess
STM () -> Cli ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> Cli ()) -> STM () -> Cli ()
forall a b. (a -> b) -> a -> b
$ STM [()] -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM [()] -> STM ()) -> STM [()] -> STM ()
forall a b. (a -> b) -> a -> b
$ do
[(ScratchFileName, ScratchFileName)]
scratchFileUpdates <- TQueue (ScratchFileName, ScratchFileName)
-> STM [(ScratchFileName, ScratchFileName)]
forall a. TQueue a -> STM [a]
Q.flush TQueue (ScratchFileName, ScratchFileName)
ucmScratchFileUpdatesQueue
[(ScratchFileName, ScratchFileName)]
-> ((ScratchFileName, ScratchFileName) -> STM ()) -> STM [()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([(ScratchFileName, ScratchFileName)]
-> [(ScratchFileName, ScratchFileName)]
forall a. [a] -> [a]
reverse [(ScratchFileName, ScratchFileName)]
scratchFileUpdates) \(ScratchFileName
fp, ScratchFileName
contents) -> do
let fenceDescription :: ScratchFileName
fenceDescription = ScratchFileName
"unison:added-by-ucm " ScratchFileName -> ScratchFileName -> ScratchFileName
forall a. Semigroup a => a -> a -> a
<> ScratchFileName
fp
TQueue (Stanza, Maybe Int) -> (Stanza, Maybe Int) -> STM ()
forall a. TQueue a -> a -> STM ()
Q.undequeue TQueue (Stanza, Maybe Int)
inputQueue (Node -> Stanza
forall a b. a -> Either a b
Left (Node -> Stanza) -> Node -> Stanza
forall a b. (a -> b) -> a -> b
$ Maybe PosInfo -> ScratchFileName -> ScratchFileName -> Node
CMarkCodeBlock Maybe PosInfo
forall a. Maybe a
Nothing ScratchFileName
fenceDescription ScratchFileName
contents, Maybe Int
forall a. Maybe a
Nothing)
Cli (Either Event Input)
awaitInput
Just (Just UcmLine
ucmLine) -> do
case UcmLine
ucmLine of
p :: UcmLine
p@(UcmComment {}) -> do
IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Cli ())
-> (ScratchFileName -> IO ()) -> ScratchFileName -> Cli ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
output ([Char] -> IO ())
-> (ScratchFileName -> [Char]) -> ScratchFileName -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScratchFileName -> [Char]
Text.unpack (ScratchFileName -> Cli ()) -> ScratchFileName -> Cli ()
forall a b. (a -> b) -> a -> b
$ ScratchFileName
"\n" ScratchFileName -> ScratchFileName -> ScratchFileName
forall a. Semigroup a => a -> a -> a
<> UcmLine -> ScratchFileName
Transcript.formatUcmLine UcmLine
p
Cli (Either Event Input)
awaitInput
p :: UcmLine
p@(UcmCommand UcmContext
context ScratchFileName
lineTxt) -> do
ProjectPath
curPath <- Cli ProjectPath
Cli.getCurrentProjectPath
Maybe Input
maybeSwitchCommand <-
case UcmContext
context of
UcmContextProject (ProjectAndBranch ProjectName
projectName ProjectBranchName
branchName) -> Transaction (Maybe Input) -> Cli (Maybe Input)
forall a. Transaction a -> Cli a
Cli.runTransaction do
Project {ProjectId
projectId :: ProjectId
$sel:projectId:Project :: Project -> ProjectId
projectId, $sel:name:Project :: Project -> ProjectName
name = ProjectName
projectName} <-
ProjectName -> Transaction (Maybe Project)
Q.loadProjectByName ProjectName
projectName
Transaction (Maybe Project)
-> (Maybe Project -> Transaction Project) -> Transaction Project
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Project
Nothing -> do
ProjectId
projectId <- IO ProjectId -> Transaction ProjectId
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (UUID -> ProjectId
Db.ProjectId (UUID -> ProjectId) -> IO UUID -> IO ProjectId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID
UUID.nextRandom)
ProjectId -> ProjectName -> Transaction ()
Q.insertProject ProjectId
projectId ProjectName
projectName
pure $ Project {ProjectId
$sel:projectId:Project :: ProjectId
projectId :: ProjectId
projectId, $sel:name:Project :: ProjectName
name = ProjectName
projectName}
Just Project
project -> Project -> Transaction Project
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Project
project
ProjectBranch
projectBranch <-
ProjectId -> ProjectBranchName -> Transaction (Maybe ProjectBranch)
Q.loadProjectBranchByName ProjectId
projectId ProjectBranchName
branchName Transaction (Maybe ProjectBranch)
-> (Maybe ProjectBranch -> Transaction ProjectBranch)
-> Transaction ProjectBranch
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe ProjectBranch
Nothing -> do
ProjectBranchId
branchId <- IO ProjectBranchId -> Transaction ProjectBranchId
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (UUID -> ProjectBranchId
Db.ProjectBranchId (UUID -> ProjectBranchId) -> IO UUID -> IO ProjectBranchId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID
UUID.nextRandom)
let projectBranch :: ProjectBranch
projectBranch = ProjectBranch {ProjectId
projectId :: ProjectId
$sel:projectId:ProjectBranch :: ProjectId
projectId, $sel:parentBranchId:ProjectBranch :: Maybe ProjectBranchId
parentBranchId = Maybe ProjectBranchId
forall a. Maybe a
Nothing, ProjectBranchId
branchId :: ProjectBranchId
$sel:branchId:ProjectBranch :: ProjectBranchId
branchId, $sel:name:ProjectBranch :: ProjectBranchName
name = ProjectBranchName
branchName}
HasCallStack =>
ScratchFileName -> CausalHashId -> ProjectBranch -> Transaction ()
ScratchFileName -> CausalHashId -> ProjectBranch -> Transaction ()
Q.insertProjectBranch ScratchFileName
"Branch Created" CausalHashId
emptyCausalHashId ProjectBranch
projectBranch
pure ProjectBranch
projectBranch
Just ProjectBranch
projBranch -> ProjectBranch -> Transaction ProjectBranch
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectBranch
projBranch
let projectAndBranchIds :: ProjectAndBranch ProjectId ProjectBranchId
projectAndBranchIds = ProjectId
-> ProjectBranchId -> ProjectAndBranch ProjectId ProjectBranchId
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch ProjectBranch
projectBranch.projectId ProjectBranch
projectBranch.branchId
Maybe Input -> Transaction (Maybe Input)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
if (ProjectPathG ProjectId ProjectBranchId
-> ProjectAndBranch ProjectId ProjectBranchId
forall p b. ProjectPathG p b -> ProjectAndBranch p b
PP.toProjectAndBranch (ProjectPathG ProjectId ProjectBranchId
-> ProjectAndBranch ProjectId ProjectBranchId)
-> (ProjectPath -> ProjectPathG ProjectId ProjectBranchId)
-> ProjectPath
-> ProjectAndBranch ProjectId ProjectBranchId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPath -> ProjectPathG ProjectId ProjectBranchId
PP.toIds (ProjectPath -> ProjectAndBranch ProjectId ProjectBranchId)
-> ProjectPath -> ProjectAndBranch ProjectId ProjectBranchId
forall a b. (a -> b) -> a -> b
$ ProjectPath
curPath) ProjectAndBranch ProjectId ProjectBranchId
-> ProjectAndBranch ProjectId ProjectBranchId -> Bool
forall a. Eq a => a -> a -> Bool
== ProjectAndBranch ProjectId ProjectBranchId
projectAndBranchIds
then Maybe Input
forall a. Maybe a
Nothing
else Input -> Maybe Input
forall a. a -> Maybe a
Just (ProjectAndBranchNames -> Input
ProjectSwitchI (These ProjectName ProjectBranchName -> ProjectAndBranchNames
ProjectAndBranchNames'Unambiguous (ProjectName
-> ProjectBranchName -> These ProjectName ProjectBranchName
forall a b. a -> b -> These a b
These ProjectName
projectName ProjectBranchName
branchName)))
case Maybe Input
maybeSwitchCommand of
Just Input
switchCommand -> do
STM () -> Cli ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> Cli ()) -> STM () -> Cli ()
forall a b. (a -> b) -> a -> b
$ TQueue (Maybe UcmLine) -> Maybe UcmLine -> STM ()
forall a. TQueue a -> a -> STM ()
Q.undequeue TQueue (Maybe UcmLine)
cmdQueue (UcmLine -> Maybe UcmLine
forall a. a -> Maybe a
Just UcmLine
p)
pure (Input -> Either Event Input
forall a b. b -> Either a b
Right Input
switchCommand)
Maybe Input
Nothing -> do
case [Char] -> [[Char]]
words ([Char] -> [[Char]])
-> (ScratchFileName -> [Char]) -> ScratchFileName -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScratchFileName -> [Char]
Text.unpack (ScratchFileName -> [[Char]]) -> ScratchFileName -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ScratchFileName
lineTxt of
[] -> Cli (Either Event Input)
awaitInput
[[Char]]
args -> do
IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Cli ())
-> (ScratchFileName -> IO ()) -> ScratchFileName -> Cli ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
output ([Char] -> IO ())
-> (ScratchFileName -> [Char]) -> ScratchFileName -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScratchFileName -> [Char]
Text.unpack (ScratchFileName -> Cli ()) -> ScratchFileName -> Cli ()
forall a b. (a -> b) -> a -> b
$ ScratchFileName
"\n" ScratchFileName -> ScratchFileName -> ScratchFileName
forall a. Semigroup a => a -> a -> a
<> UcmLine -> ScratchFileName
Transcript.formatUcmLine UcmLine
p ScratchFileName -> ScratchFileName -> ScratchFileName
forall a. Semigroup a => a -> a -> a
<> ScratchFileName
"\n"
[StructuredArgument]
numberedArgs <- Getting [StructuredArgument] LoopState [StructuredArgument]
-> Cli [StructuredArgument]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting [StructuredArgument] LoopState [StructuredArgument]
#numberedArgs
PP.ProjectAndBranch ProjectId
projId ProjectBranchId
branchId <- ProjectPathG ProjectId ProjectBranchId
-> ProjectAndBranch ProjectId ProjectBranchId
forall p b. ProjectPathG p b -> ProjectAndBranch p b
PP.toProjectAndBranch (ProjectPathG ProjectId ProjectBranchId
-> ProjectAndBranch ProjectId ProjectBranchId)
-> (NonEmpty (ProjectPathG ProjectId ProjectBranchId)
-> ProjectPathG ProjectId ProjectBranchId)
-> NonEmpty (ProjectPathG ProjectId ProjectBranchId)
-> ProjectAndBranch ProjectId ProjectBranchId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (ProjectPathG ProjectId ProjectBranchId)
-> ProjectPathG ProjectId ProjectBranchId
forall a. NonEmpty a -> a
NonEmpty.head (NonEmpty (ProjectPathG ProjectId ProjectBranchId)
-> ProjectAndBranch ProjectId ProjectBranchId)
-> Cli (NonEmpty (ProjectPathG ProjectId ProjectBranchId))
-> Cli (ProjectAndBranch ProjectId ProjectBranchId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
(NonEmpty (ProjectPathG ProjectId ProjectBranchId))
LoopState
(NonEmpty (ProjectPathG ProjectId ProjectBranchId))
-> Cli (NonEmpty (ProjectPathG ProjectId ProjectBranchId))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
(NonEmpty (ProjectPathG ProjectId ProjectBranchId))
LoopState
(NonEmpty (ProjectPathG ProjectId ProjectBranchId))
#projectPathStack
let getProjectRoot :: IO (Branch IO)
getProjectRoot = IO (Branch IO) -> IO (Branch IO)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Branch IO) -> IO (Branch IO))
-> IO (Branch IO) -> IO (Branch IO)
forall a b. (a -> b) -> a -> b
$ Codebase IO Symbol Ann
-> ProjectId -> ProjectBranchId -> IO (Branch IO)
forall (m :: * -> *) v a.
MonadIO m =>
Codebase m v a -> ProjectId -> ProjectBranchId -> m (Branch m)
Codebase.expectProjectBranchRoot Codebase IO Symbol Ann
codebase ProjectId
projId ProjectBranchId
branchId
IO (Either (Pretty ColorText) (Maybe (Arguments, Input)))
-> Cli (Either (Pretty ColorText) (Maybe (Arguments, Input)))
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Codebase IO Symbol Ann
-> ProjectPath
-> IO (Branch IO)
-> [StructuredArgument]
-> Map [Char] InputPattern
-> [[Char]]
-> IO (Either (Pretty ColorText) (Maybe (Arguments, Input)))
parseInput Codebase IO Symbol Ann
codebase ProjectPath
curPath IO (Branch IO)
getProjectRoot [StructuredArgument]
numberedArgs Map [Char] InputPattern
patternMap [[Char]]
args) Cli (Either (Pretty ColorText) (Maybe (Arguments, Input)))
-> (Either (Pretty ColorText) (Maybe (Arguments, Input))
-> Cli (Either Event Input))
-> Cli (Either Event Input)
forall a b. Cli a -> (a -> Cli b) -> Cli b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left Pretty ColorText
msg -> do
IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Cli ()) -> IO () -> Cli ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
hasErrors Bool
True
IO Bool -> Cli Bool
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
allowErrors) Cli Bool
-> (Bool -> Cli (Either Event Input)) -> Cli (Either Event Input)
forall a b. Cli a -> (a -> Cli b) -> Cli b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> do
IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ()
output ([Char] -> IO ())
-> (Pretty ColorText -> [Char]) -> Pretty ColorText -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Width -> Pretty ColorText -> [Char]
Pretty.toPlain Width
terminalWidth (Pretty ColorText -> IO ()) -> Pretty ColorText -> IO ()
forall a b. (a -> b) -> a -> b
$ (Pretty ColorText
"\n" Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
msg Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
"\n"))
Cli (Either Event Input)
awaitInput
Bool
False -> do
IO (Either Event Input) -> Cli (Either Event Input)
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO (Either Event Input)
forall a. [Char] -> IO a
dieWithMsg ([Char] -> IO (Either Event Input))
-> [Char] -> IO (Either Event Input)
forall a b. (a -> b) -> a -> b
$ Width -> Pretty ColorText -> [Char]
Pretty.toPlain Width
terminalWidth Pretty ColorText
msg)
Right Maybe (Arguments, Input)
Nothing -> Cli (Either Event Input)
awaitInput
Right (Just (Arguments
_expandedArgs, Input
input)) -> Either Event Input -> Cli (Either Event Input)
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Event Input -> Cli (Either Event Input))
-> Either Event Input -> Cli (Either Event Input)
forall a b. (a -> b) -> a -> b
$ Input -> Either Event Input
forall a b. b -> Either a b
Right Input
input
Maybe (Maybe UcmLine)
Nothing -> do
IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
dieUnexpectedSuccess)
IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Hidden -> Hidden -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Hidden
hidden Hidden
Shown)
IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
allowErrors Bool
False)
Maybe (Stanza, Maybe Int)
maybeStanza <- STM (Maybe (Stanza, Maybe Int)) -> Cli (Maybe (Stanza, Maybe Int))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TQueue (Stanza, Maybe Int) -> STM (Maybe (Stanza, Maybe Int))
forall a. TQueue a -> STM (Maybe a)
Q.tryDequeue TQueue (Stanza, Maybe Int)
inputQueue)
()
_ <- IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe (Stanza, Maybe Int))
-> Maybe (Stanza, Maybe Int) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (Stanza, Maybe Int))
mStanza Maybe (Stanza, Maybe Int)
maybeStanza)
case Maybe (Stanza, Maybe Int)
maybeStanza of
Maybe (Stanza, Maybe Int)
Nothing -> IO (Either Event Input) -> Cli (Either Event Input)
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
IO ()
clearCurrentLine
[Char] -> IO ()
putStrLn [Char]
"\r✔️ Completed transcript."
pure $ Input -> Either Event Input
forall a b. b -> Either a b
Right Input
QuitI
Just (Stanza
s, Maybe Int
midx) -> do
Bool -> Cli () -> Cli ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Verbosity -> Bool
Verbosity.isSilent Verbosity
verbosity) (Cli () -> Cli ()) -> (IO () -> Cli ()) -> IO () -> Cli ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Cli ()) -> IO () -> Cli ()
forall a b. (a -> b) -> a -> b
$ do
IO ()
clearCurrentLine
[Char] -> IO ()
putStr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
[Char] -> (Int -> [Char]) -> Maybe Int -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
[Char]
"\r⏩ Skipping non-executable Markdown block."
( \Int
idx ->
[Char]
"\r⚙️ Processing stanza "
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
idx
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" of "
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([Stanza] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Stanza]
stanzas)
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"."
)
Maybe Int
midx
Handle -> IO ()
IO.hFlush Handle
IO.stdout
(Node -> Cli (Either Event Input))
-> (ProcessedBlock -> Cli (Either Event Input))
-> Stanza
-> Cli (Either Event Input)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
( \Node
node -> do
IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Cli ())
-> (ScratchFileName -> IO ()) -> ScratchFileName -> Cli ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
output ([Char] -> IO ())
-> (ScratchFileName -> [Char]) -> ScratchFileName -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScratchFileName -> [Char]
Text.unpack (ScratchFileName -> Cli ()) -> ScratchFileName -> Cli ()
forall a b. (a -> b) -> a -> b
$ Node -> ScratchFileName
Transcript.formatNode Node
node
Cli (Either Event Input)
awaitInput
)
( \ProcessedBlock
block -> case ProcessedBlock
block of
Unison Hidden
hide Bool
errOk Maybe ScratchFileName
filename ScratchFileName
txt -> do
IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Hidden -> Hidden -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Hidden
hidden Hidden
hide)
IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Cli ())
-> (ScratchFileName -> IO ()) -> ScratchFileName -> Cli ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
outputEcho ([Char] -> IO ())
-> (ScratchFileName -> [Char]) -> ScratchFileName -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScratchFileName -> [Char]
Text.unpack (ScratchFileName -> Cli ()) -> ScratchFileName -> Cli ()
forall a b. (a -> b) -> a -> b
$ ProcessedBlock -> ScratchFileName
Transcript.formatProcessedBlock ProcessedBlock
block
IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
allowErrors Bool
errOk)
IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ()
output [Char]
"``` ucm\n")
STM () -> Cli ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> Cli ())
-> (Maybe UcmLine -> STM ()) -> Maybe UcmLine -> Cli ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TQueue (Maybe UcmLine) -> Maybe UcmLine -> STM ()
forall a. TQueue a -> a -> STM ()
Q.enqueue TQueue (Maybe UcmLine)
cmdQueue (Maybe UcmLine -> Cli ()) -> Maybe UcmLine -> Cli ()
forall a b. (a -> b) -> a -> b
$ Maybe UcmLine
forall a. Maybe a
Nothing
let sourceName :: ScratchFileName
sourceName = ScratchFileName -> Maybe ScratchFileName -> ScratchFileName
forall a. a -> Maybe a -> a
fromMaybe ScratchFileName
"scratch.u" Maybe ScratchFileName
filename
IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Cli ()) -> IO () -> Cli ()
forall a b. (a -> b) -> a -> b
$ ScratchFileName -> ScratchFileName -> IO ()
updateVirtualFile ScratchFileName
sourceName ScratchFileName
txt
pure $ Event -> Either Event Input
forall a b. a -> Either a b
Left (ScratchFileName -> ScratchFileName -> Event
UnisonFileChanged ScratchFileName
sourceName ScratchFileName
txt)
API [APIRequest]
apiRequests -> do
IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ()
output [Char]
"``` api\n")
IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([APIRequest] -> (APIRequest -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [APIRequest]
apiRequests APIRequest -> IO ()
apiRequest)
IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ()
output [Char]
"```\n\n")
Cli (Either Event Input)
awaitInput
Ucm Hidden
hide Bool
errOk [UcmLine]
cmds -> do
IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Hidden -> Hidden -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Hidden
hidden Hidden
hide)
IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
allowErrors Bool
errOk)
IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
hasErrors Bool
False)
IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ()
output [Char]
"``` ucm")
(UcmLine -> Cli ()) -> [UcmLine] -> Cli ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (STM () -> Cli ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> Cli ()) -> (UcmLine -> STM ()) -> UcmLine -> Cli ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TQueue (Maybe UcmLine) -> Maybe UcmLine -> STM ()
forall a. TQueue a -> a -> STM ()
Q.enqueue TQueue (Maybe UcmLine)
cmdQueue (Maybe UcmLine -> STM ())
-> (UcmLine -> Maybe UcmLine) -> UcmLine -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UcmLine -> Maybe UcmLine
forall a. a -> Maybe a
Just) [UcmLine]
cmds
STM () -> Cli ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> Cli ())
-> (Maybe UcmLine -> STM ()) -> Maybe UcmLine -> Cli ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TQueue (Maybe UcmLine) -> Maybe UcmLine -> STM ()
forall a. TQueue a -> a -> STM ()
Q.enqueue TQueue (Maybe UcmLine)
cmdQueue (Maybe UcmLine -> Cli ()) -> Maybe UcmLine -> Cli ()
forall a b. (a -> b) -> a -> b
$ Maybe UcmLine
forall a. Maybe a
Nothing
Cli (Either Event Input)
awaitInput
)
Stanza
s
loadPreviousUnisonBlock :: ScratchFileName -> IO LoadSourceResult
loadPreviousUnisonBlock ScratchFileName
name = do
Map ScratchFileName ScratchFileName
ufs <- IORef (Map ScratchFileName ScratchFileName)
-> IO (Map ScratchFileName ScratchFileName)
forall a. IORef a -> IO a
readIORef IORef (Map ScratchFileName ScratchFileName)
unisonFiles
case ScratchFileName
-> Map ScratchFileName ScratchFileName -> Maybe ScratchFileName
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScratchFileName
name Map ScratchFileName ScratchFileName
ufs of
Just ScratchFileName
uf ->
LoadSourceResult -> IO LoadSourceResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScratchFileName -> LoadSourceResult
Cli.LoadSuccess ScratchFileName
uf)
Maybe ScratchFileName
Nothing ->
let f :: IO LoadSourceResult
f = ScratchFileName -> LoadSourceResult
Cli.LoadSuccess (ScratchFileName -> LoadSourceResult)
-> IO ScratchFileName -> IO LoadSourceResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO ScratchFileName
readUtf8 (ScratchFileName -> [Char]
Text.unpack ScratchFileName
name)
in IO LoadSourceResult
f IO LoadSourceResult -> IO LoadSourceResult -> IO LoadSourceResult
forall a. IO a -> IO a -> IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> LoadSourceResult -> IO LoadSourceResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoadSourceResult
Cli.InvalidSourceNameError
writeSourceFile :: ScratchFileName -> Text -> IO ()
writeSourceFile :: ScratchFileName -> ScratchFileName -> IO ()
writeSourceFile ScratchFileName
fp ScratchFileName
contents = do
Bool
shouldShowSourceChanges <- (Hidden -> Hidden -> Bool
forall a. Eq a => a -> a -> Bool
== Hidden
Shown) (Hidden -> Bool) -> IO Hidden -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Hidden -> IO Hidden
forall a. IORef a -> IO a
readIORef IORef Hidden
hidden
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldShowSourceChanges (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TQueue (ScratchFileName, ScratchFileName)
-> (ScratchFileName, ScratchFileName) -> STM ()
forall a. TQueue a -> a -> STM ()
Q.enqueue TQueue (ScratchFileName, ScratchFileName)
ucmScratchFileUpdatesQueue (ScratchFileName
fp, ScratchFileName
contents))
ScratchFileName -> ScratchFileName -> IO ()
updateVirtualFile ScratchFileName
fp ScratchFileName
contents
updateVirtualFile :: ScratchFileName -> Text -> IO ()
updateVirtualFile :: ScratchFileName -> ScratchFileName -> IO ()
updateVirtualFile ScratchFileName
fp ScratchFileName
contents = do
IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Map ScratchFileName ScratchFileName)
-> (Map ScratchFileName ScratchFileName
-> Map ScratchFileName ScratchFileName)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Map ScratchFileName ScratchFileName)
unisonFiles (ScratchFileName
-> ScratchFileName
-> Map ScratchFileName ScratchFileName
-> Map ScratchFileName ScratchFileName
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ScratchFileName
fp ScratchFileName
contents))
print :: Output.Output -> IO ()
print :: Output -> IO ()
print Output
o = do
Pretty ColorText
msg <- [Char] -> Output -> IO (Pretty ColorText)
notifyUser [Char]
dir Output
o
Bool
errOk <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
allowErrors
let rendered :: [Char]
rendered = Width -> Pretty ColorText -> [Char]
Pretty.toPlain Width
terminalWidth (Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
Pretty.border Width
2 Pretty ColorText
msg)
[Char] -> IO ()
output [Char]
rendered
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Output -> Bool
Output.isFailure Output
o) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
if Bool
errOk
then IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
hasErrors Bool
True
else [Char] -> IO ()
forall a. [Char] -> IO a
dieWithMsg [Char]
rendered
printNumbered :: Output.NumberedOutput -> IO Output.NumberedArgs
printNumbered :: NumberedOutput -> IO [StructuredArgument]
printNumbered NumberedOutput
o = do
let (Pretty ColorText
msg, [StructuredArgument]
numberedArgs) = NumberedOutput -> (Pretty ColorText, [StructuredArgument])
notifyNumbered NumberedOutput
o
Bool
errOk <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
allowErrors
let rendered :: [Char]
rendered = Width -> Pretty ColorText -> [Char]
Pretty.toPlain Width
terminalWidth (Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
Pretty.border Width
2 Pretty ColorText
msg)
[Char] -> IO ()
output [Char]
rendered
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NumberedOutput -> Bool
Output.isNumberedFailure NumberedOutput
o) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
if Bool
errOk
then IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
hasErrors Bool
True
else [Char] -> IO ()
forall a. [Char] -> IO a
dieWithMsg [Char]
rendered
pure [StructuredArgument]
numberedArgs
appendFailingStanza :: IO ()
appendFailingStanza :: IO ()
appendFailingStanza = do
Maybe (Stanza, Maybe Int)
stanzaOpt <- IORef (Maybe (Stanza, Maybe Int)) -> IO (Maybe (Stanza, Maybe Int))
forall a. IORef a -> IO a
readIORef IORef (Maybe (Stanza, Maybe Int))
mStanza
Seq [Char]
currentOut <- IORef (Seq [Char]) -> IO (Seq [Char])
forall a. IORef a -> IO a
readIORef IORef (Seq [Char])
out
let stnz :: [Char]
stnz = [Char]
-> ((Stanza, Maybe Int) -> [Char])
-> Maybe (Stanza, Maybe Int)
-> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (ScratchFileName -> [Char]
Text.unpack (ScratchFileName -> [Char])
-> ((Stanza, Maybe Int) -> ScratchFileName)
-> (Stanza, Maybe Int)
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stanza -> ScratchFileName
Transcript.formatStanza (Stanza -> ScratchFileName)
-> ((Stanza, Maybe Int) -> Stanza)
-> (Stanza, Maybe Int)
-> ScratchFileName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stanza, Maybe Int) -> Stanza
forall a b. (a, b) -> a
fst) Maybe (Stanza, Maybe Int)
stanzaOpt
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Char]
stnz [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSubsequenceOf` Seq [Char] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Seq [Char]
currentOut) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
IORef (Seq [Char]) -> (Seq [Char] -> Seq [Char]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Seq [Char])
out (\Seq [Char]
acc -> Seq [Char]
acc Seq [Char] -> Seq [Char] -> Seq [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Seq [Char]
forall a. a -> Seq a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
stnz)
dieWithMsg :: forall a. String -> IO a
dieWithMsg :: forall a. [Char] -> IO a
dieWithMsg [Char]
msg = do
[Char] -> IO ()
output [Char]
"\n```\n\n"
IO ()
appendFailingStanza
IORef (Seq [Char]) -> ScratchFileName -> IO a
forall b. IORef (Seq [Char]) -> ScratchFileName -> IO b
transcriptFailure IORef (Seq [Char])
out (ScratchFileName -> IO a) -> ScratchFileName -> IO a
forall a b. (a -> b) -> a -> b
$
ScratchFileName
"The transcript failed due to an error in the stanza above. The error is:\n\n" ScratchFileName -> ScratchFileName -> ScratchFileName
forall a. Semigroup a => a -> a -> a
<> [Char] -> ScratchFileName
Text.pack [Char]
msg
dieUnexpectedSuccess :: IO ()
dieUnexpectedSuccess :: IO ()
dieUnexpectedSuccess = do
Bool
errOk <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
allowErrors
Bool
hasErr <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
hasErrors
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
errOk Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
hasErr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[Char] -> IO ()
output [Char]
"\n```\n\n"
IO ()
appendFailingStanza
IORef (Seq [Char]) -> ScratchFileName -> IO ()
forall b. IORef (Seq [Char]) -> ScratchFileName -> IO b
transcriptFailure IORef (Seq [Char])
out ScratchFileName
"The transcript was expecting an error in the stanza above, but did not encounter one."
AuthenticatedHttpClient
authenticatedHTTPClient <- TokenProvider -> ScratchFileName -> IO AuthenticatedHttpClient
forall (m :: * -> *).
MonadIO m =>
TokenProvider -> ScratchFileName -> m AuthenticatedHttpClient
AuthN.newAuthenticatedHTTPClient TokenProvider
tokenProvider ScratchFileName
ucmVersion
let env :: Env
env =
Cli.Env
{ $sel:authHTTPClient:Env :: AuthenticatedHttpClient
authHTTPClient = AuthenticatedHttpClient
authenticatedHTTPClient,
Codebase IO Symbol Ann
codebase :: Codebase IO Symbol Ann
$sel:codebase:Env :: Codebase IO Symbol Ann
codebase,
$sel:credentialManager:Env :: CredentialManager
credentialManager = CredentialManager
credMan,
$sel:generateUniqueName:Env :: IO UniqueName
generateUniqueName = do
Int
i <- IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
seedRef \Int
i -> let !i' :: Int
i' = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 in (Int
i', Int
i)
pure (ChaChaDRG -> UniqueName
forall gen. DRG gen => gen -> UniqueName
Parser.uniqueBase32Namegen (Seed -> ChaChaDRG
Random.drgNewSeed (Integer -> Seed
Random.seedFromInteger (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)))),
$sel:loadSource:Env :: ScratchFileName -> IO LoadSourceResult
loadSource = ScratchFileName -> IO LoadSourceResult
loadPreviousUnisonBlock,
$sel:writeSource:Env :: ScratchFileName -> ScratchFileName -> IO ()
writeSource = ScratchFileName -> ScratchFileName -> IO ()
writeSourceFile,
$sel:notify:Env :: Output -> IO ()
notify = Output -> IO ()
print,
$sel:notifyNumbered:Env :: NumberedOutput -> IO [StructuredArgument]
notifyNumbered = NumberedOutput -> IO [StructuredArgument]
printNumbered,
Runtime Symbol
runtime :: Runtime Symbol
$sel:runtime:Env :: Runtime Symbol
runtime,
$sel:sandboxedRuntime:Env :: Runtime Symbol
sandboxedRuntime = Runtime Symbol
sbRuntime,
$sel:nativeRuntime:Env :: Runtime Symbol
nativeRuntime = Runtime Symbol
nRuntime,
$sel:serverBaseUrl:Env :: Maybe BaseUrl
serverBaseUrl = Maybe BaseUrl
forall a. Maybe a
Nothing,
ScratchFileName
ucmVersion :: ScratchFileName
$sel:ucmVersion:Env :: ScratchFileName
ucmVersion,
$sel:isTranscriptTest:Env :: Bool
isTranscriptTest = Bool
isTest
}
let loop :: Cli.LoopState -> IO Text
loop :: LoopState -> IO ScratchFileName
loop LoopState
s0 = do
Env
-> LoopState
-> Cli (Either Event Input)
-> IO (ReturnType (Either Event Input), LoopState)
forall a. Env -> LoopState -> Cli a -> IO (ReturnType a, LoopState)
Cli.runCli Env
env LoopState
s0 Cli (Either Event Input)
awaitInput IO (ReturnType (Either Event Input), LoopState)
-> ((ReturnType (Either Event Input), LoopState)
-> IO ScratchFileName)
-> IO ScratchFileName
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
(Cli.Success Either Event Input
input, LoopState
s1) -> do
let next :: LoopState -> IO ScratchFileName
next LoopState
s =
LoopState -> IO ScratchFileName
loop case Either Event Input
input of
Left Event
_ -> LoopState
s
Right Input
inp -> LoopState
s LoopState -> (LoopState -> LoopState) -> LoopState
forall a b. a -> (a -> b) -> b
& ASetter LoopState LoopState (Maybe Input) (Maybe Input)
#lastInput ASetter LoopState LoopState (Maybe Input) (Maybe Input)
-> Input -> LoopState -> LoopState
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Input
inp
Env -> LoopState -> Cli () -> IO (ReturnType (), LoopState)
forall a. Env -> LoopState -> Cli a -> IO (ReturnType a, LoopState)
Cli.runCli Env
env LoopState
s1 (Either Event Input -> Cli ()
HandleInput.loop Either Event Input
input) IO (ReturnType (), LoopState)
-> ((ReturnType (), LoopState) -> IO ScratchFileName)
-> IO ScratchFileName
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
(Cli.Success (), LoopState
s2) -> LoopState -> IO ScratchFileName
next LoopState
s2
(ReturnType ()
Cli.Continue, LoopState
s2) -> LoopState -> IO ScratchFileName
next LoopState
s2
(ReturnType ()
Cli.HaltRepl, LoopState
_) -> IO ScratchFileName
onHalt
(ReturnType (Either Event Input)
Cli.Continue, LoopState
s1) -> LoopState -> IO ScratchFileName
loop LoopState
s1
(ReturnType (Either Event Input)
Cli.HaltRepl, LoopState
_) -> IO ScratchFileName
onHalt
where
onHalt :: IO ScratchFileName
onHalt = do
Seq [Char]
texts <- IORef (Seq [Char]) -> IO (Seq [Char])
forall a. IORef a -> IO a
readIORef IORef (Seq [Char])
out
pure $ [ScratchFileName] -> ScratchFileName
Text.concat ([Char] -> ScratchFileName
Text.pack ([Char] -> ScratchFileName) -> [[Char]] -> [ScratchFileName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq [Char] -> [[Char]]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq [Char]
texts :: Seq String))
LoopState -> IO ScratchFileName
loop (ProjectPathG ProjectId ProjectBranchId -> LoopState
Cli.loopState0 (ProjectPath -> ProjectPathG ProjectId ProjectBranchId
PP.toIds ProjectPath
initialPP))
transcriptFailure :: IORef (Seq String) -> Text -> IO b
transcriptFailure :: forall b. IORef (Seq [Char]) -> ScratchFileName -> IO b
transcriptFailure IORef (Seq [Char])
out ScratchFileName
msg = do
Seq [Char]
texts <- IORef (Seq [Char]) -> IO (Seq [Char])
forall a. IORef a -> IO a
readIORef IORef (Seq [Char])
out
Error -> IO b
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UnliftIO.throwIO (Error -> IO b)
-> (ScratchFileName -> Error) -> ScratchFileName -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScratchFileName -> Error
RunFailure (ScratchFileName -> IO b) -> ScratchFileName -> IO b
forall a b. (a -> b) -> a -> b
$ [ScratchFileName] -> ScratchFileName
forall a. Monoid a => [a] -> a
mconcat ([Char] -> ScratchFileName
Text.pack ([Char] -> ScratchFileName) -> [[Char]] -> [ScratchFileName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq [Char] -> [[Char]]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq [Char]
texts) ScratchFileName -> ScratchFileName -> ScratchFileName
forall a. Semigroup a => a -> a -> a
<> ScratchFileName
"\n\n\128721\n\n" ScratchFileName -> ScratchFileName -> ScratchFileName
forall a. Semigroup a => a -> a -> a
<> ScratchFileName
msg ScratchFileName -> ScratchFileName -> ScratchFileName
forall a. Semigroup a => a -> a -> a
<> ScratchFileName
"\n"
data Error
= ParseError (P.ParseErrorBundle Text Void)
| RunFailure Text
deriving stock (Int -> Error -> [Char] -> [Char]
[Error] -> [Char] -> [Char]
Error -> [Char]
(Int -> Error -> [Char] -> [Char])
-> (Error -> [Char]) -> ([Error] -> [Char] -> [Char]) -> Show Error
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Error -> [Char] -> [Char]
showsPrec :: Int -> Error -> [Char] -> [Char]
$cshow :: Error -> [Char]
show :: Error -> [Char]
$cshowList :: [Error] -> [Char] -> [Char]
showList :: [Error] -> [Char] -> [Char]
Show)
deriving anyclass (Show Error
Typeable Error
(Typeable Error, Show Error) =>
(Error -> SomeException)
-> (SomeException -> Maybe Error)
-> (Error -> [Char])
-> Exception Error
SomeException -> Maybe Error
Error -> [Char]
Error -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> [Char]) -> Exception e
$ctoException :: Error -> SomeException
toException :: Error -> SomeException
$cfromException :: SomeException -> Maybe Error
fromException :: SomeException -> Maybe Error
$cdisplayException :: Error -> [Char]
displayException :: Error -> [Char]
Exception)