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)
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
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
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
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
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
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
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)
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
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