content: {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE OverloadedStrings #-}
  
  module Test.Smoke.App.Print where
  
  import Control.Monad (unless)
  import Control.Monad.IO.Class (liftIO)
  import Control.Monad.Trans.Reader (ReaderT, ask)
  import Data.Maybe qualified as Maybe
  import Data.String (IsString (..))
  import Data.Text (Text)
  import Data.Text qualified as Text
  import Data.Text.IO qualified as Text.IO
  import System.Console.ANSI
  import System.IO (Handle, stderr, stdout)
  import Test.Smoke (Executable (..), Shell (..))
  import Test.Smoke.App.OptionTypes (AppOptions (..), ColorOutput (..))
  import Test.Smoke.Paths
  
  type Output a = ReaderT AppOptions IO a
  
  outputIndentation :: Int
  outputIndentation = 10
  
  nestedOutputIndentation :: Int
  nestedOutputIndentation = outputIndentation + 2
  
  messageIndentation :: Int
  messageIndentation = 2
  
  showInt :: Int -> Text
  showInt = fromString . show
  
  showPath :: Path p t -> Text
  showPath = quote . Text.pack . toFilePath
  
  showExecutable :: Executable -> Text
  showExecutable (ExecutableProgram executablePath _) =
    "The application " <> showPath executablePath
  showExecutable (ExecutableScript (Shell shellPath _) _) =
    "The shell " <> showPath shellPath
  
  quote :: Text -> Text
  quote text = "\"" <> text <> "\""
  
  quoteString :: String -> Text
  quoteString = quote . fromString
  
  hasEsc :: Text -> Bool
  hasEsc = Maybe.isJust . Text.find (== '\ESC')
  
  spaces :: Int -> Text
  spaces n = Text.replicate n space
  
  space :: Text
  space = " "
  
  newline :: Text
  newline = "\n"
  
  indented :: Int -> Text -> Text
  indented n = Text.unlines . indented' . Text.lines
    where
      indented' [] = []
      indented' (first : rest) = first : map (mappend (spaces n)) rest
  
  indentedAll :: Int -> Text -> Text
  indentedAll n = Text.unlines . map (mappend (spaces n)) . Text.lines
  
  putEmptyLn :: Output ()
  putEmptyLn = liftIO $ putStrLn ""
  
  putPlain :: Text -> Output ()
  putPlain = liftIO . Text.IO.putStr
  
  putPlainLn :: Text -> Output ()
  putPlainLn = hPutStrWithLn stdout
  
  putGreenLn :: Text -> Output ()
  putGreenLn = putColorLn Green
  
  putYellowLn :: Text -> Output ()
  putYellowLn = putColorLn Yellow
  
  putRed :: Text -> Output ()
  putRed = putColor Red
  
  putRedLn :: Text -> Output ()
  putRedLn = putColorLn Red
  
  putColor :: Color -> Text -> Output ()
  putColor color = withColor color putPlain
  
  putColorLn :: Color -> Text -> Output ()
  putColorLn color = withColor color putPlainLn
  
  putError :: Text -> Output ()
  putError = withColor Red $ hPutStrWithLn stderr
  
  hPutStrWithLn :: Handle -> Text -> Output ()
  hPutStrWithLn handle contents = do
    liftIO $ Text.IO.hPutStr handle contents
    unless (newline `Text.isSuffixOf` contents) $
      liftIO $
        Text.IO.hPutStrLn handle ""
  
  withColor :: Color -> (Text -> Output ()) -> Text -> Output ()
  withColor color act contents = do
    options <- ask
    if optionsColor options == Color && not (hasEsc contents)
      then do
        liftIO $ setSGR [SetColor Foreground Dull color]
        act contents
        liftIO $ setSGR [Reset]
      else act contents
  