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