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 ->
  49                 -- ^C. Really we'd want to interrupt the download at this
  50                 -- point, i.e. get an interrupt into the BSChan read. However,
  51                 -- I see no way to do that, so instead we require the user to
  52                 -- ^C a second time. Simply throwing a signal here doesn't
  53                 -- work, because then the whole request is aborted.
  54                 return ()
  55             Just 'q' -> return ()
  56             Just c' | c' == '\n' || c' == '\r' -> return ()
  57             Just c' | Just m <- readMay (c':""), m > 0 -> printLinesPaged' m Nothing ls
  58             Just 'c' -> printLinesPaged' 9999 Nothing ls
  59             Just 'h' -> printLinesPaged' (perpage `div` 2) Nothing ls
  60             Just c' | c' == ':' || c' == '>' -> do
  61                 liftIO (promptLine "> ") >>= \case
  62                     Just (Just cmd) -> doCmd cmd
  63                     _               -> pure ()
  64                 printLinesPaged' 0 Nothing ls
  65             _ -> printLinesPaged' perpage Nothing ls