module Language.Symantic.Document.ANSI where

import Control.Monad (Monad(..), replicateM_)
import Data.Bool (Bool(..))
import Data.Function (($), (.), const)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import System.Console.ANSI
import System.IO (IO)
import Text.Show (Show(..))
import qualified Data.List as L
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Text.Lazy.IO as TL
import qualified System.IO as IO

import Language.Symantic.Document.Sym

-- * Type 'ANSI'
newtype ANSI = ANSI { unANSI :: [SGR] -> TLB.Builder }
instance IsString ANSI where
	fromString s = ANSI $ const t
		where t = fromString s

ansi :: ANSI -> TLB.Builder
ansi (ANSI d) = d []

pushSGR :: SGR -> ANSI -> ANSI
pushSGR c (ANSI d) = ANSI $ \cs ->
	fromString (setSGRCode [c]) <>
	d (c:cs) <>
	fromString (setSGRCode $ Reset:L.reverse cs)

instance Semigroup ANSI where
	ANSI x <> ANSI y = ANSI $ \c -> x c <> y c
instance Monoid ANSI where
	mempty  = empty
	mappend = (<>)
instance Doc_Text ANSI where
	replicate i d = ANSI $ TLB.fromLazyText . TL.replicate (int64OfInt i) . TLB.toLazyText . unANSI d
	int     = ANSI . const . fromString . show
	integer = ANSI . const . fromString . show
	char    = ANSI . const . TLB.singleton
	string  = ANSI . const . fromString
	text    = ANSI . const . TLB.fromText
	ltext   = ANSI . const . TLB.fromLazyText
	charH   = char
	stringH = string
	textH   = text
	ltextH  = ltext
instance Doc_Color ANSI where
	reverse     = pushSGR $ SetSwapForegroundBackground True
	black       = pushSGR $ SetColor Foreground Dull  Black
	red         = pushSGR $ SetColor Foreground Dull  Red
	green       = pushSGR $ SetColor Foreground Dull  Green
	yellow      = pushSGR $ SetColor Foreground Dull  Yellow
	blue        = pushSGR $ SetColor Foreground Dull  Blue
	magenta     = pushSGR $ SetColor Foreground Dull  Magenta
	cyan        = pushSGR $ SetColor Foreground Dull  Cyan
	white       = pushSGR $ SetColor Foreground Dull  White
	blacker     = pushSGR $ SetColor Foreground Vivid Black
	redder      = pushSGR $ SetColor Foreground Vivid Red
	greener     = pushSGR $ SetColor Foreground Vivid Green
	yellower    = pushSGR $ SetColor Foreground Vivid Yellow
	bluer       = pushSGR $ SetColor Foreground Vivid Blue
	magentaer   = pushSGR $ SetColor Foreground Vivid Magenta
	cyaner      = pushSGR $ SetColor Foreground Vivid Cyan
	whiter      = pushSGR $ SetColor Foreground Vivid White
	onBlack     = pushSGR $ SetColor Background Dull  Black
	onRed       = pushSGR $ SetColor Background Dull  Red
	onGreen     = pushSGR $ SetColor Background Dull  Green
	onYellow    = pushSGR $ SetColor Background Dull  Yellow
	onBlue      = pushSGR $ SetColor Background Dull  Blue
	onMagenta   = pushSGR $ SetColor Background Dull  Magenta
	onCyan      = pushSGR $ SetColor Background Dull  Cyan
	onWhite     = pushSGR $ SetColor Background Dull  White
	onBlacker   = pushSGR $ SetColor Background Vivid Black
	onRedder    = pushSGR $ SetColor Background Vivid Red
	onGreener   = pushSGR $ SetColor Background Vivid Green
	onYellower  = pushSGR $ SetColor Background Vivid Yellow
	onBluer     = pushSGR $ SetColor Background Vivid Blue
	onMagentaer = pushSGR $ SetColor Background Vivid Magenta
	onCyaner    = pushSGR $ SetColor Background Vivid Cyan
	onWhiter    = pushSGR $ SetColor Background Vivid White
instance Doc_Decoration ANSI where
	bold        = pushSGR $ SetConsoleIntensity BoldIntensity
	underline   = pushSGR $ SetUnderlining SingleUnderline
	italic      = pushSGR $ SetItalicized True

-- * Type 'ANSI_IO'
newtype ANSI_IO = ANSI_IO { unANSI_IO :: [SGR] -> IO.Handle -> IO () }
instance IsString ANSI_IO where
	fromString s = ANSI_IO $ \_c h -> IO.hPutStr h t
		where t = fromString s

ansiIO :: ANSI_IO -> IO.Handle -> IO ()
ansiIO (ANSI_IO d) = d []

pushSGR_IO :: SGR -> ANSI_IO -> ANSI_IO
pushSGR_IO c (ANSI_IO d) = ANSI_IO $ \cs h -> do
	hSetSGR h [c]
	d (c:cs) h
	hSetSGR h $ Reset:L.reverse cs

instance Semigroup ANSI_IO where
	ANSI_IO x <> ANSI_IO y = ANSI_IO $ \c h -> do {x c h; y c h}
instance Monoid ANSI_IO where
	mempty  = empty
	mappend = (<>)
instance Doc_Text ANSI_IO where
	empty         = ANSI_IO $ \_ _ -> return ()
	replicate i d = ANSI_IO $ \c   -> replicateM_ i . unANSI_IO d c
	int       i   = ANSI_IO $ \_ h -> IO.hPutStr  h (show i)
	integer   i   = ANSI_IO $ \_ h -> IO.hPutStr  h (show i)
	char      x   = ANSI_IO $ \_ h -> IO.hPutChar h x
	string    x   = ANSI_IO $ \_ h -> IO.hPutStr  h x
	text      x   = ANSI_IO $ \_ h -> T.hPutStr   h x
	ltext     x   = ANSI_IO $ \_ h -> TL.hPutStr  h x
	charH         = char
	stringH       = string
	textH         = text
	ltextH        = ltext
instance Doc_Color ANSI_IO where
	reverse     = pushSGR_IO $ SetSwapForegroundBackground True
	black       = pushSGR_IO $ SetColor Foreground Dull  Black
	red         = pushSGR_IO $ SetColor Foreground Dull  Red
	green       = pushSGR_IO $ SetColor Foreground Dull  Green
	yellow      = pushSGR_IO $ SetColor Foreground Dull  Yellow
	blue        = pushSGR_IO $ SetColor Foreground Dull  Blue
	magenta     = pushSGR_IO $ SetColor Foreground Dull  Magenta
	cyan        = pushSGR_IO $ SetColor Foreground Dull  Cyan
	white       = pushSGR_IO $ SetColor Foreground Dull  White
	blacker     = pushSGR_IO $ SetColor Foreground Vivid Black
	redder      = pushSGR_IO $ SetColor Foreground Vivid Red
	greener     = pushSGR_IO $ SetColor Foreground Vivid Green
	yellower    = pushSGR_IO $ SetColor Foreground Vivid Yellow
	bluer       = pushSGR_IO $ SetColor Foreground Vivid Blue
	magentaer   = pushSGR_IO $ SetColor Foreground Vivid Magenta
	cyaner      = pushSGR_IO $ SetColor Foreground Vivid Cyan
	whiter      = pushSGR_IO $ SetColor Foreground Vivid White
	onBlack     = pushSGR_IO $ SetColor Background Dull  Black
	onRed       = pushSGR_IO $ SetColor Background Dull  Red
	onGreen     = pushSGR_IO $ SetColor Background Dull  Green
	onYellow    = pushSGR_IO $ SetColor Background Dull  Yellow
	onBlue      = pushSGR_IO $ SetColor Background Dull  Blue
	onMagenta   = pushSGR_IO $ SetColor Background Dull  Magenta
	onCyan      = pushSGR_IO $ SetColor Background Dull  Cyan
	onWhite     = pushSGR_IO $ SetColor Background Dull  White
	onBlacker   = pushSGR_IO $ SetColor Background Vivid Black
	onRedder    = pushSGR_IO $ SetColor Background Vivid Red
	onGreener   = pushSGR_IO $ SetColor Background Vivid Green
	onYellower  = pushSGR_IO $ SetColor Background Vivid Yellow
	onBluer     = pushSGR_IO $ SetColor Background Vivid Blue
	onMagentaer = pushSGR_IO $ SetColor Background Vivid Magenta
	onCyaner    = pushSGR_IO $ SetColor Background Vivid Cyan
	onWhiter    = pushSGR_IO $ SetColor Background Vivid White
instance Doc_Decoration ANSI_IO where
	bold        = pushSGR_IO $ SetConsoleIntensity BoldIntensity
	underline   = pushSGR_IO $ SetUnderlining SingleUnderline
	italic      = pushSGR_IO $ SetItalicized True