diohsc-0.1.3: Prompt.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/.

module Prompt
    ( waitKey
    , promptChar
    , promptYN
    , promptPassword
    , promptLine
    , promptLineWithCompletions
    , promptLineWithHistoryFile
    , promptLineInputT
    ) where

import           Control.Exception.Base   (bracket)
import           Control.Monad            (void)
import           Control.Monad.Catch      (MonadMask)
import           Control.Monad.IO.Class   (MonadIO)
import           Control.Monad.Trans      (lift)
import           Data.Bits                (xor)
import           Data.List                (isPrefixOf)
import           System.IO

import qualified System.Console.Haskeline as HL

import           ANSIColour
import           Util

defaultInputSettings :: HL.Settings IO
defaultInputSettings = (HL.defaultSettings :: HL.Settings IO) {HL.complete = HL.noCompletion}

runInputTDefWithAbortValue :: a -> HL.InputT IO a -> IO a
runInputTDefWithAbortValue = runInputTWithAbortValue defaultInputSettings

runInputTWithAbortValue :: HL.Settings IO -> a -> HL.InputT IO a -> IO a
runInputTWithAbortValue settings abortValue =
    HL.handleInterrupt (return abortValue) . HL.runInputT settings . HL.withInterrupt


waitKey :: String -> IO Bool
waitKey prompt = runInputTDefWithAbortValue False $
    (HL.haveTerminalUI >>? void . HL.waitForAnyKey $ escapePromptCSI prompt) >> return True

promptChar :: String -> IO (Maybe Char)
promptChar prompt = bracketSet (hGetEcho stdin) (hSetEcho stdin) False .
    bracketSet (hGetBuffering stdin) (hSetBuffering stdin) NoBuffering $ do
        putStr prompt
        hFlush stdout
        c <- runInputTDefWithAbortValue Nothing . lift $ Just <$> getChar
        putStrLn ""
        return c
    where bracketSet get set v f = bracket get set $ \_ -> set v >> f

promptYN :: Bool -> Bool -> String -> IO Bool
promptYN False def _ = return def
promptYN True def prompt =
    xor def . (`elem` map Just (if def then "nN" else "yY"))
        <$> promptChar (prompt ++ if def then " [Y/n] " else " [y/N] ")

promptPassword :: String -> IO (Maybe String)
promptPassword = runInputTDefWithAbortValue Nothing . HL.getPassword (Just '*') . escapePromptCSI

promptLineInputT :: (MonadIO m, MonadMask m) => String -> HL.InputT m (Maybe String)
promptLineInputT = HL.handleInterrupt (return Nothing) . HL.withInterrupt . HL.getInputLine . escapePromptCSI

promptLine :: String -> IO (Maybe String)
promptLine = HL.runInputT defaultInputSettings . promptLineInputT

promptLineWithCompletions :: String -> [String] -> IO (Maybe String)
promptLineWithCompletions prompt completions =
    HL.runInputT settings $ promptLineInputT prompt
    where settings = defaultInputSettings
            { HL.complete = HL.completeWord Nothing " " $ \w ->
                    return . map HL.simpleCompletion $ filter (isPrefixOf w) completions }

promptLineWithHistoryFile :: FilePath -> String -> IO (Maybe String)
promptLineWithHistoryFile path =
    HL.runInputT settings . promptLineInputT
    where settings = defaultInputSettings { HL.historyFile = Just path }