{-# 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
  , showColoredA
  , 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)

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 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 :: 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

showColoredA :: (Applicative f, Monoid o) => (a -> f o) -> (SGRCode -> f o) -> Term -> Colored a -> f o
showColoredA f g t = Flat.showColoredA 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