{-# LANGUAGE CPP #-}

module SimplePrompt (
  prompt,
  promptInitial,
  promptBuffered,
  promptNonEmpty,
  promptChar,
  promptKeyPress,
  promptEnter,
  promptPassword,
  yesNo,
  yesNoDefault
  ) where

import Control.Monad (void)
import Data.List.Extra (lower)
import System.Console.Haskeline (waitForAnyKey)

import SimplePrompt.Internal

#include "monadconstraint.h"

-- FIXME use haveTerminalUI ?
-- | prompt which drops buffered input (using `clearedInput`)
--
-- Ignores buffered input lines (ie if input line gotten in under 5ms)
prompt :: MONADCONSTRAINT => String -> m String
prompt :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> m String
prompt = InputT m String -> m String
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> m a
runPrompt (InputT m String -> m String)
-> (String -> InputT m String) -> String -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputT m String -> InputT m String
forall (m :: * -> *) a. MonadIO m => InputT m a -> InputT m a
clearedInput (InputT m String -> InputT m String)
-> (String -> InputT m String) -> String -> InputT m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> InputT m String
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m String
getPromptLine

-- FIXME non-empty?
-- | reads string with initial input (using `clearedInput`)
promptInitial :: MONADCONSTRAINT => String -> String -> m String
promptInitial :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> String -> m String
promptInitial String
s = InputT m String -> m String
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> m a
runPrompt (InputT m String -> m String)
-> (String -> InputT m String) -> String -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputT m String -> InputT m String
forall (m :: * -> *) a. MonadIO m => InputT m a -> InputT m a
clearedInput (InputT m String -> InputT m String)
-> (String -> InputT m String) -> String -> InputT m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> InputT m String
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> String -> InputT m String
getPromptInitial String
s

-- | reads string with buffering
promptBuffered :: MONADCONSTRAINT => String -> m String
promptBuffered :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> m String
promptBuffered = InputT m String -> m String
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> m a
runPrompt (InputT m String -> m String)
-> (String -> InputT m String) -> String -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> InputT m String
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m String
getPromptLine

-- | reads non-empty string (using `nonEmptyInput`)
promptNonEmpty :: MONADCONSTRAINT => String -> m String
promptNonEmpty :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> m String
promptNonEmpty = InputT m String -> m String
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> m a
runPrompt (InputT m String -> m String)
-> (String -> InputT m String) -> String -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputT m String -> InputT m String
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
InputT m String -> InputT m String
nonEmptyInput (InputT m String -> InputT m String)
-> (String -> InputT m String) -> String -> InputT m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> InputT m String
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m String
getPromptLine

-- | prompt for a password
promptPassword :: MONADCONSTRAINT => String -> m String
promptPassword :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> m String
promptPassword = InputT m String -> m String
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> m a
runPrompt (InputT m String -> m String)
-> (String -> InputT m String) -> String -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputT m String -> InputT m String
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
InputT m String -> InputT m String
nonEmptyInput (InputT m String -> InputT m String)
-> (String -> InputT m String) -> String -> InputT m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> InputT m String
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m String
getPromptPassword

-- | prompt for a printable character
promptChar :: MONADCONSTRAINT => String -> m Char
promptChar :: forall (m :: * -> *). (MonadIO m, MonadMask m) => String -> m Char
promptChar =
  InputT m Char -> m Char
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> m a
runPrompt (InputT m Char -> m Char)
-> (String -> InputT m Char) -> String -> m Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputT m Char -> InputT m Char
forall (m :: * -> *) a. MonadIO m => InputT m a -> InputT m a
clearedInput (InputT m Char -> InputT m Char)
-> (String -> InputT m Char) -> String -> InputT m Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> InputT m Char
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m Char
getPromptChar

-- | prompt for key press (returns False if Ctrl-d or EOF)
promptKeyPress :: MONADCONSTRAINT => String -> m Bool
promptKeyPress :: forall (m :: * -> *). (MonadIO m, MonadMask m) => String -> m Bool
promptKeyPress =
  InputT m Bool -> m Bool
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> m a
runPrompt (InputT m Bool -> m Bool)
-> (String -> InputT m Bool) -> String -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputT m Bool -> InputT m Bool
forall (m :: * -> *) a. MonadIO m => InputT m a -> InputT m a
clearedInput (InputT m Bool -> InputT m Bool)
-> (String -> InputT m Bool) -> String -> InputT m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> InputT m Bool
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m Bool
waitForAnyKey

-- | prompt for Enter key
promptEnter :: MONADCONSTRAINT => String -> m ()
promptEnter :: forall (m :: * -> *). (MonadIO m, MonadMask m) => String -> m ()
promptEnter =
  m String -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m String -> m ()) -> (String -> m String) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputT m String -> m String
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> m a
runPrompt (InputT m String -> m String)
-> (String -> InputT m String) -> String -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> InputT m String -> InputT m String
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
(a -> Bool) -> InputT m a -> InputT m a
untilInput (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"") (InputT m String -> InputT m String)
-> (String -> InputT m String) -> String -> InputT m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputT m String -> InputT m String
forall (m :: * -> *) a. MonadIO m => InputT m a -> InputT m a
clearedInput (InputT m String -> InputT m String)
-> (String -> InputT m String) -> String -> InputT m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> InputT m String
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m String
getPromptLine

-- | Yes-No prompt (accepts only {y,n,yes,no} case-insensitive)
yesNo :: MONADCONSTRAINT => String -> m Bool
yesNo :: forall (m :: * -> *). (MonadIO m, MonadMask m) => String -> m Bool
yesNo String
desc =
  InputT m Bool -> m Bool
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> m a
runPrompt (InputT m Bool -> m Bool)
-> (String -> InputT m Bool) -> String -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe Bool) -> InputT m String -> InputT m Bool
forall (m :: * -> *) a b.
(MonadIO m, MonadMask m) =>
(a -> Maybe b) -> InputT m a -> InputT m b
mapInput String -> Maybe Bool
maybeYN (InputT m String -> InputT m Bool)
-> (String -> InputT m String) -> String -> InputT m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> InputT m String
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m String
getPromptLine (String -> m Bool) -> String -> m Bool
forall a b. (a -> b) -> a -> b
$ String
desc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"? [y/n]"
  where
    maybeYN :: String -> Maybe Bool
maybeYN String
inp =
      case String -> String
lower String
inp of
        String
"y" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
        String
"yes" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
        String
"n" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
        String
"no" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
        String
_ ->  Maybe Bool
forall a. Maybe a
Nothing

-- | Yes-No prompt with default (uses `clearedInput`)
yesNoDefault :: MONADCONSTRAINT => Bool -> String -> m Bool
yesNoDefault :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
Bool -> String -> m Bool
yesNoDefault Bool
yes String
desc =
  InputT m Bool -> m Bool
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> m a
runPrompt (InputT m Bool -> m Bool)
-> (String -> InputT m Bool) -> String -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe Bool) -> InputT m String -> InputT m Bool
forall (m :: * -> *) a b.
(MonadIO m, MonadMask m) =>
(a -> Maybe b) -> InputT m a -> InputT m b
mapInput String -> Maybe Bool
maybeYN' (InputT m String -> InputT m Bool)
-> (String -> InputT m String) -> String -> InputT m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputT m String -> InputT m String
forall (m :: * -> *) a. MonadIO m => InputT m a -> InputT m a
clearedInput (InputT m String -> InputT m String)
-> (String -> InputT m String) -> String -> InputT m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> InputT m String
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m String
getPromptLine (String -> m Bool) -> String -> m Bool
forall a b. (a -> b) -> a -> b
$
  String
desc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"? " String -> String -> String
forall a. [a] -> [a] -> [a]
++ if Bool
yes then String
"[Y/n]" else String
"[y/N]"
  where
    maybeYN' :: String -> Maybe Bool
maybeYN' String
inp =
      case String -> String
lower String
inp of
        String
"" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
yes
        String
"y" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
        String
"yes" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
        String
"n" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
        String
"no" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
        String
_ ->  Maybe Bool
forall a. Maybe a
Nothing