{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Ormolu.Terminal
(
Term,
ColorMode (..),
runTerm,
bold,
cyan,
green,
red,
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)
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)
data RC = RC
{
RC -> Bool
rcUseColor :: Bool,
RC -> Handle
rcHandle :: Handle
}
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)
runTerm ::
Term a ->
ColorMode ->
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
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]
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]
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]
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]
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
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
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
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
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
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"