module Unison.Util.Less where

import Control.Exception.Extra (ignore)
import Data.Text.IO qualified as Text
import System.Environment (lookupEnv)
import System.IO (hClose)
import System.Process
import Unison.Prelude
import UnliftIO qualified
import UnliftIO.Directory (findExecutable)
import UnliftIO.Process qualified as UnliftIO

less :: Text -> IO ()
less :: Text -> IO ()
less Text
str = do
  Bool
isInteractive <-
    String -> IO (Maybe String)
lookupEnv String
"INSIDE_EMACS" IO (Maybe String) -> (Maybe String -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just String
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      Maybe String
Nothing -> Handle -> IO Bool
forall (m :: * -> *). MonadIO m => Handle -> m Bool
UnliftIO.hIsTerminalDevice Handle
UnliftIO.stdin
  if Bool
isInteractive
    then IO ()
usePager
    else IO ()
noPager
  where
    noPager :: IO ()
    noPager :: IO ()
noPager = Text -> IO ()
Text.putStr Text
str
    usePager :: IO ()
    usePager :: IO ()
usePager = do
      Maybe CreateProcess
pager <-
        MaybeT IO CreateProcess -> IO (Maybe CreateProcess)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO CreateProcess -> IO (Maybe CreateProcess))
-> MaybeT IO CreateProcess -> IO (Maybe CreateProcess)
forall a b. (a -> b) -> a -> b
$
          [MaybeT IO CreateProcess] -> MaybeT IO CreateProcess
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
            [ String -> CreateProcess
shell (String -> CreateProcess)
-> MaybeT IO String -> MaybeT IO CreateProcess
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe String) -> MaybeT IO String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (String -> IO (Maybe String)
lookupEnv String
"UNISON_PAGER"),
              IO (Maybe String) -> MaybeT IO String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (String -> IO (Maybe String)
forall (m :: * -> *). MonadIO m => String -> m (Maybe String)
findExecutable String
"less") MaybeT IO String
-> (String -> CreateProcess) -> MaybeT IO CreateProcess
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \String
less -> String -> [String] -> CreateProcess
proc String
less [String]
lessArgs,
              -- most windows machines have 'more'.
              IO (Maybe String) -> MaybeT IO String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (String -> IO (Maybe String)
forall (m :: * -> *). MonadIO m => String -> m (Maybe String)
findExecutable String
"more") MaybeT IO String
-> (String -> CreateProcess) -> MaybeT IO CreateProcess
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \String
more -> String -> [String] -> CreateProcess
proc String
more []
            ]
      case Maybe CreateProcess
pager of
        Maybe CreateProcess
Nothing -> IO ()
noPager
        Just CreateProcess
process -> do
          IO () -> IO ()
ignore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
-> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> m a)
-> m a
UnliftIO.withCreateProcess (CreateProcess
process {std_in = CreatePipe}) \Maybe Handle
mayStdin Maybe Handle
_mayStdout Maybe Handle
_mayStderr ProcessHandle
pid -> do
            case Maybe Handle
mayStdin of
              Maybe Handle
Nothing ->
                -- Should be impossible, but just use noPager if we can't get a handle to the pager's stdin.
                IO ()
noPager
              Just Handle
stdin -> do
                -- If pager exits before consuming all of stdin, `hPutStr` will crash.
                Handle -> Text -> IO ()
Text.hPutStr Handle
stdin Text
str

                -- If pager has already exited, hClose throws an exception.
                Handle -> IO ()
hClose Handle
stdin
                -- Wait for pager to exit.
                IO ExitCode -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ExitCode -> IO ()) -> IO ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid

    lessArgs :: [String]
    lessArgs :: [String]
lessArgs =
      [ String
"--no-init", -- don't clear the screen on exit
        String
"--RAW-CONTROL-CHARS", -- pass through colors and stuff
        String
"--prompt=[less] Use space/arrow keys to navigate, or 'q' to return to ucm:",
        String
"--quit-if-one-screen" -- self-explanatory
      ]