module Text.Chatty.Extended.ANSI where
import qualified System.Console.ANSI as A
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.IO.Class
import Text.Chatty.Printer
import Text.Chatty.Extended.Printer
import Text.Chatty.Expansion
newtype AnsiPrinterT m a = AnsiPrinter { runAnsiPrinterT :: [Colour] -> m (a,[Colour]) }
instance Monad m => Monad (AnsiPrinterT m) where
return a = AnsiPrinter $ \s -> return (a,s)
(AnsiPrinter p) >>= f = AnsiPrinter $ \s -> do (a,s') <- p s; runAnsiPrinterT (f a) s'
instance MonadTrans AnsiPrinterT where
lift m = AnsiPrinter $ \c -> do a <- m; return (a,c)
instance Monad m => Functor (AnsiPrinterT m) where
fmap f a = AnsiPrinter $ \s -> do (a',s') <- runAnsiPrinterT a s; return (f a',s')
instance Monad m => Applicative (AnsiPrinterT m) where
pure = return
(<*>) = ap
instance MonadIO m => MonadIO (AnsiPrinterT m) where
liftIO = lift . liftIO
instance ChPrinter m => ChPrinter (AnsiPrinterT m) where
mprint = lift . mprint
mnoecho = lift . mnoecho
mflush = lift mflush
mnomask = lift . mnomask
instance ChPrinter m => ChExtendedPrinter (AnsiPrinterT m) where
estart c = AnsiPrinter $ \c1 -> do
mprint $ A.setSGRCode [A.SetColor A.Foreground (mkColourInt c) (mkColourCode c)]
return ((),c:c1)
efin = AnsiPrinter $ \c1 ->
case c1 of
(_:c:cx) -> do
mprint $ A.setSGRCode [A.SetColor A.Foreground (mkColourInt c) (mkColourCode c)]
return ((),c:cx)
_ -> do
mprint $ A.setSGRCode [A.Reset]
return ((),[])
instance (Functor m,ChExpand m) => ChExpand (AnsiPrinterT m) where
expand s = AnsiPrinter $ \cx -> do
s1 <- (expand =<<) $ liftM (replay.snd) $ runRecorderT $ liftM fst $ flip runAnsiPrinterT cx $ expandClr s
return (s1, cx)
mkColourInt (Dull _) = A.Dull
mkColourInt (Vivid _) = A.Vivid
mkColourCode (Dull c) = mkColourCode (Vivid c)
mkColourCode (Vivid c) = case c of
Green -> A.Green
Red -> A.Red
Yellow -> A.Yellow
Blue -> A.Blue
Black -> A.Black
White -> A.White
Cyan -> A.Cyan
Magenta -> A.Magenta