module Language.Symantic.Document.Term.IO
 ( module Language.Symantic.Document.Sym
 , module Language.Symantic.Document.Term.IO
 ) where

import Control.Applicative (Applicative(..))
import Data.Bool
import Data.Function (($), id)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import GHC.Exts (IsList(..))
import Prelude (fromIntegral, Num(..))
import System.Console.ANSI
import System.IO (IO)
import qualified Data.List as List
import qualified Data.Text.IO as Text
import qualified Data.Text.Lazy.IO as TL
import qualified System.IO as IO

import Language.Symantic.Document.Sym

-- * Type 'Reader'
data Reader
 =   Reader
 {   reader_indent    :: !Indent         -- ^ Current indentation level, used by 'newline'.
 ,   reader_newline   :: TermIO          -- ^ How to display 'newline'.
 ,   reader_sgr       :: ![SGR]          -- ^ Active ANSI codes.
 ,   reader_handle    :: !IO.Handle      -- ^ Where to write.
 ,   reader_breakable :: !(Maybe Column) -- ^ 'Column' after which to break.
 ,   reader_colorable :: !Bool           -- ^ Whether colors are activated or not.
 ,   reader_decorable :: !Bool           -- ^ Whether decorations are activated or not.
 }

-- | Default 'Reader'.
defReader :: Reader
defReader = Reader
 { reader_indent      = 0
 , reader_newline     = newlineWithIndent
 , reader_sgr         = []
 , reader_handle      = IO.stdout
 , reader_breakable   = Nothing
 , reader_colorable   = True
 , reader_decorable   = True
 }

-- * Type 'State'
type State = Column

-- | Default 'State'.
defState :: State
defState = 0

-- * Type 'TermIO'
newtype TermIO
 =      TermIO
 {    unTermIO :: Reader -> State ->
                  (State -> IO () -> IO ()) -> -- normal continuation
                  (State -> IO () -> IO ()) -> -- should-break continuation
                  IO () }

-- | Write a 'TermIO'.
runTermIO :: IO.Handle -> TermIO -> IO ()
runTermIO h (TermIO t) = t defReader{reader_handle=h} defState oko oko
	where oko _st = id

instance IsList TermIO where
	type Item TermIO = TermIO
	fromList = mconcat
	toList   = pure
instance Semigroup TermIO where
	x <> y = TermIO $ \ro st ok ko ->
		unTermIO x ro st
		 (\sx tx -> unTermIO y ro sx
			 (\sy ty -> ok sy (tx<>ty))
			 (\sy ty -> ko sy (tx<>ty)))
		 (\sx tx -> unTermIO y ro sx
			 (\sy ty -> ko sy (tx<>ty))
			 (\sy ty -> ko sy (tx<>ty)))
instance Monoid TermIO where
	mempty  = empty
	mappend = (<>)
instance IsString TermIO where
	fromString = string

writeH :: Column -> (IO.Handle -> IO ()) -> TermIO
writeH len t =
	TermIO $ \ro st ok ko ->
		let newCol = st + len in
		(case reader_breakable ro of
		 Just breakCol | breakCol < newCol -> ko
		 _ -> ok)
		newCol (t (reader_handle ro))

instance Textable TermIO where
	empty     = TermIO $ \_ro st ok _ko -> ok st mempty
	charH   t = writeH 1 (`IO.hPutChar` t)
	stringH t = writeH (length t) (`IO.hPutStr` t)
	textH   t = writeH (length t) (`Text.hPutStr` t)
	ltextH  t = writeH (length t) (`TL.hPutStr` t)
	newline   = TermIO $ \ro -> unTermIO (reader_newline ro) ro
instance Indentable TermIO where
	align t = TermIO $ \ro st -> unTermIO t ro{reader_indent=st} st
	withNewline nl  t = TermIO $ \ro -> unTermIO t ro{reader_newline=nl}
	withIndent  ind t = TermIO $ \ro -> unTermIO t ro{reader_indent=ind}
	incrIndent  ind t = TermIO $ \ro -> unTermIO t ro{reader_indent=reader_indent ro + ind}
	column f = TermIO $ \ro st -> unTermIO (f st) ro st
	indent f = TermIO $ \ro -> unTermIO (f (reader_indent ro)) ro
	newlineWithoutIndent = TermIO $ \ro _st ok _ko ->
		ok 0 $ IO.hPutChar (reader_handle ro) '\n'
	newlineWithIndent = TermIO $ \ro@Reader{reader_handle=h} _st ok _ko ->
		ok (reader_indent ro) $ do
			IO.hPutChar h '\n'
			IO.hPutStr h $ List.replicate (fromIntegral $ reader_indent ro) ' '
instance Breakable TermIO where
	breakable f       = TermIO $ \ro -> unTermIO (f (reader_breakable ro)) ro
	withBreakable b t = TermIO $ \ro -> unTermIO t ro{reader_breakable=b}
	ifBreak y x = TermIO $ \ro st ok ko ->
		unTermIO x ro st ok $
		case reader_breakable ro of
		 Nothing -> ko
		 Just{} -> (\_sx _tx -> unTermIO y ro st ok ko)
	breakpoint onNoBreak onBreak t = TermIO $ \ro st ok ko ->
		unTermIO (onNoBreak <> t) ro st ok $
		case reader_breakable ro of
		 Nothing -> ko
		 Just{} -> (\_sp _tp -> unTermIO (onBreak <> t) ro st ok ko)

writeSGR :: (Reader -> Bool) -> SGR -> TermIO -> TermIO
writeSGR isOn s (TermIO t) =
	TermIO $ \ro ->
		if isOn ro
		then unTermIO (o <> m <> c) ro
		else t ro
	where
	o = TermIO $ \ro st ok _ko -> ok st $ hSetSGR (reader_handle ro) [s]
	m = TermIO $ \ro -> t ro{reader_sgr=s:reader_sgr ro}
	c = TermIO $ \ro st ok _ko -> ok st $ hSetSGR (reader_handle ro) $ Reset:List.reverse (reader_sgr ro)

instance Colorable TermIO where
	colorable f       = TermIO $ \ro -> unTermIO (f (reader_colorable ro)) ro
	withColorable b t = TermIO $ \ro -> unTermIO t ro{reader_colorable=b}
	reverse     = writeSGR reader_colorable $ SetSwapForegroundBackground True
	black       = writeSGR reader_colorable $ SetColor Foreground Dull  Black
	red         = writeSGR reader_colorable $ SetColor Foreground Dull  Red
	green       = writeSGR reader_colorable $ SetColor Foreground Dull  Green
	yellow      = writeSGR reader_colorable $ SetColor Foreground Dull  Yellow
	blue        = writeSGR reader_colorable $ SetColor Foreground Dull  Blue
	magenta     = writeSGR reader_colorable $ SetColor Foreground Dull  Magenta
	cyan        = writeSGR reader_colorable $ SetColor Foreground Dull  Cyan
	white       = writeSGR reader_colorable $ SetColor Foreground Dull  White
	blacker     = writeSGR reader_colorable $ SetColor Foreground Vivid Black
	redder      = writeSGR reader_colorable $ SetColor Foreground Vivid Red
	greener     = writeSGR reader_colorable $ SetColor Foreground Vivid Green
	yellower    = writeSGR reader_colorable $ SetColor Foreground Vivid Yellow
	bluer       = writeSGR reader_colorable $ SetColor Foreground Vivid Blue
	magentaer   = writeSGR reader_colorable $ SetColor Foreground Vivid Magenta
	cyaner      = writeSGR reader_colorable $ SetColor Foreground Vivid Cyan
	whiter      = writeSGR reader_colorable $ SetColor Foreground Vivid White
	onBlack     = writeSGR reader_colorable $ SetColor Background Dull  Black
	onRed       = writeSGR reader_colorable $ SetColor Background Dull  Red
	onGreen     = writeSGR reader_colorable $ SetColor Background Dull  Green
	onYellow    = writeSGR reader_colorable $ SetColor Background Dull  Yellow
	onBlue      = writeSGR reader_colorable $ SetColor Background Dull  Blue
	onMagenta   = writeSGR reader_colorable $ SetColor Background Dull  Magenta
	onCyan      = writeSGR reader_colorable $ SetColor Background Dull  Cyan
	onWhite     = writeSGR reader_colorable $ SetColor Background Dull  White
	onBlacker   = writeSGR reader_colorable $ SetColor Background Vivid Black
	onRedder    = writeSGR reader_colorable $ SetColor Background Vivid Red
	onGreener   = writeSGR reader_colorable $ SetColor Background Vivid Green
	onYellower  = writeSGR reader_colorable $ SetColor Background Vivid Yellow
	onBluer     = writeSGR reader_colorable $ SetColor Background Vivid Blue
	onMagentaer = writeSGR reader_colorable $ SetColor Background Vivid Magenta
	onCyaner    = writeSGR reader_colorable $ SetColor Background Vivid Cyan
	onWhiter    = writeSGR reader_colorable $ SetColor Background Vivid White
instance Decorable TermIO where
	decorable f       = TermIO $ \ro -> unTermIO (f (reader_decorable ro)) ro
	withDecorable b t = TermIO $ \ro -> unTermIO t ro{reader_decorable=b}
	bold      = writeSGR reader_decorable $ SetConsoleIntensity BoldIntensity
	underline = writeSGR reader_decorable $ SetUnderlining SingleUnderline
	italic    = writeSGR reader_decorable $ SetItalicized True