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 LambdaCase        #-}
  12 {-# LANGUAGE OverloadedStrings #-}
  13
  14 module Pager where
  15
  16 import           Control.Monad          (when)
  17 import           Control.Monad.IO.Class (MonadIO, liftIO)
  18 import           Data.Char              (toLower)
  19 import           Data.Maybe             (fromMaybe, isJust)
  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 :: MonadIO m => Int -> Int -> Int -> (String -> m ()) -> [T.Text] -> m ()
  30 printLinesPaged wrapCol termWidth perpage doCmd
  31     | perpage <= 0 = \_ -> pure ()
  32     | otherwise = printLinesPaged' perpage Nothing
  33     where
  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             Just c' | c' == ':' || c' == '>' -> do
  55                 liftIO (promptLine "> ") >>= \case
  56                     Just (Just cmd) -> doCmd cmd
  57                     _               -> pure ()
  58                 printLinesPaged' 0 Nothing ls
  59             _ -> printLinesPaged' perpage Nothing ls