module Symantic.Document.Term.IO
 ( module Symantic.Document.Sym
 , module 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 Symantic.Document.Sym

-- * Type 'TermIOInh'
data TermIOInh = TermIOInh
 {   termIOInh_indent    :: !Indent         -- ^ Current indentation level, used by 'newline'.
 ,   termIOInh_newline   :: TermIO          -- ^ How to display 'newline'.
 ,   termIOInh_sgr       :: ![SGR]          -- ^ Active ANSI codes.
 ,   termIOInh_handle    :: !IO.Handle      -- ^ Where to write.
 ,   termIOInh_breakable :: !(Maybe Column) -- ^ 'Column' after which to break.
 ,   termIOInh_colorable :: !Bool           -- ^ Whether colors are activated or not.
 ,   termIOInh_decorable :: !Bool           -- ^ Whether decorations are activated or not.
 }

-- | Default 'TermIOInh'.
defTermIOInh :: TermIOInh
defTermIOInh = TermIOInh
 { termIOInh_indent    = 0
 , termIOInh_newline   = newlineWithIndent
 , termIOInh_sgr       = []
 , termIOInh_handle    = IO.stdout
 , termIOInh_breakable = Nothing
 , termIOInh_colorable = True
 , termIOInh_decorable = True
 }

-- * Type 'TermIOState'
type TermIOState = Column

-- | Default 'TermIOState'.
defTermIOState :: TermIOState
defTermIOState = 0

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

-- | Write a 'TermIO'.
runTermIO :: IO.Handle -> TermIO -> IO ()
runTermIO h (TermIO t) = t defTermIOInh{termIOInh_handle=h} defTermIOState 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 currCol ok ko ->
		let newCol = currCol + len in
		(case termIOInh_breakable ro of
		 Just breakCol | breakCol < newCol -> ko
		 _ -> ok)
		newCol (t (termIOInh_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 (termIOInh_newline ro) ro
instance Indentable TermIO where
	align t = TermIO $ \ro st -> unTermIO t ro{termIOInh_indent=st} st
	withNewline nl  t = TermIO $ \ro -> unTermIO t ro{termIOInh_newline=nl}
	withIndent  ind t = TermIO $ \ro -> unTermIO t ro{termIOInh_indent=ind}
	incrIndent  ind t = TermIO $ \ro -> unTermIO t ro{termIOInh_indent=termIOInh_indent ro + ind}
	column f = TermIO $ \ro st -> unTermIO (f st) ro st
	indent f = TermIO $ \ro -> unTermIO (f (termIOInh_indent ro)) ro
	newlineWithoutIndent = TermIO $ \ro _st ok _ko ->
		ok 0 $ IO.hPutChar (termIOInh_handle ro) '\n'
	newlineWithIndent = TermIO $ \ro@TermIOInh{termIOInh_handle=h} _st ok _ko ->
		ok (termIOInh_indent ro) $ do
			IO.hPutChar h '\n'
			IO.hPutStr h $ List.replicate (fromIntegral $ termIOInh_indent ro) ' '
instance Breakable TermIO where
	breakable f       = TermIO $ \ro -> unTermIO (f (termIOInh_breakable ro)) ro
	withBreakable b t = TermIO $ \ro -> unTermIO t ro{termIOInh_breakable=b}
	ifBreak y x = TermIO $ \ro st ok ko ->
		unTermIO x ro st ok $
		case termIOInh_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 termIOInh_breakable ro of
		 Nothing -> ko
		 Just{} -> (\_sp _tp -> unTermIO (onBreak <> t) ro st ok ko)

writeSGR :: (TermIOInh -> 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 (termIOInh_handle ro) [s]
	m = TermIO $ \ro -> t ro{termIOInh_sgr=s:termIOInh_sgr ro}
	c = TermIO $ \ro st ok _ko -> ok st $ hSetSGR (termIOInh_handle ro) $ Reset:List.reverse (termIOInh_sgr ro)

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