Prompt.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 module Prompt
  12     ( waitKey
  13     , promptChar
  14     , promptYN
  15     , promptPassword
  16     , promptLine
  17     , promptLineWithCompletions
  18     , promptLineWithHistoryFile
  19     , promptLineInputT
  20     ) where
  21
  22 import           Control.Exception.Base   (bracket)
  23 import           Control.Monad            (void)
  24 import           Control.Monad.Catch      (MonadMask)
  25 import           Control.Monad.IO.Class   (MonadIO)
  26 import           Control.Monad.Trans      (lift)
  27 import           Data.Bits                (xor)
  28 import           Data.List                (isPrefixOf)
  29 import           System.IO
  30
  31 import qualified System.Console.Haskeline as HL
  32
  33 import           ANSIColour
  34 import           Util
  35
  36 defaultInputSettings :: HL.Settings IO
  37 defaultInputSettings = (HL.defaultSettings :: HL.Settings IO) {HL.complete = HL.noCompletion}
  38
  39 runInputTDefWithAbortValue :: a -> HL.InputT IO a -> IO a
  40 runInputTDefWithAbortValue = runInputTWithAbortValue defaultInputSettings
  41
  42 runInputTWithAbortValue :: HL.Settings IO -> a -> HL.InputT IO a -> IO a
  43 runInputTWithAbortValue settings abortValue =
  44     HL.handleInterrupt (return abortValue) . HL.runInputT settings . HL.withInterrupt
  45
  46
  47 waitKey :: String -> IO Bool
  48 waitKey prompt = runInputTDefWithAbortValue False $
  49     (HL.haveTerminalUI >>? void . HL.waitForAnyKey $ escapePromptCSI prompt) >> return True
  50
  51 promptChar :: String -> IO (Maybe Char)
  52 promptChar prompt = bracketSet (hGetEcho stdin) (hSetEcho stdin) False .
  53     bracketSet (hGetBuffering stdin) (hSetBuffering stdin) NoBuffering $ do
  54         putStr prompt
  55         hFlush stdout
  56         runInputTDefWithAbortValue Nothing . lift $ Just <$> getChar
  57     where bracketSet get set v f = bracket get set $ \_ -> set v >> f
  58
  59 promptYN :: Bool -> Bool -> String -> IO Bool
  60 promptYN False def _ = return def
  61 promptYN True def prompt = do
  62     answer <- xor def . (`elem` map Just (if def then "nN" else "yY"))
  63         <$> promptChar (prompt ++ if def then " [Y/n] " else " [y/N] ")
  64     putStrLn $ if answer then "y" else "n"
  65     return answer
  66
  67 promptPassword :: String -> IO (Maybe String)
  68 promptPassword = runInputTDefWithAbortValue Nothing . HL.getPassword (Just '*') . escapePromptCSI
  69
  70 promptLineInputT :: (MonadIO m, MonadMask m) => String -> HL.InputT m (Maybe String)
  71 promptLineInputT = HL.handleInterrupt (return Nothing) . HL.withInterrupt . HL.getInputLine . escapePromptCSI
  72
  73 promptLine :: String -> IO (Maybe String)
  74 promptLine = HL.runInputT defaultInputSettings . promptLineInputT
  75
  76 promptLineWithCompletions :: String -> [String] -> IO (Maybe String)
  77 promptLineWithCompletions prompt completions =
  78     HL.runInputT settings $ promptLineInputT prompt
  79     where settings = defaultInputSettings
  80             { HL.complete = HL.completeWord Nothing " " $ \w ->
  81                     return . map HL.simpleCompletion $ filter (isPrefixOf w) completions }
  82
  83 promptLineWithHistoryFile :: FilePath -> String -> IO (Maybe String)
  84 promptLineWithHistoryFile path =
  85     HL.runInputT settings . promptLineInputT
  86     where settings = defaultInputSettings { HL.historyFile = Just path }