{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Ormolu.Terminal
(
Term,
ColorMode (..),
runTerm,
bold,
cyan,
green,
red,
put,
putS,
putSrcSpan,
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 (a -> Term b -> Term a
(a -> b) -> Term a -> Term b
(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
<$ :: a -> Term b -> Term a
$c<$ :: forall a b. a -> Term b -> Term a
fmap :: (a -> b) -> Term a -> Term b
$cfmap :: forall a b. (a -> b) -> Term a -> Term b
Functor, Functor Term
a -> Term a
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
Term a -> Term b -> Term b
Term a -> Term b -> Term a
Term (a -> b) -> Term a -> Term b
(a -> b -> c) -> Term a -> Term b -> Term c
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
<* :: Term a -> Term b -> Term a
$c<* :: forall a b. Term a -> Term b -> Term a
*> :: Term a -> Term b -> Term b
$c*> :: forall a b. Term a -> Term b -> Term b
liftA2 :: (a -> b -> c) -> Term a -> Term b -> Term c
$cliftA2 :: forall a b c. (a -> b -> c) -> Term a -> Term b -> Term c
<*> :: Term (a -> b) -> Term a -> Term b
$c<*> :: forall a b. Term (a -> b) -> Term a -> Term b
pure :: a -> Term a
$cpure :: forall a. a -> Term a
$cp1Applicative :: Functor Term
Applicative, Applicative Term
a -> Term a
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
Term a -> (a -> Term b) -> Term b
Term a -> Term b -> Term b
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 :: a -> Term a
$creturn :: forall a. a -> Term a
>> :: Term a -> Term b -> Term b
$c>> :: forall a b. Term a -> Term b -> Term b
>>= :: Term a -> (a -> Term b) -> Term b
$c>>= :: forall a b. Term a -> (a -> Term b) -> Term b
$cp1Monad :: Applicative Term
Monad)
data RC = RC
{
RC -> Bool
rcUseColor :: Bool,
RC -> Handle
rcHandle :: Handle
}
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
/= :: ColorMode -> ColorMode -> Bool
$c/= :: ColorMode -> ColorMode -> Bool
== :: ColorMode -> ColorMode -> Bool
$c== :: 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
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]
(ColorMode -> ColorMode)
-> (ColorMode -> ColorMode)
-> (Int -> ColorMode)
-> (ColorMode -> Int)
-> (ColorMode -> [ColorMode])
-> (ColorMode -> ColorMode -> [ColorMode])
-> (ColorMode -> ColorMode -> [ColorMode])
-> (ColorMode -> ColorMode -> ColorMode -> [ColorMode])
-> Enum 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
ColorMode -> ColorMode -> Bounded ColorMode
forall a. a -> a -> Bounded a
maxBound :: ColorMode
$cmaxBound :: ColorMode
minBound :: ColorMode
$cminBound :: ColorMode
Bounded)
runTerm ::
Term a ->
ColorMode ->
Handle ->
IO a
runTerm :: 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 (m :: * -> *) a. Monad m => a -> m a
return Bool
False
ColorMode
Always -> Bool -> IO Bool
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 -> RC
RC {Bool
Handle
rcUseColor :: Bool
rcHandle :: Handle
rcHandle :: Handle
rcUseColor :: Bool
..}
Handle -> IO ()
hFlush Handle
rcHandle
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
bold :: Term a -> Term a
bold :: Term a -> Term a
bold = [SGR] -> Term a -> Term a
forall a. [SGR] -> Term a -> Term a
withSGR [ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity]
cyan :: Term a -> Term a
cyan :: 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]
green :: Term a -> Term a
green :: 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]
red :: Term a -> Term a
red :: 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]
withSGR :: [SGR] -> Term a -> Term a
withSGR :: [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
rcHandle :: Handle
rcUseColor :: Bool
rcHandle :: RC -> Handle
rcUseColor :: RC -> Bool
..} <- ReaderT RC IO RC
forall r (m :: * -> *). MonadReader r m => m r
ask
if Bool
rcUseColor
then do
IO () -> ReaderT RC IO ()
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 (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 (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 = 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
rcHandle :: Handle
rcUseColor :: Bool
rcHandle :: RC -> Handle
rcUseColor :: RC -> Bool
..} <- ReaderT RC IO RC
forall r (m :: * -> *). MonadReader r m => m r
ask
IO () -> ReaderT RC IO ()
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
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
rcHandle :: Handle
rcUseColor :: Bool
rcHandle :: RC -> Handle
rcUseColor :: RC -> Bool
..} <- ReaderT RC IO RC
forall r (m :: * -> *). MonadReader r m => m r
ask
IO () -> ReaderT RC IO ()
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
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
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
rcHandle :: Handle
rcUseColor :: Bool
rcHandle :: RC -> Handle
rcUseColor :: RC -> Bool
..} <- ReaderT RC IO RC
forall r (m :: * -> *). MonadReader r m => m r
ask
IO () -> ReaderT RC IO ()
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"