{-# 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 -> 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
<$ :: forall a b. a -> Term b -> Term a
$c<$ :: forall a b. a -> Term b -> Term a
fmap :: forall a b. (a -> b) -> Term a -> Term b
$cfmap :: forall a b. (a -> b) -> Term a -> Term b
Functor, Functor 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
<* :: forall a b. Term a -> Term b -> Term a
$c<* :: forall a b. Term a -> Term b -> Term a
*> :: forall a b. Term a -> Term b -> Term b
$c*> :: forall a b. Term a -> Term b -> Term b
liftA2 :: forall a b c. (a -> b -> c) -> Term a -> Term b -> Term c
$cliftA2 :: forall a b c. (a -> b -> c) -> Term a -> Term b -> Term c
<*> :: forall a b. Term (a -> b) -> Term a -> Term b
$c<*> :: forall a b. Term (a -> b) -> Term a -> Term b
pure :: forall a. a -> Term a
$cpure :: forall a. a -> Term a
Applicative, Applicative 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
return :: forall a. a -> Term a
$creturn :: forall a. a -> Term a
>> :: forall a b. Term a -> Term b -> Term b
$c>> :: forall a b. Term a -> Term b -> Term b
>>= :: forall a b. Term a -> (a -> Term b) -> Term b
$c>>= :: forall a b. Term a -> (a -> Term b) -> Term b
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
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, Int -> ColorMode
ColorMode -> Int
ColorMode -> [ColorMode]
ColorMode -> ColorMode
ColorMode -> ColorMode -> [ColorMode]
ColorMode -> ColorMode -> ColorMode -> [ColorMode]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ColorMode -> ColorMode -> ColorMode -> [ColorMode]
$cenumFromThenTo :: ColorMode -> ColorMode -> ColorMode -> [ColorMode]
enumFromTo :: ColorMode -> ColorMode -> [ColorMode]
$cenumFromTo :: ColorMode -> ColorMode -> [ColorMode]
enumFromThen :: ColorMode -> ColorMode -> [ColorMode]
$cenumFromThen :: ColorMode -> ColorMode -> [ColorMode]
enumFrom :: ColorMode -> [ColorMode]
$cenumFrom :: ColorMode -> [ColorMode]
fromEnum :: ColorMode -> Int
$cfromEnum :: ColorMode -> Int
toEnum :: Int -> ColorMode
$ctoEnum :: Int -> ColorMode
pred :: ColorMode -> ColorMode
$cpred :: ColorMode -> ColorMode
succ :: ColorMode -> ColorMode
$csucc :: ColorMode -> ColorMode
Enum, ColorMode
forall a. a -> a -> Bounded a
maxBound :: ColorMode
$cmaxBound :: ColorMode
minBound :: ColorMode
$cminBound :: ColorMode
Bounded)

-- | 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 -> 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
rcHandle
  a
x <- 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
  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 = 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 = 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 = 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 = 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) = forall a. ReaderT RC IO a -> Term a
Term forall a b. (a -> b) -> a -> b
$ do
  RC {Bool
Handle
rcHandle :: Handle
rcUseColor :: Bool
rcHandle :: RC -> Handle
rcUseColor :: RC -> Bool
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
  if Bool
rcUseColor
    then do
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> [SGR] -> IO ()
hSetSGR Handle
rcHandle [SGR]
sgrs
      a
x <- ReaderT RC IO a
m
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> [SGR] -> IO ()
hSetSGR Handle
rcHandle [SGR
Reset]
      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 = forall a. ReaderT RC IO a -> Term a
Term forall a b. (a -> b) -> a -> b
$ do
  RC {Bool
Handle
rcHandle :: Handle
rcUseColor :: Bool
rcHandle :: RC -> Handle
rcUseColor :: RC -> Bool
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 = forall a. ReaderT RC IO a -> Term a
Term forall a b. (a -> b) -> a -> b
$ do
  RC {Bool
Handle
rcHandle :: Handle
rcUseColor :: Bool
rcHandle :: RC -> Handle
rcUseColor :: RC -> Bool
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall o. Outputable o => o -> String
showOutputable

-- | Output a 'GHC.RealSrcSpan'.
putRealSrcSpan :: RealSrcSpan -> Term ()
putRealSrcSpan :: RealSrcSpan -> Term ()
putRealSrcSpan = String -> Term ()
putS 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 = forall a. ReaderT RC IO a -> Term a
Term forall a b. (a -> b) -> a -> b
$ do
  RC {Bool
Handle
rcHandle :: Handle
rcUseColor :: Bool
rcHandle :: RC -> Handle
rcUseColor :: RC -> Bool
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
T.hPutStr Handle
rcHandle Text
"\n"