module Darcs.Util.Prompt
(
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 )
askUser :: String
-> IO String
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
askEnter :: String
-> 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 :: 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]
, PromptConfig -> Maybe Char
pDefault :: Maybe Char
, PromptConfig -> String
pHelp :: [Char]
}
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 [])
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