{-# LANGUAGE NoImplicitPrelude   #-}

-- | Run external pagers (@$PAGER@, @less@, @more@).

module System.Process.Pager
  ( pageWriter
  , pageText
  , PagerException (..)
  ) where

import           Control.Monad.Trans.Maybe ( MaybeT (runMaybeT, MaybeT) )
import qualified Data.Text.IO as T
import           Stack.Prelude
import           System.Directory ( findExecutable )
import           System.Environment ( lookupEnv )
import           System.Process
                   ( createProcess, cmdspec, shell, proc, waitForProcess
                   , CmdSpec (ShellCommand, RawCommand)
                   , StdStream (CreatePipe)
                   , CreateProcess (std_in, close_fds, delegate_ctlc)
                   )

-- | Type representing exceptions thrown by functions exported by the

-- "System.Process.Pager" module.

data PagerException
  = PagerExitFailure CmdSpec Int
  deriving (Int -> PagerException -> ShowS
[PagerException] -> ShowS
PagerException -> String
(Int -> PagerException -> ShowS)
-> (PagerException -> String)
-> ([PagerException] -> ShowS)
-> Show PagerException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PagerException -> ShowS
showsPrec :: Int -> PagerException -> ShowS
$cshow :: PagerException -> String
show :: PagerException -> String
$cshowList :: [PagerException] -> ShowS
showList :: [PagerException] -> ShowS
Show, Typeable)

instance Exception PagerException where
  displayException :: PagerException -> String
displayException (PagerExitFailure CmdSpec
cmd Int
n) =
    let getStr :: CmdSpec -> String
getStr (ShellCommand String
c) = String
c
        getStr (RawCommand String
exePath [String]
_) = String
exePath
    in  [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ String
"Error: [S-9392]\n"
          , String
"Pager (`"
          , CmdSpec -> String
getStr CmdSpec
cmd
          , String
"') exited with non-zero status: "
          , Int -> String
forall a. Show a => a -> String
show Int
n
          ]

-- | Run pager, providing a function that writes to the pager's input.

pageWriter :: (Handle -> IO ()) -> IO ()
pageWriter :: (Handle -> IO ()) -> IO ()
pageWriter Handle -> IO ()
writer = do
  Maybe CreateProcess
mpager <- 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
cmdspecFromEnvVar
                    MaybeT IO CreateProcess
-> MaybeT IO CreateProcess -> MaybeT IO CreateProcess
forall a. MaybeT IO a -> MaybeT IO a -> MaybeT IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> MaybeT IO CreateProcess
cmdspecFromExeName String
"less"
                    MaybeT IO CreateProcess
-> MaybeT IO CreateProcess -> MaybeT IO CreateProcess
forall a. MaybeT IO a -> MaybeT IO a -> MaybeT IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> MaybeT IO CreateProcess
cmdspecFromExeName String
"more"
  case Maybe CreateProcess
mpager of
    Just CreateProcess
pager ->
      do (Just Handle
h,Maybe Handle
_,Maybe Handle
_,ProcessHandle
procHandle) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
pager
                                      { std_in = CreatePipe
                                      , close_fds = True
                                      , delegate_ctlc = True
                                      }
         (Either IOException ()
_ :: Either IOException ()) <- IO () -> IO (Either IOException ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (do Handle -> IO ()
writer Handle
h
                                                 Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
h)
         ExitCode
exit <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
procHandle
         case ExitCode
exit of
           ExitCode
ExitSuccess -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
           ExitFailure Int
n -> PagerException -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (CmdSpec -> Int -> PagerException
PagerExitFailure (CreateProcess -> CmdSpec
cmdspec CreateProcess
pager) Int
n)
         () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Maybe CreateProcess
Nothing -> Handle -> IO ()
writer Handle
stdout
 where
  cmdspecFromEnvVar :: MaybeT IO CreateProcess
cmdspecFromEnvVar = 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
"PAGER")
  cmdspecFromExeName :: String -> MaybeT IO CreateProcess
cmdspecFromExeName =
    (String -> CreateProcess)
-> MaybeT IO String -> MaybeT IO CreateProcess
forall a b. (a -> b) -> MaybeT IO a -> MaybeT IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\String
command -> String -> [String] -> CreateProcess
proc String
command []) (MaybeT IO String -> MaybeT IO CreateProcess)
-> (String -> MaybeT IO String)
-> String
-> MaybeT IO CreateProcess
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Maybe String) -> MaybeT IO String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe String) -> MaybeT IO String)
-> (String -> IO (Maybe String)) -> String -> MaybeT IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Maybe String)
findExecutable

-- | Run pager to display a 'Text'

pageText :: Text -> IO ()
pageText :: Text -> IO ()
pageText = (Handle -> IO ()) -> IO ()
pageWriter ((Handle -> IO ()) -> IO ())
-> (Text -> Handle -> IO ()) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Handle -> Text -> IO ()) -> Text -> Handle -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Handle -> Text -> IO ()
T.hPutStr