module Symantic.Document.Term
 ( module Symantic.Document.Sym
 , module Symantic.Document.Term
 ) 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 (pred, fromIntegral, Num(..))
import System.Console.ANSI
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB

import Symantic.Document.Sym

-- * Type 'TermInh'
data TermInh = TermInh
 {   termInh_indent    :: !Indent         -- ^ Current indentation level, used by 'newline'.
 ,   termInh_newline   :: Term            -- ^ How to display 'newline'.
 ,   termInh_sgr       :: ![SGR]          -- ^ Active ANSI codes.
 ,   termInh_breakable :: !(Maybe Column) -- ^ 'Column' after which to break, or 'Nothing'
 ,   termInh_colorable :: !Bool           -- ^ Whether colors are activated or not.
 ,   termInh_decorable :: !Bool           -- ^ Whether decorations are activated or not.
 }

-- | Default 'TermInh'.
defTermInh :: TermInh
defTermInh = TermInh
 { termInh_indent    = 0
 , termInh_newline   = newlineWithIndent
 , termInh_sgr       = []
 , termInh_breakable = Nothing
 , termInh_colorable = True
 , termInh_decorable = True
 }

-- * Type 'TermState'
type TermState = Column

-- | Default 'TermState'.
defTermState :: TermState
defTermState = 0

-- * Type 'Term'
newtype Term = Term
 { unTerm :: TermInh -> TermState ->
             (TermState -> TLB.Builder -> TLB.Builder) -> -- normal continuation
             (TermState -> TLB.Builder -> TLB.Builder) -> -- should-break continuation
             TLB.Builder }

-- | Render a 'Term' into a 'TL.Text'.
textTerm :: Term -> TL.Text
textTerm = TLB.toLazyText . runTerm

-- | Render a 'Term' into a 'TLB.Builder'.
runTerm :: Term -> TLB.Builder
runTerm (Term t) = t defTermInh defTermState oko oko
	where oko _st = id

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

writeH :: Column -> TLB.Builder -> Term
writeH len t =
	Term $ \ro currCol ok ko ->
		let newCol = currCol + len in
		(case termInh_breakable ro of
		 Just breakCol | breakCol < newCol -> ko
		 _ -> ok)
		newCol t

instance Textable Term where
	empty     = Term $ \_ro st ok _ko -> ok st mempty
	charH   t = writeH (Nat 1) (TLB.singleton t)
	stringH t = writeH (length t) (fromString t)
	textH   t = writeH (length t) (TLB.fromText t)
	ltextH  t = writeH (length t) (TLB.fromLazyText t)
	replicate cnt t | cnt <= 0  = empty
	                | otherwise = t <> replicate (pred cnt) t
	newline = Term $ \ro -> unTerm (termInh_newline ro) ro
instance Indentable Term where
	align t = Term $ \ro st -> unTerm t ro{termInh_indent=st} st
	withNewline nl  t = Term $ \ro -> unTerm t ro{termInh_newline=nl}
	withIndent  ind t = Term $ \ro -> unTerm t ro{termInh_indent=ind}
	incrIndent  ind t = Term $ \ro -> unTerm t ro{termInh_indent=termInh_indent ro + ind}
	column f = Term $ \ro st -> unTerm (f st) ro st
	indent f = Term $ \ro -> unTerm (f (termInh_indent ro)) ro
	newlineWithoutIndent = Term $ \_ro _st ok _ko ->
		ok 0 $ TLB.singleton '\n'
	newlineWithIndent = Term $ \ro _st ok _ko ->
		ok (termInh_indent ro) $
			TLB.singleton '\n' <>
			fromString (List.replicate (fromIntegral $ termInh_indent ro) ' ')
instance Breakable Term where
	breakable f       = Term $ \ro -> unTerm (f (termInh_breakable ro)) ro
	withBreakable b t = Term $ \ro -> unTerm t ro{termInh_breakable=b}
	ifBreak y x = Term $ \ro st ok ko ->
		unTerm x ro st ok $
		case termInh_breakable ro of
		 Nothing -> ko
		 Just{} -> (\_sx _tx -> unTerm y ro st ok ko)
	breakpoint onNoBreak onBreak t = Term $ \ro st ok ko ->
		unTerm (onNoBreak <> t) ro st ok $
		case termInh_breakable ro of
		 Nothing -> ko
		 Just{}  -> (\_sp _tp -> unTerm (onBreak <> t) ro st ok ko)

writeSGR :: (TermInh -> Bool) -> SGR -> Term -> Term
writeSGR isOn s (Term t) =
	Term $ \ro ->
		if isOn ro
		then unTerm (o <> m <> c) ro
		else t ro
	where
	o = Term $ \_ro st ok _ko -> ok st $ fromString $ setSGRCode [s]
	m = Term $ \ro -> t ro{termInh_sgr=s:termInh_sgr ro}
	c = Term $ \ro st ok _ko -> ok st $ fromString $ setSGRCode $ Reset:List.reverse (termInh_sgr ro)

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