summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorpharpend <>2015-05-16 18:47:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-05-16 18:47:00 (GMT)
commit9e631636f8284f6163fdff7eddee2902cfaeb5f9 (patch)
tree48f4eb80847d23641cda853c72565f56f7cd85fa
parent2bebe448d9f167367d5ef84de93affa781360a13 (diff)
version 0.1.1.0HEAD0.1.1.0master
-rw-r--r--System/Pager.hs40
-rw-r--r--pager.cabal10
-rw-r--r--test/main.hs9
3 files changed, 55 insertions, 4 deletions
diff --git a/System/Pager.hs b/System/Pager.hs
index ca80e17..f0b05b4 100644
--- a/System/Pager.hs
+++ b/System/Pager.hs
@@ -21,20 +21,56 @@ import Data.ByteString.Char8 (unpack)
import qualified Data.ByteString.Lazy as Bl
import Data.Conduit
import Data.Conduit.Binary
-import Data.Text (Text)
+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)
+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:
--
diff --git a/pager.cabal b/pager.cabal
index b30a78e..cc42fca 100644
--- a/pager.cabal
+++ b/pager.cabal
@@ -1,9 +1,13 @@
name: pager
-version: 0.1.0.0
+version: 0.1.1.0
synopsis: Open up a pager, like 'less' or 'more'
description:
This opens up the user's $PAGER. On Linux, this is usually called @less@. On
the various BSDs, this is usually @more@.
+ .
+ CHANGES
+ .
+ [0.1.1.0] Add @printOrPage@ function and @sendToPagerStrict@ function.
homepage: https://github.com/pharpend/pager
license: BSD2
license-file: LICENSE
@@ -27,7 +31,7 @@ source-repository head
source-repository this
type: git
location: https://github.com/pharpend/pager.git
- tag: 0.1.0.0
+ tag: 0.1.1.0
library
other-extensions:
@@ -47,6 +51,7 @@ library
, resourcet
, safe
, unix
+ , terminfo
, text
, transformers
@@ -60,4 +65,5 @@ executable hs-pager-test-pager
, bytestring
, conduit-extra
, pager
+ , text
diff --git a/test/main.hs b/test/main.hs
index 67ced70..997d209 100644
--- a/test/main.hs
+++ b/test/main.hs
@@ -1,8 +1,13 @@
import qualified Data.ByteString.Lazy as B
+import qualified Data.Text.IO as TIO
import Data.Conduit.Binary
import Paths_pager
import System.Pager
+testPrintOrPage :: FilePath -> IO ()
+testPrintOrPage fnom =
+ TIO.readFile fnom >>= printOrPage
+
testConduit :: FilePath -> IO ()
testConduit fnom =
sendToPagerConduit (sourceFile fnom)
@@ -10,6 +15,7 @@ testConduit fnom =
test :: FilePath -> IO ()
test fp = B.readFile fp >>= sendToPager
+main :: IO ()
main =
do fnom <- getDataFileName "LICENSE"
putStrLn "Hit Return to start the conduit-free test"
@@ -18,3 +24,6 @@ main =
putStrLn "Hit Return to start the conduit test"
_ <- getLine
testConduit fnom
+ putStrLn "Hit Return to start the printOrPage test (no conduits)"
+ _ <- getLine
+ testPrintOrPage fnom