module Unison.Util.Less where

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

less :: String -> IO ()
less :: String -> IO ()
less String
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 = String -> IO ()
putStr String
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
          (Just Handle
stdin, Maybe Handle
_stdout, Maybe Handle
_stderr, ProcessHandle
pid) <-
            CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
process {std_in = CreatePipe}

          -- If pager exits before consuming all of stdin, `hPutStr` will crash.
          IO () -> IO ()
ignore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStr Handle
stdin String
str

          -- If pager has already exited, hClose throws an exception.
          IO () -> IO ()
ignore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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
      ]