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