{-# 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, getLine, putStr, putStrLn)

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 = (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 :: forall (m :: * -> *).
Interactive m =>
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 :: forall (m :: * -> *) t.
(Interactive m, Parsec t, Pretty t) =>
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 :: 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
  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 a. [a] -> 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 a. [a] -> 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 a. [a] -> 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 a. [a] -> 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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
input -> String -> m String
forall a. a -> m a
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 a. a -> m a
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. HasCallStack => [a] -> Int -> a
!! (Int
n Int -> 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 :: 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
  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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
input -> t -> m t
forall a. a -> m a
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 a. a -> m a
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 :: forall (m :: * -> *) a. Interactive m => 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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> BreakException -> m a
forall a. 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