{-# 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 qualified as T
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
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
stimes :: forall b. Integral b => b -> TermOutput a -> TermOutput a
$cstimes :: forall a b. Integral b => b -> TermOutput a -> TermOutput a
sconcat :: NonEmpty (TermOutput a) -> TermOutput a
$csconcat :: forall a. NonEmpty (TermOutput a) -> TermOutput a
<> :: TermOutput a -> TermOutput a -> TermOutput a
$c<> :: forall a. TermOutput a -> TermOutput a -> TermOutput a
Semigroup, 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
mconcat :: [TermOutput a] -> TermOutput a
$cmconcat :: forall a. [TermOutput a] -> TermOutput a
mappend :: TermOutput a -> TermOutput a -> TermOutput a
$cmappend :: forall a. TermOutput a -> TermOutput a -> TermOutput a
mempty :: TermOutput a
$cmempty :: forall a. TermOutput a
Monoid, 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
<$ :: forall a b. a -> TermOutput b -> TermOutput a
$c<$ :: forall a b. a -> TermOutput b -> TermOutput a
fmap :: forall a b. (a -> b) -> TermOutput a -> TermOutput b
$cfmap :: forall a b. (a -> b) -> TermOutput a -> TermOutput b
Functor, Functor 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
<* :: forall a b. TermOutput a -> TermOutput b -> TermOutput a
$c<* :: forall a b. TermOutput a -> TermOutput b -> TermOutput a
*> :: forall a b. TermOutput a -> TermOutput b -> TermOutput b
$c*> :: forall a b. TermOutput a -> TermOutput b -> TermOutput b
liftA2 :: forall a b c.
(a -> b -> c) -> TermOutput a -> TermOutput b -> TermOutput c
$cliftA2 :: forall a b c.
(a -> b -> c) -> TermOutput a -> TermOutput b -> TermOutput c
<*> :: forall a b. TermOutput (a -> b) -> TermOutput a -> TermOutput b
$c<*> :: forall a b. TermOutput (a -> b) -> TermOutput a -> TermOutput b
pure :: forall a. a -> TermOutput a
$cpure :: forall a. a -> TermOutput a
Applicative)

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

singleTerm :: TermOutputNode -> Term
singleTerm :: TermOutputNode -> Term
singleTerm = forall a. Const (Seq TermOutputNode) a -> TermOutput a
TermOutput forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} a (b :: k). a -> Const a b
Const forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ColorMode -> ColorMode -> Bool
$c/= :: ColorMode -> ColorMode -> Bool
== :: ColorMode -> ColorMode -> Bool
$c== :: ColorMode -> ColorMode -> Bool
Eq, Int -> ColorMode -> ShowS
[ColorMode] -> ShowS
ColorMode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ColorMode] -> ShowS
$cshowList :: [ColorMode] -> ShowS
show :: ColorMode -> String
$cshow :: ColorMode -> String
showsPrec :: Int -> ColorMode -> ShowS
$cshowsPrec :: Int -> 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
  Bool
useSGR <- case ColorMode
colorMode of
    ColorMode
Never -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    ColorMode
Always -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    ColorMode
Auto -> Handle -> IO Bool
hSupportsANSI Handle
handle
  Bool -> Term -> IO ()
runTerm' Bool
useSGR Term
term0
  Handle -> IO ()
hFlush Handle
handle
  where
    runTerm' :: Bool -> Term -> IO ()
runTerm' Bool
useSGR = Term -> IO ()
go
      where
        go :: Term -> IO ()
go (TermOutput (Const Seq TermOutputNode
nodes)) =
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Seq TermOutputNode
nodes forall a b. (a -> b) -> a -> b
$ \case
            OutputText Text
s -> Handle -> Text -> IO ()
T.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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
m 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Seq TermOutputNode
nodes 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 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 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 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 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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall o. Outputable o => o -> String
showOutputable

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