module Unison.CommandLine.Main
  ( main,
  )
where

import Compat (withInterruptHandler)
import Control.Exception (catch, displayException, 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 GHC.IO qualified as IO
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.FSNotify qualified as FSNotify
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 (UnisonFileChanged), 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.Codebase.Watch qualified as Watch
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 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 ParseFailure (Maybe (Arguments, Input)))
-> InputT IO (Either ParseFailure (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 ParseFailure (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 ParseFailure (Maybe (Arguments, Input)))
-> (Either ParseFailure (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 ParseFailure
failure -> 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
l
                IO () -> InputT IO ()
forall a. IO a -> InputT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT IO ())
-> (Pretty ColorText -> IO ()) -> Pretty ColorText -> InputT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty ColorText -> IO ()
putPrettyLn (Pretty ColorText -> InputT IO ())
-> Pretty ColorText -> InputT IO ()
forall a b. (a -> b) -> a -> b
$ ParseFailure -> Pretty ColorText
reportParseFailure ParseFailure
failure
                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
expandedArgsStr
                Input -> InputT IO Input
forall a. a -> InputT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
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 = do
  -- we don't like FSNotify's debouncing (it seems to drop later events)
  -- so we will be doing our own instead
  let config :: WatchConfig
config = WatchConfig
FSNotify.defaultConfig
  WatchConfig -> (WatchManager -> IO ()) -> IO ()
forall a. WatchConfig -> (WatchManager -> IO a) -> IO a
FSNotify.withManagerConf WatchConfig
config \WatchManager
mgr -> do
    (Scope -> IO ()) -> IO ()
forall a. (Scope -> IO a) -> IO a
Ki.scoped \Scope
scope -> do
      -- Pre-load the project root in the background so it'll be ready when a command needs it.
      Thread (Branch IO)
_ <- Scope -> IO (Branch IO) -> IO (Thread (Branch IO))
forall a. Scope -> IO a -> IO (Thread a)
Ki.fork Scope
scope (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)
      -- IOSource takes a while to compile, we should start compiling it on startup
      Thread (TypecheckedUnisonFile Symbol Ann)
_ <- Scope
-> IO (TypecheckedUnisonFile Symbol Ann)
-> IO (Thread (TypecheckedUnisonFile Symbol Ann))
forall a. Scope -> IO a -> IO (Thread a)
Ki.fork Scope
scope (TypecheckedUnisonFile Symbol Ann
-> IO (TypecheckedUnisonFile Symbol Ann)
forall a. a -> IO a
IO.evaluate TypecheckedUnisonFile Symbol Ann
IOSource.typecheckedFile)
      -- Fork the file watcher thread, which returns an IO action we can call to get one filesystem event (automatically
      -- first tossing all that have accumulated since the last call)
      IO Event
awaitFileEvent <- do
        ((IO (FilePath, Text) -> IO Event)
-> IO (IO (FilePath, Text)) -> IO (IO Event)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((IO (FilePath, Text) -> IO Event)
 -> IO (IO (FilePath, Text)) -> IO (IO Event))
-> (((FilePath, Text) -> Event) -> IO (FilePath, Text) -> IO Event)
-> ((FilePath, Text) -> Event)
-> IO (IO (FilePath, Text))
-> IO (IO Event)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath, Text) -> Event) -> IO (FilePath, Text) -> IO Event
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap)
          (\(FilePath
file, Text
contents) -> Text -> Text -> Event
UnisonFileChanged (FilePath -> Text
Text.pack FilePath
file) Text
contents)
          ( Scope
-> WatchManager
-> FilePath
-> (FilePath -> Bool)
-> IO (IO (FilePath, Text))
Watch.watchDirectory
              Scope
scope
              WatchManager
mgr
              FilePath
dir
              -- We could elect to not spawn a file-watching thread at all if --no-file-watch is passed to ucm, but that
              -- is an extremely uncommon option, this isn't super inefficient, and this makes the types simpler.
              case ShouldWatchFiles
shouldWatchFiles of
                ShouldWatchFiles
ShouldNotWatchFiles -> Bool -> FilePath -> Bool
forall a b. a -> b -> a
const Bool
False
                ShouldWatchFiles
ShouldWatchFiles -> FilePath -> Bool
allow
          )

      let initialState :: LoopState
initialState = ProjectPathIds -> LoopState
Cli.loopState0 ProjectPathIds
ppIds
      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

      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
                      LoadSourceResult -> IO LoadSourceResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LoadSourceResult -> IO LoadSourceResult)
-> LoadSourceResult -> IO LoadSourceResult
forall a b. (a -> b) -> a -> b
$ 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 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
              [] -> do
                -- Race the user input and file watch.
                IO (Either Event Input)
action <-
                  (Scope -> IO (IO (Either Event Input)))
-> IO (IO (Either Event Input))
forall a. (Scope -> IO a) -> IO a
Ki.scoped \Scope
scope -> do
                    Thread Event
fileEventThread <- Scope -> IO Event -> IO (Thread Event)
forall a. Scope -> IO a -> IO (Thread a)
Ki.fork Scope
scope IO Event
awaitFileEvent
                    Thread Input
userInputThread <- Scope -> IO Input -> IO (Thread Input)
forall a. Scope -> IO a -> IO (Thread a)
Ki.fork Scope
scope (LoopState -> IO Input
getInput LoopState
loopState)
                    (STM (IO (Either Event Input)) -> IO (IO (Either Event Input))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (IO (Either Event Input)) -> IO (IO (Either Event Input)))
-> ([STM (IO (Either Event Input))]
    -> STM (IO (Either Event Input)))
-> [STM (IO (Either Event Input))]
-> IO (IO (Either Event Input))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [STM (IO (Either Event Input))] -> STM (IO (Either Event Input))
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum)
                      [ do
                          Event
event <- Thread Event -> STM Event
forall a. Thread a -> STM a
Ki.await Thread Event
fileEventThread
                          IO (Either Event Input) -> STM (IO (Either Event Input))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure do
                            IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
pageOutput Bool
False
                            Either Event Input -> IO (Either Event Input)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Event -> Either Event Input
forall a b. a -> Either a b
Left Event
event),
                        do
                          Input
input <- Thread Input -> STM Input
forall a. Thread a -> STM a
Ki.await Thread Input
userInputThread
                          IO (Either Event Input) -> STM (IO (Either Event Input))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Event Input -> IO (Either Event Input)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Input -> Either Event Input
forall a b. b -> Either a b
Right Input
input))
                      ]
                IO (Either Event Input)
action

      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,
                ProjectPathIds -> IO ()
lspCheckForChanges :: ProjectPathIds -> IO ()
$sel:lspCheckForChanges:Env :: ProjectPathIds -> IO ()
lspCheckForChanges,
                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
              let stepInput :: Either Event Input -> IO (Cli.ReturnType (), Cli.LoopState)
                  stepInput :: Either Event Input -> IO (ReturnType (), LoopState)
stepInput Either Event Input
input =
                    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)

              -- We want to handle file-change events in a way that allow interruption by other file-change events for
              -- the same file. The idea here is that, if we're (say) typechecking a big file any edits made in the
              -- meantime should cause the typecheck to be canceled and started anew.
              --
              -- This does raise the question: what do we do with both of the following, which we could receive while
              -- handling a file-change event?
              --
              --   1. File-change events for a different .u file than the one we're processing.
              --   2. User input (i.e. they're typing stuff into the prompt against the flow of typechecking output).
              --
              -- Our answers:
              --
              --   1. Throw these away.
              --   2. Don't even try to read these, so they'll buffer and be handled later.
              --
              -- This simplifies the implementation and avoids doing weird stuff like handling file-change events that
              -- were made against a arbitrarily different loop state than the one resulting from the handling of the
              -- first file-change event. Users are unlikely to even notice these details, as while one file is
              -- typechecking, they are not likely to be trying to input things into the prompt nor trying to typecheck
              -- a different file.
              let stepEvent :: Event -> IO (Cli.ReturnType (), Cli.LoopState)
                  stepEvent :: Event -> IO (ReturnType (), LoopState)
stepEvent event :: Event
event@(UnisonFileChanged Text
file Text
contents) = do
                    IO (ReturnType (), LoopState)
action <-
                      (Scope -> IO (IO (ReturnType (), LoopState)))
-> IO (IO (ReturnType (), LoopState))
forall a. (Scope -> IO a) -> IO a
Ki.scoped \Scope
scope -> do
                        Thread (ReturnType (), LoopState)
handleEventThread <- Scope
-> IO (ReturnType (), LoopState)
-> IO (Thread (ReturnType (), LoopState))
forall a. Scope -> IO a -> IO (Thread a)
Ki.fork Scope
scope (Either Event Input -> IO (ReturnType (), LoopState)
stepInput (Event -> Either Event Input
forall a b. a -> Either a b
Left Event
event))
                        Thread Event
fileEventThread <-
                          Scope -> IO Event -> IO (Thread Event)
forall a. Scope -> IO a -> IO (Thread a)
Ki.fork Scope
scope do
                            let loop :: IO Event
loop =
                                  IO Event
awaitFileEvent IO Event -> (Event -> IO Event) -> IO Event
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                                    event2 :: Event
event2@(UnisonFileChanged Text
file2 Text
contents2)
                                      | Text
file2 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
file Bool -> Bool -> Bool
&& Text
contents Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
contents2 -> Event -> IO Event
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Event
event2
                                    Event
_ -> IO Event
loop
                            IO Event
loop
                        (STM (IO (ReturnType (), LoopState))
-> IO (IO (ReturnType (), LoopState))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (IO (ReturnType (), LoopState))
 -> IO (IO (ReturnType (), LoopState)))
-> ([STM (IO (ReturnType (), LoopState))]
    -> STM (IO (ReturnType (), LoopState)))
-> [STM (IO (ReturnType (), LoopState))]
-> IO (IO (ReturnType (), LoopState))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [STM (IO (ReturnType (), LoopState))]
-> STM (IO (ReturnType (), LoopState))
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum)
                          [ do
                              (ReturnType (), LoopState)
result <- Thread (ReturnType (), LoopState) -> STM (ReturnType (), LoopState)
forall a. Thread a -> STM a
Ki.await Thread (ReturnType (), LoopState)
handleEventThread
                              IO (ReturnType (), LoopState)
-> STM (IO (ReturnType (), LoopState))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ReturnType (), LoopState) -> IO (ReturnType (), LoopState)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReturnType (), LoopState)
result),
                            do
                              Event
event2 <- Thread Event -> STM Event
forall a. Thread a -> STM a
Ki.await Thread Event
fileEventThread
                              IO (ReturnType (), LoopState)
-> STM (IO (ReturnType (), LoopState))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Event -> IO (ReturnType (), LoopState)
stepEvent Event
event2)
                          ]
                    IO (ReturnType (), LoopState)
action

              let step :: IO (Cli.ReturnType (), Cli.LoopState)
                  step :: IO (ReturnType (), LoopState)
step = do
                    Either Event Input
input <- LoopState -> IO (Either Event Input)
awaitInput LoopState
s0
                    (!ReturnType ()
result, LoopState
resultState) <-
                      case Either Event Input
input of
                        Left Event
event -> Event -> IO (ReturnType (), LoopState)
stepEvent Event
event
                        Right Input
_ -> Either Event Input -> IO (ReturnType (), LoopState)
stepInput 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)

-- | 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)