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           Control.Monad.Trans.Writer (WriterT, execWriterT, tell)
  18 import           Data.Char                  (toLower)
  19 import           Data.Maybe                 (fromMaybe, isJust, maybeToList)
  20 import           Safe                       (readMay)
  21 import           System.IO                  (hFlush, stdout)
  22
  23 import qualified Data.Text.Lazy             as T
  24 import qualified Data.Text.Lazy.IO          as T
  25
  26 import           ANSIColour
  27 import           Prompt
  28
  29 printLinesPaged :: Int -> Int -> Int -> [T.Text] -> IO [String]
  30 printLinesPaged wrapCol termWidth perpage
  31     | perpage <= 0 = \_ -> return []
  32     | otherwise = execWriterT . printLinesPaged' perpage Nothing
  33     where
  34     printLinesPaged' :: Int -> Maybe Int -> [T.Text] -> WriterT [String] IO ()
  35     printLinesPaged' _ mcol [] =
  36         when (isJust mcol) . liftIO $ putStrLn ""
  37     printLinesPaged' n mcol (l:ls) =
  38         let physLines = (+ 1) . max 0 $ (visibleLength l - 1) `div` termWidth
  39             endCol = visibleLength l `mod` termWidth
  40         in if n >= physLines
  41         then do
  42             when (isJust mcol) . liftIO $ putStrLn ""
  43             liftIO $ T.putStr l >> hFlush stdout
  44             printLinesPaged' (n - physLines) (Just endCol) ls
  45         else do
  46             let col = fromMaybe 0 mcol
  47             liftIO . T.putStr $ T.replicate (fromIntegral $ wrapCol - col) " "
  48             c <- liftIO . promptChar . withBoldStr $ drop (col + 4 - termWidth) "  --"
  49             liftIO $ putStrLn ""
  50             let rest = l:ls
  51             case toLower <$> c of
  52                 Nothing -> return ()
  53                 Just 'q' -> return ()
  54                 Just c' | c' == '\n' || c' == '\r' -> return ()
  55                 Just c' | Just m <- readMay (c':""), m > 0 -> printLinesPaged' m Nothing rest
  56                 Just 'c' -> printLinesPaged' 9999 Nothing rest
  57                 Just 'h' -> printLinesPaged' (perpage `div` 2) Nothing rest
  58                 Just c' | c' == ':' || c' == '>' ->
  59                     liftIO (promptLine "Queue command: ") >>= tell . maybeToList >>
  60                         printLinesPaged' 0 Nothing rest
  61                 _ -> printLinesPaged' perpage Nothing rest