module Unison.CommandLine.Main
  ( main,
  )
where

import Compat (withInterruptHandler)
import Control.Concurrent (threadDelay)
import Control.Exception (displayException, mask)
import Control.Lens ((?~))
import Control.Lens.Lens
import Crypto.Random qualified as Random
import Data.IORef
import Data.List qualified as List
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 U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Auth.CredentialManager qualified as AuthN
import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
import Unison.Auth.HTTPClient 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, outputShouldUsePager)
import Unison.Codebase.Editor.UCMVersion (UCMVersion)
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.Watch qualified as Watch
import Unison.CommandLine
import Unison.CommandLine.Completion (haskelineTabComplete)
import Unison.CommandLine.InputPattern qualified as IP
import Unison.CommandLine.InputPatterns qualified as IP
import Unison.CommandLine.OutputMessages (fetchIssueFromGitHub, 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.Project qualified as Project
import Unison.Runtime (Runtime)
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.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 :: [Char]
codeserverPrompt =
      if CodeserverURI -> Bool
isCustomCodeserver CodeserverURI
Codeserver.defaultCodeserver
        then
          [Char]
"🌐"
            [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> CodeserverURI -> [Char]
Codeserver.codeserverRegName CodeserverURI
Codeserver.defaultCodeserver
            [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> ([Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ([Char]
":" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>) (Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> Maybe Int -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CodeserverURI -> Maybe Int
Codeserver.codeserverPort CodeserverURI
Codeserver.defaultCodeserver)
            [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\n"
        else [Char]
""

    go :: Line.InputT IO Input
    go :: InputT IO Input
go = do
      let statusString :: Pretty ColorText
statusString = if ProjectPath
pp.branch.isUpdate Bool -> Bool -> Bool
|| ProjectPath
pp.branch.isUpgrade Bool -> Bool -> Bool
|| ProjectPath
pp.branch.isMerge then Pretty ColorText
"🧩 " else Pretty ColorText
""
      let branchString :: Pretty ColorText
branchString = ProjectPath -> Pretty ColorText
P.prettyProjectPath ProjectPath
pp
      let fullPrompt :: Text
fullPrompt =
            Width -> Pretty ColorText -> Text
P.toANSI Width
80 (Pretty ColorText -> Text) -> Pretty ColorText -> Text
forall a b. (a -> b) -> a -> b
$
              [Pretty ColorText] -> Pretty ColorText
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
                [ Pretty ColorText -> Pretty ColorText
P.red ([Char] -> Pretty ColorText
forall s. IsString s => [Char] -> Pretty s
P.string [Char]
codeserverPrompt),
                  Pretty ColorText
statusString,
                  Pretty ColorText
branchString,
                  [Char] -> Pretty ColorText
forall a. IsString a => [Char] -> a
fromString [Char]
prompt
                ]
      line <- [Char] -> InputT IO (Maybe [Char])
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
[Char] -> InputT m (Maybe [Char])
Line.getInputLine ([Char] -> InputT IO (Maybe [Char]))
-> [Char] -> InputT IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
markNonPrinting (Text -> [Char]
Text.unpack Text
fullPrompt)
      case line of
        Maybe [Char]
Nothing -> Input -> InputT IO Input
forall a. a -> InputT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Input
QuitI
        Just [Char]
l -> case [CliArg] -> Maybe [CliArg] -> [CliArg]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [CliArg] -> [CliArg]) -> Maybe [CliArg] -> [CliArg]
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [CliArg]
IP.parseArgs [Char]
l of
          [] -> InputT IO Input
go
          [CliArg]
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 [Char] InputPattern
-> [CliArg]
-> IO (Either ParseFailure (Maybe (Arguments, Input)))
parseInput Codebase IO Symbol Ann
codebase ProjectPath
pp IO (Branch IO)
currentProjectRoot NumberedArgs
numberedArgs Map [Char] InputPattern
IP.patternMap [CliArg]
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
$ [Char] -> History -> History
Line.addHistoryUnlessConsecutiveDupe [Char]
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
                go
              Right (Just (Arguments
expandedArgs, Input
i)) -> do
                let expandedArgs' :: [[Char]]
expandedArgs' = Argument -> [Char]
IP.unifyArgument (Argument -> [Char]) -> Arguments -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Arguments
expandedArgs
                    expandedArgsStr :: [Char]
expandedArgsStr =
                      [[Char]]
expandedArgs'
                        [[Char]] -> ([Char] -> [Char]) -> [[Char]]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [Char] -> [Char]
requote
                        [[Char]] -> ([[Char]] -> [Char]) -> [Char]
forall a b. a -> (a -> b) -> b
& [[Char]] -> [Char]
unwords
                Bool -> InputT IO () -> InputT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([[Char]]
expandedArgs' [[Char]] -> [[Char]] -> Bool
forall a. Eq a => a -> a -> Bool
/= (CliArg -> [Char]) -> [CliArg] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CliArg -> [Char]
IP.renderCliArg [CliArg]
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 ()) -> (Text -> IO ()) -> Text -> InputT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
Text.putStrLn (Text -> InputT IO ()) -> Text -> InputT IO ()
forall a b. (a -> b) -> a -> b
$ Text
fullPrompt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack [Char]
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
$ [Char] -> History -> History
Line.addHistoryUnlessConsecutiveDupe [Char]
expandedArgsStr
                Input -> InputT IO Input
forall a. a -> InputT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Input
i
    requote :: String -> String
    requote :: [Char] -> [Char]
requote [Char]
s =
      -- Requote args that have spaces, or were literal numbers to ensure
      -- they're not expanded differently on re-input.
      if Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
' ' [Char]
s
        then [Char]
"\"" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
s [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\""
        else [Char]
s
    settings :: Line.Settings IO
    settings :: Settings IO
settings =
      Line.Settings
        { complete :: CompletionFunc IO
complete = CompletionFunc IO
tabComplete,
          historyFile :: Maybe [Char]
historyFile = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
".unisonHistory",
          autoAddHistory :: Bool
autoAddHistory = Bool
False
        }
    tabComplete :: CompletionFunc IO
tabComplete = Map [Char] InputPattern
-> Codebase IO Symbol Ann
-> AuthenticatedHttpClient
-> ProjectPath
-> CompletionFunc IO
forall (m :: * -> *) v a.
MonadIO m =>
Map [Char] InputPattern
-> Codebase m v a
-> AuthenticatedHttpClient
-> ProjectPath
-> CompletionFunc m
haskelineTabComplete Map [Char] InputPattern
IP.patternMap Codebase IO Symbol Ann
codebase AuthenticatedHttpClient
authHTTPClient ProjectPath
pp

    -- Haskeline needs non-printing prompt segments wrapped with \SOH/\STX so
    -- cursor positioning stays correct with ANSI colors.
    markNonPrinting :: String -> String
    markNonPrinting :: [Char] -> [Char]
markNonPrinting = \case
      [] -> []
      Char
'\ESC' : [Char]
rest ->
        let ([Char]
seqChars, [Char]
rest') = [Char] -> ([Char], [Char])
takeAnsi [Char]
rest
         in Char
'\SOH' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Char
'\ESC' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
seqChars [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\STX" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
markNonPrinting [Char]
rest'
      Char
c : [Char]
rest -> Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
markNonPrinting [Char]
rest

    -- Consume a CSI sequence after ESC, if present.
    takeAnsi :: String -> (String, String)
    takeAnsi :: [Char] -> ([Char], [Char])
takeAnsi = \case
      Char
'[' : [Char]
rest ->
        let ([Char]
body, [Char]
rest') = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isFinalAnsi) [Char]
rest
         in case [Char]
rest' of
              [] -> (Char
'[' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
body, [])
              Char
f : [Char]
fs -> (Char
'[' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
body [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char
f], [Char]
fs)
      [Char]
rest -> ([], [Char]
rest)

    isFinalAnsi :: Char -> Bool
    isFinalAnsi :: Char -> Bool
isFinalAnsi Char
c = Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'@' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'~'

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 Symbol ->
  Runtime Symbol ->
  Codebase IO Symbol Ann ->
  Maybe Server.BaseUrl ->
  UCMVersion ->
  AuthN.AuthenticatedHttpClient ->
  AuthN.CredentialManager ->
  (PP.ProjectPathIds -> IO ()) ->
  ShouldWatchFiles ->
  IO ()
main :: [Char]
-> Welcome
-> ProjectPathIds
-> [Either Event Input]
-> Runtime Symbol
-> Runtime Symbol
-> Codebase IO Symbol Ann
-> Maybe BaseUrl
-> Text
-> AuthenticatedHttpClient
-> CredentialManager
-> (ProjectPathIds -> IO ())
-> ShouldWatchFiles
-> IO ()
main [Char]
dir Welcome
welcome ProjectPathIds
ppIds [Either Event Input]
initialInputs Runtime Symbol
runtime Runtime Symbol
sbRuntime Codebase IO Symbol Ann
codebase Maybe BaseUrl
serverBaseUrl Text
ucmVersion AuthenticatedHttpClient
authHTTPClient CredentialManager
credentialManager 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.
      _ <- 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
      _ <- Ki.fork scope (IO.evaluate IOSource.typecheckedFile)

      -- Create the watch state for managing all watched paths (including working directory).
      -- When --no-file-watch is passed, watchState is Nothing.
      watchState <- case shouldWatchFiles of
        ShouldWatchFiles
ShouldNotWatchFiles -> Maybe WatchState -> IO (Maybe WatchState)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe WatchState
forall a. Maybe a
Nothing
        ShouldWatchFiles
ShouldWatchFiles -> do
          ws <- WatchManager -> ([Char] -> Bool) -> IO WatchState
Watch.newWatchState WatchManager
mgr [Char] -> Bool
allow
          -- Add the working directory as the first watched path
          _ <- Watch.watchPath ws dir
          pure (Just ws)

      -- Await function that gets events from any watched path.
      -- When --no-file-watch is passed, this blocks forever.
      let awaitFileEvent :: IO Event
          awaitFileEvent = case Maybe WatchState
watchState of
            Maybe WatchState
Nothing -> IO () -> IO Event
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Int -> IO ()
threadDelay Int
forall a. Bounded a => a
maxBound)
            Just WatchState
ws -> do
              (file, contents) <- WatchState -> IO ([Char], Text)
Watch.awaitEvent WatchState
ws
              pure (UnisonFileChanged (Text.pack file) contents)

      -- On startup, we tell the user about any existing project names that don't pass the new project name regex,
      -- which isn't enforced yet.

      invalidProjectNamesInputs <- do
        projects <- Codebase.runTransaction codebase Queries.loadAllProjects
        let invalidProjectNames =
              (Project -> Maybe ProjectName) -> [Project] -> [ProjectName]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe
                ( \Project
project ->
                    if ProjectName -> Bool
Project.isValidNewProjectName Project
project.name
                      then Maybe ProjectName
forall a. Maybe a
Nothing
                      else ProjectName -> Maybe ProjectName
forall a. a -> Maybe a
Just Project
project.name
                )
                [Project]
projects
        pure case invalidProjectNames of
          [] -> []
          [ProjectName]
_ ->
            let isReservedName :: source -> Bool
isReservedName (forall target source. From source target => source -> target
into @Text -> Text
name) = Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"code" Bool -> Bool -> Bool
|| Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"p"
                hasReservedName :: Bool
hasReservedName = Maybe ProjectName -> Bool
forall a. Maybe a -> Bool
isJust ((ProjectName -> Bool) -> [ProjectName] -> Maybe ProjectName
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ProjectName -> Bool
forall {source}. From source Text => source -> Bool
isReservedName [ProjectName]
invalidProjectNames)
             in [ Input -> Either Event Input
forall a b. b -> Either a b
Right (Input -> Either Event Input)
-> (Pretty ColorText -> Input)
-> Pretty ColorText
-> Either Event Input
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty ColorText -> Input
CreateMessage (Pretty ColorText -> Input)
-> (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText
-> Input
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.warnCallout (Pretty ColorText -> Either Event Input)
-> Pretty ColorText -> Either Event Input
forall a b. (a -> b) -> a -> b
$
                    Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap Pretty ColorText
"We're updating UCM's project naming rules, and these names won’t be supported much longer:"
                      Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
forall s. IsString s => Pretty s
P.newline
                      Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
forall s. IsString s => Pretty s
P.newline
                      Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText -> Pretty ColorText
forall s. Pretty s -> Pretty s
P.group ([Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.commas ((ProjectName -> Pretty ColorText)
-> [ProjectName] -> [Pretty ColorText]
forall a b. (a -> b) -> [a] -> [b]
map ProjectName -> Pretty ColorText
P.prettyProjectName [ProjectName]
invalidProjectNames))
                      Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
forall s. IsString s => Pretty s
P.newline
                      Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
forall s. IsString s => Pretty s
P.newline
                      Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap
                        ( Pretty ColorText
"Please"
                            Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> InputPattern -> [Pretty ColorText] -> Pretty ColorText
IP.makeExample InputPattern
IP.projectRenameInputPattern []
                            Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
"them using only ASCII letters, numbers, hyphens, and underscores."
                            Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> (if Bool
hasReservedName then Pretty ColorText
"(You also can't use the names 'code' or 'p'.)" else Pretty ColorText
forall a. Monoid a => a
mempty)
                        )
                ]

      let initialState = ProjectPathIds -> LoopState
Cli.loopState0 ProjectPathIds
ppIds
      initialInputsRef <- newIORef $ Welcome.run welcome ++ initialInputs ++ invalidProjectNamesInputs
      initialEcho <- hGetEcho stdin
      let 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
loopState = do
            currentEcho <- Handle -> IO Bool
hGetEcho Handle
stdin
            liftIO $ restoreEcho currentEcho
            let PP.ProjectAndBranch projId branchId = PP.toProjectAndBranch $ NonEmpty.head loopState.projectPathStack
            let 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
            pp <- loopStateProjectPath codebase loopState
            getUserInput
              codebase
              authHTTPClient
              pp
              getProjectRoot
              (loopState ^. #numberedArgs)
      let notify :: Output -> IO ()
          notify Output
o = do
            rendered <- Maybe [Char]
-> (Word -> IO (Pretty ColorText))
-> Output
-> IO (Pretty ColorText)
notifyUser ([Char] -> Maybe [Char]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
dir) Word -> IO (Pretty ColorText)
fetchIssueFromGitHub Output
o
            if outputShouldUsePager o
              then putPrettyNonempty rendered
              else putPrettyLnUnpaged rendered

      let awaitInput :: Cli.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.
                action <-
                  (Scope -> IO (IO (Either Event Input)))
-> IO (IO (Either Event Input))
forall a. (Scope -> IO a) -> IO a
Ki.scoped \Scope
scope -> do
                    fileEventThread <- Scope -> IO Event -> IO (Thread Event)
forall a. Scope -> IO a -> IO (Thread a)
Ki.fork Scope
scope IO Event
awaitFileEvent
                    userInputThread <- Ki.fork scope (getInput loopState)
                    (atomically . asum)
                      [ do
                          event <- Ki.await fileEventThread
                          pure do
                            pure (Left event),
                        do
                          input <- Ki.await userInputThread
                          pure do
                            pure (Right input)
                      ]
                action

      let env =
            Cli.Env
              { AuthenticatedHttpClient
authHTTPClient :: AuthenticatedHttpClient
authHTTPClient :: AuthenticatedHttpClient
authHTTPClient,
                Codebase IO Symbol Ann
codebase :: Codebase IO Symbol Ann
codebase :: Codebase IO Symbol Ann
codebase,
                CredentialManager
credentialManager :: CredentialManager
credentialManager :: CredentialManager
credentialManager,
                loadSource :: Text -> IO LoadSourceResult
loadSource = Text -> IO LoadSourceResult
defaultLoadSourceFile,
                ProjectPathIds -> IO ()
lspCheckForChanges :: ProjectPathIds -> IO ()
lspCheckForChanges :: ProjectPathIds -> IO ()
lspCheckForChanges,
                writeSource :: Text -> Text -> Bool -> IO ()
writeSource = Text -> Text -> Bool -> IO ()
defaultWriteSourceFile,
                generateUniqueName :: 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 ()
notify :: Output -> IO ()
notify,
                notifyNumbered :: 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
runtime :: Runtime Symbol
runtime,
                sandboxedRuntime :: Runtime Symbol
sandboxedRuntime = Runtime Symbol
sbRuntime,
                Maybe BaseUrl
serverBaseUrl :: Maybe BaseUrl
serverBaseUrl :: Maybe BaseUrl
serverBaseUrl,
                Text
ucmVersion :: Text
ucmVersion :: Text
ucmVersion,
                isTranscriptTest :: Bool
isTranscriptTest = Bool
False,
                watchState :: Maybe WatchState
watchState = Maybe WatchState
watchState
              }

      (onInterrupt, waitForInterrupt) <- buildInterruptHandler

      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
                    action <-
                      (Scope -> IO (IO (ReturnType (), LoopState)))
-> IO (IO (ReturnType (), LoopState))
forall a. (Scope -> IO a) -> IO a
Ki.scoped \Scope
scope -> do
                        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))
                        fileEventThread <-
                          Ki.fork scope do
                            let 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
                            loop
                        (atomically . asum)
                          [ do
                              result <- Ki.await handleEventThread
                              pure (pure result),
                            do
                              event2 <- Ki.await fileEventThread
                              pure (stepEvent event2)
                          ]
                    action

              let step :: IO (Cli.ReturnType (), Cli.LoopState)
                  step :: IO (ReturnType (), LoopState)
step = do
                    input <- LoopState -> IO (Either Event Input)
awaitInput LoopState
s0
                    (!result, resultState) <-
                      case 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 = 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
                    pure (result, 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 (ReturnType (), LoopState)
-> ((ReturnType (), LoopState) -> IO (ReturnType (), LoopState))
-> IO (ReturnType (), LoopState)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ReturnType (), LoopState) -> IO (ReturnType (), LoopState)
forall (m :: * -> *) a. MonadIO m => a -> m a
UnliftIO.evaluate)) 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 -> [Char] -> IO ()
hPutStrLn Handle
stderr [Char]
"\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
<> [Char] -> Text
Text.pack (SomeException -> [Char]
forall e. Exception e => e -> [Char]
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
  ctrlCMarker <- IO (MVar ())
forall (m :: * -> *) a. MonadIO m => m (MVar a)
UnliftIO.newEmptyMVar
  let 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 = MVar () -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
UnliftIO.takeMVar MVar ()
ctrlCMarker
  pure $ (onInterrupt, waitForInterrupt)