{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Monoid.Colorful.Nested (
Style(..)
, Color(..)
, Term(..)
, Colored(..)
, hGetTerm
, getTerm
, hPrintColored
, printColored
, hPrintColoredIO
, printColoredIO
, hPrintColoredS
, printColoredS
, showColored
, showColoredM
, showColoredS
) where
import System.IO (Handle)
import Data.Monoid.Colorful.Term
import Data.Monoid.Colorful.Color
import Data.Monoid.Colorful.SGR
import Data.Monoid.Colorful.Trustworthy
import Data.String (IsString(..))
import qualified Data.Semigroup as Sem
import GHC.Generics (Generic, Generic1)
import qualified Data.Monoid.Colorful.Flat as Flat
import Control.Monad (ap)
data Colored a
= Nil
| Value a
| Style !Style (Colored a)
| Unstyle !Style (Colored a)
| Fg !Color (Colored a)
| Bg !Color (Colored a)
| Pair (Colored a) (Colored a)
deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable, Generic, Generic1)
instance Applicative Colored where
pure = Value
(<*>) = ap
instance Monad Colored where
Nil >>= _ = Nil
Value x >>= f = f x
Style a x >>= f = Style a (x >>= f)
Unstyle a x >>= f = Unstyle a (x >>= f)
Fg a x >>= f = Fg a (x >>= f)
Bg a x >>= f = Bg a (x >>= f)
Pair x y >>= f = Pair (x >>= f) (y >>= f)
instance Sem.Semigroup (Colored a) where
(<>) = Pair
instance Monoid (Colored a) where
mempty = Nil
mappend = (Sem.<>)
instance IsString a => IsString (Colored a) where
fromString = Value . fromString
instance IsList (Colored a) where
type Item (Colored a) = Colored a
fromList = foldr Pair Nil
toList = (:[])
flatten :: Colored a -> [Flat.Colored a]
flatten s = go s []
where go (Value a) = (Flat.Value a:)
go (Style a b) = (Flat.Push:) . (Flat.Style a:) . go b . (Flat.Pop:)
go (Unstyle a b) = (Flat.Push:) . (Flat.Unstyle a:) . go b . (Flat.Pop:)
go (Fg a b) = (Flat.Push:) . (Flat.Fg a:) . go b . (Flat.Pop:)
go (Bg a b) = (Flat.Push:) . (Flat.Bg a:) . go b . (Flat.Pop:)
go Nil = id
go (Pair a b) = go a . go b
hPrintColoredIO :: Handle -> Term -> Colored (IO ()) -> IO ()
hPrintColoredIO h t = Flat.hPrintColoredIO h t . flatten
printColoredIO :: Term -> Colored (IO ()) -> IO ()
printColoredIO t = Flat.printColoredIO t . flatten
hPrintColored :: (Handle -> a -> IO ()) -> Handle -> Term -> Colored a -> IO ()
hPrintColored f h t = Flat.hPrintColored f h t . flatten
printColored :: (a -> IO ()) -> Term -> Colored a -> IO ()
printColored f t = Flat.printColored f t . flatten
hPrintColoredS :: Handle -> Term -> Colored String -> IO ()
hPrintColoredS h t = Flat.hPrintColoredS h t . flatten
printColoredS :: Term -> Colored String -> IO ()
printColoredS t = Flat.printColoredS t . flatten
showColoredM :: (Monad f, Monoid o) => (a -> f o) -> (SGRCode -> f o) -> Term -> Colored a -> f o
showColoredM f g t = Flat.showColoredM f g t . flatten
showColored :: Monoid o => (a -> o) -> (SGRCode -> o) -> Term -> Colored a -> o
showColored f g t = Flat.showColored f g t . flatten
showColoredS :: Term -> Colored String -> ShowS
showColoredS t = Flat.showColoredS t . flatten