{-# LANGUAGE MultiWayIf   #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

{- |
Copyright: (c) 2017-2019 Kowainik
SPDX-License-Identifier: MPL-2.0
Maintainer: Kowainik <xrom.xkov@gmail.com>

This module contains function to proper questioning in terminal.
-}

module Summoner.Question
       ( -- * Choose functions.
         choose
       , chooseYesNo
       , chooseYesNoBool

         -- * YesNoPrompt
       , YesNoPrompt(..)
       , mkDefaultYesNoPrompt

         -- * Queries
       , query
       , queryWithPredicate
       , queryNotNull
       , queryDef
       , queryManyRepeatOnFail
       , checkUniqueName
       , doesExistProjectName

         -- * Customize target message
       , targetMessageWithText
       , targetMessage
       , trueMessage
       , falseMessage
       ) where

import Colourista (bold, cyan, formatWith, formattedMessage, green, italic)
import System.Directory (doesPathExist, getCurrentDirectory)
import System.FilePath ((</>))

import Summoner.Ansi (boldDefault, errorMessage, prompt, putStrFlush, warningMessage)
import Summoner.Text (headToUpper, intercalateMap)

import qualified Data.Text as T
import qualified Relude.Unsafe as Unsafe


{- HLINT ignore "Redundant multi-way if" -}

{- | Build a prompt

For example,

@
YesNoPrompt
  { yesNoTarget = "Cabal"
  , yesNoPrompt = "Do you want to add a cabal integration?"}
@

will generate a following prompt message to the user

@
Do you want to add a cabal integration? [y]/n
 -> y
[Cabal] will be added to the project
@

-}
data YesNoPrompt = YesNoPrompt
    { YesNoPrompt -> Text
yesNoTarget :: !Text -- ^ target (e.g., __TARGET will be added to the project__)
    , YesNoPrompt -> Text
yesNoPrompt :: !Text -- ^ prompt (e.g., __PROMPT [y]/n__)
    }

{- | Build a prompt with the TARGET name only

It will generate a simple default prompt such that

@
Add TARGET? [y]/n
@

-}
mkDefaultYesNoPrompt
    :: Text -- ^ target name
    -> YesNoPrompt
mkDefaultYesNoPrompt :: Text -> YesNoPrompt
mkDefaultYesNoPrompt target :: Text
target = Text -> Text -> YesNoPrompt
YesNoPrompt Text
target ("Add " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
target Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "?")

-- | Represents a user's answer
data Answer
    = Y
    | N

-- | Parse an answer to 'Answer'
yesOrNo :: Text -> Maybe Answer
yesOrNo :: Text -> Maybe Answer
yesOrNo (Text -> Text
T.toLower -> Text
answer )
    | Text -> Bool
T.null Text
answer = Answer -> Maybe Answer
forall a. a -> Maybe a
Just Answer
Y
    | Text
answer Text -> [Text] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` ["yes", "y", "ys"] = Answer -> Maybe Answer
forall a. a -> Maybe a
Just Answer
Y
    | Text
answer Text -> [Text] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` ["no", "n"]  = Answer -> Maybe Answer
forall a. a -> Maybe a
Just Answer
N
    | Bool
otherwise = Maybe Answer
forall a. Maybe a
Nothing

----------------------------------------------------------------------------
-- IO Questioning
----------------------------------------------------------------------------

{- | Prints the given question in the following way:

>>> printQuestion "Which option?" [A, B, C]
"Which option? [A]/B/C"

__ Note__ that the first element in the given list is considered as
the default one.
-}
printQuestion
    :: Text    -- ^ Question text.
    -> [Text]  -- ^ List of available answers.
    -> IO ()
printQuestion :: Text -> [Text] -> IO ()
printQuestion question :: Text
question [] = Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn Text
question
printQuestion question :: Text
question (def :: Text
def:rest :: [Text]
rest) = do
    Text -> IO ()
putStrFlush (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
question Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
boldDefault Text
def
    let restSlash :: Text
restSlash = Text -> [Text] -> Text
T.intercalate "/" [Text]
rest
    if Text
restSlash Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== ""
    then Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn ""
    else Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ "/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
restSlash

-- | Allows users to choose one of the given options.
-- It asks the question until the appropriate answer is received.
choose :: Show a
    => (Text -> Maybe a)  -- ^ Parse function
    -> Text  -- ^ Question text.
    -> [a]   -- ^ List of available options.
    -> IO a  -- ^ The chosen option.
choose :: (Text -> Maybe a) -> Text -> [a] -> IO a
choose parser :: Text -> Maybe a
parser question :: Text
question choices :: [a]
choices = do
    let showChoices :: [Text]
showChoices = (a -> Text) -> [a] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map a -> Text
forall b a. (Show a, IsString b) => a -> b
show [a]
choices
    Text -> [Text] -> IO ()
printQuestion Text
question [Text]
showChoices
    Text
answer <- IO Text
prompt
    if Text -> Bool
T.null Text
answer
        then a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> a
forall a. [a] -> a
Unsafe.head [a]
choices)
        else Maybe a -> IO a -> IO a
forall (f :: * -> *) a. Applicative f => Maybe a -> f a -> f a
whenNothing (Text -> Maybe a
parser Text
answer)
                (Text -> IO ()
errorMessage "This wasn't a valid choice." IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Text -> Maybe a) -> Text -> [a] -> IO a
forall a. Show a => (Text -> Maybe a) -> Text -> [a] -> IO a
choose Text -> Maybe a
parser Text
question [a]
choices)

-- | Like 'choose' but the possible answer are 'Y' or 'N'.
chooseYesNo :: YesNoPrompt -- ^ Target and Prompt
            -> IO a -- ^ action for 'Y' answer
            -> IO a -- ^ action for 'N' answer
            -> IO a
chooseYesNo :: YesNoPrompt -> IO a -> IO a -> IO a
chooseYesNo p :: YesNoPrompt
p@YesNoPrompt {..} yesDo :: IO a
yesDo noDo :: IO a
noDo = do
    Text -> [Text] -> IO ()
printQuestion Text
yesNoPrompt ["y", "n"]
    Maybe Answer
answer <- Text -> Maybe Answer
yesOrNo (Text -> Maybe Answer) -> IO Text -> IO (Maybe Answer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Text
prompt
    case Maybe Answer
answer of
        Nothing -> do
           Text -> IO ()
errorMessage "This wasn't a valid choice."
           YesNoPrompt -> IO a -> IO a -> IO a
forall a. YesNoPrompt -> IO a -> IO a -> IO a
chooseYesNo YesNoPrompt
p IO a
yesDo IO a
noDo
        Just Y -> Text -> IO Bool
trueMessage Text
yesNoTarget IO Bool -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
yesDo
        Just N -> Text -> IO Bool
falseMessage Text
yesNoTarget IO Bool -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
noDo

-- | Like 'chooseYesNo' but returns 'Bool'.
chooseYesNoBool :: YesNoPrompt -> IO Bool
chooseYesNoBool :: YesNoPrompt -> IO Bool
chooseYesNoBool ynPrompt :: YesNoPrompt
ynPrompt = YesNoPrompt -> IO Bool -> IO Bool -> IO Bool
forall a. YesNoPrompt -> IO a -> IO a -> IO a
chooseYesNo YesNoPrompt
ynPrompt (Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) (Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)

{- | The message after yes/no questions. The output depends on the answer.

@
  __Benchmarks__ will be added to the project
@
-}
targetMessageWithText :: Bool -> Text -> Text -> IO Bool
targetMessageWithText :: Bool -> Text -> Text -> IO Bool
targetMessageWithText result :: Bool
result target :: Text
target text :: Text
text = do
    let (color :: Text
color, actionResult :: Text
actionResult) = if Bool
result
          then (Text
forall str. IsString str => str
green, " will be "  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text)
          else (Text
forall str. IsString str => str
cyan,  " won't be " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text)

    Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ [Text] -> Text -> Text
forall str. (IsString str, Semigroup str) => [str] -> str -> str
formatWith [Text
forall str. IsString str => str
italic, Text
forall str. IsString str => str
bold, Text
color] (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ "  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
headToUpper Text
target
            , [Text] -> Text -> Text
forall str. (IsString str, Semigroup str) => [str] -> str -> str
formatWith [Text
color] Text
actionResult
            ]
    Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
result

-- | Like 'targetMessageWithText' but the text is "added to the project"
targetMessage :: Bool -> Text -> IO Bool
targetMessage :: Bool -> Text -> IO Bool
targetMessage result :: Bool
result target :: Text
target = Bool -> Text -> Text -> IO Bool
targetMessageWithText Bool
result Text
target "added to the project"

trueMessage, falseMessage :: Text -> IO Bool
trueMessage :: Text -> IO Bool
trueMessage  = Bool -> Text -> IO Bool
targetMessage Bool
True
falseMessage :: Text -> IO Bool
falseMessage = Bool -> Text -> IO Bool
targetMessage Bool
False


{- | Queries for any answer.

@
  Short project description:
  ->
@
-}
query :: Text -> IO Text
query :: Text -> IO Text
query question :: Text
question = Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn Text
question IO () -> IO Text -> IO Text
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO Text
prompt

{- | Queries for the answer that should satisfy the given predicate, or be empty.
-}
queryWithPredicate :: Text -> [Text] -> Text -> (Text -> Bool) -> IO Text
queryWithPredicate :: Text -> [Text] -> Text -> (Text -> Bool) -> IO Text
queryWithPredicate question :: Text
question options :: [Text]
options instruction :: Text
instruction p :: Text -> Bool
p = IO Text
loop
  where
    loop :: IO Text
    loop :: IO Text
loop = do
        Text -> [Text] -> IO ()
printQuestion Text
question [Text]
options
        [Text] -> Text -> IO ()
formattedMessage [Text
forall str. IsString str => str
italic] Text
instruction
        Text
input <- IO Text
prompt
        if Text
input Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= "" Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Bool
p Text
input)
        then Text -> IO ()
errorMessage ("'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
input Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "' doesn't satisfy the requirements.") IO () -> IO Text -> IO Text
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO Text
loop
        else Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
input


-- | Queries for an non-empty answer.
queryNotNull :: Text -> IO Text
queryNotNull :: Text -> IO Text
queryNotNull question :: Text
question = do
    Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn Text
question
    Text
answer <- IO Text
prompt
    if | Text -> Bool
T.null Text
answer -> do
           Text -> IO ()
errorMessage "An answer is required."
           Text -> IO Text
queryNotNull Text
question
       | Bool
otherwise -> Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
answer

-- | Like 'query' but has the default answer if no answer is specified.
queryDef :: Text -> Text -> IO Text
queryDef :: Text -> Text -> IO Text
queryDef question :: Text
question defAnswer :: Text
defAnswer = do
    Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
question Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
boldDefault Text
defAnswer
    Text
answer <- IO Text
prompt
    if | Text -> Bool
T.null Text
answer -> Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
defAnswer
       | Bool
otherwise     -> Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
answer

-- | Queries many answers. If answers are not parsable shows the failing part
-- and queries again
queryManyRepeatOnFail :: forall a . (Text -> Maybe a) -> IO [a]
queryManyRepeatOnFail :: (Text -> Maybe a) -> IO [a]
queryManyRepeatOnFail parser :: Text -> Maybe a
parser = IO [a]
promptLoop
  where
    -- TODO: probably a good idea to use 'Validation' here to simplify code
    promptLoop :: IO [a]
    promptLoop :: IO [a]
promptLoop = do
        Text
answer <- IO Text
prompt
        let answers :: [(Text, Maybe a)]
answers = (Text -> (Text, Maybe a)) -> [Text] -> [(Text, Maybe a)]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
forall a. a -> a
id (Text -> Text) -> (Text -> Maybe a) -> Text -> (Text, Maybe a)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Text -> Maybe a
parser) ([Text] -> [(Text, Maybe a)]) -> [Text] -> [(Text, Maybe a)]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
forall t. IsText t "words" => t -> [t]
words Text
answer  -- converts [Text] into [(Text, Maybe a)]
        case [(Text, Maybe a)] -> Either [Text] [a]
forall x y. [(x, Maybe y)] -> Either [x] [y]
partitionPairs [(Text, Maybe a)]
answers of
            Left unparsed :: [Text]
unparsed -> do
                -- TODO: create intercalateMap function
                Text -> IO ()
errorMessage (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ "Unable to parse the following items: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (Text -> Text) -> [Text] -> Text
forall a. Text -> (a -> Text) -> [a] -> Text
intercalateMap " " Text -> Text
quote [Text]
unparsed
                IO [a]
promptLoop
            Right results :: [a]
results -> [a] -> IO [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
results

    -- puts only those @c@ into Left list where snd is Nothing;
    -- returns Left if at least one second element is Nothing
    partitionPairs :: forall x y . [(x, Maybe y)] -> Either [x] [y]
    partitionPairs :: [(x, Maybe y)] -> Either [x] [y]
partitionPairs [] = [y] -> Either [x] [y]
forall a b. b -> Either a b
Right []
    partitionPairs ((x :: x
x, my :: Maybe y
my):xs :: [(x, Maybe y)]
xs) = case Maybe y
my of
        Just y :: y
y -> (y
yy -> [y] -> [y]
forall a. a -> [a] -> [a]
:) ([y] -> [y]) -> Either [x] [y] -> Either [x] [y]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(x, Maybe y)] -> Either [x] [y]
forall x y. [(x, Maybe y)] -> Either [x] [y]
partitionPairs [(x, Maybe y)]
xs
        Nothing -> case [(x, Maybe y)] -> Either [x] [y]
forall x y. [(x, Maybe y)] -> Either [x] [y]
partitionPairs [(x, Maybe y)]
xs of
            Left fails :: [x]
fails -> [x] -> Either [x] [y]
forall a b. a -> Either a b
Left (x
x x -> [x] -> [x]
forall a. a -> [a] -> [a]
: [x]
fails)
            Right _    -> [x] -> Either [x] [y]
forall a b. a -> Either a b
Left [x
x]

    quote :: Text -> Text
    quote :: Text -> Text
quote t :: Text
t = "'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "'"

checkUniqueName :: Text -> IO Text
checkUniqueName :: Text -> IO Text
checkUniqueName nm :: Text
nm = do
    Bool
exist <- Text -> IO Bool
doesExistProjectName Text
nm
    if Bool
exist then do
        Text -> IO ()
warningMessage "Project with this name is already exist. Please choose another one"
        Text
newNm <- Text -> IO Text
queryNotNull "Project name: "
        Text -> IO Text
checkUniqueName Text
newNm
    else
        Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
nm

-- | Check if the folder with the suggested project name is already exist.
doesExistProjectName :: Text -> IO Bool
doesExistProjectName :: Text -> IO Bool
doesExistProjectName projectName :: Text
projectName = do
    FilePath
curPath <- IO FilePath
getCurrentDirectory
    FilePath -> IO Bool
doesPathExist (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath
curPath FilePath -> FilePath -> FilePath
</> Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
projectName