module Language.Symantic.Document.Term
 ( module Language.Symantic.Document.Sym
 , module Language.Symantic.Document.Term
 ) 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 Text.Show (Show(..))
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB

import Language.Symantic.Document.Sym

-- * Type 'Reader'
data Reader
 =   Reader
 {   reader_indent      :: !Indent -- ^ Current indentation level, used by 'newline'.
 ,   reader_newline     :: Term    -- ^ 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_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_colorable   = True
 , reader_decorable   = True
 }

-- * Type 'State'
type State = Column

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

-- * Type 'Term'
newtype Term
 =      Term
 {    unTerm :: Reader ->
                State  ->
                (State -> TLB.Builder -> TLB.Builder) -> -- normal continuation
                (State -> TLB.Builder -> TLB.Builder) -> -- should-wrap continuation
                TLB.Builder }

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

-- | Render a 'Term' into a 'TLB.Builder'.
buildTerm :: Term -> TLB.Builder
buildTerm (Term t) = t defReader defState 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 st ok ko ->
		let newCol = st + len in
		(if newCol <= reader_wrap_column ro then ok else ko)
		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)
	int       = stringH . show
	integer   = stringH . show
	replicate cnt t | cnt <= 0  = empty
	                | otherwise = t <> replicate (pred cnt) t
	newline = Term $ \ro -> unTerm (reader_newline ro) ro
instance Alignable Term where
	align t = Term $ \ro st -> unTerm t ro{reader_indent=st} st
	withNewline nl  t = Term $ \ro -> unTerm t ro{reader_newline=nl}
	withIndent  ind t = Term $ \ro -> unTerm t ro{reader_indent=ind}
	incrIndent  ind t = Term $ \ro -> unTerm t ro{reader_indent=reader_indent ro + ind}
	column f = Term $ \ro st -> unTerm (f st) ro st
	newlineWithoutIndent = Term $ \_ro _st ok _ko ->
		ok 0 $ TLB.singleton '\n'
	newlineWithIndent = Term $ \ro _st ok _ko ->
		ok (reader_indent ro) $
			TLB.singleton '\n' <>
			fromString (List.replicate (fromIntegral $ reader_indent ro) ' ')
instance Wrapable Term where
	ifWrap y x = Term $ \ro st ok ko ->
		unTerm x ro st ok (\_sx _tx -> unTerm y ro st ok ko)
	breakpoint onNoBreak onBreak t = Term $ \ro st ok ko ->
		unTerm (onNoBreak <> t) ro st ok
		 (\_sp _tp -> unTerm (onBreak <> t) ro st ok ko)
	withWrapColumn col t = Term $ \ro -> unTerm t ro{reader_wrap_column=col}

writeSGR :: SGR -> Term -> Term
writeSGR s (Term t) =
	Term $ \ro ->
		if reader_colorable 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{reader_sgr=s:reader_sgr ro}
	c = Term $ \ro st ok _ko -> ok st $ fromString $ setSGRCode $ Reset:List.reverse (reader_sgr ro)

instance Colorable Term where
	colorable f       = Term $ \ro -> unTerm (f (reader_colorable ro)) ro
	withColorable b t = Term $ \ro -> unTerm 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 Term where
	decorable f       = Term $ \ro -> unTerm (f (reader_decorable ro)) ro
	withDecorable b t = Term $ \ro -> unTerm t ro{reader_decorable=b}
	bold        = writeSGR $ SetConsoleIntensity BoldIntensity
	underline   = writeSGR $ SetUnderlining SingleUnderline
	italic      = writeSGR $ SetItalicized True