module Unison.CommandLine.Main
  ( main,
  )
where

import Compat (withInterruptHandler)
import Control.Concurrent.Async qualified as Async
import Control.Exception (catch, displayException, finally, mask)
import Control.Lens ((?~))
import Control.Lens.Lens
import Crypto.Random qualified as Random
import Data.IORef
import Data.List.NonEmpty qualified as NEL
import Data.List.NonEmpty qualified as NonEmpty
import Data.Text qualified as Text
import Data.Text.IO qualified as Text
import Ki qualified
import System.Console.Haskeline (Settings (autoAddHistory))
import System.Console.Haskeline qualified as Line
import System.Console.Haskeline.History qualified as Line
import System.IO (hGetEcho, hPutStrLn, hSetEcho, stderr, stdin)
import System.IO.Error (isDoesNotExistError)
import Unison.Auth.CredentialManager (newCredentialManager)
import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
import Unison.Auth.HTTPClient qualified as AuthN
import Unison.Auth.Tokens qualified as AuthN
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.Pretty qualified as P
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Codebase (Codebase)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch (Branch)
import Unison.Codebase.Editor.HandleInput qualified as HandleInput
import Unison.Codebase.Editor.Input (Event, Input (..))
import Unison.Codebase.Editor.Output (NumberedArgs, Output)
import Unison.Codebase.Editor.UCMVersion (UCMVersion)
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.Runtime qualified as Runtime
import Unison.CommandLine
import Unison.CommandLine.Completion (haskelineTabComplete)
import Unison.CommandLine.InputPatterns qualified as IP
import Unison.CommandLine.OutputMessages (notifyNumbered, notifyUser)
import Unison.CommandLine.Types (ShouldWatchFiles (..))
import Unison.CommandLine.Welcome qualified as Welcome
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import Unison.PrettyTerminal
import Unison.Runtime.IOSource qualified as IOSource
import Unison.Server.CodebaseServer qualified as Server
import Unison.Share.Codeserver (isCustomCodeserver)
import Unison.Share.Codeserver qualified as Codeserver
import Unison.Symbol (Symbol)
import Unison.Syntax.Parser qualified as Parser
import Unison.Util.Pretty qualified as P
import Unison.Util.TQueue qualified as Q
import UnliftIO qualified
import UnliftIO.Directory qualified as Directory
import UnliftIO.STM

getUserInput ::
  Codebase IO Symbol Ann ->
  AuthenticatedHttpClient ->
  PP.ProjectPath ->
  IO (Branch IO) ->
  NumberedArgs ->
  IO Input
getUserInput :: Codebase IO Symbol Ann
-> AuthenticatedHttpClient
-> ProjectPath
-> IO (Branch IO)
-> NumberedArgs
-> IO Input
getUserInput Codebase IO Symbol Ann
codebase AuthenticatedHttpClient
authHTTPClient ProjectPath
pp IO (Branch IO)
currentProjectRoot NumberedArgs
numberedArgs =
  Settings IO -> InputT IO Input -> IO Input
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
Line.runInputT
    Settings IO
settings
    (InputT IO Input -> InputT IO Input
forall b. InputT IO b -> InputT IO b
haskelineCtrlCHandling InputT IO Input
go)
  where
    -- Catch ctrl-c and simply re-render the prompt.
    haskelineCtrlCHandling :: Line.InputT IO b -> Line.InputT IO b
    haskelineCtrlCHandling :: forall b. InputT IO b -> InputT IO b
haskelineCtrlCHandling InputT IO b
act = do
      -- We return a Maybe result to ensure we don't nest an action within the masked exception
      -- handler.
      InputT IO (Maybe b) -> InputT IO (Maybe b) -> InputT IO (Maybe b)
forall (m :: * -> *) a. MonadMask m => m a -> m a -> m a
Line.handleInterrupt (Maybe b -> InputT IO (Maybe b)
forall a. a -> InputT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe b
forall a. Maybe a
Nothing) (InputT IO (Maybe b) -> InputT IO (Maybe b)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> InputT m a
Line.withInterrupt (b -> Maybe b
forall a. a -> Maybe a
Just (b -> Maybe b) -> InputT IO b -> InputT IO (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputT IO b
act)) InputT IO (Maybe b) -> (Maybe b -> InputT IO b) -> InputT IO b
forall a b. InputT IO a -> (a -> InputT IO b) -> InputT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe b
Nothing -> InputT IO b -> InputT IO b
forall b. InputT IO b -> InputT IO b
haskelineCtrlCHandling InputT IO b
act
        Just b
a -> b -> InputT IO b
forall a. a -> InputT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
a

    codeserverPrompt :: String
    codeserverPrompt :: FilePath
codeserverPrompt =
      if CodeserverURI -> Bool
isCustomCodeserver CodeserverURI
Codeserver.defaultCodeserver
        then FilePath
"🌐" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> CodeserverURI -> FilePath
Codeserver.codeserverRegName CodeserverURI
Codeserver.defaultCodeserver FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> (FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" (FilePath
":" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>) (Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Maybe Int -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CodeserverURI -> Maybe Int
Codeserver.codeserverPort CodeserverURI
Codeserver.defaultCodeserver) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\n"
        else FilePath
""

    go :: Line.InputT IO Input
    go :: InputT IO Input
go = do
      let promptString :: Pretty ColorText
promptString = ProjectPath -> Pretty ColorText
P.prettyProjectPath ProjectPath
pp
      let fullPrompt :: FilePath
fullPrompt = Width -> Pretty ColorText -> FilePath
P.toANSI Width
80 (Pretty ColorText -> Pretty ColorText
P.red (FilePath -> Pretty ColorText
forall s. IsString s => FilePath -> Pretty s
P.string FilePath
codeserverPrompt) Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
promptString Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> FilePath -> Pretty ColorText
forall a. IsString a => FilePath -> a
fromString FilePath
prompt)
      Maybe FilePath
line <- FilePath -> InputT IO (Maybe FilePath)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
FilePath -> InputT m (Maybe FilePath)
Line.getInputLine FilePath
fullPrompt
      case Maybe FilePath
line of
        Maybe FilePath
Nothing -> Input -> InputT IO Input
forall a. a -> InputT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Input
QuitI
        Just FilePath
l -> case FilePath -> [FilePath]
words FilePath
l of
          [] -> InputT IO Input
go
          [FilePath]
ws -> do
            IO (Either (Pretty ColorText) (Maybe (Arguments, Input)))
-> InputT IO (Either (Pretty ColorText) (Maybe (Arguments, Input)))
forall a. IO a -> InputT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Codebase IO Symbol Ann
-> ProjectPath
-> IO (Branch IO)
-> NumberedArgs
-> Map FilePath InputPattern
-> [FilePath]
-> IO (Either (Pretty ColorText) (Maybe (Arguments, Input)))
parseInput Codebase IO Symbol Ann
codebase ProjectPath
pp IO (Branch IO)
currentProjectRoot NumberedArgs
numberedArgs Map FilePath InputPattern
IP.patternMap [FilePath]
ws) InputT IO (Either (Pretty ColorText) (Maybe (Arguments, Input)))
-> (Either (Pretty ColorText) (Maybe (Arguments, Input))
    -> InputT IO Input)
-> InputT IO Input
forall a b. InputT IO a -> (a -> InputT IO b) -> InputT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Left Pretty ColorText
msg -> do
                -- We still add history that failed to parse so the user can easily reload
                -- the input and fix it.
                (History -> History) -> InputT IO ()
forall (m :: * -> *).
MonadIO m =>
(History -> History) -> InputT m ()
Line.modifyHistory ((History -> History) -> InputT IO ())
-> (History -> History) -> InputT IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> History -> History
Line.addHistoryUnlessConsecutiveDupe (FilePath -> History -> History) -> FilePath -> History -> History
forall a b. (a -> b) -> a -> b
$ FilePath
l
                IO () -> InputT IO ()
forall a. IO a -> InputT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT IO ()) -> IO () -> InputT IO ()
forall a b. (a -> b) -> a -> b
$ Pretty ColorText -> IO ()
putPrettyLn Pretty ColorText
msg
                InputT IO Input
go
              Right Maybe (Arguments, Input)
Nothing -> do
                -- Ctrl-c or some input cancel, re-run the prompt
                InputT IO Input
go
              Right (Just (Arguments
expandedArgs, Input
i)) -> do
                let expandedArgs' :: [FilePath]
expandedArgs' = Argument -> FilePath
IP.unifyArgument (Argument -> FilePath) -> Arguments -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Arguments
expandedArgs
                    expandedArgsStr :: FilePath
expandedArgsStr = [FilePath] -> FilePath
unwords [FilePath]
expandedArgs'
                Bool -> InputT IO () -> InputT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([FilePath]
expandedArgs' [FilePath] -> [FilePath] -> Bool
forall a. Eq a => a -> a -> Bool
/= [FilePath]
ws) (InputT IO () -> InputT IO ()) -> InputT IO () -> InputT IO ()
forall a b. (a -> b) -> a -> b
$ do
                  IO () -> InputT IO ()
forall a. IO a -> InputT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT IO ())
-> (FilePath -> IO ()) -> FilePath -> InputT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ()
putStrLn (FilePath -> InputT IO ()) -> FilePath -> InputT IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
fullPrompt FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
expandedArgsStr
                (History -> History) -> InputT IO ()
forall (m :: * -> *).
MonadIO m =>
(History -> History) -> InputT m ()
Line.modifyHistory ((History -> History) -> InputT IO ())
-> (History -> History) -> InputT IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> History -> History
Line.addHistoryUnlessConsecutiveDupe (FilePath -> History -> History) -> FilePath -> History -> History
forall a b. (a -> b) -> a -> b
$ FilePath
expandedArgsStr
                pure Input
i
    settings :: Line.Settings IO
    settings :: Settings IO
settings =
      Line.Settings
        { complete :: CompletionFunc IO
complete = CompletionFunc IO
tabComplete,
          historyFile :: Maybe FilePath
historyFile = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
".unisonHistory",
          autoAddHistory :: Bool
autoAddHistory = Bool
False
        }
    tabComplete :: CompletionFunc IO
tabComplete = Map FilePath InputPattern
-> Codebase IO Symbol Ann
-> AuthenticatedHttpClient
-> ProjectPath
-> CompletionFunc IO
forall (m :: * -> *) v a.
MonadIO m =>
Map FilePath InputPattern
-> Codebase m v a
-> AuthenticatedHttpClient
-> ProjectPath
-> CompletionFunc m
haskelineTabComplete Map FilePath InputPattern
IP.patternMap Codebase IO Symbol Ann
codebase AuthenticatedHttpClient
authHTTPClient ProjectPath
pp

loopStateProjectPath ::
  Codebase IO Symbol Ann ->
  Cli.LoopState ->
  IO PP.ProjectPath
loopStateProjectPath :: Codebase IO Symbol Ann -> LoopState -> IO ProjectPath
loopStateProjectPath Codebase IO Symbol Ann
codebase LoopState
loopState = do
  let ppIds :: ProjectPathIds
ppIds = NonEmpty ProjectPathIds -> ProjectPathIds
forall a. NonEmpty a -> a
NEL.head (NonEmpty ProjectPathIds -> ProjectPathIds)
-> NonEmpty ProjectPathIds -> ProjectPathIds
forall a b. (a -> b) -> a -> b
$ LoopState -> NonEmpty ProjectPathIds
Cli.projectPathStack LoopState
loopState
  ProjectPathIds
ppIds ProjectPathIds
-> (ProjectPathIds -> IO ProjectPath) -> IO ProjectPath
forall a b. a -> (a -> b) -> b
& (ProjectAndBranch ProjectId ProjectBranchId
 -> IO (ProjectAndBranch Project ProjectBranch))
-> ProjectPathIds -> IO ProjectPath
forall p b p' b' (f :: * -> *).
Functor f =>
(ProjectAndBranch p b -> f (ProjectAndBranch p' b'))
-> ProjectPathG p b -> f (ProjectPathG p' b')
PP.projectAndBranch_ ((ProjectAndBranch ProjectId ProjectBranchId
  -> IO (ProjectAndBranch Project ProjectBranch))
 -> ProjectPathIds -> IO ProjectPath)
-> (ProjectAndBranch ProjectId ProjectBranchId
    -> IO (ProjectAndBranch Project ProjectBranch))
-> ProjectPathIds
-> IO ProjectPath
forall {k} (f :: k -> *) s (t :: k) a (b :: k).
LensLike f s t a b -> LensLike f s t a b
%%~ \ProjectAndBranch ProjectId ProjectBranchId
pabIds -> IO (ProjectAndBranch Project ProjectBranch)
-> IO (ProjectAndBranch Project ProjectBranch)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ProjectAndBranch Project ProjectBranch)
 -> IO (ProjectAndBranch Project ProjectBranch))
-> (Transaction (ProjectAndBranch Project ProjectBranch)
    -> IO (ProjectAndBranch Project ProjectBranch))
-> Transaction (ProjectAndBranch Project ProjectBranch)
-> IO (ProjectAndBranch Project ProjectBranch)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Codebase IO Symbol Ann
-> Transaction (ProjectAndBranch Project ProjectBranch)
-> IO (ProjectAndBranch Project ProjectBranch)
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Codebase IO Symbol Ann
codebase (Transaction (ProjectAndBranch Project ProjectBranch)
 -> IO (ProjectAndBranch Project ProjectBranch))
-> Transaction (ProjectAndBranch Project ProjectBranch)
-> IO (ProjectAndBranch Project ProjectBranch)
forall a b. (a -> b) -> a -> b
$ ProjectAndBranch ProjectId ProjectBranchId
-> Transaction (ProjectAndBranch Project ProjectBranch)
ProjectUtils.expectProjectAndBranchByIds ProjectAndBranch ProjectId ProjectBranchId
pabIds

main ::
  FilePath ->
  Welcome.Welcome ->
  PP.ProjectPathIds ->
  [Either Event Input] ->
  Runtime.Runtime Symbol ->
  Runtime.Runtime Symbol ->
  Runtime.Runtime Symbol ->
  Codebase IO Symbol Ann ->
  Maybe Server.BaseUrl ->
  UCMVersion ->
  (PP.ProjectPathIds -> IO ()) ->
  ShouldWatchFiles ->
  IO ()
main :: FilePath
-> Welcome
-> ProjectPathIds
-> [Either Event Input]
-> Runtime Symbol
-> Runtime Symbol
-> Runtime Symbol
-> Codebase IO Symbol Ann
-> Maybe BaseUrl
-> Text
-> (ProjectPathIds -> IO ())
-> ShouldWatchFiles
-> IO ()
main FilePath
dir Welcome
welcome ProjectPathIds
ppIds [Either Event Input]
initialInputs Runtime Symbol
runtime Runtime Symbol
sbRuntime Runtime Symbol
nRuntime Codebase IO Symbol Ann
codebase Maybe BaseUrl
serverBaseUrl Text
ucmVersion ProjectPathIds -> IO ()
lspCheckForChanges ShouldWatchFiles
shouldWatchFiles = (Scope -> IO ()) -> IO ()
forall a. (Scope -> IO a) -> IO a
Ki.scoped \Scope
scope -> do
  Thread ()
_ <- Scope -> IO () -> IO (Thread ())
forall a. Scope -> IO a -> IO (Thread a)
Ki.fork Scope
scope do
    -- Pre-load the project root in the background so it'll be ready when a command needs it.
    Branch IO
projectRoot <- 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 ProjectPathIds
ppIds.project ProjectPathIds
ppIds.branch
    -- Start forcing thunks in a background thread.
    IO (Branch IO) -> IO (TypecheckedUnisonFile Symbol Ann) -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
UnliftIO.concurrently_
      (Branch IO -> IO (Branch IO)
forall (m :: * -> *) a. MonadIO m => a -> m a
UnliftIO.evaluate Branch IO
projectRoot)
      (TypecheckedUnisonFile Symbol Ann
-> IO (TypecheckedUnisonFile Symbol Ann)
forall (m :: * -> *) a. MonadIO m => a -> m a
UnliftIO.evaluate TypecheckedUnisonFile Symbol Ann
IOSource.typecheckedFile) -- IOSource takes a while to compile, we should start compiling it on startup
  let initialState :: LoopState
initialState = ProjectPathIds -> LoopState
Cli.loopState0 ProjectPathIds
ppIds
  TQueue Event
eventQueue <- IO (TQueue Event)
forall a (m :: * -> *). MonadIO m => m (TQueue a)
Q.newIO
  IORef [Either Event Input]
initialInputsRef <- [Either Event Input] -> IO (IORef [Either Event Input])
forall a. a -> IO (IORef a)
newIORef ([Either Event Input] -> IO (IORef [Either Event Input]))
-> [Either Event Input] -> IO (IORef [Either Event Input])
forall a b. (a -> b) -> a -> b
$ Welcome -> [Either Event Input]
Welcome.run Welcome
welcome [Either Event Input]
-> [Either Event Input] -> [Either Event Input]
forall a. [a] -> [a] -> [a]
++ [Either Event Input]
initialInputs
  IORef Bool
pageOutput <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
True
  IO ()
cancelFileSystemWatch <- case ShouldWatchFiles
shouldWatchFiles of
    ShouldWatchFiles
ShouldNotWatchFiles -> IO () -> IO (IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    ShouldWatchFiles
ShouldWatchFiles -> TQueue Event -> FilePath -> IO (IO ())
watchFileSystem TQueue Event
eventQueue FilePath
dir
  CredentialManager
credentialManager <- IO CredentialManager
forall (m :: * -> *). MonadIO m => m CredentialManager
newCredentialManager
  let tokenProvider :: TokenProvider
tokenProvider = CredentialManager -> TokenProvider
AuthN.newTokenProvider CredentialManager
credentialManager
  AuthenticatedHttpClient
authHTTPClient <- TokenProvider -> Text -> IO AuthenticatedHttpClient
forall (m :: * -> *).
MonadIO m =>
TokenProvider -> Text -> m AuthenticatedHttpClient
AuthN.newAuthenticatedHTTPClient TokenProvider
tokenProvider Text
ucmVersion
  Bool
initialEcho <- Handle -> IO Bool
hGetEcho Handle
stdin
  let restoreEcho :: Bool -> IO ()
restoreEcho = (\Bool
currentEcho -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
currentEcho Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
initialEcho) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Bool -> IO ()
hSetEcho Handle
stdin Bool
initialEcho)
  let getInput :: Cli.LoopState -> IO Input
      getInput :: LoopState -> IO Input
getInput LoopState
loopState = do
        Bool
currentEcho <- Handle -> IO Bool
hGetEcho Handle
stdin
        IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO ()
restoreEcho Bool
currentEcho
        let PP.ProjectAndBranch ProjectId
projId ProjectBranchId
branchId = ProjectPathIds -> ProjectAndBranch ProjectId ProjectBranchId
forall p b. ProjectPathG p b -> ProjectAndBranch p b
PP.toProjectAndBranch (ProjectPathIds -> ProjectAndBranch ProjectId ProjectBranchId)
-> ProjectPathIds -> ProjectAndBranch ProjectId ProjectBranchId
forall a b. (a -> b) -> a -> b
$ NonEmpty ProjectPathIds -> ProjectPathIds
forall a. NonEmpty a -> a
NonEmpty.head LoopState
loopState.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
        ProjectPath
pp <- Codebase IO Symbol Ann -> LoopState -> IO ProjectPath
loopStateProjectPath Codebase IO Symbol Ann
codebase LoopState
loopState
        Codebase IO Symbol Ann
-> AuthenticatedHttpClient
-> ProjectPath
-> IO (Branch IO)
-> NumberedArgs
-> IO Input
getUserInput
          Codebase IO Symbol Ann
codebase
          AuthenticatedHttpClient
authHTTPClient
          ProjectPath
pp
          IO (Branch IO)
getProjectRoot
          (LoopState
loopState LoopState
-> Getting NumberedArgs LoopState NumberedArgs -> NumberedArgs
forall s a. s -> Getting a s a -> a
^. Getting NumberedArgs LoopState NumberedArgs
#numberedArgs)
  let loadSourceFile :: Text -> IO Cli.LoadSourceResult
      loadSourceFile :: Text -> IO LoadSourceResult
loadSourceFile Text
fname =
        if FilePath -> Bool
allow (FilePath -> Bool) -> FilePath -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
Text.unpack Text
fname
          then
            let handle :: IOException -> IO Cli.LoadSourceResult
                handle :: IOException -> IO LoadSourceResult
handle IOException
e =
                  case IOException
e of
                    IOException
_ | IOException -> Bool
isDoesNotExistError IOException
e -> LoadSourceResult -> IO LoadSourceResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return LoadSourceResult
Cli.InvalidSourceNameError
                    IOException
_ -> LoadSourceResult -> IO LoadSourceResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return LoadSourceResult
Cli.LoadError
                go :: IO LoadSourceResult
go = do
                  Text
contents <- FilePath -> IO Text
readUtf8 (FilePath -> IO Text) -> FilePath -> IO Text
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
Text.unpack Text
fname
                  return $ Text -> LoadSourceResult
Cli.LoadSuccess Text
contents
             in IO LoadSourceResult
-> (IOException -> IO LoadSourceResult) -> IO LoadSourceResult
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO LoadSourceResult
go IOException -> IO LoadSourceResult
handle
          else LoadSourceResult -> IO LoadSourceResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return LoadSourceResult
Cli.InvalidSourceNameError
  let notify :: Output -> IO ()
      notify :: Output -> IO ()
notify =
        FilePath -> Output -> IO (Pretty ColorText)
notifyUser FilePath
dir
          (Output -> IO (Pretty ColorText))
-> (Pretty ColorText -> IO ()) -> Output -> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> ( \Pretty ColorText
o ->
                  IO Bool -> IO () -> IO () -> IO ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM
                    (IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
pageOutput)
                    (Pretty ColorText -> IO ()
putPrettyNonempty Pretty ColorText
o)
                    (Pretty ColorText -> IO ()
putPrettyLnUnpaged Pretty ColorText
o)
              )

  let cleanup :: IO ()
      cleanup :: IO ()
cleanup = IO ()
cancelFileSystemWatch
      awaitInput :: Cli.LoopState -> IO (Either Event Input)
      awaitInput :: LoopState -> IO (Either Event Input)
awaitInput LoopState
loopState = do
        -- use up buffered input before consulting external events
        IORef [Either Event Input] -> IO [Either Event Input]
forall a. IORef a -> IO a
readIORef IORef [Either Event Input]
initialInputsRef IO [Either Event Input]
-> ([Either Event Input] -> IO (Either Event Input))
-> IO (Either Event Input)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Either Event Input
h : [Either Event Input]
t -> IORef [Either Event Input] -> [Either Event Input] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [Either Event Input]
initialInputsRef [Either Event Input]
t IO () -> IO (Either Event Input) -> IO (Either Event Input)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either Event Input -> IO (Either Event Input)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either Event Input
h
          [] ->
            -- Race the user input and file watch.
            IO Event -> IO Input -> IO (Either Event Input)
forall a b. IO a -> IO b -> IO (Either a b)
Async.race (STM Event -> IO Event
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Event -> IO Event) -> STM Event -> IO Event
forall a b. (a -> b) -> a -> b
$ TQueue Event -> STM Event
forall a. TQueue a -> STM a
Q.peek TQueue Event
eventQueue) (LoopState -> IO Input
getInput LoopState
loopState) IO (Either Event Input)
-> (Either Event Input -> IO (Either Event Input))
-> IO (Either Event Input)
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 Event
_ -> do
                let e :: IO (Either Event Input)
e = Event -> Either Event Input
forall a b. a -> Either a b
Left (Event -> Either Event Input)
-> IO Event -> IO (Either Event Input)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM Event -> IO Event
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TQueue Event -> STM Event
forall a. TQueue a -> STM a
Q.dequeue TQueue Event
eventQueue)
                IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
pageOutput Bool
False
                IO (Either Event Input)
e
              Either Event Input
x -> do
                IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
pageOutput Bool
True
                pure Either Event Input
x

  let writeSource :: Text -> Text -> Bool -> IO ()
      writeSource :: Text -> Text -> Bool -> IO ()
writeSource Text
fp Text
contents Bool
addFold = do
        FilePath
path <- FilePath -> IO FilePath
forall (m :: * -> *). MonadIO m => FilePath -> m FilePath
Directory.canonicalizePath (Text -> FilePath
Text.unpack Text
fp)
        FilePath -> Text -> IO ()
prependUtf8
          FilePath
path
          if Bool
addFold
            then Text
contents Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n---- Anything below this line is ignored by Unison.\n\n"
            else Text
contents Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n"

  let env :: Env
env =
        Cli.Env
          { AuthenticatedHttpClient
authHTTPClient :: AuthenticatedHttpClient
$sel:authHTTPClient:Env :: AuthenticatedHttpClient
authHTTPClient,
            Codebase IO Symbol Ann
codebase :: Codebase IO Symbol Ann
$sel:codebase:Env :: Codebase IO Symbol Ann
codebase,
            CredentialManager
credentialManager :: CredentialManager
$sel:credentialManager:Env :: CredentialManager
credentialManager,
            $sel:loadSource:Env :: Text -> IO LoadSourceResult
loadSource = Text -> IO LoadSourceResult
loadSourceFile,
            Text -> Text -> Bool -> IO ()
writeSource :: Text -> Text -> Bool -> IO ()
$sel:writeSource:Env :: Text -> Text -> Bool -> IO ()
writeSource,
            $sel:generateUniqueName:Env :: IO UniqueName
generateUniqueName = SystemDRG -> UniqueName
forall gen. DRG gen => gen -> UniqueName
Parser.uniqueBase32Namegen (SystemDRG -> UniqueName) -> IO SystemDRG -> IO UniqueName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO SystemDRG
Random.getSystemDRG,
            Output -> IO ()
notify :: Output -> IO ()
$sel:notify:Env :: Output -> IO ()
notify,
            $sel:notifyNumbered:Env :: NumberedOutput -> IO NumberedArgs
notifyNumbered = \NumberedOutput
o ->
              let (Pretty ColorText
p, NumberedArgs
args) = NumberedOutput -> (Pretty ColorText, NumberedArgs)
notifyNumbered NumberedOutput
o
               in Pretty ColorText -> IO ()
putPrettyNonempty Pretty ColorText
p IO () -> NumberedArgs -> IO NumberedArgs
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> NumberedArgs
args,
            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,
            Maybe BaseUrl
serverBaseUrl :: Maybe BaseUrl
$sel:serverBaseUrl:Env :: Maybe BaseUrl
serverBaseUrl,
            Text
ucmVersion :: Text
$sel:ucmVersion:Env :: Text
ucmVersion,
            $sel:isTranscriptTest:Env :: Bool
isTranscriptTest = Bool
False
          }

  (IO ()
onInterrupt, IO ()
waitForInterrupt) <- IO (IO (), IO ())
buildInterruptHandler

  ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask \forall a. IO a -> IO a
restore -> do
    -- Handle inputs until @HaltRepl@, staying in the loop on Ctrl+C or synchronous exception.
    let loop0 :: Cli.LoopState -> IO ()
        loop0 :: LoopState -> IO ()
loop0 LoopState
s0 = do
          -- It's always possible the previous command changed the branch head, so tell the LSP to check if the current
          -- path or project has changed.
          ProjectPathIds -> IO ()
lspCheckForChanges (NonEmpty ProjectPathIds -> ProjectPathIds
forall a. NonEmpty a -> a
NEL.head (NonEmpty ProjectPathIds -> ProjectPathIds)
-> NonEmpty ProjectPathIds -> ProjectPathIds
forall a b. (a -> b) -> a -> b
$ LoopState -> NonEmpty ProjectPathIds
Cli.projectPathStack LoopState
s0)
          let step :: IO (ReturnType (), LoopState)
step = do
                Either Event Input
input <- LoopState -> IO (Either Event Input)
awaitInput LoopState
s0
                (!ReturnType ()
result, LoopState
resultState) <- Env -> LoopState -> Cli () -> IO (ReturnType (), LoopState)
forall a. Env -> LoopState -> Cli a -> IO (ReturnType a, LoopState)
Cli.runCli Env
env LoopState
s0 (Either Event Input -> Cli ()
HandleInput.loop Either Event Input
input)
                let sNext :: LoopState
sNext = case Either Event Input
input of
                      Left Event
_ -> LoopState
resultState
                      Right Input
inp -> LoopState
resultState 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
                (ReturnType (), LoopState) -> IO (ReturnType (), LoopState)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReturnType ()
result, LoopState
sNext)
          IO ()
-> IO (Either SomeException (ReturnType (), LoopState))
-> IO (Either () (Either SomeException (ReturnType (), LoopState)))
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> m b -> m (Either a b)
UnliftIO.race IO ()
waitForInterrupt (IO (ReturnType (), LoopState)
-> IO (Either SomeException (ReturnType (), LoopState))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
UnliftIO.tryAny (IO (ReturnType (), LoopState) -> IO (ReturnType (), LoopState)
forall a. IO a -> IO a
restore IO (ReturnType (), LoopState)
step)) IO (Either () (Either SomeException (ReturnType (), LoopState)))
-> (Either () (Either SomeException (ReturnType (), LoopState))
    -> IO ())
-> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            -- SIGINT
            Left () -> do
              Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr FilePath
"\nAborted."
              LoopState -> IO ()
loop0 LoopState
s0
            -- Exception during command execution
            Right (Left SomeException
e) -> do
              Handle -> Text -> IO ()
Text.hPutStrLn Handle
stderr (Text
"Encountered exception:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack (SomeException -> FilePath
forall e. Exception e => e -> FilePath
displayException SomeException
e))
              LoopState -> IO ()
loop0 LoopState
s0
            Right (Right (ReturnType ()
result, LoopState
s1)) -> do
              case ReturnType ()
result of
                Cli.Success () -> LoopState -> IO ()
loop0 LoopState
s1
                ReturnType ()
Cli.Continue -> LoopState -> IO ()
loop0 LoopState
s1
                ReturnType ()
Cli.HaltRepl -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    IO () -> IO () -> IO ()
forall a. IO () -> IO a -> IO a
withInterruptHandler IO ()
onInterrupt (LoopState -> IO ()
loop0 LoopState
initialState IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` IO ()
cleanup)

-- | Installs a posix interrupt handler for catching SIGINT.
-- This replaces GHC's default sigint handler which throws a UserInterrupt async exception
-- and kills the entire process.
--
-- Returns an IO action which blocks until a ctrl-c is detected. It may be used multiple
-- times.
buildInterruptHandler :: IO (IO (), IO ())
buildInterruptHandler :: IO (IO (), IO ())
buildInterruptHandler = do
  MVar ()
ctrlCMarker <- IO (MVar ())
forall (m :: * -> *) a. MonadIO m => m (MVar a)
UnliftIO.newEmptyMVar
  let onInterrupt :: IO ()
onInterrupt = IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> IO Bool
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m Bool
UnliftIO.tryPutMVar MVar ()
ctrlCMarker ()
  let waitForInterrupt :: IO ()
waitForInterrupt = MVar () -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
UnliftIO.takeMVar MVar ()
ctrlCMarker
  (IO (), IO ()) -> IO (IO (), IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((IO (), IO ()) -> IO (IO (), IO ()))
-> (IO (), IO ()) -> IO (IO (), IO ())
forall a b. (a -> b) -> a -> b
$ (IO ()
onInterrupt, IO ()
waitForInterrupt)