{-# 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
(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
  Bool
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
  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)) =
          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.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"