{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Summoner.Question
(
choose
, chooseYesNo
, chooseYesNoBool
, YesNoPrompt(..)
, mkDefaultYesNoPrompt
, query
, queryWithPredicate
, queryNotNull
, queryDef
, queryManyRepeatOnFail
, checkUniqueName
, doesExistProjectName
, 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
data YesNoPrompt = YesNoPrompt
{ YesNoPrompt -> Text
yesNoTarget :: !Text
, YesNoPrompt -> Text
yesNoPrompt :: !Text
}
mkDefaultYesNoPrompt
:: Text
-> 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
<> "?")
data Answer
= Y
| N
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
printQuestion
:: Text
-> [Text]
-> 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
choose :: Show a
=> (Text -> Maybe a)
-> Text
-> [a]
-> IO a
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)
chooseYesNo :: YesNoPrompt
-> IO a
-> IO a
-> 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
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)
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
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
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
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
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
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
queryManyRepeatOnFail :: forall a . (Text -> Maybe a) -> IO [a]
queryManyRepeatOnFail :: (Text -> Maybe a) -> IO [a]
queryManyRepeatOnFail parser :: Text -> Maybe a
parser = IO [a]
promptLoop
where
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
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
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
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
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