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.Int (Int)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import GHC.Exts (IsList(..))
import Prelude ((+), pred)
import System.Console.ANSI
import Text.Show (Show(..))
import qualified Data.List as List
import qualified Data.Text as Text
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 Term) -- ^ Current indentation level, used by 'newline'.
 ,   reader_newline     :: Term           -- ^ How to display 'newline'.
 ,   reader_wrap_column :: !(Column Term) -- ^ '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 = 80
 , reader_sgr         = []
 , reader_colorable   = True
 , reader_decorable   = True
 }

-- * Type 'State'
type State = Column Term

-- | 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 }

type instance Column Term = Int
type instance Indent Term = Int

-- | 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 Term -> 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 Doc_Text Term where
	empty     = Term $ \_ro st ok _ko -> ok st mempty
	charH   t = writeH 1 $ TLB.singleton t
	stringH t = writeH (List.length t) (fromString t)
	textH   t = writeH (Text.length t) (TLB.fromText t)
	ltextH  t = writeH (intOfInt64 $ TL.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 Doc_Align 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 (reader_indent ro) ' ')
instance Doc_Wrap Term where
	ifFit x y = 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 Doc_Color 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 Doc_Decoration 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