{-# LANGUAGE NoImplicitPrelude #-}
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)
)
data
= CmdSpec Int
deriving (Int -> PagerException -> ShowS
[PagerException] -> ShowS
PagerException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PagerException] -> ShowS
$cshowList :: [PagerException] -> ShowS
show :: PagerException -> String
$cshow :: PagerException -> String
showsPrec :: Int -> PagerException -> ShowS
$cshowsPrec :: Int -> 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 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: "
, forall a. Show a => a -> String
show Int
n
]
pageWriter :: (Handle -> IO ()) -> IO ()
pageWriter :: (Handle -> IO ()) -> IO ()
pageWriter Handle -> IO ()
writer = do
Maybe CreateProcess
mpager <- forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ MaybeT IO CreateProcess
cmdspecFromEnvVar
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> MaybeT IO CreateProcess
cmdspecFromExeName String
"less"
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 :: StdStream
std_in = StdStream
CreatePipe
, close_fds :: Bool
close_fds = Bool
True
, delegate_ctlc :: Bool
delegate_ctlc = Bool
True
}
(Either IOException ()
_ :: Either IOException ()) <- forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (do Handle -> IO ()
writer Handle
h
forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
h)
ExitCode
exit <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
procHandle
case ExitCode
exit of
ExitCode
ExitSuccess -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ExitFailure Int
n -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (CmdSpec -> Int -> PagerException
PagerExitFailure (CreateProcess -> CmdSpec
cmdspec CreateProcess
pager) Int
n)
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (String -> IO (Maybe String)
lookupEnv String
"PAGER")
cmdspecFromExeName :: String -> MaybeT IO CreateProcess
cmdspecFromExeName =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\String
command -> String -> [String] -> CreateProcess
proc String
command []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Maybe String)
findExecutable
pageText :: Text -> IO ()
pageText :: Text -> IO ()
pageText = (Handle -> IO ()) -> IO ()
pageWriter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip Handle -> Text -> IO ()
T.hPutStr