    {-# 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 ()