summaryrefslogtreecommitdiff
path: root/System/Pager.hs
blob: f0b05b41dedc2e46cdb50a2ba3f984f4bbc5716d (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
{-# 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 =
  do terminal <- setupTermFromEnv
     let linesInTerminal =
           getCapability terminal termLines
         columnsInTerminal =
           getCapability terminal termColumns
         linesInText = length (T.lines text)
         columnsInText =
           last (sort (fmap T.length (T.lines text)))
         usePager =
           case (columnsInTerminal,linesInTerminal) of
             (Nothing,_) -> True
             (_,Nothing) -> True
             (Just x,Just y)
               | or [x <= columnsInText,y <= linesInText] -> True
               | otherwise -> False
     if usePager
        then sendToPagerStrict (TE.encodeUtf8 text)
        else TIO.putStr text

-- |Send a lazy 'Bl.ByteString' to the user's @$PAGER@.
sendToPager :: Bl.ByteString -> IO ()
sendToPager bytes =
  sendToPagerConduit (sourceLbs bytes)

-- |Send a strict 'B.ByteString' to the user's @$PAGER@.
sendToPagerStrict :: B.ByteString -> IO ()
sendToPagerStrict bytes =
  sendToPagerConduit (sourceLbs (Bl.fromStrict 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 =
  getEnv "PAGER" >>=
  \case
    Just x -> return x
    Nothing ->
      getEnv "PATH" >>=
      \case
        Nothing ->
          fail "There is no $PATH, so I can't see if 'less' or 'more' is installed."
        Just p ->
          do let pathText = TE.decodeUtf8 p
                 pathPieces =
                   T.splitOn ":" pathText
             searchForLess <-
               fmap mconcat
                    (forM pathPieces
                          (\pathPiece ->
                             do dirExists <-
                                  doesDirectoryExist (T.unpack pathPiece)
                                filesInDir <-
                                  if |  dirExists ->
                                       getDirectoryContents (T.unpack pathPiece)
                                     |  otherwise -> return mempty
                                return (filter (\x ->
                                                  (x == "less") ||
                                                  (x == "more"))
                                               filesInDir)))
             if |  searchForLess == mempty ->
                  fail "There doesn't appear to be any pager installed."
                |  elem "less" searchForLess ->
                  return "less"
                |  otherwise -> return "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 =
  do pager <- fmap unpack 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 i ->
         do errContents <- hGetContents stderrH
            fail (unlines [mappend "Pager exited with exit code " (show i)
                          ,errContents])
       ExitSuccess -> return ()