    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE OverloadedStrings #-}

    -- | An abstraction for colorful output in terminal.
    module Ormolu.Terminal
      ( -- * The 'Term' abstraction
        Term,
        ColorMode (..),
        runTerm,
        runTermPure,

        -- * Styling
        bold,
        cyan,
        green,
        red,

        -- * Printing
        put,
        putShow,
        putOutputable,
        newline,
      )
    where

    import Control.Applicative (Const (..))
    import Control.Monad (forM_)
    import Data.Foldable (toList)
    import Data.Sequence (Seq)
    import Data.Sequence qualified as Seq
    import Data.Text (Text)
    import Data.Text qualified as T
    import Data.Text.IO.Utf8 qualified as T.Utf8
    import GHC.Utils.Outputable (Outputable)
    import Ormolu.Utils (showOutputable)
    import System.Console.ANSI
    import System.IO (Handle, hFlush)

    ----------------------------------------------------------------------------
    -- The 'Term' abstraction

    type Term = TermOutput ()

    newtype TermOutput a = TermOutput (Const (Seq TermOutputNode) a)
      deriving (NonEmpty (TermOutput a) -> TermOutput a
    TermOutput a -> TermOutput a -> TermOutput a
    (TermOutput a -> TermOutput a -> TermOutput a)
    -> (NonEmpty (TermOutput a) -> TermOutput a)
    -> (forall b. Integral b => b -> TermOutput a -> TermOutput a)
    -> Semigroup (TermOutput a)
    forall b. Integral b => b -> TermOutput a -> TermOutput a
    forall a. NonEmpty (TermOutput a) -> TermOutput a
    forall a. TermOutput a -> TermOutput a -> TermOutput a
    forall a.
    (a -> a -> a)
    -> (NonEmpty a -> a)
    -> (forall b. Integral b => b -> a -> a)
    -> Semigroup a
    forall a b. Integral b => b -> TermOutput a -> TermOutput a
    $c<> :: forall a. TermOutput a -> TermOutput a -> TermOutput a
    <> :: TermOutput a -> TermOutput a -> TermOutput a
    $csconcat :: forall a. NonEmpty (TermOutput a) -> TermOutput a
    sconcat :: NonEmpty (TermOutput a) -> TermOutput a
    $cstimes :: forall a b. Integral b => b -> TermOutput a -> TermOutput a
    stimes :: forall b. Integral b => b -> TermOutput a -> TermOutput a
    Semigroup, Semigroup (TermOutput a)
    TermOutput a
    Semigroup (TermOutput a) =>
    TermOutput a
    -> (TermOutput a -> TermOutput a -> TermOutput a)
    -> ([TermOutput a] -> TermOutput a)
    -> Monoid (TermOutput a)
    [TermOutput a] -> TermOutput a
    TermOutput a -> TermOutput a -> TermOutput a
    forall a. Semigroup (TermOutput a)
    forall a. TermOutput a
    forall a.
    Semigroup a =>
    a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
    forall a. [TermOutput a] -> TermOutput a
    forall a. TermOutput a -> TermOutput a -> TermOutput a
    $cmempty :: forall a. TermOutput a
    mempty :: TermOutput a
    $cmappend :: forall a. TermOutput a -> TermOutput a -> TermOutput a
    mappend :: TermOutput a -> TermOutput a -> TermOutput a
    $cmconcat :: forall a. [TermOutput a] -> TermOutput a
    mconcat :: [TermOutput a] -> TermOutput a
    Monoid, (forall a b. (a -> b) -> TermOutput a -> TermOutput b)
    -> (forall a b. a -> TermOutput b -> TermOutput a)
    -> Functor TermOutput
    forall a b. a -> TermOutput b -> TermOutput a
    forall a b. (a -> b) -> TermOutput a -> TermOutput b
    forall (f :: * -> *).
    (forall a b. (a -> b) -> f a -> f b)
    -> (forall a b. a -> f b -> f a) -> Functor f
    $cfmap :: forall a b. (a -> b) -> TermOutput a -> TermOutput b
    fmap :: forall a b. (a -> b) -> TermOutput a -> TermOutput b
    $c<$ :: forall a b. a -> TermOutput b -> TermOutput a
    <$ :: forall a b. a -> TermOutput b -> TermOutput a
    Functor, Functor TermOutput
    Functor TermOutput =>
    (forall a. a -> TermOutput a)
    -> (forall a b.
        TermOutput (a -> b) -> TermOutput a -> TermOutput b)
    -> (forall a b c.
        (a -> b -> c) -> TermOutput a -> TermOutput b -> TermOutput c)
    -> (forall a b. TermOutput a -> TermOutput b -> TermOutput b)
    -> (forall a b. TermOutput a -> TermOutput b -> TermOutput a)
    -> Applicative TermOutput
    forall a. a -> TermOutput a
    forall a b. TermOutput a -> TermOutput b -> TermOutput a
    forall a b. TermOutput a -> TermOutput b -> TermOutput b
    forall a b. TermOutput (a -> b) -> TermOutput a -> TermOutput b
    forall a b c.
    (a -> b -> c) -> TermOutput a -> TermOutput b -> TermOutput c
    forall (f :: * -> *).
    Functor f =>
    (forall a. a -> f a)
    -> (forall a b. f (a -> b) -> f a -> f b)
    -> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
    -> (forall a b. f a -> f b -> f b)
    -> (forall a b. f a -> f b -> f a)
    -> Applicative f
    $cpure :: forall a. a -> TermOutput a
    pure :: forall a. a -> TermOutput a
    $c<*> :: forall a b. TermOutput (a -> b) -> TermOutput a -> TermOutput b
    <*> :: forall a b. TermOutput (a -> b) -> TermOutput a -> TermOutput b
    $cliftA2 :: forall a b c.
    (a -> b -> c) -> TermOutput a -> TermOutput b -> TermOutput c
    liftA2 :: forall a b c.
    (a -> b -> c) -> TermOutput a -> TermOutput b -> TermOutput c
    $c*> :: forall a b. TermOutput a -> TermOutput b -> TermOutput b
    *> :: forall a b. TermOutput a -> TermOutput b -> TermOutput b
    $c<* :: forall a b. TermOutput a -> TermOutput b -> TermOutput a
    <* :: forall a b. TermOutput a -> TermOutput b -> TermOutput a
    Applicative)

    data TermOutputNode
      = OutputText Text
      | WithColor Color Term
      | WithBold Term

    singleTerm :: TermOutputNode -> Term
    singleTerm :: TermOutputNode -> Term
    singleTerm = Const (Seq TermOutputNode) () -> Term
    forall a. Const (Seq TermOutputNode) a -> TermOutput a
    TermOutput (Const (Seq TermOutputNode) () -> Term)
    -> (TermOutputNode -> Const (Seq TermOutputNode) ())
    -> TermOutputNode
    -> Term
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Seq TermOutputNode -> Const (Seq TermOutputNode) ()
    forall {k} a (b :: k). a -> Const a b
    Const (Seq TermOutputNode -> Const (Seq TermOutputNode) ())
    -> (TermOutputNode -> Seq TermOutputNode)
    -> TermOutputNode
    -> Const (Seq TermOutputNode) ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TermOutputNode -> Seq TermOutputNode
    forall a. a -> Seq a
    Seq.singleton

    -- | Whether to use colors and other features of ANSI terminals.
    data ColorMode = Never | Always | Auto
      deriving (ColorMode -> ColorMode -> Bool
    (ColorMode -> ColorMode -> Bool)
    -> (ColorMode -> ColorMode -> Bool) -> Eq ColorMode
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: ColorMode -> ColorMode -> Bool
    == :: ColorMode -> ColorMode -> Bool
    $c/= :: ColorMode -> ColorMode -> Bool
    /= :: ColorMode -> ColorMode -> Bool
    Eq, Int -> ColorMode -> ShowS
    [ColorMode] -> ShowS
    ColorMode -> String
    (Int -> ColorMode -> ShowS)
    -> (ColorMode -> String)
    -> ([ColorMode] -> ShowS)
    -> Show ColorMode
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> ColorMode -> ShowS
    showsPrec :: Int -> ColorMode -> ShowS
    $cshow :: ColorMode -> String
    show :: ColorMode -> String
    $cshowList :: [ColorMode] -> ShowS
    showList :: [ColorMode] -> ShowS
    Show)

    -- | Run 'Term' monad.
    runTerm ::
      Term ->
      -- | Color mode
      ColorMode ->
      -- | Handle to print to
      Handle ->
      IO ()
    runTerm :: Term -> ColorMode -> Handle -> IO ()
    runTerm Term
    term0 ColorMode
    colorMode Handle
    handle = do
      useSGR <- case ColorMode
    colorMode of
        ColorMode
    Never -> Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
        ColorMode
    Always -> Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True
        ColorMode
    Auto -> Handle -> IO Bool
    hSupportsANSI Handle
    handle
      runTerm' useSGR term0
      hFlush handle
      where
        runTerm' :: Bool -> Term -> IO ()
    runTerm' Bool
    useSGR = Term -> IO ()
    go
          where
            go :: Term -> IO ()
    go (TermOutput (Const Seq TermOutputNode
    nodes)) =
              Seq TermOutputNode -> (TermOutputNode -> IO ()) -> IO ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ Seq TermOutputNode
    nodes ((TermOutputNode -> IO ()) -> IO ())
    -> (TermOutputNode -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \case
                OutputText Text
    s -> Handle -> Text -> IO ()
    T.Utf8.hPutStr Handle
    handle Text
    s
                WithColor Color
    color Term
    term -> [SGR] -> IO () -> IO ()
    withSGR [ConsoleLayer -> ColorIntensity -> Color -> SGR
    SetColor ConsoleLayer
    Foreground ColorIntensity
    Dull Color
    color] (Term -> IO ()
    go Term
    term)
                WithBold Term
    term -> [SGR] -> IO () -> IO ()
    withSGR [ConsoleIntensity -> SGR
    SetConsoleIntensity ConsoleIntensity
    BoldIntensity] (Term -> IO ()
    go Term
    term)

            withSGR :: [SGR] -> IO () -> IO ()
    withSGR [SGR]
    sgrs IO ()
    m
              | Bool
    useSGR = Handle -> [SGR] -> IO ()
    hSetSGR Handle
    handle [SGR]
    sgrs IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> IO ()
    m IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Handle -> [SGR] -> IO ()
    hSetSGR Handle
    handle [SGR
    Reset]
              | Bool
    otherwise = IO ()
    m

    runTermPure :: Term -> Text
    runTermPure :: Term -> Text
    runTermPure (TermOutput (Const Seq TermOutputNode
    nodes)) =
      [Text] -> Text
    T.concat ([Text] -> Text)
    -> ((TermOutputNode -> Text) -> [Text])
    -> (TermOutputNode -> Text)
    -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Seq Text -> [Text]
    forall a. Seq a -> [a]
    forall (t :: * -> *) a. Foldable t => t a -> [a]
    toList (Seq Text -> [Text])
    -> ((TermOutputNode -> Text) -> Seq Text)
    -> (TermOutputNode -> Text)
    -> [Text]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((TermOutputNode -> Text) -> Seq TermOutputNode -> Seq Text)
    -> Seq TermOutputNode -> (TermOutputNode -> Text) -> Seq Text
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip (TermOutputNode -> Text) -> Seq TermOutputNode -> Seq Text
    forall a b. (a -> b) -> Seq a -> Seq b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Seq TermOutputNode
    nodes ((TermOutputNode -> Text) -> Text)
    -> (TermOutputNode -> Text) -> Text
    forall a b. (a -> b) -> a -> b
    $ \case
        OutputText Text
    s -> Text
    s
        WithColor Color
    _ Term
    term -> Term -> Text
    runTermPure Term
    term
        WithBold Term
    term -> Term -> Text
    runTermPure Term
    term

    ----------------------------------------------------------------------------
    -- Styling

    -- | Make the output bold text.
    bold :: Term -> Term
    bold :: Term -> Term
    bold = TermOutputNode -> Term
    singleTerm (TermOutputNode -> Term)
    -> (Term -> TermOutputNode) -> Term -> Term
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Term -> TermOutputNode
    WithBold

    -- | Make the output cyan text.
    cyan :: Term -> Term
    cyan :: Term -> Term
    cyan = TermOutputNode -> Term
    singleTerm (TermOutputNode -> Term)
    -> (Term -> TermOutputNode) -> Term -> Term
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Color -> Term -> TermOutputNode
    WithColor Color
    Cyan

    -- | Make the output green text.
    green :: Term -> Term
    green :: Term -> Term
    green = TermOutputNode -> Term
    singleTerm (TermOutputNode -> Term)
    -> (Term -> TermOutputNode) -> Term -> Term
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Color -> Term -> TermOutputNode
    WithColor Color
    Green

    -- | Make the output red text.
    red :: Term -> Term
    red :: Term -> Term
    red = TermOutputNode -> Term
    singleTerm (TermOutputNode -> Term)
    -> (Term -> TermOutputNode) -> Term -> Term
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Color -> Term -> TermOutputNode
    WithColor Color
    Red

    ----------------------------------------------------------------------------
    -- Printing

    -- | Output 'Text'.
    put :: Text -> Term
    put :: Text -> Term
    put = TermOutputNode -> Term
    singleTerm (TermOutputNode -> Term)
    -> (Text -> TermOutputNode) -> Text -> Term
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> TermOutputNode
    OutputText

    -- | Output a 'Show' value.
    putShow :: (Show a) => a -> Term
    putShow :: forall a. Show a => a -> Term
    putShow = Text -> Term
    put (Text -> Term) -> (a -> Text) -> a -> Term
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Text
    T.pack (String -> Text) -> (a -> String) -> a -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> String
    forall a. Show a => a -> String
    show

    -- | Output an 'Outputable' value.
    putOutputable :: (Outputable a) => a -> Term
    putOutputable :: forall a. Outputable a => a -> Term
    putOutputable = Text -> Term
    put (Text -> Term) -> (a -> Text) -> a -> Term
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Text
    T.pack (String -> Text) -> (a -> String) -> a -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> String
    forall o. Outputable o => o -> String
    showOutputable

    -- | Output a newline.
    newline :: Term
    newline :: Term
    newline = Text -> Term
    put Text
    "\n"