diohsc-0.1.14.3: 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.Exception        (throw)
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 qualified System.Console.Haskeline as HL

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 -> throw HL.Interrupt
            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