{-# LANGUAGE MultiWayIf, LambdaCase, OverloadedStrings, RankNTypes #-}
module System.Pager where
import Control.Monad (forM)
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.ByteString.Char8 (unpack)
import qualified Data.ByteString.Lazy as Bl
import Data.Conduit
import Data.Conduit.Binary
import Data.List
import qualified Data.Monoid (mconcat, mempty)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.IO as TIO
import Safe
import System.Directory
import System.Exit
import System.IO
import System.Posix.ByteString
import System.Process
import System.Console.Terminfo
printOrPage :: Text -> IO ()
printOrPage :: Text -> IO ()
printOrPage Text
text =
do terminal <- IO Terminal
setupTermFromEnv
let linesInTerminal =
Terminal -> Capability Int -> Maybe Int
forall a. Terminal -> Capability a -> Maybe a
getCapability Terminal
terminal Capability Int
termLines
columnsInTerminal =
Terminal -> Capability Int -> Maybe Int
forall a. Terminal -> Capability a -> Maybe a
getCapability Terminal
terminal Capability Int
termColumns
linesInText = [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Text -> [Text]
T.lines Text
text)
columnsInText =
[Int] -> Int
forall a. HasCallStack => [a] -> a
last ([Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ((Text -> Int) -> [Text] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Int
T.length (Text -> [Text]
T.lines Text
text)))
usePager =
case (Maybe Int
columnsInTerminal,Maybe Int
linesInTerminal) of
(Maybe Int
Nothing,Maybe Int
_) -> Bool
True
(Maybe Int
_,Maybe Int
Nothing) -> Bool
True
(Just Int
x,Just Int
y)
| [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
columnsInText,Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
linesInText] -> Bool
True
| Bool
otherwise -> Bool
False
if usePager
then sendToPagerStrict (TE.encodeUtf8 text)
else TIO.putStr text
sendToPager :: Bl.ByteString -> IO ()
ByteString
bytes =
Producer (ResourceT IO) ByteString -> IO ()
sendToPagerConduit (ByteString -> ConduitT i ByteString (ResourceT IO) ()
forall (m :: * -> *) i.
Monad m =>
ByteString -> ConduitT i ByteString m ()
sourceLbs ByteString
bytes)
sendToPagerStrict :: B.ByteString -> IO ()
ByteString
bytes =
Producer (ResourceT IO) ByteString -> IO ()
sendToPagerConduit (ByteString -> ConduitT i ByteString (ResourceT IO) ()
forall (m :: * -> *) i.
Monad m =>
ByteString -> ConduitT i ByteString m ()
sourceLbs (ByteString -> ByteString
Bl.fromStrict ByteString
bytes))
findPager :: IO ByteString
=
ByteString -> IO (Maybe ByteString)
getEnv ByteString
"PAGER" IO (Maybe ByteString)
-> (Maybe ByteString -> IO ByteString) -> IO ByteString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
\case
Just ByteString
x -> ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
Maybe ByteString
Nothing ->
ByteString -> IO (Maybe ByteString)
getEnv ByteString
"PATH" IO (Maybe ByteString)
-> (Maybe ByteString -> IO ByteString) -> IO ByteString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
\case
Maybe ByteString
Nothing ->
FilePath -> IO ByteString
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"There is no $PATH, so I can't see if 'less' or 'more' is installed."
Just ByteString
p ->
do let pathText :: Text
pathText = ByteString -> Text
TE.decodeUtf8 ByteString
p
pathPieces :: [Text]
pathPieces =
HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
":" Text
pathText
searchForLess <-
([[FilePath]] -> [FilePath]) -> IO [[FilePath]] -> IO [FilePath]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[FilePath]] -> [FilePath]
forall a. Monoid a => [a] -> a
mconcat
([Text] -> (Text -> IO [FilePath]) -> IO [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Text]
pathPieces
(\Text
pathPiece ->
do dirExists <-
FilePath -> IO Bool
doesDirectoryExist (Text -> FilePath
T.unpack Text
pathPiece)
filesInDir <-
if | dirExists ->
getDirectoryContents (T.unpack pathPiece)
| otherwise -> return mempty
return (filter (\FilePath
x ->
(FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"less") Bool -> Bool -> Bool
||
(FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"more"))
filesInDir)))
if | searchForLess == mempty ->
fail "There doesn't appear to be any pager installed."
| elem "less" searchForLess ->
return "less"
| otherwise -> return "more"
sendToPagerConduit :: Producer (ResourceT IO) ByteString -> IO ()
Producer (ResourceT IO) ByteString
producer =
do pager <- (ByteString -> FilePath) -> IO ByteString -> IO FilePath
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> FilePath
unpack IO ByteString
findPager
((Just stdinH),_,(Just stderrH),ph) <-
createProcess
((shell pager) {std_in = CreatePipe
,std_err = CreatePipe})
runResourceT (connect producer (sinkHandle stdinH))
hClose stdinH
exitCode <- waitForProcess ph
case exitCode of
ExitFailure Int
i ->
do errContents <- Handle -> IO FilePath
hGetContents Handle
stderrH
fail (unlines [mappend "Pager exited with exit code " (show i)
,errContents])
ExitCode
ExitSuccess -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()