diohsc-0.1.1: 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 OverloadedStrings #-}

module Pager where

import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Writer (WriterT, execWriterT, tell)
import Data.Char (toLower)
import Data.Maybe (fromMaybe, isJust, maybeToList)
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 :: Int -> Int -> Int -> [T.Text] -> IO [String]
printLinesPaged wrapCol termWidth perpage
    | perpage <= 0 = \_ -> return []
    | otherwise = execWriterT . printLinesPaged' perpage Nothing
    where
    printLinesPaged' :: Int -> Maybe Int -> [T.Text] -> WriterT [String] IO ()
    printLinesPaged' _ mcol [] =
        when (isJust mcol) . liftIO $ putStrLn ""
    printLinesPaged' n mcol (l:ls) =
        let physLines = (+ 1) . max 0 $ (visibleLength l - 1) `div` termWidth
            endCol = visibleLength l `mod` termWidth
        in if n >= physLines
        then do
            when (isJust mcol) . liftIO $ putStrLn ""
            liftIO $ T.putStr l >> hFlush stdout
            printLinesPaged' (n - physLines) (Just endCol) ls
        else do
            let col = fromMaybe 0 mcol
            liftIO . T.putStr $ T.replicate (fromIntegral $ wrapCol - col) " "
            c <- liftIO . promptChar . withBoldStr $ drop (col + 4 - termWidth) "  --"
            let rest = l:ls
            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 rest
                Just 'c' -> printLinesPaged' 9999 Nothing rest
                Just 'h' -> printLinesPaged' (perpage `div` 2) Nothing rest
                Just c' | c' == ':' || c' == '>' ->
                    liftIO (promptLine "Queue command: ") >>= tell . maybeToList >>
                        printLinesPaged' 0 Nothing rest
                _ -> printLinesPaged' perpage Nothing rest