IO.hs

-- |
-- Module    : Aura.IO
-- Copyright : (c) Colin Woodbury, 2012 - 2021
-- 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           Prettyprinter
import           Prettyprinter.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 ss d = putStrA ss $ d <> hardline

-- | Will remove all colour annotations if the user specified @--color=never@.
putStrA :: MonadIO m => Settings -> Doc AnsiStyle -> m ()
putStrA ss d = B.putStr . encodeUtf8 . dtot $ "aura >>=" <+> colourCheck ss 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 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

-- | Format two lists into two nice rows a la `-Qi` or `-Si`.
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

-- | Right-pads strings according to the longest string in the group.
padding :: Settings -> [Text] -> [Text]
padding ss fs = map (T.justifyLeft longest ws) fs
  where ws      = whitespace $ langOf ss
        longest = maximum $ map T.length fs

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

-- | An empty response emplies "yes".
isAffirmative :: Language -> Text -> Bool
isAffirmative l t = T.null t || elem (T.toCaseFold t) (yesPattern l)

-- | Doesn't prompt when `--noconfirm` is used.
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 $ FailMsg failed) f okay

-- | Given a number of selections, allows the user to choose one.
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  -- Ask again.