1{-# LANGUAGE NoImplicitPrelude #-}
2{-# LANGUAGE ScopedTypeVariables, RankNTypes, DeriveDataTypeable #-}
3
4-- | Run external pagers (@$PAGER@, @less@, @more@).
5module System.Process.Pager
6  ( pageWriter
7  , pageText
8  , PagerException (..)
9  ) where
10
11import Stack.Prelude
12import System.Directory (findExecutable)
13import System.Environment (lookupEnv)
14import System.Process ( createProcess, cmdspec, shell, proc, waitForProcess
15                      , CmdSpec (ShellCommand, RawCommand)
16                      , StdStream (CreatePipe)
17                      , CreateProcess (std_in, close_fds, delegate_ctlc)
18                      )
19import Control.Monad.Trans.Maybe (MaybeT (runMaybeT, MaybeT))
20import qualified Data.Text.IO as T
21
22-- | Run pager, providing a function that writes to the pager's input.
23pageWriter :: (Handle -> IO ()) -> IO ()
24pageWriter writer =
25  do mpager <- runMaybeT $ cmdspecFromEnvVar
26                       <|> cmdspecFromExeName "less"
27                       <|> cmdspecFromExeName "more"
28     case mpager of
29       Just pager ->
30         do (Just h,_,_,procHandle) <- createProcess pager
31                                         { std_in = CreatePipe
32                                         , close_fds = True
33                                         , delegate_ctlc = True
34                                         }
35            (_ :: Either IOException ()) <- try (do writer h
36                                                    hClose h)
37            exit <- waitForProcess procHandle
38            case exit of
39              ExitSuccess -> return ()
40              ExitFailure n -> throwIO (PagerExitFailure (cmdspec pager) n)
41            return ()
42       Nothing -> writer stdout
43  where
44    cmdspecFromEnvVar = shell <$> MaybeT (lookupEnv "PAGER")
45    cmdspecFromExeName =
46      fmap (\path -> proc path []) . MaybeT . findExecutable
47
48-- | Run pager to display a 'Text'
49pageText :: Text -> IO ()
50pageText = pageWriter . flip T.hPutStr
51
52-- | Exception running pager.
53data PagerException = PagerExitFailure CmdSpec Int
54  deriving Typeable
55instance Show PagerException where
56  show (PagerExitFailure cmd n) =
57    let
58      getStr (ShellCommand c) = c
59      getStr (RawCommand exePath _) = exePath
60    in
61      "Pager (`" ++ getStr cmd ++ "') exited with non-zero status: " ++ show n
62
63instance Exception PagerException
64