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