-- |
-- Module    : Aura.IO
-- Copyright : (c) Colin Woodbury, 2012 - 2020
-- License   : GPL3
-- Maintainer: Colin Woodbury <colin@fosskers.ca>
--
-- User-facing input and output utilities.

module Aura.IO where

import           Aura.Colour
import           Aura.Languages (whitespace, yesNoMessage, yesPattern)
import           Aura.Settings
import           Aura.Types (FailMsg(..), Failure(..), Language)
import           Data.Text.Prettyprint.Doc
import           Data.Text.Prettyprint.Doc.Render.Terminal
import           RIO
import qualified RIO.ByteString as B
import qualified RIO.ByteString.Lazy as BL
import           RIO.List.Partial (maximum)
import qualified RIO.Text as T
import           Text.Printf (printf)

---

----------------
-- CUSTOM OUTPUT
----------------
-- | Print a `Doc` with Aura flair after performing a `colourCheck`.
putStrLnA :: MonadIO m => Settings -> Doc AnsiStyle -> m ()
putStrLnA :: Settings -> Doc AnsiStyle -> m ()
putStrLnA Settings
ss Doc AnsiStyle
d = Settings -> Doc AnsiStyle -> m ()
forall (m :: * -> *).
MonadIO m =>
Settings -> Doc AnsiStyle -> m ()
putStrA Settings
ss (Doc AnsiStyle -> m ()) -> Doc AnsiStyle -> m ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
d Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
hardline

-- | Will remove all colour annotations if the user specified @--color=never@.
putStrA :: MonadIO m => Settings -> Doc AnsiStyle -> m ()
putStrA :: Settings -> Doc AnsiStyle -> m ()
putStrA Settings
ss Doc AnsiStyle
d = ByteString -> m ()
forall (m :: * -> *). MonadIO m => ByteString -> m ()
B.putStr (ByteString -> m ())
-> (Doc AnsiStyle -> ByteString) -> Doc AnsiStyle -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (Doc AnsiStyle -> Text) -> Doc AnsiStyle -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle -> Text
dtot (Doc AnsiStyle -> m ()) -> Doc AnsiStyle -> m ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"aura >>=" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Settings -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Settings -> Doc ann -> Doc ann
colourCheck Settings
ss Doc AnsiStyle
d

-- | Strip colours from a `Doc` if @--color=never@ is specified,
-- or if the output target isn't a terminal.
colourCheck :: Settings -> Doc ann -> Doc ann
colourCheck :: Settings -> Doc ann -> Doc ann
colourCheck Settings
ss | Settings -> CommonSwitch -> Bool
shared Settings
ss (ColourMode -> CommonSwitch
Colour ColourMode
Never)  = Doc ann -> Doc ann
forall ann xxx. Doc ann -> Doc xxx
unAnnotate
               | Settings -> CommonSwitch -> Bool
shared Settings
ss (ColourMode -> CommonSwitch
Colour ColourMode
Always) = Doc ann -> Doc ann
forall a. a -> a
id
               | Settings -> Bool
isTerminal Settings
ss = Doc ann -> Doc ann
forall a. a -> a
id
               | Bool
otherwise = Doc ann -> Doc ann
forall ann xxx. Doc ann -> Doc xxx
unAnnotate

putText :: MonadIO m => Text -> m ()
putText :: Text -> m ()
putText = ByteString -> m ()
forall (m :: * -> *). MonadIO m => ByteString -> m ()
B.putStr (ByteString -> m ()) -> (Text -> ByteString) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8

putTextLn :: MonadIO m => Text -> m ()
putTextLn :: Text -> m ()
putTextLn = LByteString -> m ()
forall (m :: * -> *). MonadIO m => LByteString -> m ()
BL.putStrLn (LByteString -> m ()) -> (Text -> LByteString) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> LByteString
BL.fromStrict (ByteString -> LByteString)
-> (Text -> ByteString) -> Text -> LByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8

-- | Format two lists into two nice rows a la `-Qi` or `-Si`.
entrify :: Settings -> [Text] -> [Doc AnsiStyle] -> Doc AnsiStyle
entrify :: Settings -> [Text] -> [Doc AnsiStyle] -> Doc AnsiStyle
entrify Settings
ss [Text]
fs [Doc AnsiStyle]
es = [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vsep ([Doc AnsiStyle] -> Doc AnsiStyle)
-> [Doc AnsiStyle] -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ (Text -> Doc AnsiStyle -> Doc AnsiStyle)
-> [Text] -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Text -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Pretty a => a -> Doc AnsiStyle -> Doc AnsiStyle
combine [Text]
fs' [Doc AnsiStyle]
es
  where fs' :: [Text]
fs' = Settings -> [Text] -> [Text]
padding Settings
ss [Text]
fs
        combine :: a -> Doc AnsiStyle -> Doc AnsiStyle
combine a
f Doc AnsiStyle
e = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate AnsiStyle
bold (a -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty a
f) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
":" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
e

-- | Right-pads strings according to the longest string in the group.
padding :: Settings -> [Text] -> [Text]
padding :: Settings -> [Text] -> [Text]
padding Settings
ss [Text]
fs = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char -> Text -> Text
T.justifyLeft Int
longest Char
ws) [Text]
fs
  where ws :: Char
ws      = Language -> Char
whitespace (Language -> Char) -> Language -> Char
forall a b. (a -> b) -> a -> b
$ Settings -> Language
langOf Settings
ss
        longest :: Int
longest = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Text -> Int) -> [Text] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Int
T.length [Text]
fs

----------
-- PROMPTS
----------
yesNoPrompt :: Settings -> Doc AnsiStyle -> IO Bool
yesNoPrompt :: Settings -> Doc AnsiStyle -> IO Bool
yesNoPrompt Settings
ss Doc AnsiStyle
msg = do
  Settings -> Doc AnsiStyle -> IO ()
forall (m :: * -> *).
MonadIO m =>
Settings -> Doc AnsiStyle -> m ()
putStrA Settings
ss (Doc AnsiStyle -> IO ())
-> (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle -> Doc AnsiStyle
yellow (Doc AnsiStyle -> IO ()) -> Doc AnsiStyle -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
msg Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Language -> Doc AnsiStyle
forall ann. Language -> Doc ann
yesNoMessage (Settings -> Language
langOf Settings
ss) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
" "
  Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stdout
  Text
response <- ByteString -> Text
decodeUtf8Lenient (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ByteString
forall (m :: * -> *). MonadIO m => m ByteString
B.getLine
  Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Language -> Text -> Bool
isAffirmative (Settings -> Language
langOf Settings
ss) Text
response

-- | An empty response emplies "yes".
isAffirmative :: Language -> Text -> Bool
isAffirmative :: Language -> Text -> Bool
isAffirmative Language
l Text
t = Text -> Bool
T.null Text
t Bool -> Bool -> Bool
|| Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (Text -> Text
T.toCaseFold Text
t) (Language -> [Text]
yesPattern Language
l)

-- | Doesn't prompt when `--noconfirm` is used.
optionalPrompt :: Settings -> (Language -> Doc AnsiStyle) -> IO Bool
optionalPrompt :: Settings -> (Language -> Doc AnsiStyle) -> IO Bool
optionalPrompt Settings
ss Language -> Doc AnsiStyle
msg | Settings -> CommonSwitch -> Bool
shared Settings
ss CommonSwitch
NoConfirm = Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                      | Bool
otherwise           = Settings -> Doc AnsiStyle -> IO Bool
yesNoPrompt Settings
ss (Language -> Doc AnsiStyle
msg (Language -> Doc AnsiStyle) -> Language -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Settings -> Language
langOf Settings
ss)

withOkay
  :: Settings
  -> (Language -> Doc AnsiStyle)
  -> (Language -> Doc AnsiStyle)
  -> RIO e a
  -> RIO e a
withOkay :: Settings
-> (Language -> Doc AnsiStyle)
-> (Language -> Doc AnsiStyle)
-> RIO e a
-> RIO e a
withOkay Settings
ss Language -> Doc AnsiStyle
asking Language -> Doc AnsiStyle
failed RIO e a
f = do
  Bool
okay <- IO Bool -> RIO e Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RIO e Bool) -> IO Bool -> RIO e Bool
forall a b. (a -> b) -> a -> b
$ Settings -> (Language -> Doc AnsiStyle) -> IO Bool
optionalPrompt Settings
ss Language -> Doc AnsiStyle
asking
  RIO e a -> RIO e a -> Bool -> RIO e a
forall a. a -> a -> Bool -> a
bool (Failure -> RIO e a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Failure -> RIO e a) -> (FailMsg -> Failure) -> FailMsg -> RIO e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FailMsg -> Failure
Failure (FailMsg -> RIO e a) -> FailMsg -> RIO e a
forall a b. (a -> b) -> a -> b
$ (Language -> Doc AnsiStyle) -> FailMsg
FailMsg Language -> Doc AnsiStyle
failed) RIO e a
f Bool
okay

-- | Given a number of selections, allows the user to choose one.
getSelection :: Foldable f => (a -> Text) -> f a -> IO a
getSelection :: (a -> Text) -> f a -> IO a
getSelection a -> Text
f f a
choiceLabels = do
  let quantity :: Int
quantity = f a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length f a
choiceLabels
      valids :: [Text]
valids   = (Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Text
forall a. Show a => a -> Text
tshow [Int
1..Int
quantity]
      pad :: String
pad      = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Int -> Int) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> (Int -> String) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Int
quantity
      choices :: [(Text, a)]
choices  = [Text] -> [a] -> [(Text, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
valids ([a] -> [(Text, a)]) -> [a] -> [(Text, a)]
forall a b. (a -> b) -> a -> b
$ f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f a
choiceLabels
  ((Text, a) -> IO ()) -> [(Text, a)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(Text
l,a
v) -> String -> Text -> Text -> IO ()
forall r. PrintfType r => String -> r
printf (String
"%" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pad String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"s. %s\n") Text
l (a -> Text
f a
v)) [(Text, a)]
choices
  LByteString -> IO ()
forall (m :: * -> *). MonadIO m => LByteString -> m ()
BL.putStr LByteString
">> "
  Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stdout
  Text
userChoice <- ByteString -> Text
decodeUtf8Lenient (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ByteString
forall (m :: * -> *). MonadIO m => m ByteString
B.getLine
  case Text
userChoice Text -> [(Text, a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(Text, a)]
choices of
    Just a
valid -> a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
valid
    Maybe a
Nothing    -> (a -> Text) -> f a -> IO a
forall (f :: * -> *) a. Foldable f => (a -> Text) -> f a -> IO a
getSelection a -> Text
f f a
choiceLabels  -- Ask again.