{-# LANGUAGE MultiWayIf, LambdaCase, OverloadedStrings, RankNTypes #-}

-- | 
-- Module      : System.Pager
-- Description : Send stuff to the user's $PAGER.
-- Copyright   : Copyright (c) 2015, Peter Harpending.
-- License     : BSD2
-- Maintainer  : Peter Harpending <peter@harpending.org>
-- Stability   : experimental
-- Portability : Tested with GHC on Linux and FreeBSD
-- 

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

-- |If the user's terminal is long enough to display the (strict)
-- 'Text', just print it. Else, send it to the pager.
-- 
-- The text needs to be strict, because the function counts the number
-- of lines in the text. (This is also why it needs to be text, and not
-- a bytestring, because Text has stuff like line-counting).
printOrPage :: Text -> IO ()
printOrPage :: Text -> IO ()
printOrPage Text
text =
  do Terminal
terminal <- IO Terminal
setupTermFromEnv
     let linesInTerminal :: Maybe Int
linesInTerminal =
           Terminal -> Capability Int -> Maybe Int
forall a. Terminal -> Capability a -> Maybe a
getCapability Terminal
terminal Capability Int
termLines
         columnsInTerminal :: Maybe Int
columnsInTerminal =
           Terminal -> Capability Int -> Maybe Int
forall a. Terminal -> Capability a -> Maybe a
getCapability Terminal
terminal Capability Int
termColumns
         linesInText :: Int
linesInText = [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Text -> [Text]
T.lines Text
text)
         columnsInText :: Int
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 :: Bool
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 Bool
usePager
        then ByteString -> IO ()
sendToPagerStrict (Text -> ByteString
TE.encodeUtf8 Text
text)
        else Text -> IO ()
TIO.putStr Text
text

-- |Send a lazy 'Bl.ByteString' to the user's @$PAGER@.
sendToPager :: Bl.ByteString -> IO ()
sendToPager :: ByteString -> IO ()
sendToPager 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)

-- |Send a strict 'B.ByteString' to the user's @$PAGER@.
sendToPagerStrict :: B.ByteString -> IO ()
sendToPagerStrict :: ByteString -> IO ()
sendToPagerStrict 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))

-- |This finds the user's @$PAGER@. This will fail if:
-- 
-- * There is no @$PATH@ variable
-- * The user doesn't have a @less@ or @more@ installed, and hasn't
--   specified an alternate program via @$PAGER@.
-- 
findPager :: IO ByteString
findPager :: IO ByteString
findPager =
  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
             [FilePath]
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 Bool
dirExists <-
                                  FilePath -> IO Bool
doesDirectoryExist (Text -> FilePath
T.unpack Text
pathPiece)
                                [FilePath]
filesInDir <-
                                  if |  Bool
dirExists ->
                                       FilePath -> IO [FilePath]
getDirectoryContents (Text -> FilePath
T.unpack Text
pathPiece)
                                     |  Bool
otherwise -> [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath]
forall a. Monoid a => a
mempty
                                [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
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"))
                                               [FilePath]
filesInDir)))
             if |  [FilePath]
searchForLess [FilePath] -> [FilePath] -> Bool
forall a. Eq a => a -> a -> Bool
== [FilePath]
forall a. Monoid a => a
mempty ->
                  FilePath -> IO ByteString
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"There doesn't appear to be any pager installed."
                |  FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem FilePath
"less" [FilePath]
searchForLess ->
                  ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
"less"
                |  Bool
otherwise -> ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
"more"

-- |This is what 'sendToPager' uses on the back end. It takes a
-- 'Producer', from "Data.Conduit", and then sends the produced bytes to
-- the pager's stdin.
sendToPagerConduit :: Producer (ResourceT IO) ByteString -> IO ()
sendToPagerConduit :: Producer (ResourceT IO) ByteString -> IO ()
sendToPagerConduit Producer (ResourceT IO) ByteString
producer =
  do FilePath
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 Handle
stdinH),Maybe Handle
_,(Just Handle
stderrH),ProcessHandle
ph) <-
       CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess
         ((FilePath -> CreateProcess
shell FilePath
pager) {std_in = CreatePipe
                        ,std_err = CreatePipe})
     ResourceT IO () -> IO ()
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ConduitT () ByteString (ResourceT IO) ()
-> ConduitT ByteString Void (ResourceT IO) () -> ResourceT IO ()
forall (m :: * -> *) a r.
Monad m =>
ConduitT () a m () -> ConduitT a Void m r -> m r
connect ConduitT () ByteString (ResourceT IO) ()
Producer (ResourceT IO) ByteString
producer (Handle -> ConduitT ByteString Void (ResourceT IO) ()
forall (m :: * -> *) o.
MonadIO m =>
Handle -> ConduitT ByteString o m ()
sinkHandle Handle
stdinH))
     Handle -> IO ()
hClose Handle
stdinH
     ExitCode
exitCode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
     case ExitCode
exitCode of
       ExitFailure Int
i ->
         do FilePath
errContents <- Handle -> IO FilePath
hGetContents Handle
stderrH
            FilePath -> IO ()
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail ([FilePath] -> FilePath
unlines [FilePath -> FilePath -> FilePath
forall a. Monoid a => a -> a -> a
mappend FilePath
"Pager exited with exit code " (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i)
                          ,FilePath
errContents])
       ExitCode
ExitSuccess -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()