diohsc-0.1.12: Pager.hs

-- This file is part of Diohsc
-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation, or any later version.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see http://www.gnu.org/licenses/.

{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}

module Pager where

import           Control.Monad          (when)
import           Control.Monad.IO.Class (MonadIO, liftIO)
import           Data.Char              (toLower)
import           Data.Maybe             (fromMaybe, isJust)
import           Safe                   (readMay)
import           System.IO              (hFlush, stdout)

import qualified Data.Text.Lazy         as T
import qualified Data.Text.Lazy.IO      as T

import           ANSIColour
import           Prompt

printLinesPaged :: MonadIO m => Int -> Int -> Int -> (String -> m ()) -> [T.Text] -> m ()
printLinesPaged wrapCol termWidth perpage doCmd
    | perpage <= 0 = \_ -> pure ()
    | otherwise = printLinesPaged' perpage Nothing
    where
    printLinesPaged' n mcol [] | n > 0 =
        when (isJust mcol) . liftIO $ putStrLn ""
    printLinesPaged' n mcol (l:ls) | n > 0 = do
        let physLines = (+ 1) . max 0 $ (visibleLength l - 1) `div` termWidth
            endCol = visibleLength l `mod` termWidth
        when (isJust mcol) . liftIO $ putStrLn ""
        liftIO $ T.putStr l >> hFlush stdout
        printLinesPaged' (n - physLines) (Just endCol) ls
    printLinesPaged' _ mcol ls = do
        let col = fromMaybe 0 mcol
        liftIO . T.putStr $ T.replicate (fromIntegral $ wrapCol - col) " "
        c <- liftIO . promptChar $ drop (col + 4 - termWidth) "  --"
        liftIO $ putStrLn ""
        case toLower <$> c of
            Nothing -> return ()
            Just 'q' -> return ()
            Just c' | c' == '\n' || c' == '\r' -> return ()
            Just c' | Just m <- readMay (c':""), m > 0 -> printLinesPaged' m Nothing ls
            Just 'c' -> printLinesPaged' 9999 Nothing ls
            Just 'h' -> printLinesPaged' (perpage `div` 2) Nothing ls
            Just c' | c' == ':' || c' == '>' -> do
                liftIO (promptLine "> ") >>= \case
                    Just (Just cmd) -> doCmd cmd
                    _               -> pure ()
                printLinesPaged' 0 Nothing ls
            _ -> printLinesPaged' perpage Nothing ls