Term.hs

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.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 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_sgr       :: ![SGR]          -- ^ Active ANSI codes.
 ,   reader_breakable :: !(Maybe Column) -- ^ 'Column' after which to break, or 'Nothing'
 ,   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_sgr       = []
 , reader_breakable = Nothing
 , 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-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 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
		(case reader_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 (reader_newline ro) ro
instance Indentable 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
	indent f = Term $ \ro -> unTerm (f (reader_indent ro)) ro
	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 Breakable Term where
	breakable f       = Term $ \ro -> unTerm (f (reader_breakable ro)) ro
	withBreakable b t = Term $ \ro -> unTerm t ro{reader_breakable=b}
	ifBreak y x = Term $ \ro st ok ko ->
		unTerm x ro st ok $
		case reader_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 reader_breakable ro of
		 Nothing -> ko
		 Just{}  -> (\_sp _tp -> unTerm (onBreak <> t) ro st ok ko)

writeSGR :: (Reader -> 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{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 reader_colorable $ SetSwapForegroundBackground True
	black       = writeSGR reader_colorable $ SetColor Foreground Dull  Black
	red         = writeSGR reader_colorable $ SetColor Foreground Dull  Red
	green       = writeSGR reader_colorable $ SetColor Foreground Dull  Green
	yellow      = writeSGR reader_colorable $ SetColor Foreground Dull  Yellow
	blue        = writeSGR reader_colorable $ SetColor Foreground Dull  Blue
	magenta     = writeSGR reader_colorable $ SetColor Foreground Dull  Magenta
	cyan        = writeSGR reader_colorable $ SetColor Foreground Dull  Cyan
	white       = writeSGR reader_colorable $ SetColor Foreground Dull  White
	blacker     = writeSGR reader_colorable $ SetColor Foreground Vivid Black
	redder      = writeSGR reader_colorable $ SetColor Foreground Vivid Red
	greener     = writeSGR reader_colorable $ SetColor Foreground Vivid Green
	yellower    = writeSGR reader_colorable $ SetColor Foreground Vivid Yellow
	bluer       = writeSGR reader_colorable $ SetColor Foreground Vivid Blue
	magentaer   = writeSGR reader_colorable $ SetColor Foreground Vivid Magenta
	cyaner      = writeSGR reader_colorable $ SetColor Foreground Vivid Cyan
	whiter      = writeSGR reader_colorable $ SetColor Foreground Vivid White
	onBlack     = writeSGR reader_colorable $ SetColor Background Dull  Black
	onRed       = writeSGR reader_colorable $ SetColor Background Dull  Red
	onGreen     = writeSGR reader_colorable $ SetColor Background Dull  Green
	onYellow    = writeSGR reader_colorable $ SetColor Background Dull  Yellow
	onBlue      = writeSGR reader_colorable $ SetColor Background Dull  Blue
	onMagenta   = writeSGR reader_colorable $ SetColor Background Dull  Magenta
	onCyan      = writeSGR reader_colorable $ SetColor Background Dull  Cyan
	onWhite     = writeSGR reader_colorable $ SetColor Background Dull  White
	onBlacker   = writeSGR reader_colorable $ SetColor Background Vivid Black
	onRedder    = writeSGR reader_colorable $ SetColor Background Vivid Red
	onGreener   = writeSGR reader_colorable $ SetColor Background Vivid Green
	onYellower  = writeSGR reader_colorable $ SetColor Background Vivid Yellow
	onBluer     = writeSGR reader_colorable $ SetColor Background Vivid Blue
	onMagentaer = writeSGR reader_colorable $ SetColor Background Vivid Magenta
	onCyaner    = writeSGR reader_colorable $ SetColor Background Vivid Cyan
	onWhiter    = writeSGR reader_colorable $ 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 reader_decorable $ SetConsoleIntensity BoldIntensity
	underline = writeSGR reader_decorable $ SetUnderlining SingleUnderline
	italic    = writeSGR reader_decorable $ SetItalicized True