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              (join, 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' n mcol [] | n > 0 =
  36         when (isJust mcol) . liftIO $ putStrLn ""
  37     printLinesPaged' n mcol (l:ls) | n > 0 = do
  38         let physLines = (+ 1) . max 0 $ (visibleLength l - 1) `div` termWidth
  39             endCol = visibleLength l `mod` termWidth
  40         when (isJust mcol) . liftIO $ putStrLn ""
  41         liftIO $ T.putStr l >> hFlush stdout
  42         printLinesPaged' (n - physLines) (Just endCol) ls
  43     printLinesPaged' _ mcol ls = do
  44         let col = fromMaybe 0 mcol
  45         liftIO . T.putStr $ T.replicate (fromIntegral $ wrapCol - col) " "
  46         c <- liftIO . promptChar $ drop (col + 4 - termWidth) "  --"
  47         liftIO $ putStrLn ""
  48         case toLower <$> c of
  49             Nothing -> return ()
  50             Just 'q' -> return ()
  51             Just c' | c' == '\n' || c' == '\r' -> return ()
  52             Just c' | Just m <- readMay (c':""), m > 0 -> printLinesPaged' m Nothing ls
  53             Just 'c' -> printLinesPaged' 9999 Nothing ls
  54             Just 'h' -> printLinesPaged' (perpage `div` 2) Nothing ls
  55             Just c' | c' == ':' || c' == '>' ->
  56                 liftIO (promptLine "Queue command: ") >>= tell . maybeToList . join >>
  57                     printLinesPaged' 0 Nothing ls
  58             _ -> printLinesPaged' perpage Nothing ls