module Darcs.Util.Prompt
    (
    -- * User prompts
      askEnter
    , askUser
    , askUserListItem
    , PromptConfig(..)
    , promptYorn
    , promptChar
    ) where


import Darcs.Prelude

import Control.Monad ( void )
import Control.Monad.Trans ( liftIO )

import Data.Char ( toUpper, toLower, isSpace )

import System.Console.Haskeline ( runInputT, defaultSettings, getInputLine,
                                  getInputChar, outputStr, outputStrLn )

import Darcs.Util.Progress ( withoutProgress )

-- | Ask the user for a line of input.
askUser :: String    -- ^ The prompt to display
        -> IO String -- ^ The string the user entered.
askUser :: String -> IO String
askUser String
prompt = IO String -> IO String
forall a. IO a -> IO a
withoutProgress (IO String -> IO String) -> IO String -> IO String
forall a b. (a -> b) -> a -> b
$ Settings IO -> InputT IO String -> IO String
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
runInputT Settings IO
forall (m :: * -> *). MonadIO m => Settings m
defaultSettings (InputT IO String -> IO String) -> InputT IO String -> IO String
forall a b. (a -> b) -> a -> b
$
                    String -> InputT IO (Maybe String)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
getInputLine String
prompt
                        InputT IO (Maybe String)
-> (Maybe String -> InputT IO String) -> InputT IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InputT IO String
-> (String -> InputT IO String) -> Maybe String -> InputT IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO String -> InputT IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> InputT IO String) -> IO String -> InputT IO String
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"askUser: unexpected end of input") String -> InputT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Ask the user to press Enter
askEnter :: String  -- ^ The prompt to display
         -> IO ()
askEnter :: String -> IO ()
askEnter String
prompt = IO String -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
askUser String
prompt

-- | @askUserListItem prompt xs@ enumerates @xs@ on the screen, allowing
--   the user to choose one of the items
askUserListItem :: String
                -> [String]
                -> IO String
askUserListItem :: String -> [String] -> IO String
askUserListItem String
prompt [String]
xs = IO String -> IO String
forall a. IO a -> IO a
withoutProgress (IO String -> IO String) -> IO String -> IO String
forall a b. (a -> b) -> a -> b
$ Settings IO -> InputT IO String -> IO String
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
runInputT Settings IO
forall (m :: * -> *). MonadIO m => Settings m
defaultSettings (InputT IO String -> IO String) -> InputT IO String -> IO String
forall a b. (a -> b) -> a -> b
$ do
    String -> InputT IO ()
forall (m :: * -> *). MonadIO m => String -> InputT m ()
outputStr (String -> InputT IO ())
-> ([String] -> String) -> [String] -> InputT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> InputT IO ()) -> [String] -> InputT IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> String -> String) -> [Int] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
n String
x -> Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x) [Int
1::Int ..] [String]
xs
    InputT IO String
loop
  where
    loop :: InputT IO String
loop = do
      String
answer <- String -> InputT IO (Maybe String)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
getInputLine String
prompt
                  InputT IO (Maybe String)
-> (Maybe String -> InputT IO String) -> InputT IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InputT IO String
-> (String -> InputT IO String) -> Maybe String -> InputT IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO String -> InputT IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> InputT IO String) -> IO String -> InputT IO String
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"askUser: unexpected end of input") String -> InputT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return
      case String -> Maybe Int
forall a. Read a => String -> Maybe a
maybeRead String
answer of
        Just Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
xs -> String -> InputT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
xs [String] -> Int -> String
forall a. [a] -> Int -> a
!! (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1))
        Maybe Int
_ -> String -> InputT IO ()
forall (m :: * -> *). MonadIO m => String -> InputT m ()
outputStrLn String
"Invalid response, try again!" InputT IO () -> InputT IO String -> InputT IO String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InputT IO String
loop


maybeRead :: Read a
          => String
          -> Maybe a
maybeRead :: String -> Maybe a
maybeRead String
s = case ReadS a
forall a. Read a => ReadS a
reads String
s of
    [(a
x, String
rest)] | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
rest -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
    [(a, String)]
_         -> Maybe a
forall a. Maybe a
Nothing


data PromptConfig = PromptConfig { PromptConfig -> String
pPrompt :: String
                                 , PromptConfig -> String
pBasicCharacters :: [Char]
                                 , PromptConfig -> String
pAdvancedCharacters :: [Char] -- ^ only shown on help
                                 , PromptConfig -> Maybe Char
pDefault :: Maybe Char
                                 , PromptConfig -> String
pHelp    :: [Char]
                                 }


-- | Prompt the user for a yes or no
promptYorn :: String -> IO Bool
promptYorn :: String -> IO Bool
promptYorn String
p = (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'y') (Char -> Bool) -> IO Char -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` PromptConfig -> IO Char
promptChar (String -> String -> String -> Maybe Char -> String -> PromptConfig
PromptConfig String
p String
"yn" [] Maybe Char
forall a. Maybe a
Nothing [])


-- | Prompt the user for a character, among a list of possible ones.
--   Always returns a lowercase character. This is because the default
--   character (ie, the character shown in uppercase, that is automatically
--   selected when the user presses the space bar) is shown as uppercase,
--   hence users may want to enter it as uppercase.
promptChar :: PromptConfig -> IO Char
promptChar :: PromptConfig -> IO Char
promptChar (PromptConfig String
p String
basic_chs String
adv_chs Maybe Char
def_ch String
help_chs) =
  IO Char -> IO Char
forall a. IO a -> IO a
withoutProgress (IO Char -> IO Char) -> IO Char -> IO Char
forall a b. (a -> b) -> a -> b
$ Settings IO -> InputT IO Char -> IO Char
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
runInputT Settings IO
forall (m :: * -> *). MonadIO m => Settings m
defaultSettings InputT IO Char
loopChar
 where
 chs :: String
chs = String
basic_chs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
adv_chs
 loopChar :: InputT IO Char
loopChar = do
    let chars :: String
chars = String -> String
setDefault (String
basic_chs String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
adv_chs then String
"" else String
"..."))
        prompt :: String
prompt = String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
chars String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
helpStr
    Char
a <- String -> InputT IO (Maybe Char)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe Char)
getInputChar String
prompt InputT IO (Maybe Char)
-> (Maybe Char -> InputT IO Char) -> InputT IO Char
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InputT IO Char
-> (Char -> InputT IO Char) -> Maybe Char -> InputT IO Char
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO Char -> InputT IO Char
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Char -> InputT IO Char) -> IO Char -> InputT IO Char
forall a b. (a -> b) -> a -> b
$ String -> IO Char
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"promptChar: unexpected end of input") (Char -> InputT IO Char
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> InputT IO Char)
-> (Char -> Char) -> Char -> InputT IO Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
toLower)
    case () of
     ()
_ | Char
a Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
chs                   -> Char -> InputT IO Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
a
       | Char
a Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '                       -> InputT IO Char
-> (Char -> InputT IO Char) -> Maybe Char -> InputT IO Char
forall b a. b -> (a -> b) -> Maybe a -> b
maybe InputT IO Char
tryAgain Char -> InputT IO Char
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Char
def_ch
       | Char
a Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
help_chs              -> Char -> InputT IO Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
a
       | Bool
otherwise                      -> InputT IO Char
tryAgain
 helpStr :: String
helpStr = case String
help_chs of
           []                      -> String
""
           (Char
h:String
_) | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
adv_chs    -> String
", or " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char
hChar -> String -> String
forall a. a -> [a] -> [a]
:String
" for help: ")
                 | Bool
otherwise       -> String
", or " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char
hChar -> String -> String
forall a. a -> [a] -> [a]
:String
" for more options: ")
 tryAgain :: InputT IO Char
tryAgain = do String -> InputT IO ()
forall (m :: * -> *). MonadIO m => String -> InputT m ()
outputStrLn String
"Invalid response, try again!"
               InputT IO Char
loopChar
 setDefault :: String -> String
setDefault String
s = case Maybe Char
def_ch of Maybe Char
Nothing -> String
s
                               Just Char
d  -> (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (Char -> Char -> Char
setUpper Char
d) String
s
 setUpper :: Char -> Char -> Char
setUpper Char
d Char
c = if Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c then Char -> Char
toUpper Char
c else Char
c