{-# 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 :: forall (m :: * -> *).
Interactive m =>
String -> DefaultPrompt String -> m String
promptStr = forall (m :: * -> *) t.
Interactive m =>
(String -> Either String t)
-> (t -> String) -> String -> DefaultPrompt t -> m t
promptDefault forall a b. b -> Either a b
Right 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 :: forall (m :: * -> *).
Interactive m =>
String -> DefaultPrompt Bool -> m Bool
promptYesNo =
    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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
s) forall a. Eq a => a -> a -> Bool
== String
"y" = forall a b. b -> Either a b
Right Bool
True
      | (Char -> Char
toLower forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
s) forall a. Eq a => a -> a -> Bool
== String
"n" Bool -> Bool -> Bool
|| String
s forall a. Eq a => a -> a -> Bool
== String
"N" = forall a b. b -> Either a b
Right Bool
False
      | Bool
otherwise = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Cannot parse input: " 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 :: forall (m :: * -> *) t.
(Interactive m, Parsec t, Pretty t) =>
String -> DefaultPrompt t -> m t
prompt = forall (m :: * -> *) t.
Interactive m =>
(String -> Either String t)
-> (t -> String) -> String -> DefaultPrompt t -> m t
promptDefault forall a. Parsec a => String -> Either String a
eitherParsec 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 forall a. [a] -> [a] -> [a]
++ 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: " forall a. [a] -> [a] -> [a]
++ String
s 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 :: forall (m :: * -> *).
Interactive m =>
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
  forall (m :: * -> *). Interactive m => String -> m ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
msg forall a. [a] -> [a] -> [a]
++ String
":"

  -- Output nicely formatted list of options
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Int, String)]
prettyChoices forall a b. (a -> b) -> a -> b
$ \(Int
i,String
c) -> do
    let star :: String
star = if forall t. t -> DefaultPrompt t
DefaultPrompt String
c forall a. Eq a => a -> a -> Bool
== DefaultPrompt String
def
          then String
"*"
          else String
" "

    let output :: String
output = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ if Int
i forall a. Ord a => a -> a -> Bool
< Int
10
          then [String
" ", String
star, String
" ", forall a. Show a => a -> String
show Int
i, String
") ", String
c]
          else [String
" ", String
star, forall a. Show a => a -> String
show Int
i, String
") ", String
c]

    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 forall a. [a] -> [a] -> [a]
++ [String
"Other (specify)"]
           else [String]
choices
     in forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1::Int .. forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
choices forall a. Num a => a -> a -> a
+ Int
1] [String]
cs

   numChoices :: Int
numChoices = forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
choices

   invalidChoice :: String -> m String
invalidChoice String
input = do
      let msg' :: String
msg' = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
input
            then String
"Empty input is not a valid choice."
            else forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ String
input
              , String
" is not a valid choice. Please choose a number from 1 to "
              , forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, String)]
prettyChoices)
              , String
"."
              ]

      forall (m :: * -> *). Interactive m => String -> m ()
putStrLn String
msg'
      forall (m :: * -> *) a. Interactive m => String -> m a -> m a
breakOrContinue (String
"promptList: " forall a. [a] -> [a] -> [a]
++ String
input) m String
go

   go :: m String
go = do
     forall (m :: * -> *). Interactive m => String -> m ()
putStr
       forall a b. (a -> b) -> a -> b
$ String -> DefaultPrompt String -> String
mkDefPrompt String
"Your choice"
       forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe DefaultPrompt String
def (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefaultPrompt String
def) Maybe (String -> String)
modDef

     String
input <- forall (m :: * -> *). Interactive m => m String
getLine
     case DefaultPrompt String
def of
       DefaultPrompt String
d | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
input -> forall (m :: * -> *) a. Monad m => a -> m a
return String
d
       DefaultPrompt String
_ -> case 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 forall a. Ord a => a -> a -> Bool
> Int
0, Int
n forall a. Ord a => a -> a -> Bool
<= Int
numChoices -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [String]
choices forall a. [a] -> Int -> a
!! (Int
nforall a. Num a => a -> a -> a
-Int
1)
           | Int
n forall a. Eq a => a -> a -> Bool
== Int
numChoices forall a. Num a => a -> a -> a
+ Int
1, Bool
hasOther ->
             forall (m :: * -> *).
Interactive m =>
String -> DefaultPrompt String -> m String
promptStr String
"Please specify" forall t. DefaultPrompt t
OptionalPrompt
           | Bool
otherwise -> String -> m String
invalidChoice (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 :: 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 = do
  forall (m :: * -> *). Interactive m => String -> m ()
putStr forall a b. (a -> b) -> a -> b
$ String -> DefaultPrompt String -> String
mkDefPrompt String
msg (t -> String
pprint forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefaultPrompt t
def)
  forall (m :: * -> *). Interactive m => Handle -> m ()
hFlush Handle
System.IO.stdout
  String
input <- forall (m :: * -> *). Interactive m => m String
getLine
  case DefaultPrompt t
def of
    DefaultPrompt t
d | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
input  -> 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  -> forall (m :: * -> *) a. Monad m => a -> m a
return t
t
      Left String
err -> do
        forall (m :: * -> *). Interactive m => String -> m ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Couldn't parse " forall a. [a] -> [a] -> [a]
++ String
input forall a. [a] -> [a] -> [a]
++ String
", please try again!"
        forall (m :: * -> *) a. Interactive m => String -> m a -> m a
breakOrContinue
          (String
"promptDefault: " forall a. [a] -> [a] -> [a]
++ String
err forall a. [a] -> [a] -> [a]
++ String
" on input: " forall a. [a] -> [a] -> [a]
++ String
input)
          (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 :: forall (m :: * -> *) a. Interactive m => String -> m a -> m a
breakOrContinue String
msg m a
act = forall (m :: * -> *). Interactive m => m Bool
break forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> forall (m :: * -> *) a. Interactive m => BreakException -> m a
throwPrompt forall a b. (a -> b) -> a -> b
$ String -> BreakException
BreakException String
msg
    Bool
False -> m a
act