{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables, RankNTypes, DeriveDataTypeable #-}
module System.Process.Pager
( pageWriter
, pageText
, PagerException (..)
) where
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)
)
import Control.Monad.Trans.Maybe (MaybeT (runMaybeT, MaybeT))
import qualified Data.Text.IO as T
pageWriter :: (Handle -> IO ()) -> IO ()
pageWriter writer =
do mpager <- runMaybeT $ cmdspecFromEnvVar
<|> cmdspecFromExeName "less"
<|> cmdspecFromExeName "more"
case mpager of
Just pager ->
do (Just h,_,_,procHandle) <- createProcess pager
{ std_in = CreatePipe
, close_fds = True
, delegate_ctlc = True
}
(_ :: Either IOException ()) <- try (do writer h
hClose h)
exit <- waitForProcess procHandle
case exit of
ExitSuccess -> return ()
ExitFailure n -> throwIO (PagerExitFailure (cmdspec pager) n)
return ()
Nothing -> writer stdout
where
cmdspecFromEnvVar = shell <$> MaybeT (lookupEnv "PAGER")
cmdspecFromExeName =
fmap (\path -> proc path []) . MaybeT . findExecutable
pageText :: Text -> IO ()
pageText = pageWriter . flip T.hPutStr
data PagerException = PagerExitFailure CmdSpec Int
deriving Typeable
instance Show PagerException where
show (PagerExitFailure cmd n) =
let
getStr (ShellCommand c) = c
getStr (RawCommand exePath _) = exePath
in
"Pager (`" ++ getStr cmd ++ "') exited with non-zero status: " ++ show n
instance Exception PagerException