    {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RecordWildCards #-}

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

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

        -- * Printing
        put,
        putS,
        putSrcSpan,
        putRealSrcSpan,
        newline,
      )
    where

    import Control.Monad.Reader
    import Data.Text (Text)
    import qualified Data.Text.IO as T
    import GHC.Types.SrcLoc
    import Ormolu.Utils (showOutputable)
    import System.Console.ANSI
    import System.IO (Handle, hFlush, hPutStr)

    ----------------------------------------------------------------------------
    -- The 'Term' monad

    -- | Terminal monad.
    newtype Term a = Term (ReaderT RC IO a)
      deriving ((forall a b. (a -> b) -> Term a -> Term b)
    -> (forall a b. a -> Term b -> Term a) -> Functor Term
    forall a b. a -> Term b -> Term a
    forall a b. (a -> b) -> Term a -> Term 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) -> Term a -> Term b
    fmap :: forall a b. (a -> b) -> Term a -> Term b
    $c<$ :: forall a b. a -> Term b -> Term a
    <$ :: forall a b. a -> Term b -> Term a
    Functor, Functor Term
    Functor Term
    -> (forall a. a -> Term a)
    -> (forall a b. Term (a -> b) -> Term a -> Term b)
    -> (forall a b c. (a -> b -> c) -> Term a -> Term b -> Term c)
    -> (forall a b. Term a -> Term b -> Term b)
    -> (forall a b. Term a -> Term b -> Term a)
    -> Applicative Term
    forall a. a -> Term a
    forall a b. Term a -> Term b -> Term a
    forall a b. Term a -> Term b -> Term b
    forall a b. Term (a -> b) -> Term a -> Term b
    forall a b c. (a -> b -> c) -> Term a -> Term b -> Term 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 -> Term a
    pure :: forall a. a -> Term a
    $c<*> :: forall a b. Term (a -> b) -> Term a -> Term b
    <*> :: forall a b. Term (a -> b) -> Term a -> Term b
    $cliftA2 :: forall a b c. (a -> b -> c) -> Term a -> Term b -> Term c
    liftA2 :: forall a b c. (a -> b -> c) -> Term a -> Term b -> Term c
    $c*> :: forall a b. Term a -> Term b -> Term b
    *> :: forall a b. Term a -> Term b -> Term b
    $c<* :: forall a b. Term a -> Term b -> Term a
    <* :: forall a b. Term a -> Term b -> Term a
    Applicative, Applicative Term
    Applicative Term
    -> (forall a b. Term a -> (a -> Term b) -> Term b)
    -> (forall a b. Term a -> Term b -> Term b)
    -> (forall a. a -> Term a)
    -> Monad Term
    forall a. a -> Term a
    forall a b. Term a -> Term b -> Term b
    forall a b. Term a -> (a -> Term b) -> Term b
    forall (m :: * -> *).
    Applicative m
    -> (forall a b. m a -> (a -> m b) -> m b)
    -> (forall a b. m a -> m b -> m b)
    -> (forall a. a -> m a)
    -> Monad m
    $c>>= :: forall a b. Term a -> (a -> Term b) -> Term b
    >>= :: forall a b. Term a -> (a -> Term b) -> Term b
    $c>> :: forall a b. Term a -> Term b -> Term b
    >> :: forall a b. Term a -> Term b -> Term b
    $creturn :: forall a. a -> Term a
    return :: forall a. a -> Term a
    Monad)

    -- | Reader context of 'Term'.
    data RC = RC
      { -- | Whether to use colors
        RC -> Bool
    rcUseColor :: Bool,
        -- | Handle to print to
        RC -> Handle
    rcHandle :: Handle
      }

    -- | 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 ::
      -- | Monad to run
      Term a ->
      -- | Color mode
      ColorMode ->
      -- | Handle to print to
      Handle ->
      IO a
    runTerm :: forall a. Term a -> ColorMode -> Handle -> IO a
    runTerm (Term ReaderT RC IO a
    m) ColorMode
    colorMode Handle
    rcHandle = do
      Bool
    rcUseColor <- 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
    rcHandle
      a
    x <- ReaderT RC IO a -> RC -> IO a
    forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
    runReaderT ReaderT RC IO a
    m RC {Bool
    Handle
    rcUseColor :: Bool
    rcHandle :: Handle
    rcHandle :: Handle
    rcUseColor :: Bool
    ..}
      Handle -> IO ()
    hFlush Handle
    rcHandle
      a -> IO a
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return a
    x

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

    -- | Make the inner computation output bold text.
    bold :: Term a -> Term a
    bold :: forall a. Term a -> Term a
    bold = [SGR] -> Term a -> Term a
    forall a. [SGR] -> Term a -> Term a
    withSGR [ConsoleIntensity -> SGR
    SetConsoleIntensity ConsoleIntensity
    BoldIntensity]

    -- | Make the inner computation output cyan text.
    cyan :: Term a -> Term a
    cyan :: forall a. Term a -> Term a
    cyan = [SGR] -> Term a -> Term a
    forall a. [SGR] -> Term a -> Term a
    withSGR [ConsoleLayer -> ColorIntensity -> Color -> SGR
    SetColor ConsoleLayer
    Foreground ColorIntensity
    Dull Color
    Cyan]

    -- | Make the inner computation output green text.
    green :: Term a -> Term a
    green :: forall a. Term a -> Term a
    green = [SGR] -> Term a -> Term a
    forall a. [SGR] -> Term a -> Term a
    withSGR [ConsoleLayer -> ColorIntensity -> Color -> SGR
    SetColor ConsoleLayer
    Foreground ColorIntensity
    Dull Color
    Green]

    -- | Make the inner computation output red text.
    red :: Term a -> Term a
    red :: forall a. Term a -> Term a
    red = [SGR] -> Term a -> Term a
    forall a. [SGR] -> Term a -> Term a
    withSGR [ConsoleLayer -> ColorIntensity -> Color -> SGR
    SetColor ConsoleLayer
    Foreground ColorIntensity
    Dull Color
    Red]

    -- | Alter 'SGR' for inner computation.
    withSGR :: [SGR] -> Term a -> Term a
    withSGR :: forall a. [SGR] -> Term a -> Term a
    withSGR [SGR]
    sgrs (Term ReaderT RC IO a
    m) = ReaderT RC IO a -> Term a
    forall a. ReaderT RC IO a -> Term a
    Term (ReaderT RC IO a -> Term a) -> ReaderT RC IO a -> Term a
    forall a b. (a -> b) -> a -> b
    $ do
      RC {Bool
    Handle
    rcUseColor :: RC -> Bool
    rcHandle :: RC -> Handle
    rcUseColor :: Bool
    rcHandle :: Handle
    ..} <- ReaderT RC IO RC
    forall r (m :: * -> *). MonadReader r m => m r
    ask
      if Bool
    rcUseColor
        then do
          IO () -> ReaderT RC IO ()
    forall a. IO a -> ReaderT RC IO a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> ReaderT RC IO ()) -> IO () -> ReaderT RC IO ()
    forall a b. (a -> b) -> a -> b
    $ Handle -> [SGR] -> IO ()
    hSetSGR Handle
    rcHandle [SGR]
    sgrs
          a
    x <- ReaderT RC IO a
    m
          IO () -> ReaderT RC IO ()
    forall a. IO a -> ReaderT RC IO a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> ReaderT RC IO ()) -> IO () -> ReaderT RC IO ()
    forall a b. (a -> b) -> a -> b
    $ Handle -> [SGR] -> IO ()
    hSetSGR Handle
    rcHandle [SGR
    Reset]
          a -> ReaderT RC IO a
    forall a. a -> ReaderT RC IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return a
    x
        else ReaderT RC IO a
    m

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

    -- | Output 'Text'.
    put :: Text -> Term ()
    put :: Text -> Term ()
    put Text
    txt = ReaderT RC IO () -> Term ()
    forall a. ReaderT RC IO a -> Term a
    Term (ReaderT RC IO () -> Term ()) -> ReaderT RC IO () -> Term ()
    forall a b. (a -> b) -> a -> b
    $ do
      RC {Bool
    Handle
    rcUseColor :: RC -> Bool
    rcHandle :: RC -> Handle
    rcUseColor :: Bool
    rcHandle :: Handle
    ..} <- ReaderT RC IO RC
    forall r (m :: * -> *). MonadReader r m => m r
    ask
      IO () -> ReaderT RC IO ()
    forall a. IO a -> ReaderT RC IO a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> ReaderT RC IO ()) -> IO () -> ReaderT RC IO ()
    forall a b. (a -> b) -> a -> b
    $ Handle -> Text -> IO ()
    T.hPutStr Handle
    rcHandle Text
    txt

    -- | Output 'String'.
    putS :: String -> Term ()
    putS :: String -> Term ()
    putS String
    str = ReaderT RC IO () -> Term ()
    forall a. ReaderT RC IO a -> Term a
    Term (ReaderT RC IO () -> Term ()) -> ReaderT RC IO () -> Term ()
    forall a b. (a -> b) -> a -> b
    $ do
      RC {Bool
    Handle
    rcUseColor :: RC -> Bool
    rcHandle :: RC -> Handle
    rcUseColor :: Bool
    rcHandle :: Handle
    ..} <- ReaderT RC IO RC
    forall r (m :: * -> *). MonadReader r m => m r
    ask
      IO () -> ReaderT RC IO ()
    forall a. IO a -> ReaderT RC IO a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> ReaderT RC IO ()) -> IO () -> ReaderT RC IO ()
    forall a b. (a -> b) -> a -> b
    $ Handle -> String -> IO ()
    hPutStr Handle
    rcHandle String
    str

    -- | Output a 'GHC.SrcSpan'.
    putSrcSpan :: SrcSpan -> Term ()
    putSrcSpan :: SrcSpan -> Term ()
    putSrcSpan = String -> Term ()
    putS (String -> Term ()) -> (SrcSpan -> String) -> SrcSpan -> Term ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . SrcSpan -> String
    forall o. Outputable o => o -> String
    showOutputable

    -- | Output a 'GHC.RealSrcSpan'.
    putRealSrcSpan :: RealSrcSpan -> Term ()
    putRealSrcSpan :: RealSrcSpan -> Term ()
    putRealSrcSpan = String -> Term ()
    putS (String -> Term ())
    -> (RealSrcSpan -> String) -> RealSrcSpan -> Term ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . RealSrcSpan -> String
    forall o. Outputable o => o -> String
    showOutputable

    -- | Output a newline.
    newline :: Term ()
    newline :: Term ()
    newline = ReaderT RC IO () -> Term ()
    forall a. ReaderT RC IO a -> Term a
    Term (ReaderT RC IO () -> Term ()) -> ReaderT RC IO () -> Term ()
    forall a b. (a -> b) -> a -> b
    $ do
      RC {Bool
    Handle
    rcUseColor :: RC -> Bool
    rcHandle :: RC -> Handle
    rcUseColor :: Bool
    rcHandle :: Handle
    ..} <- ReaderT RC IO RC
    forall r (m :: * -> *). MonadReader r m => m r
    ask
      IO () -> ReaderT RC IO ()
    forall a. IO a -> ReaderT RC IO a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> ReaderT RC IO ()) -> IO () -> ReaderT RC IO ()
    forall a b. (a -> b) -> a -> b
    $ Handle -> Text -> IO ()
    T.hPutStr Handle
    rcHandle Text
    "\n"