{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.Init.Prompt
-- Copyright   :  (c) Brent Yorgey 2009
-- License     :  BSD-like
--
-- Maintainer  :  cabal-devel@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- User prompt utility functions for use by the 'cabal init' command.
--
-----------------------------------------------------------------------------

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


-- | Create a prompt with optional default value that returns a
-- String.
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

-- | Create a yes/no prompt with optional default value.
promptYesNo
    :: Interactive m
    => String
      -- ^ prompt message
    -> DefaultPrompt Bool
      -- ^ optional default value
    -> 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"

-- | Create a prompt with optional default value that returns a value
--   of some Text instance.
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

-- | Create a prompt from a prompt string and a String representation
--   of an optional default value.
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
"] "

-- | Create a prompt from a list of strings
promptList
    :: Interactive m
    => String
      -- ^ prompt
    -> [String]
      -- ^ choices
    -> DefaultPrompt String
      -- ^ optional default value
    -> Maybe (String -> String)
      -- ^ modify the default value to present in-prompt
      -- e.g. empty string maps to "(none)", but only in the
      -- prompt.
    -> Bool
      -- ^ whether to allow an 'other' option
    -> 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
":"

  -- Output nicely formatted list of options
  [(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)

-- | Create a prompt with an optional default value.
promptDefault
    :: Interactive m
    => (String -> Either String t)
      -- ^ parser
    -> (t -> String)
      -- ^ pretty-printer
    -> String
      -- ^ prompt message
    -> (DefaultPrompt t)
      -- ^ optional default value
    -> 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)

-- | Prompt utility for breaking out of an interactive loop
-- in the pure case
--
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