Pager.hs

   1 -- This file is part of Diohsc
   2 -- Copyright (C) 2020 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 {-# LANGUAGE OverloadedStrings #-}
  12
  13 module Pager where
  14
  15 import           Control.Monad          (when)
  16 import           Control.Monad.IO.Class (liftIO)
  17 import           Data.Char              (toLower)
  18 import           Data.Maybe             (fromMaybe, isJust)
  19 import           Safe                   (readMay)
  20 import           System.IO              (hFlush, stdout)
  21
  22 import qualified Data.Text.Lazy         as T
  23 import qualified Data.Text.Lazy.IO      as T
  24
  25 import           ANSIColour
  26 import           Prompt
  27
  28 printLinesPaged :: Int -> Int -> Int -> [T.Text] -> IO ()
  29 printLinesPaged wrapCol termWidth perpage
  30     | perpage <= 0 = \_ -> pure ()
  31     | otherwise = printLinesPaged' perpage Nothing
  32     where
  33     printLinesPaged' :: Int -> Maybe Int -> [T.Text] -> IO ()
  34     printLinesPaged' n mcol [] | n > 0 =
  35         when (isJust mcol) . liftIO $ putStrLn ""
  36     printLinesPaged' n mcol (l:ls) | n > 0 = do
  37         let physLines = (+ 1) . max 0 $ (visibleLength l - 1) `div` termWidth
  38             endCol = visibleLength l `mod` termWidth
  39         when (isJust mcol) . liftIO $ putStrLn ""
  40         liftIO $ T.putStr l >> hFlush stdout
  41         printLinesPaged' (n - physLines) (Just endCol) ls
  42     printLinesPaged' _ mcol ls = do
  43         let col = fromMaybe 0 mcol
  44         liftIO . T.putStr $ T.replicate (fromIntegral $ wrapCol - col) " "
  45         c <- liftIO . promptChar $ drop (col + 4 - termWidth) "  --"
  46         liftIO $ putStrLn ""
  47         case toLower <$> c of
  48             Nothing -> return ()
  49             Just 'q' -> return ()
  50             Just c' | c' == '\n' || c' == '\r' -> return ()
  51             Just c' | Just m <- readMay (c':""), m > 0 -> printLinesPaged' m Nothing ls
  52             Just 'c' -> printLinesPaged' 9999 Nothing ls
  53             Just 'h' -> printLinesPaged' (perpage `div` 2) Nothing ls
  54             _ -> printLinesPaged' perpage Nothing ls