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 = forall a. IO a -> IO a
withoutProgress forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
runInputT forall (m :: * -> *). MonadIO m => Settings m
defaultSettings forall a b. (a -> b) -> a -> b
$
                    forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
getInputLine String
prompt
                        forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"askUser: unexpected end of input") 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void 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 = forall a. IO a -> IO a
withoutProgress forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
runInputT forall (m :: * -> *). MonadIO m => Settings m
defaultSettings forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *). MonadIO m => String -> InputT m ()
outputStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
n String
x -> forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ 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 <- forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
getInputLine String
prompt
                  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"askUser: unexpected end of input") forall (m :: * -> *) a. Monad m => a -> m a
return
      case forall a. Read a => String -> Maybe a
maybeRead String
answer of
        Just Int
n | Int
n forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
n forall a. Ord a => a -> a -> Bool
<= forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
xs -> forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
xs forall a. [a] -> Int -> a
!! (Int
nforall a. Num a => a -> a -> a
-Int
1))
        Maybe Int
_ -> forall (m :: * -> *). MonadIO m => String -> InputT m ()
outputStrLn String
"Invalid response, try again!" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InputT IO String
loop


maybeRead :: Read a
          => String
          -> Maybe a
maybeRead :: forall a. Read a => String -> Maybe a
maybeRead String
s = case forall a. Read a => ReadS a
reads String
s of
    [(a
x, String
rest)] | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
rest -> forall a. a -> Maybe a
Just a
x
    [(a, String)]
_         -> 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 = (forall a. Eq a => a -> a -> Bool
== Char
'y') 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" [] 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) =
  forall a. IO a -> IO a
withoutProgress forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
runInputT forall (m :: * -> *). MonadIO m => Settings m
defaultSettings InputT IO Char
loopChar
 where
 chs :: String
chs = String
basic_chs forall a. [a] -> [a] -> [a]
++ String
adv_chs
 loopChar :: InputT IO Char
loopChar = do
    let chars :: String
chars = String -> String
setDefault (String
basic_chs forall a. [a] -> [a] -> [a]
++ (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
adv_chs then String
"" else String
"..."))
        prompt :: String
prompt = String
p forall a. [a] -> [a] -> [a]
++ String
" [" forall a. [a] -> [a] -> [a]
++ String
chars forall a. [a] -> [a] -> [a]
++ String
"]" forall a. [a] -> [a] -> [a]
++ String
helpStr
    Char
a <- forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe Char)
getInputChar String
prompt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"promptChar: unexpected end of input") (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
toLower)
    case () of
     ()
_ | Char
a forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
chs                   -> forall (m :: * -> *) a. Monad m => a -> m a
return Char
a
       | Char
a forall a. Eq a => a -> a -> Bool
== Char
' '                       -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe InputT IO Char
tryAgain forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Char
def_ch
       | Char
a forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
help_chs              -> 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
_) | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
adv_chs    -> String
", or " forall a. [a] -> [a] -> [a]
++ (Char
hforall a. a -> [a] -> [a]
:String
" for help: ")
                 | Bool
otherwise       -> String
", or " forall a. [a] -> [a] -> [a]
++ (Char
hforall a. a -> [a] -> [a]
:String
" for more options: ")
 tryAgain :: InputT IO Char
tryAgain = do 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  -> 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 forall a. Eq a => a -> a -> Bool
== Char
c then Char -> Char
toUpper Char
c else Char
c