module Aura.IO where
import Aura.Colour
import Aura.Languages (whitespace, yesNoMessage, yesPattern)
import Aura.Settings
import Aura.Types (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 ss d = putStrA ss $ d <> hardline
putStrA :: MonadIO m => Settings -> Doc AnsiStyle -> m ()
putStrA ss d = B.putStr . encodeUtf8 . dtot $ "aura >>=" <+> colourCheck ss d
colourCheck :: Settings -> Doc ann -> Doc ann
colourCheck ss | shared ss (Colour Never) = unAnnotate
| shared ss (Colour Always) = id
| isTerminal ss = id
| otherwise = unAnnotate
putText :: MonadIO m => Text -> m ()
putText = B.putStr . encodeUtf8
putTextLn :: MonadIO m => Text -> m ()
putTextLn = BL.putStrLn . BL.fromStrict . encodeUtf8
entrify :: Settings -> [Text] -> [Doc AnsiStyle] -> Doc AnsiStyle
entrify ss fs es = vsep $ zipWith combine fs' es
where fs' = padding ss fs
combine f e = annotate bold (pretty f) <+> ":" <+> e
padding :: Settings -> [Text] -> [Text]
padding ss fs = map (T.justifyLeft longest ws) fs
where ws = whitespace $ langOf ss
longest = maximum $ map T.length fs
yesNoPrompt :: Settings -> Doc AnsiStyle -> IO Bool
yesNoPrompt ss msg = do
putStrA ss . yellow $ msg <+> yesNoMessage (langOf ss) <> " "
hFlush stdout
response <- decodeUtf8Lenient <$> B.getLine
pure $ isAffirmative (langOf ss) response
isAffirmative :: Language -> Text -> Bool
isAffirmative l t = T.null t || elem (T.toCaseFold t) (yesPattern l)
optionalPrompt :: Settings -> (Language -> Doc AnsiStyle) -> IO Bool
optionalPrompt ss msg | shared ss NoConfirm = pure True
| otherwise = yesNoPrompt ss (msg $ langOf ss)
withOkay
:: Settings
-> (Language -> Doc AnsiStyle)
-> (Language -> Doc AnsiStyle)
-> RIO e a
-> RIO e a
withOkay ss asking failed f = do
okay <- liftIO $ optionalPrompt ss asking
bool (throwM $ Failure failed) f okay
getSelection :: Foldable f => (a -> Text) -> f a -> IO a
getSelection f choiceLabels = do
let quantity = length choiceLabels
valids = map tshow [1..quantity]
pad = show . length . show $ quantity
choices = zip valids $ toList choiceLabels
traverse_ (\(l,v) -> printf ("%" <> pad <> "s. %s\n") l (f v)) choices
BL.putStr ">> "
hFlush stdout
userChoice <- decodeUtf8Lenient <$> B.getLine
case userChoice `lookup` choices of
Just valid -> pure valid
Nothing -> getSelection f choiceLabels