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.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import GHC.Exts (IsList(..))
import Prelude (pred, fromIntegral, Num(..))
import System.Console.ANSI
import System.IO (IO)
import Text.Show (Show(..))
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_wrap_column :: !Column    -- ^ 'Column' after which 'wrap' breaks on a 'breakpoint' or 'breakspace'.
 ,   reader_sgr         :: ![SGR]     -- ^ Active ANSI codes.
 ,   reader_handle      :: !IO.Handle -- ^ Where to write.
 ,   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_wrap_column = Nat 80
 , reader_sgr         = []
 , reader_handle      = IO.stdout
 , 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-wrap continuation
                  IO () }

-- | Write a 'TermIO'.
runTermIO :: IO.Handle -> TermIO -> IO ()
runTermIO h (TermIO p) = p 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
		(if newCol <= reader_wrap_column ro then ok else ko)
		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)
	int       = stringH . show
	integer   = stringH . show
	replicate cnt p | cnt <= 0  = empty
	                | otherwise = p <> replicate (pred cnt) p
	newline = TermIO $ \ro -> unTermIO (reader_newline ro) ro
instance Alignable TermIO where
	align p = TermIO $ \ro st -> unTermIO p ro{reader_indent=st} st
	withNewline nl  p = TermIO $ \ro -> unTermIO p ro{reader_newline=nl}
	withIndent  ind p = TermIO $ \ro -> unTermIO p ro{reader_indent=ind}
	incrIndent  ind p = TermIO $ \ro -> unTermIO p ro{reader_indent=reader_indent ro + ind}
	column f = TermIO $ \ro st -> unTermIO (f st) ro st
	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 Wrapable TermIO where
	ifWrap y x = TermIO $ \ro st ok ko ->
		unTermIO x ro st ok (\_sx _tx -> unTermIO y ro st ok ko)
	breakpoint onNoBreak onBreak p = TermIO $ \ro st ok ko ->
		unTermIO (onNoBreak <> p) ro st ok
		 (\_sp _tp -> unTermIO (onBreak <> p) ro st ok ko)
	withWrapColumn col p = TermIO $ \ro -> unTermIO p ro{reader_wrap_column=col}

writeSGR :: SGR -> TermIO -> TermIO
writeSGR s p = o <> m <> c
	where
	o = TermIO $ \ro st ok _ko -> ok st $ hSetSGR (reader_handle ro) [s]
	m = TermIO $ \ro -> unTermIO p 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 $ SetSwapForegroundBackground True
	black       = writeSGR $ SetColor Foreground Dull  Black
	red         = writeSGR $ SetColor Foreground Dull  Red
	green       = writeSGR $ SetColor Foreground Dull  Green
	yellow      = writeSGR $ SetColor Foreground Dull  Yellow
	blue        = writeSGR $ SetColor Foreground Dull  Blue
	magenta     = writeSGR $ SetColor Foreground Dull  Magenta
	cyan        = writeSGR $ SetColor Foreground Dull  Cyan
	white       = writeSGR $ SetColor Foreground Dull  White
	blacker     = writeSGR $ SetColor Foreground Vivid Black
	redder      = writeSGR $ SetColor Foreground Vivid Red
	greener     = writeSGR $ SetColor Foreground Vivid Green
	yellower    = writeSGR $ SetColor Foreground Vivid Yellow
	bluer       = writeSGR $ SetColor Foreground Vivid Blue
	magentaer   = writeSGR $ SetColor Foreground Vivid Magenta
	cyaner      = writeSGR $ SetColor Foreground Vivid Cyan
	whiter      = writeSGR $ SetColor Foreground Vivid White
	onBlack     = writeSGR $ SetColor Background Dull  Black
	onRed       = writeSGR $ SetColor Background Dull  Red
	onGreen     = writeSGR $ SetColor Background Dull  Green
	onYellow    = writeSGR $ SetColor Background Dull  Yellow
	onBlue      = writeSGR $ SetColor Background Dull  Blue
	onMagenta   = writeSGR $ SetColor Background Dull  Magenta
	onCyan      = writeSGR $ SetColor Background Dull  Cyan
	onWhite     = writeSGR $ SetColor Background Dull  White
	onBlacker   = writeSGR $ SetColor Background Vivid Black
	onRedder    = writeSGR $ SetColor Background Vivid Red
	onGreener   = writeSGR $ SetColor Background Vivid Green
	onYellower  = writeSGR $ SetColor Background Vivid Yellow
	onBluer     = writeSGR $ SetColor Background Vivid Blue
	onMagentaer = writeSGR $ SetColor Background Vivid Magenta
	onCyaner    = writeSGR $ SetColor Background Vivid Cyan
	onWhiter    = writeSGR $ 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 $ SetConsoleIntensity BoldIntensity
	underline   = writeSGR $ SetUnderlining SingleUnderline
	italic      = writeSGR $ SetItalicized True