{-# LANGUAGE CPP               #-}
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE RankNTypes  #-}

module GHCup.Utils.Pager where

import System.Environment
import GHCup.Utils.Dirs (findExecutable)
import Data.Foldable (asum)
import System.Process
import System.Exit
import System.IO
import Data.Text (Text)
import qualified Data.Text.IO as T
import Control.Monad (forM_, (<=<))
import Control.Exception (IOException, try)
import GHCup.Utils.Output
import qualified Data.Text as T


getPager :: IO (Maybe FilePath)
getPager :: IO (Maybe String)
getPager = do
  String -> IO (Maybe String)
lookupEnv String
"GHCUP_PAGER" IO (Maybe String)
-> (Maybe String -> IO (Maybe String)) -> IO (Maybe String)
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
r  -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
r
    Maybe String
Nothing -> String -> IO (Maybe String)
lookupEnv String
"PAGER" IO (Maybe String)
-> (Maybe String -> IO (Maybe String)) -> IO (Maybe String)
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
r' -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
r'
      Maybe String
Nothing ->
        let pagers :: [String]
pagers = [String
"most", String
"more", String
"less"]
        in (Either IOException String -> Maybe String)
-> IO (Either IOException String) -> IO (Maybe String)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((IOException -> Maybe String)
-> (String -> Maybe String)
-> Either IOException String
-> Maybe String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe String -> IOException -> Maybe String
forall a b. a -> b -> a
const Maybe String
forall a. Maybe a
Nothing) String -> Maybe String
forall a. a -> Maybe a
Just)
           (IO (Either IOException String) -> IO (Maybe String))
-> ([String] -> IO (Either IOException String))
-> [String]
-> IO (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => IO a -> IO (Either e a)
try @IOException
           (IO String -> IO (Either IOException String))
-> ([String] -> IO String)
-> [String]
-> IO (Either IOException String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [IO String] -> IO String
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
           ([IO String] -> IO String)
-> ([String] -> [IO String]) -> [String] -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO String) -> [String] -> [IO String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO String
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"could not find") String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> IO String)
-> (String -> IO (Maybe String)) -> String -> IO String
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> IO (Maybe String)
findExecutable)
           ([String] -> IO (Maybe String)) -> [String] -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ [String]
pagers

-- 'more' reads from STDERR, and requires std_err to be 'Inherit'
sendToPager :: FilePath -> [Text] -> IO (Either IOException ())
sendToPager :: String -> [Text] -> IO (Either IOException ())
sendToPager String
pager [Text]
text = forall e a. Exception e => IO a -> IO (Either e a)
try @IOException
    (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
-> IO ()
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess (String -> CreateProcess
shell String
pager) { std_in = CreatePipe
                                      , std_err = Inherit
                                      , std_out = Inherit
                                      , delegate_ctlc = True
                                      }
    ((Maybe Handle
  -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
 -> IO ())
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(Just Handle
stdinH) Maybe Handle
_ Maybe Handle
_ ProcessHandle
ph -> do
        [Text] -> (Text -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
text ((Text -> IO ()) -> IO ()) -> (Text -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
T.hPutStrLn Handle
stdinH
        Handle -> IO ()
hClose Handle
stdinH
        ExitCode
exitCode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
        case ExitCode
exitCode of
          ExitFailure Int
i -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Pager exited with exit code " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i)
          ExitCode
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


sendToPager' :: Maybe FilePath -> [Text] -> IO ()
sendToPager' :: Maybe String -> [Text] -> IO ()
sendToPager' (Just String
pager) [Text]
text = do
  Maybe Bool
fits <- [Text] -> IO (Maybe Bool)
fitsInTerminal [Text]
text
  case Maybe Bool
fits of
    Just Bool
True -> do
      Text -> IO ()
T.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines [Text]
text
    Maybe Bool
_ -> String -> [Text] -> IO (Either IOException ())
sendToPager String
pager [Text]
text IO (Either IOException ())
-> (Either IOException () -> 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
      Right ()
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Left IOException
_ -> do
        Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines [Text]
text
sendToPager' Maybe String
_ [Text]
text =
  [Text] -> (Text -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
text Text -> IO ()
T.putStrLn