{-# LANGUAGE DataKinds #-}

-- | The main CLI monad.
module Unison.Cli.Monad
  ( -- * Cli monad
    Cli,
    ReturnType (..),
    SourceName,
    runCli,

    -- * Envronment
    Env (..),

    -- * Immutable state
    LoopState (..),
    loopState0,
    getProjectPathIds,

    -- * Lifting IO actions
    ioE,

    -- * Acquiring resources
    with,
    with_,
    withE,

    -- * Short-circuiting
    label,
    labelE,
    returnEarly,
    returnEarlyWithoutOutput,
    haltRepl,

    -- * Changing the current directory
    cd,
    popd,
    switchProject,

    -- * Communicating output to the user
    respond,
    respondNumbered,
    withRespondRegion,
    setNumberedArgs,

    -- * Debug-timing actions
    time,

    -- * Running transactions
    runTransaction,
    runTransactionWithRollback,
    runTransactionWithRollback2,

    -- * Internal
    setMostRecentProjectPath,

    -- * Misc types
    LoadSourceResult (..),
  )
where

import Control.Exception (throwIO)
import Control.Lens
import Control.Monad.Reader (MonadReader (..))
import Control.Monad.State.Strict (MonadState)
import Control.Monad.State.Strict qualified as State
import Data.List.NonEmpty qualified as List (NonEmpty)
import Data.List.NonEmpty qualified as List.NonEmpty
import Data.List.NonEmpty qualified as NonEmpty
import Data.Time.Clock (DiffTime, diffTimeToPicoseconds)
import Data.Time.Clock.System (getSystemTime, systemToTAITime)
import Data.Time.Clock.TAI (diffAbsoluteTime)
import Data.Unique (Unique, newUnique)
import System.CPUTime (getCPUTime)
import System.Console.Regions qualified as Console.Regions
import Text.Printf (printf)
import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId)
import U.Codebase.Sqlite.Queries qualified as Q
import Unison.Auth.CredentialManager (CredentialManager)
import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
import Unison.Codebase (Codebase)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Editor.Input (Input)
import Unison.Codebase.Editor.Output (NumberedArgs, NumberedOutput, Output)
import Unison.Codebase.Editor.UCMVersion (UCMVersion)
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.Runtime (Runtime)
import Unison.CommandLine.OutputMessages qualified as OutputMessages
import Unison.Core.Project (ProjectAndBranch (..))
import Unison.Debug qualified as Debug
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import Unison.PrettyTerminal qualified as PrettyTerminal
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.Term (Term)
import Unison.Type (Type)
import Unison.UnisonFile qualified as UF
import Unison.Util.Pretty qualified as Pretty
import Unsafe.Coerce (unsafeCoerce)

-- | The main command-line app monad.
--
-- * It is a reader monad of 'Env'.
--
-- * It is a state monad of 'LoopState'.
--
-- * It is a short-circuiting monad: a @Cli@ computation can short-circuit with success or failure in a delimited scope.
--
-- * It is a resource monad: resources can be acquired in callback-style.
--
-- * It is an IO monad: you can do IO things, but throwing synchronous exceptions is discouraged. Use the built-in
-- short-circuiting mechanism instead.
newtype Cli a = Cli
  { forall a.
Cli a
-> forall r.
   Env
   -> (a -> LoopState -> IO (ReturnType r, LoopState))
   -> LoopState
   -> IO (ReturnType r, LoopState)
unCli ::
      forall r.
      Env ->
      (a -> LoopState -> IO (ReturnType r, LoopState)) ->
      LoopState ->
      IO (ReturnType r, LoopState)
  }
  deriving stock ((forall a b. (a -> b) -> Cli a -> Cli b)
-> (forall a b. a -> Cli b -> Cli a) -> Functor Cli
forall a b. a -> Cli b -> Cli a
forall a b. (a -> b) -> Cli a -> Cli b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Cli a -> Cli b
fmap :: forall a b. (a -> b) -> Cli a -> Cli b
$c<$ :: forall a b. a -> Cli b -> Cli a
<$ :: forall a b. a -> Cli b -> Cli a
Functor)

instance Applicative Cli where
  pure :: forall a. a -> Cli a
pure a
x = (forall r.
 Env
 -> (a -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli a
forall a.
(forall r.
 Env
 -> (a -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli a
Cli \Env
_ a -> LoopState -> IO (ReturnType r, LoopState)
k -> a -> LoopState -> IO (ReturnType r, LoopState)
k a
x
  <*> :: forall a b. Cli (a -> b) -> Cli a -> Cli b
(<*>) = Cli (a -> b) -> Cli a -> Cli b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad Cli where
  return :: forall a. a -> Cli a
return = a -> Cli a
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Cli forall r.
Env
-> (a -> LoopState -> IO (ReturnType r, LoopState))
-> LoopState
-> IO (ReturnType r, LoopState)
mx >>= :: forall a b. Cli a -> (a -> Cli b) -> Cli b
>>= a -> Cli b
f =
    (forall r.
 Env
 -> (b -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli b
forall a.
(forall r.
 Env
 -> (a -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli a
Cli \Env
env b -> LoopState -> IO (ReturnType r, LoopState)
k ->
      Env
-> (a -> LoopState -> IO (ReturnType r, LoopState))
-> LoopState
-> IO (ReturnType r, LoopState)
forall r.
Env
-> (a -> LoopState -> IO (ReturnType r, LoopState))
-> LoopState
-> IO (ReturnType r, LoopState)
mx Env
env \a
a -> Cli b
-> forall r.
   Env
   -> (b -> LoopState -> IO (ReturnType r, LoopState))
   -> LoopState
   -> IO (ReturnType r, LoopState)
forall a.
Cli a
-> forall r.
   Env
   -> (a -> LoopState -> IO (ReturnType r, LoopState))
   -> LoopState
   -> IO (ReturnType r, LoopState)
unCli (a -> Cli b
f a
a) Env
env b -> LoopState -> IO (ReturnType r, LoopState)
k

instance MonadIO Cli where
  liftIO :: forall a. IO a -> Cli a
liftIO IO a
mx =
    (forall r.
 Env
 -> (a -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli a
forall a.
(forall r.
 Env
 -> (a -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli a
Cli \Env
_ a -> LoopState -> IO (ReturnType r, LoopState)
k LoopState
s -> do
      a
x <- IO a
mx
      a -> LoopState -> IO (ReturnType r, LoopState)
k a
x LoopState
s

instance MonadReader Env Cli where
  ask :: Cli Env
ask = (forall r.
 Env
 -> (Env -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli Env
forall a.
(forall r.
 Env
 -> (a -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli a
Cli \Env
env Env -> LoopState -> IO (ReturnType r, LoopState)
k -> Env -> LoopState -> IO (ReturnType r, LoopState)
k Env
env
  local :: forall a. (Env -> Env) -> Cli a -> Cli a
local Env -> Env
f Cli a
m = (forall r.
 Env
 -> (a -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli a
forall a.
(forall r.
 Env
 -> (a -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli a
Cli \Env
env -> Cli a
-> forall r.
   Env
   -> (a -> LoopState -> IO (ReturnType r, LoopState))
   -> LoopState
   -> IO (ReturnType r, LoopState)
forall a.
Cli a
-> forall r.
   Env
   -> (a -> LoopState -> IO (ReturnType r, LoopState))
   -> LoopState
   -> IO (ReturnType r, LoopState)
unCli Cli a
m (Env -> Env
f Env
env)

instance MonadState LoopState Cli where
  get :: Cli LoopState
get = (forall r.
 Env
 -> (LoopState -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli LoopState
forall a.
(forall r.
 Env
 -> (a -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli a
Cli \Env
_ LoopState -> LoopState -> IO (ReturnType r, LoopState)
k LoopState
s -> LoopState -> LoopState -> IO (ReturnType r, LoopState)
k LoopState
s LoopState
s
  put :: LoopState -> Cli ()
put LoopState
s = (forall r.
 Env
 -> (() -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli ()
forall a.
(forall r.
 Env
 -> (a -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli a
Cli \Env
_ () -> LoopState -> IO (ReturnType r, LoopState)
k LoopState
_ -> () -> LoopState -> IO (ReturnType r, LoopState)
k () LoopState
s

-- | What a Cli action returns: a value, an instruction to continue processing input, or an instruction to stop
-- processing input.
data ReturnType a
  = Success a
  | Continue
  | HaltRepl
  deriving stock (ReturnType a -> ReturnType a -> Bool
(ReturnType a -> ReturnType a -> Bool)
-> (ReturnType a -> ReturnType a -> Bool) -> Eq (ReturnType a)
forall a. Eq a => ReturnType a -> ReturnType a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => ReturnType a -> ReturnType a -> Bool
== :: ReturnType a -> ReturnType a -> Bool
$c/= :: forall a. Eq a => ReturnType a -> ReturnType a -> Bool
/= :: ReturnType a -> ReturnType a -> Bool
Eq, Int -> ReturnType a -> ShowS
[ReturnType a] -> ShowS
ReturnType a -> FilePath
(Int -> ReturnType a -> ShowS)
-> (ReturnType a -> FilePath)
-> ([ReturnType a] -> ShowS)
-> Show (ReturnType a)
forall a. Show a => Int -> ReturnType a -> ShowS
forall a. Show a => [ReturnType a] -> ShowS
forall a. Show a => ReturnType a -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> ReturnType a -> ShowS
showsPrec :: Int -> ReturnType a -> ShowS
$cshow :: forall a. Show a => ReturnType a -> FilePath
show :: ReturnType a -> FilePath
$cshowList :: forall a. Show a => [ReturnType a] -> ShowS
showList :: [ReturnType a] -> ShowS
Show)

-- | Name used for a source-file/source buffer
type SourceName = Text

-- | The command-line app monad environment.
--
-- Get the environment with 'ask'.
data Env = Env
  { Env -> AuthenticatedHttpClient
authHTTPClient :: AuthenticatedHttpClient,
    Env -> Codebase IO Symbol Ann
codebase :: Codebase IO Symbol Ann,
    Env -> CredentialManager
credentialManager :: CredentialManager,
    -- | Generate a unique name.
    Env -> IO UniqueName
generateUniqueName :: IO Parser.UniqueName,
    -- | How to load source code.
    Env -> SourceName -> IO LoadSourceResult
loadSource :: SourceName -> IO LoadSourceResult,
    -- | How to write source code. Bool = make new fold?
    Env -> SourceName -> SourceName -> Bool -> IO ()
writeSource :: SourceName -> Text -> Bool -> IO (),
    -- | What to do with output for the user.
    Env -> Output -> IO ()
notify :: Output -> IO (),
    -- | What to do with numbered output for the user.
    Env -> NumberedOutput -> IO [StructuredArgument]
notifyNumbered :: NumberedOutput -> IO NumberedArgs,
    Env -> Runtime Symbol
runtime :: Runtime Symbol,
    Env -> Runtime Symbol
sandboxedRuntime :: Runtime Symbol,
    Env -> Runtime Symbol
nativeRuntime :: Runtime Symbol,
    Env -> Maybe BaseUrl
serverBaseUrl :: Maybe Server.BaseUrl,
    Env -> SourceName
ucmVersion :: UCMVersion,
    -- | Whether we're running in a transcript test or not.
    -- Avoid using this except when absolutely necessary.
    Env -> Bool
isTranscriptTest :: Bool
  }
  deriving stock ((forall x. Env -> Rep Env x)
-> (forall x. Rep Env x -> Env) -> Generic Env
forall x. Rep Env x -> Env
forall x. Env -> Rep Env x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Env -> Rep Env x
from :: forall x. Env -> Rep Env x
$cto :: forall x. Rep Env x -> Env
to :: forall x. Rep Env x -> Env
Generic)

-- | The command-line app monad mutable state.
--
-- There's an additional pseudo @"currentPath"@ field lens, for convenience.
data LoopState = LoopState
  { -- the current position in the codebase, with the head being the most recent lcoation.
    LoopState -> NonEmpty (ProjectPathG ProjectId ProjectBranchId)
projectPathStack :: List.NonEmpty PP.ProjectPathIds,
    -- TBD
    -- , _activeEdits :: Set Branch.EditGuid

    -- The file name last modified, and whether to skip the next file
    -- change event for that path (we skip file changes if the file has
    -- just been modified programmatically)
    LoopState -> Maybe (FilePath, Bool)
latestFile :: Maybe (FilePath, Bool),
    -- Nothing means the file didn't parse
    -- Just (Left) means the file parsed but didn't typecheck
    -- Just (Right) means the file parsed and typechecked
    LoopState
-> Maybe
     (Either (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann))
latestTypecheckedFile :: Maybe (Either (UF.UnisonFile Symbol Ann) (UF.TypecheckedUnisonFile Symbol Ann)),
    -- The previous user input. Used to request confirmation of
    -- questionable user commands.
    LoopState -> Maybe Input
lastInput :: Maybe Input,
    -- A 1-indexed list of strings that can be referenced by index at the
    -- CLI prompt.  e.g. Given ["Foo.bat", "Foo.cat"],
    -- `rename 2 Foo.foo` will rename `Foo.cat` to `Foo.foo`.
    LoopState -> [StructuredArgument]
numberedArgs :: NumberedArgs,
    -- The result of the last run, along with a unison file that
    -- captures the state of dependencies when the last run occurred
    LoopState
-> Maybe
     (Term Symbol Ann, Type Symbol Ann,
      TypecheckedUnisonFile Symbol Ann)
lastRunResult :: Maybe (Term Symbol Ann, Type Symbol Ann, UF.TypecheckedUnisonFile Symbol Ann)
  }
  deriving stock ((forall x. LoopState -> Rep LoopState x)
-> (forall x. Rep LoopState x -> LoopState) -> Generic LoopState
forall x. Rep LoopState x -> LoopState
forall x. LoopState -> Rep LoopState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LoopState -> Rep LoopState x
from :: forall x. LoopState -> Rep LoopState x
$cto :: forall x. Rep LoopState x -> LoopState
to :: forall x. Rep LoopState x -> LoopState
Generic)

-- | Create an initial loop state given a root branch and the current path.
loopState0 :: PP.ProjectPathIds -> LoopState
loopState0 :: ProjectPathG ProjectId ProjectBranchId -> LoopState
loopState0 ProjectPathG ProjectId ProjectBranchId
p = do
  LoopState
    { $sel:projectPathStack:LoopState :: NonEmpty (ProjectPathG ProjectId ProjectBranchId)
projectPathStack = ProjectPathG ProjectId ProjectBranchId
-> NonEmpty (ProjectPathG ProjectId ProjectBranchId)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectPathG ProjectId ProjectBranchId
p,
      $sel:latestFile:LoopState :: Maybe (FilePath, Bool)
latestFile = Maybe (FilePath, Bool)
forall a. Maybe a
Nothing,
      $sel:latestTypecheckedFile:LoopState :: Maybe
  (Either (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann))
latestTypecheckedFile = Maybe
  (Either (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann))
forall a. Maybe a
Nothing,
      $sel:lastInput:LoopState :: Maybe Input
lastInput = Maybe Input
forall a. Maybe a
Nothing,
      $sel:numberedArgs:LoopState :: [StructuredArgument]
numberedArgs = [],
      $sel:lastRunResult:LoopState :: Maybe
  (Term Symbol Ann, Type Symbol Ann,
   TypecheckedUnisonFile Symbol Ann)
lastRunResult = Maybe
  (Term Symbol Ann, Type Symbol Ann,
   TypecheckedUnisonFile Symbol Ann)
forall a. Maybe a
Nothing
    }

-- | Run a @Cli@ action down to @IO@.
runCli :: Env -> LoopState -> Cli a -> IO (ReturnType a, LoopState)
runCli :: forall a. Env -> LoopState -> Cli a -> IO (ReturnType a, LoopState)
runCli Env
env LoopState
s0 (Cli forall r.
Env
-> (a -> LoopState -> IO (ReturnType r, LoopState))
-> LoopState
-> IO (ReturnType r, LoopState)
action) =
  Env
-> (a -> LoopState -> IO (ReturnType a, LoopState))
-> LoopState
-> IO (ReturnType a, LoopState)
forall r.
Env
-> (a -> LoopState -> IO (ReturnType r, LoopState))
-> LoopState
-> IO (ReturnType r, LoopState)
action Env
env (\a
x LoopState
s1 -> (ReturnType a, LoopState) -> IO (ReturnType a, LoopState)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> ReturnType a
forall a. a -> ReturnType a
Success a
x, LoopState
s1)) LoopState
s0

feed :: (a -> LoopState -> IO (ReturnType b, LoopState)) -> (ReturnType a, LoopState) -> IO (ReturnType b, LoopState)
feed :: forall a b.
(a -> LoopState -> IO (ReturnType b, LoopState))
-> (ReturnType a, LoopState) -> IO (ReturnType b, LoopState)
feed a -> LoopState -> IO (ReturnType b, LoopState)
k = \case
  (Success a
x, LoopState
s) -> a -> LoopState -> IO (ReturnType b, LoopState)
k a
x LoopState
s
  (ReturnType a
Continue, LoopState
s) -> (ReturnType b, LoopState) -> IO (ReturnType b, LoopState)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReturnType b
forall a. ReturnType a
Continue, LoopState
s)
  (ReturnType a
HaltRepl, LoopState
s) -> (ReturnType b, LoopState) -> IO (ReturnType b, LoopState)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReturnType b
forall a. ReturnType a
HaltRepl, LoopState
s)

-- | The result of calling 'loadSource'.
data LoadSourceResult
  = InvalidSourceNameError
  | LoadError
  | LoadSuccess Text

-- | Lift an action of type @IO (Either e a)@, given a continuation for @e@.
ioE :: IO (Either e a) -> (e -> Cli a) -> Cli a
ioE :: forall e a. IO (Either e a) -> (e -> Cli a) -> Cli a
ioE IO (Either e a)
action e -> Cli a
errK =
  IO (Either e a) -> Cli (Either e a)
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Either e a)
action Cli (Either e a) -> (Either e a -> Cli a) -> Cli a
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 e
err -> e -> Cli a
errK e
err
    Right a
value -> a -> Cli a
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
value

short :: (forall r. ReturnType r) -> Cli a
short :: forall a. (forall a. ReturnType a) -> Cli a
short forall a. ReturnType a
r = (forall r.
 Env
 -> (a -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli a
forall a.
(forall r.
 Env
 -> (a -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli a
Cli \Env
_env a -> LoopState -> IO (ReturnType r, LoopState)
_k LoopState
s -> (ReturnType r, LoopState) -> IO (ReturnType r, LoopState)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReturnType r
forall a. ReturnType a
r, LoopState
s)

-- | Short-circuit the processing of the current input.
returnEarly :: Output -> Cli a
returnEarly :: forall a. Output -> Cli a
returnEarly Output
x = do
  Output -> Cli ()
respond Output
x
  Cli a
forall a. Cli a
returnEarlyWithoutOutput

-- | Variant of 'returnEarly' that doesn't take a final output message.
returnEarlyWithoutOutput :: Cli a
returnEarlyWithoutOutput :: forall a. Cli a
returnEarlyWithoutOutput =
  (forall a. ReturnType a) -> Cli a
forall a. (forall a. ReturnType a) -> Cli a
short ReturnType r
forall a. ReturnType a
Continue

-- | Stop processing inputs from the user.
haltRepl :: Cli a
haltRepl :: forall a. Cli a
haltRepl = (forall a. ReturnType a) -> Cli a
forall a. (forall a. ReturnType a) -> Cli a
short ReturnType r
forall a. ReturnType a
HaltRepl

-- | Wrap a continuation with 'Cli'.
--
-- Useful for resource acquisition:
--
-- @
-- with (bracket create destroy) \\resource ->
--   ...
-- @
with :: (forall x. (a -> IO x) -> IO x) -> (a -> Cli b) -> Cli b
with :: forall a b.
(forall x. (a -> IO x) -> IO x) -> (a -> Cli b) -> Cli b
with forall x. (a -> IO x) -> IO x
resourceK a -> Cli b
action =
  (forall r.
 Env
 -> (b -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli b
forall a.
(forall r.
 Env
 -> (a -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli a
Cli \Env
env b -> LoopState -> IO (ReturnType r, LoopState)
k LoopState
s ->
    (a -> IO (ReturnType b, LoopState)) -> IO (ReturnType b, LoopState)
forall x. (a -> IO x) -> IO x
resourceK (Env -> LoopState -> Cli b -> IO (ReturnType b, LoopState)
forall a. Env -> LoopState -> Cli a -> IO (ReturnType a, LoopState)
runCli Env
env LoopState
s (Cli b -> IO (ReturnType b, LoopState))
-> (a -> Cli b) -> a -> IO (ReturnType b, LoopState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Cli b
action) IO (ReturnType b, LoopState)
-> ((ReturnType b, LoopState) -> IO (ReturnType r, LoopState))
-> IO (ReturnType r, LoopState)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (b -> LoopState -> IO (ReturnType r, LoopState))
-> (ReturnType b, LoopState) -> IO (ReturnType r, LoopState)
forall a b.
(a -> LoopState -> IO (ReturnType b, LoopState))
-> (ReturnType a, LoopState) -> IO (ReturnType b, LoopState)
feed b -> LoopState -> IO (ReturnType r, LoopState)
k

-- | A variant of 'with' for actions that don't acquire a resource (like 'Control.Exception.bracket_').
with_ :: (forall x. IO x -> IO x) -> Cli a -> Cli a
with_ :: forall a. (forall x. IO x -> IO x) -> Cli a -> Cli a
with_ forall x. IO x -> IO x
resourceK Cli a
action =
  (forall r.
 Env
 -> (a -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli a
forall a.
(forall r.
 Env
 -> (a -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli a
Cli \Env
env a -> LoopState -> IO (ReturnType r, LoopState)
k LoopState
s ->
    IO (ReturnType a, LoopState) -> IO (ReturnType a, LoopState)
forall x. IO x -> IO x
resourceK (Env -> LoopState -> Cli a -> IO (ReturnType a, LoopState)
forall a. Env -> LoopState -> Cli a -> IO (ReturnType a, LoopState)
runCli Env
env LoopState
s Cli a
action) IO (ReturnType a, LoopState)
-> ((ReturnType a, LoopState) -> IO (ReturnType r, LoopState))
-> IO (ReturnType r, LoopState)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> LoopState -> IO (ReturnType r, LoopState))
-> (ReturnType a, LoopState) -> IO (ReturnType r, LoopState)
forall a b.
(a -> LoopState -> IO (ReturnType b, LoopState))
-> (ReturnType a, LoopState) -> IO (ReturnType b, LoopState)
feed a -> LoopState -> IO (ReturnType r, LoopState)
k

-- | A variant of 'with' for the variant of bracketing function that may return a Left rather than call the provided
-- continuation.
withE :: (forall x. (a -> IO x) -> IO (Either e x)) -> (Either e a -> Cli b) -> Cli b
withE :: forall a e b.
(forall x. (a -> IO x) -> IO (Either e x))
-> (Either e a -> Cli b) -> Cli b
withE forall x. (a -> IO x) -> IO (Either e x)
resourceK Either e a -> Cli b
action =
  (forall r.
 Env
 -> (b -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli b
forall a.
(forall r.
 Env
 -> (a -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli a
Cli \Env
env b -> LoopState -> IO (ReturnType r, LoopState)
k LoopState
s ->
    (a -> IO (ReturnType b, LoopState))
-> IO (Either e (ReturnType b, LoopState))
forall x. (a -> IO x) -> IO (Either e x)
resourceK (\a
a -> Env -> LoopState -> Cli b -> IO (ReturnType b, LoopState)
forall a. Env -> LoopState -> Cli a -> IO (ReturnType a, LoopState)
runCli Env
env LoopState
s (Either e a -> Cli b
action (a -> Either e a
forall a b. b -> Either a b
Right a
a))) IO (Either e (ReturnType b, LoopState))
-> (Either e (ReturnType b, LoopState)
    -> IO (ReturnType r, LoopState))
-> IO (ReturnType r, LoopState)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left e
err -> Env -> LoopState -> Cli b -> IO (ReturnType b, LoopState)
forall a. Env -> LoopState -> Cli a -> IO (ReturnType a, LoopState)
runCli Env
env LoopState
s (Either e a -> Cli b
action (e -> Either e a
forall a b. a -> Either a b
Left e
err)) IO (ReturnType b, LoopState)
-> ((ReturnType b, LoopState) -> IO (ReturnType r, LoopState))
-> IO (ReturnType r, LoopState)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (b -> LoopState -> IO (ReturnType r, LoopState))
-> (ReturnType b, LoopState) -> IO (ReturnType r, LoopState)
forall a b.
(a -> LoopState -> IO (ReturnType b, LoopState))
-> (ReturnType a, LoopState) -> IO (ReturnType b, LoopState)
feed b -> LoopState -> IO (ReturnType r, LoopState)
k
      Right (ReturnType b, LoopState)
result -> (b -> LoopState -> IO (ReturnType r, LoopState))
-> (ReturnType b, LoopState) -> IO (ReturnType r, LoopState)
forall a b.
(a -> LoopState -> IO (ReturnType b, LoopState))
-> (ReturnType a, LoopState) -> IO (ReturnType b, LoopState)
feed b -> LoopState -> IO (ReturnType r, LoopState)
k (ReturnType b, LoopState)
result

data X
  = forall a. X !Unique !LoopState a
  deriving anyclass (Show X
Typeable X
(Typeable X, Show X) =>
(X -> SomeException)
-> (SomeException -> Maybe X) -> (X -> FilePath) -> Exception X
SomeException -> Maybe X
X -> FilePath
X -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> FilePath) -> Exception e
$ctoException :: X -> SomeException
toException :: X -> SomeException
$cfromException :: SomeException -> Maybe X
fromException :: SomeException -> Maybe X
$cdisplayException :: X -> FilePath
displayException :: X -> FilePath
Exception)

instance Show X where
  show :: X -> FilePath
show X
_ = FilePath
"<internal exception type>"

-- | Create a label that can be jumped to.
--
-- @
-- x \<- label \\j0 -\> do
--   ...
--   label \\j1 -> do
--     ...
--     j0 someValue
--     ... -- We don't get here
--   ... -- We don't get here
-- -- x is bound to someValue
-- @
label :: forall a. ((forall void. a -> Cli void) -> Cli a) -> Cli a
label :: forall a. ((forall void. a -> Cli void) -> Cli a) -> Cli a
label (forall void. a -> Cli void) -> Cli a
f =
  (forall r.
 Env
 -> (a -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli a
forall a.
(forall r.
 Env
 -> (a -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli a
Cli \Env
env a -> LoopState -> IO (ReturnType r, LoopState)
k LoopState
s0 -> do
    Unique
n <- IO Unique
newUnique
    let bail :: forall void. a -> Cli void
        bail :: forall void. a -> Cli void
bail a
a = do
          LoopState
s1 <- Cli LoopState
forall s (m :: * -> *). MonadState s m => m s
State.get
          IO void -> Cli void
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (X -> IO void
forall e a. Exception e => e -> IO a
throwIO (Unique -> LoopState -> a -> X
forall a. Unique -> LoopState -> a -> X
X Unique
n LoopState
s1 a
a))
    IO (ReturnType a, LoopState)
-> IO (Either X (ReturnType a, LoopState))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (Env -> LoopState -> Cli a -> IO (ReturnType a, LoopState)
forall a. Env -> LoopState -> Cli a -> IO (ReturnType a, LoopState)
runCli Env
env LoopState
s0 ((forall void. a -> Cli void) -> Cli a
f a -> Cli void
forall void. a -> Cli void
bail)) IO (Either X (ReturnType a, LoopState))
-> (Either X (ReturnType a, LoopState)
    -> IO (ReturnType r, LoopState))
-> IO (ReturnType r, LoopState)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left err :: X
err@(X Unique
m LoopState
s1 a
a)
        | Unique
n Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
m -> a -> LoopState -> IO (ReturnType r, LoopState)
k (a -> a
forall a b. a -> b
unsafeCoerce a
a) LoopState
s1
        | Bool
otherwise -> X -> IO (ReturnType r, LoopState)
forall e a. Exception e => e -> IO a
throwIO X
err
      Right (ReturnType a, LoopState)
a -> (a -> LoopState -> IO (ReturnType r, LoopState))
-> (ReturnType a, LoopState) -> IO (ReturnType r, LoopState)
forall a b.
(a -> LoopState -> IO (ReturnType b, LoopState))
-> (ReturnType a, LoopState) -> IO (ReturnType b, LoopState)
feed a -> LoopState -> IO (ReturnType r, LoopState)
k (ReturnType a, LoopState)
a

-- | A variant of @label@ for the common case that early-return values are tagged with a Left.
labelE :: ((forall void. a -> Cli void) -> Cli b) -> Cli (Either a b)
labelE :: forall a b.
((forall void. a -> Cli void) -> Cli b) -> Cli (Either a b)
labelE (forall void. a -> Cli void) -> Cli b
f =
  ((forall void. Either a b -> Cli void) -> Cli (Either a b))
-> Cli (Either a b)
forall a. ((forall void. a -> Cli void) -> Cli a) -> Cli a
label \forall void. Either a b -> Cli void
goto ->
    b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> Cli b -> Cli (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall void. a -> Cli void) -> Cli b
f (Either a b -> Cli void
forall void. Either a b -> Cli void
goto (Either a b -> Cli void) -> (a -> Either a b) -> a -> Cli void
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a b
forall a b. a -> Either a b
Left)

-- | Time an action.
time :: String -> Cli a -> Cli a
time :: forall a. FilePath -> Cli a -> Cli a
time FilePath
label Cli a
action =
  if DebugFlag -> Bool
Debug.shouldDebug DebugFlag
Debug.Timing
    then (forall r.
 Env
 -> (a -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli a
forall a.
(forall r.
 Env
 -> (a -> LoopState -> IO (ReturnType r, LoopState))
 -> LoopState
 -> IO (ReturnType r, LoopState))
-> Cli a
Cli \Env
env a -> LoopState -> IO (ReturnType r, LoopState)
k LoopState
s -> do
      SystemTime
systemStart <- IO SystemTime
getSystemTime
      Integer
cpuPicoStart <- IO Integer
getCPUTime
      (ReturnType a, LoopState)
a <- Cli a
-> forall r.
   Env
   -> (a -> LoopState -> IO (ReturnType r, LoopState))
   -> LoopState
   -> IO (ReturnType r, LoopState)
forall a.
Cli a
-> forall r.
   Env
   -> (a -> LoopState -> IO (ReturnType r, LoopState))
   -> LoopState
   -> IO (ReturnType r, LoopState)
unCli Cli a
action Env
env (\a
a LoopState
loopState -> (ReturnType a, LoopState) -> IO (ReturnType a, LoopState)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> ReturnType a
forall a. a -> ReturnType a
Success a
a, LoopState
loopState)) LoopState
s
      Integer
cpuPicoEnd <- IO Integer
getCPUTime
      SystemTime
systemEnd <- IO SystemTime
getSystemTime
      let systemDiff :: Double
systemDiff =
            DiffTime -> Double
diffTimeToNanos
              (AbsoluteTime -> AbsoluteTime -> DiffTime
diffAbsoluteTime (SystemTime -> AbsoluteTime
systemToTAITime SystemTime
systemEnd) (SystemTime -> AbsoluteTime
systemToTAITime SystemTime
systemStart))
      let cpuDiff :: Double
cpuDiff = Integer -> Double
picosToNanos (Integer
cpuPicoEnd Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
cpuPicoStart)
      FilePath -> FilePath -> FilePath -> FilePath -> IO ()
forall r. PrintfType r => FilePath -> r
printf FilePath
"%s: %s (cpu), %s (system)\n" FilePath
label (Double -> FilePath
renderNanos Double
cpuDiff) (Double -> FilePath
renderNanos Double
systemDiff)
      (a -> LoopState -> IO (ReturnType r, LoopState))
-> (ReturnType a, LoopState) -> IO (ReturnType r, LoopState)
forall a b.
(a -> LoopState -> IO (ReturnType b, LoopState))
-> (ReturnType a, LoopState) -> IO (ReturnType b, LoopState)
feed a -> LoopState -> IO (ReturnType r, LoopState)
k (ReturnType a, LoopState)
a
    else Cli a
action
  where
    diffTimeToNanos :: DiffTime -> Double
    diffTimeToNanos :: DiffTime -> Double
diffTimeToNanos =
      Integer -> Double
picosToNanos (Integer -> Double) -> (DiffTime -> Integer) -> DiffTime -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> Integer
diffTimeToPicoseconds

    picosToNanos :: Integer -> Double
    picosToNanos :: Integer -> Double
picosToNanos =
      (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1_000) (Double -> Double) -> (Integer -> Double) -> Integer -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac

    -- Render nanoseconds, trying to fit into 4 characters.
    renderNanos :: Double -> String
    renderNanos :: Double -> FilePath
renderNanos Double
ns
      | Double
ns Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0.5 = FilePath
"0 ns"
      | Double
ns Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
995 = FilePath -> Double -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%.0f ns" Double
ns
      | Double
ns Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
9_950 = FilePath -> Double -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%.2f µs" Double
us
      | Double
ns Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
99_500 = FilePath -> Double -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%.1f µs" Double
us
      | Double
ns Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
995_000 = FilePath -> Double -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%.0f µs" Double
us
      | Double
ns Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
9_950_000 = FilePath -> Double -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%.2f ms" Double
ms
      | Double
ns Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
99_500_000 = FilePath -> Double -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%.1f ms" Double
ms
      | Double
ns Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
995_000_000 = FilePath -> Double -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%.0f ms" Double
ms
      | Double
ns Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
9_950_000_000 = FilePath -> Double -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%.2f s" Double
s
      | Double
ns Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
99_500_000_000 = FilePath -> Double -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%.1f s" Double
s
      | Bool
otherwise = FilePath -> Double -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%.0f s" Double
s
      where
        us :: Double
us = Double
ns Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1_000
        ms :: Double
ms = Double
ns Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1_000_000
        s :: Double
s = Double
ns Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1_000_000_000

getProjectPathIds :: Cli PP.ProjectPathIds
getProjectPathIds :: Cli (ProjectPathG ProjectId ProjectBranchId)
getProjectPathIds = do
  NonEmpty (ProjectPathG ProjectId ProjectBranchId)
-> ProjectPathG ProjectId ProjectBranchId
forall a. NonEmpty a -> a
NonEmpty.head (NonEmpty (ProjectPathG ProjectId ProjectBranchId)
 -> ProjectPathG ProjectId ProjectBranchId)
-> Cli (NonEmpty (ProjectPathG ProjectId ProjectBranchId))
-> Cli (ProjectPathG 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

cd :: Path.Absolute -> Cli ()
cd :: Absolute -> Cli ()
cd Absolute
path = do
  ProjectPathG ProjectId ProjectBranchId
pp <- Cli (ProjectPathG ProjectId ProjectBranchId)
getProjectPathIds
  let newPP :: ProjectPathG ProjectId ProjectBranchId
newPP = ProjectPathG ProjectId ProjectBranchId
pp ProjectPathG ProjectId ProjectBranchId
-> (ProjectPathG ProjectId ProjectBranchId
    -> ProjectPathG ProjectId ProjectBranchId)
-> ProjectPathG ProjectId ProjectBranchId
forall a b. a -> (a -> b) -> b
& (Absolute -> Identity Absolute)
-> ProjectPathG ProjectId ProjectBranchId
-> Identity (ProjectPathG ProjectId ProjectBranchId)
forall p b (f :: * -> *).
Functor f =>
(Absolute -> f Absolute)
-> ProjectPathG p b -> f (ProjectPathG p b)
PP.absPath_ ((Absolute -> Identity Absolute)
 -> ProjectPathG ProjectId ProjectBranchId
 -> Identity (ProjectPathG ProjectId ProjectBranchId))
-> Absolute
-> ProjectPathG ProjectId ProjectBranchId
-> ProjectPathG ProjectId ProjectBranchId
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Absolute
path
  ProjectPathG ProjectId ProjectBranchId -> Cli ()
setMostRecentProjectPath ProjectPathG ProjectId ProjectBranchId
newPP
  #projectPathStack %= NonEmpty.cons newPP

switchProject :: ProjectAndBranch ProjectId ProjectBranchId -> Cli ()
switchProject :: ProjectAndBranch ProjectId ProjectBranchId -> Cli ()
switchProject pab :: ProjectAndBranch ProjectId ProjectBranchId
pab@(ProjectAndBranch ProjectId
projectId ProjectBranchId
branchId) = do
  Env {Codebase IO Symbol Ann
$sel:codebase:Env :: Env -> Codebase IO Symbol Ann
codebase :: Codebase IO Symbol Ann
codebase} <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  let newPP :: ProjectPathG ProjectId ProjectBranchId
newPP = ProjectId
-> ProjectBranchId
-> Absolute
-> ProjectPathG ProjectId ProjectBranchId
forall proj branch.
proj -> branch -> Absolute -> ProjectPathG proj branch
PP.ProjectPath ProjectId
projectId ProjectBranchId
branchId Absolute
Path.absoluteEmpty
  #projectPathStack %= NonEmpty.cons newPP
  Transaction () -> Cli ()
forall a. Transaction a -> Cli a
runTransaction (Transaction () -> Cli ()) -> Transaction () -> Cli ()
forall a b. (a -> b) -> a -> b
$ do ProjectId -> ProjectBranchId -> Transaction ()
Q.setMostRecentBranch ProjectId
projectId ProjectBranchId
branchId
  ProjectPathG ProjectId ProjectBranchId -> Cli ()
setMostRecentProjectPath ProjectPathG ProjectId ProjectBranchId
newPP
  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
$ Codebase IO Symbol Ann
-> ProjectAndBranch ProjectId ProjectBranchId -> IO ()
forall (m :: * -> *) v a.
MonadUnliftIO m =>
Codebase m v a
-> ProjectAndBranch ProjectId ProjectBranchId -> m ()
Codebase.preloadProjectBranch Codebase IO Symbol Ann
codebase ProjectAndBranch ProjectId ProjectBranchId
pab

-- | Pop the latest path off the stack, if it's not the only path in the stack.
--
-- Returns whether anything was popped.
popd :: Cli Bool
popd :: Cli Bool
popd = do
  LoopState
state <- Cli LoopState
forall s (m :: * -> *). MonadState s m => m s
State.get
  case NonEmpty (ProjectPathG ProjectId ProjectBranchId)
-> (ProjectPathG ProjectId ProjectBranchId,
    Maybe (NonEmpty (ProjectPathG ProjectId ProjectBranchId)))
forall a. NonEmpty a -> (a, Maybe (NonEmpty a))
List.NonEmpty.uncons (LoopState -> NonEmpty (ProjectPathG ProjectId ProjectBranchId)
projectPathStack LoopState
state) of
    (ProjectPathG ProjectId ProjectBranchId
_, Maybe (NonEmpty (ProjectPathG ProjectId ProjectBranchId))
Nothing) -> Bool -> Cli Bool
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    (ProjectPathG ProjectId ProjectBranchId
_, Just NonEmpty (ProjectPathG ProjectId ProjectBranchId)
paths) -> do
      ProjectPathG ProjectId ProjectBranchId -> Cli ()
setMostRecentProjectPath (NonEmpty (ProjectPathG ProjectId ProjectBranchId)
-> ProjectPathG ProjectId ProjectBranchId
forall a. NonEmpty a -> a
List.NonEmpty.head NonEmpty (ProjectPathG ProjectId ProjectBranchId)
paths)
      LoopState -> Cli ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put LoopState
state {projectPathStack = paths}
      pure Bool
True

setMostRecentProjectPath :: PP.ProjectPathIds -> Cli ()
setMostRecentProjectPath :: ProjectPathG ProjectId ProjectBranchId -> Cli ()
setMostRecentProjectPath ProjectPathG ProjectId ProjectBranchId
loc =
  Transaction () -> Cli ()
forall a. Transaction a -> Cli a
runTransaction (Transaction () -> Cli ()) -> Transaction () -> Cli ()
forall a b. (a -> b) -> a -> b
$ ProjectPathG ProjectId ProjectBranchId -> Transaction ()
Codebase.setCurrentProjectPath ProjectPathG ProjectId ProjectBranchId
loc

respond :: Output -> Cli ()
respond :: Output -> Cli ()
respond Output
output = do
  Env {Output -> IO ()
$sel:notify:Env :: Env -> Output -> IO ()
notify :: Output -> IO ()
notify} <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Output -> IO ()
notify Output
output)

respondNumbered :: NumberedOutput -> Cli ()
respondNumbered :: NumberedOutput -> Cli ()
respondNumbered NumberedOutput
output = do
  Env {NumberedOutput -> IO [StructuredArgument]
$sel:notifyNumbered:Env :: Env -> NumberedOutput -> IO [StructuredArgument]
notifyNumbered :: NumberedOutput -> IO [StructuredArgument]
notifyNumbered} <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  [StructuredArgument]
args <- IO [StructuredArgument] -> Cli [StructuredArgument]
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (NumberedOutput -> IO [StructuredArgument]
notifyNumbered NumberedOutput
output)
  [StructuredArgument] -> Cli ()
setNumberedArgs [StructuredArgument]
args

-- | Perform a Cli action with access to a console region, which is closed upon completion.
--
-- (In transcripts, this just outputs messages as normal).
withRespondRegion :: ((Output -> Cli ()) -> Cli a) -> Cli a
withRespondRegion :: forall a. ((Output -> Cli ()) -> Cli a) -> Cli a
withRespondRegion (Output -> Cli ()) -> Cli a
action = do
  Env
env <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  case Env
env.isTranscriptTest of
    Bool
False ->
      (forall x. IO x -> IO x) -> Cli a -> Cli a
forall a. (forall x. IO x -> IO x) -> Cli a -> Cli a
with_ IO x -> IO x
forall x. IO x -> IO x
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
Console.Regions.displayConsoleRegions do
        (forall x. (ConsoleRegion -> IO x) -> IO x)
-> (ConsoleRegion -> Cli a) -> Cli a
forall a b.
(forall x. (a -> IO x) -> IO x) -> (a -> Cli b) -> Cli b
with (RegionLayout -> (ConsoleRegion -> IO x) -> IO x
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RegionLayout -> (ConsoleRegion -> m a) -> m a
Console.Regions.withConsoleRegion RegionLayout
Console.Regions.Linear) \ConsoleRegion
region ->
          (Output -> Cli ()) -> Cli a
action \Output
output ->
            IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
              Pretty
string <- (FilePath -> Output -> IO Pretty
OutputMessages.notifyUser FilePath
"." Output
output)
              Width
width <- IO Width
PrettyTerminal.getAvailableWidth
              ConsoleRegion -> FilePath -> IO ()
forall v (m :: * -> *).
(ToRegionContent v, LiftRegion m) =>
ConsoleRegion -> v -> m ()
Console.Regions.setConsoleRegion ConsoleRegion
region (Width -> Pretty -> FilePath
Pretty.toANSI Width
width (Width -> Pretty -> Pretty
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
Pretty.border Width
2 Pretty
string))
    Bool
True -> (Output -> Cli ()) -> Cli a
action Output -> Cli ()
respond

-- | Updates the numbered args, but only if the new args are non-empty.
setNumberedArgs :: NumberedArgs -> Cli ()
setNumberedArgs :: [StructuredArgument] -> Cli ()
setNumberedArgs [StructuredArgument]
args = do
  Bool -> Cli () -> Cli ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([StructuredArgument] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StructuredArgument]
args) do
    #numberedArgs .= args

runTransaction :: Sqlite.Transaction a -> Cli a
runTransaction :: forall a. Transaction a -> Cli a
runTransaction Transaction a
action = do
  Env {Codebase IO Symbol Ann
$sel:codebase:Env :: Env -> Codebase IO Symbol Ann
codebase :: Codebase IO Symbol Ann
codebase} <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO a -> Cli a
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Codebase IO Symbol Ann -> Transaction a -> IO a
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Codebase IO Symbol Ann
codebase Transaction a
action)

-- | Run a transaction that can abort early with an output message.
-- todo: rename to runTransactionWithReturnEarly
runTransactionWithRollback :: ((forall void. Output -> Sqlite.Transaction void) -> Sqlite.Transaction a) -> Cli a
runTransactionWithRollback :: forall a.
((forall void. Output -> Transaction void) -> Transaction a)
-> Cli a
runTransactionWithRollback (forall void. Output -> Transaction void) -> Transaction a
action = do
  Env {Codebase IO Symbol Ann
$sel:codebase:Env :: Env -> Codebase IO Symbol Ann
codebase :: Codebase IO Symbol Ann
codebase} <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO (Either Output a) -> Cli (Either Output a)
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Codebase IO Symbol Ann
-> ((forall void. Either Output a -> Transaction void)
    -> Transaction (Either Output a))
-> IO (Either Output a)
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a
-> ((forall void. b -> Transaction void) -> Transaction b) -> m b
Codebase.runTransactionWithRollback Codebase IO Symbol Ann
codebase \forall void. Either Output a -> Transaction void
rollback -> a -> Either Output a
forall a b. b -> Either a b
Right (a -> Either Output a)
-> Transaction a -> Transaction (Either Output a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall void. Output -> Transaction void) -> Transaction a
action (\Output
output -> Either Output a -> Transaction void
forall void. Either Output a -> Transaction void
rollback (Output -> Either Output a
forall a b. a -> Either a b
Left Output
output)))
    Cli (Either Output a) -> (Cli (Either Output a) -> Cli a) -> Cli a
forall a b. a -> (a -> b) -> b
& (Output -> Cli a) -> Cli (Either Output a) -> Cli a
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> m (Either a b) -> m b
onLeftM Output -> Cli a
forall a. Output -> Cli a
returnEarly

-- | Run a transaction that can abort early.
-- todo: rename to runTransactionWithRollback
runTransactionWithRollback2 :: ((forall void. a -> Sqlite.Transaction void) -> Sqlite.Transaction a) -> Cli a
runTransactionWithRollback2 :: forall a.
((forall void. a -> Transaction void) -> Transaction a) -> Cli a
runTransactionWithRollback2 (forall void. a -> Transaction void) -> Transaction a
action = do
  Env
env <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO a -> Cli a
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Codebase IO Symbol Ann
-> ((forall void. a -> Transaction void) -> Transaction a) -> IO a
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a
-> ((forall void. b -> Transaction void) -> Transaction b) -> m b
Codebase.runTransactionWithRollback Env
env.codebase (forall void. a -> Transaction void) -> Transaction a
action)