{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Distribution.Client.Init.Prompt
( prompt
, promptYesNo
, promptStr
, promptList
) where
import Prelude hiding (break, putStrLn, getLine, putStr)
import Distribution.Client.Compat.Prelude hiding (break, empty, getLine, putStr, putStrLn)
import Distribution.Client.Init.Types
import qualified System.IO
promptStr :: Interactive m => String -> DefaultPrompt String -> m String
promptStr :: String -> DefaultPrompt String -> m String
promptStr = (String -> Either String String)
-> (String -> String) -> String -> DefaultPrompt String -> m String
forall (m :: * -> *) t.
Interactive m =>
(String -> Either String t)
-> (t -> String) -> String -> DefaultPrompt t -> m t
promptDefault String -> Either String String
forall a b. b -> Either a b
Right String -> String
forall a. a -> a
id
promptYesNo
:: Interactive m
=> String
-> DefaultPrompt Bool
-> m Bool
promptYesNo :: String -> DefaultPrompt Bool -> m Bool
promptYesNo =
(String -> Either String Bool)
-> (Bool -> String) -> String -> DefaultPrompt Bool -> m Bool
forall (m :: * -> *) t.
Interactive m =>
(String -> Either String t)
-> (t -> String) -> String -> DefaultPrompt t -> m t
promptDefault String -> Either String Bool
recogniseYesNo Bool -> String
showYesNo
where
recogniseYesNo :: String -> Either String Bool
recogniseYesNo String
s
| (Char -> Char
toLower (Char -> Char) -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
s) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"y" = Bool -> Either String Bool
forall a b. b -> Either a b
Right Bool
True
| (Char -> Char
toLower (Char -> Char) -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
s) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"n" Bool -> Bool -> Bool
|| String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"N" = Bool -> Either String Bool
forall a b. b -> Either a b
Right Bool
False
| Bool
otherwise = String -> Either String Bool
forall a b. a -> Either a b
Left (String -> Either String Bool) -> String -> Either String Bool
forall a b. (a -> b) -> a -> b
$ String
"Cannot parse input: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
showYesNo :: Bool -> String
showYesNo Bool
True = String
"y"
showYesNo Bool
False = String
"n"
prompt :: (Interactive m, Parsec t, Pretty t) => String -> DefaultPrompt t -> m t
prompt :: String -> DefaultPrompt t -> m t
prompt = (String -> Either String t)
-> (t -> String) -> String -> DefaultPrompt t -> m t
forall (m :: * -> *) t.
Interactive m =>
(String -> Either String t)
-> (t -> String) -> String -> DefaultPrompt t -> m t
promptDefault String -> Either String t
forall a. Parsec a => String -> Either String a
eitherParsec t -> String
forall a. Pretty a => a -> String
prettyShow
mkDefPrompt :: String -> DefaultPrompt String -> String
mkDefPrompt :: String -> DefaultPrompt String -> String
mkDefPrompt String
msg DefaultPrompt String
def = String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"?" String -> String -> String
forall a. [a] -> [a] -> [a]
++ DefaultPrompt String -> String
format DefaultPrompt String
def
where
format :: DefaultPrompt String -> String
format DefaultPrompt String
MandatoryPrompt = String
" "
format DefaultPrompt String
OptionalPrompt = String
" [optional] "
format (DefaultPrompt String
s) = String
" [default: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"] "
promptList
:: Interactive m
=> String
-> [String]
-> DefaultPrompt String
-> Maybe (String -> String)
-> Bool
-> m String
promptList :: String
-> [String]
-> DefaultPrompt String
-> Maybe (String -> String)
-> Bool
-> m String
promptList String
msg [String]
choices DefaultPrompt String
def Maybe (String -> String)
modDef Bool
hasOther = do
String -> m ()
forall (m :: * -> *). Interactive m => String -> m ()
putStrLn (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
[(Int, String)] -> ((Int, String) -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Int, String)]
prettyChoices (((Int, String) -> m ()) -> m ())
-> ((Int, String) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(Int
i,String
c) -> do
let star :: String
star = if String -> DefaultPrompt String
forall t. t -> DefaultPrompt t
DefaultPrompt String
c DefaultPrompt String -> DefaultPrompt String -> Bool
forall a. Eq a => a -> a -> Bool
== DefaultPrompt String
def
then String
"*"
else String
" "
let output :: String
output = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10
then [String
" ", String
star, String
" ", Int -> String
forall a. Show a => a -> String
show Int
i, String
") ", String
c]
else [String
" ", String
star, Int -> String
forall a. Show a => a -> String
show Int
i, String
") ", String
c]
String -> m ()
forall (m :: * -> *). Interactive m => String -> m ()
putStrLn String
output
m String
go
where
prettyChoices :: [(Int, String)]
prettyChoices =
let cs :: [String]
cs = if Bool
hasOther
then [String]
choices [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"Other (specify)"]
else [String]
choices
in [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1::Int .. [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
choices Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1] [String]
cs
numChoices :: Int
numChoices = [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
choices
invalidChoice :: String -> m String
invalidChoice String
input = do
let msg' :: String
msg' = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
input
then String
"Empty input is not a valid choice."
else [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
input
, String
" is not a valid choice. Please choose a number from 1 to "
, Int -> String
forall a. Show a => a -> String
show ([(Int, String)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, String)]
prettyChoices)
, String
"."
]
String -> m ()
forall (m :: * -> *). Interactive m => String -> m ()
putStrLn String
msg'
String -> m String -> m String
forall (m :: * -> *) a. Interactive m => String -> m a -> m a
breakOrContinue (String
"promptList: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
input) m String
go
go :: m String
go = do
String -> m ()
forall (m :: * -> *). Interactive m => String -> m ()
putStr
(String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String -> DefaultPrompt String -> String
mkDefPrompt String
"Your choice"
(DefaultPrompt String -> String) -> DefaultPrompt String -> String
forall a b. (a -> b) -> a -> b
$ DefaultPrompt String
-> ((String -> String) -> DefaultPrompt String)
-> Maybe (String -> String)
-> DefaultPrompt String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DefaultPrompt String
def ((String -> String) -> DefaultPrompt String -> DefaultPrompt String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefaultPrompt String
def) Maybe (String -> String)
modDef
String
input <- m String
forall (m :: * -> *). Interactive m => m String
getLine
case DefaultPrompt String
def of
DefaultPrompt String
d | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
input -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
d
DefaultPrompt String
_ -> case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
input of
Maybe Int
Nothing -> String -> m String
invalidChoice String
input
Just Int
n
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0, Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
numChoices -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ [String]
choices [String] -> Int -> String
forall a. [a] -> Int -> a
!! (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
numChoices Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Bool
hasOther ->
String -> DefaultPrompt String -> m String
forall (m :: * -> *).
Interactive m =>
String -> DefaultPrompt String -> m String
promptStr String
"Please specify" DefaultPrompt String
forall t. DefaultPrompt t
OptionalPrompt
| Bool
otherwise -> String -> m String
invalidChoice (Int -> String
forall a. Show a => a -> String
show Int
n)
promptDefault
:: Interactive m
=> (String -> Either String t)
-> (t -> String)
-> String
-> (DefaultPrompt t)
-> m t
promptDefault :: (String -> Either String t)
-> (t -> String) -> String -> DefaultPrompt t -> m t
promptDefault String -> Either String t
parse t -> String
pprint String
msg DefaultPrompt t
def = do
String -> m ()
forall (m :: * -> *). Interactive m => String -> m ()
putStr (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String -> DefaultPrompt String -> String
mkDefPrompt String
msg (t -> String
pprint (t -> String) -> DefaultPrompt t -> DefaultPrompt String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefaultPrompt t
def)
Handle -> m ()
forall (m :: * -> *). Interactive m => Handle -> m ()
hFlush Handle
System.IO.stdout
String
input <- m String
forall (m :: * -> *). Interactive m => m String
getLine
case DefaultPrompt t
def of
DefaultPrompt t
d | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
input -> t -> m t
forall (m :: * -> *) a. Monad m => a -> m a
return t
d
DefaultPrompt t
_ -> case String -> Either String t
parse String
input of
Right t
t -> t -> m t
forall (m :: * -> *) a. Monad m => a -> m a
return t
t
Left String
err -> do
String -> m ()
forall (m :: * -> *). Interactive m => String -> m ()
putStrLn (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Couldn't parse " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
input String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", please try again!"
String -> m t -> m t
forall (m :: * -> *) a. Interactive m => String -> m a -> m a
breakOrContinue
(String
"promptDefault: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" on input: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
input)
((String -> Either String t)
-> (t -> String) -> String -> DefaultPrompt t -> m t
forall (m :: * -> *) t.
Interactive m =>
(String -> Either String t)
-> (t -> String) -> String -> DefaultPrompt t -> m t
promptDefault String -> Either String t
parse t -> String
pprint String
msg DefaultPrompt t
def)
breakOrContinue :: Interactive m => String -> m a -> m a
breakOrContinue :: String -> m a -> m a
breakOrContinue String
msg m a
act = m Bool
forall (m :: * -> *). Interactive m => m Bool
break m Bool -> (Bool -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> BreakException -> m a
forall (m :: * -> *) a. Interactive m => BreakException -> m a
throwPrompt (BreakException -> m a) -> BreakException -> m a
forall a b. (a -> b) -> a -> b
$ String -> BreakException
BreakException String
msg
Bool
False -> m a
act