Nested.hs

{-# 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 Data.Semigroup (Semigroup)
import GHC.Generics (Generic, Generic1)
import qualified Data.Monoid.Colorful.Flat as Flat
import Control.Monad (ap)

-- | Colored Monoid
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)

-- | Free monad!
instance Applicative Colored where
  pure = Value
  (<*>) = ap

-- | Free monad!
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 Semigroup (Colored a)
instance Monoid (Colored a) where
  mempty = Nil
  mappend = Pair

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   = (:[]) -- TODO, invalid

-- | Flatten the Monoid @Colored a@ and return @[Flat.Colored a]@
--
-- This function is used internally for rendering the Colored monoids.
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