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

import Language.Symantic.Document.Sym

-- * Type 'Reader'
data Reader
 =   Reader
 {   reader_indent    :: !Indent         -- ^ Current indentation level, used by 'newline'.
 ,   reader_newline   :: TermIO          -- ^ How to display 'newline'.
 ,   reader_sgr       :: ![SGR]          -- ^ Active ANSI codes.
 ,   reader_handle    :: !IO.Handle      -- ^ Where to write.
 ,   reader_breakable :: !(Maybe Column) -- ^ 'Column' after which to break.
 ,   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_handle      = IO.stdout
 , reader_breakable   = Nothing
 , reader_colorable   = True
 , reader_decorable   = True
 }

-- * Type 'State'
type State = Column

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

-- * Type 'TermIO'
newtype TermIO
 =      TermIO
 {    unTermIO :: Reader -> State ->
                  (State -> IO () -> IO ()) -> -- normal continuation
                  (State -> IO () -> IO ()) -> -- should-break continuation
                  IO () }

-- | Write a 'TermIO'.
runTermIO :: IO.Handle -> TermIO -> IO ()
runTermIO h (TermIO t) = t defReader{reader_handle=h} defState oko oko
        where oko _st = id

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

writeH :: Column -> (IO.Handle -> IO ()) -> TermIO
writeH len t =
        TermIO $ \ro st ok ko ->
                let newCol = st + len in
                (case reader_breakable ro of
                 Just breakCol | breakCol < newCol -> ko
                 _ -> ok)
                newCol (t (reader_handle ro))

instance Textable TermIO where
        empty     = TermIO $ \_ro st ok _ko -> ok st mempty
        charH   t = writeH 1 (`IO.hPutChar` t)
        stringH t = writeH (length t) (`IO.hPutStr` t)
        textH   t = writeH (length t) (`Text.hPutStr` t)
        ltextH  t = writeH (length t) (`TL.hPutStr` t)
        newline   = TermIO $ \ro -> unTermIO (reader_newline ro) ro
instance Indentable TermIO where
        align t = TermIO $ \ro st -> unTermIO t ro{reader_indent=st} st
        withNewline nl  t = TermIO $ \ro -> unTermIO t ro{reader_newline=nl}
        withIndent  ind t = TermIO $ \ro -> unTermIO t ro{reader_indent=ind}
        incrIndent  ind t = TermIO $ \ro -> unTermIO t ro{reader_indent=reader_indent ro + ind}
        column f = TermIO $ \ro st -> unTermIO (f st) ro st
        indent f = TermIO $ \ro -> unTermIO (f (reader_indent ro)) ro
        newlineWithoutIndent = TermIO $ \ro _st ok _ko ->
                ok 0 $ IO.hPutChar (reader_handle ro) '\n'
        newlineWithIndent = TermIO $ \ro@Reader{reader_handle=h} _st ok _ko ->
                ok (reader_indent ro) $ do
                        IO.hPutChar h '\n'
                        IO.hPutStr h $ List.replicate (fromIntegral $ reader_indent ro) ' '
instance Breakable TermIO where
        breakable f       = TermIO $ \ro -> unTermIO (f (reader_breakable ro)) ro
        withBreakable b t = TermIO $ \ro -> unTermIO t ro{reader_breakable=b}
        ifBreak y x = TermIO $ \ro st ok ko ->
                unTermIO x ro st ok $
                case reader_breakable ro of
                 Nothing -> ko
                 Just{} -> (\_sx _tx -> unTermIO y ro st ok ko)
        breakpoint onNoBreak onBreak t = TermIO $ \ro st ok ko ->
                unTermIO (onNoBreak <> t) ro st ok $
                case reader_breakable ro of
                 Nothing -> ko
                 Just{} -> (\_sp _tp -> unTermIO (onBreak <> t) ro st ok ko)

writeSGR :: (Reader -> Bool) -> SGR -> TermIO -> TermIO
writeSGR isOn s (TermIO t) =
        TermIO $ \ro ->
                if isOn ro
                then unTermIO (o <> m <> c) ro
                else t ro
        where
        o = TermIO $ \ro st ok _ko -> ok st $ hSetSGR (reader_handle ro) [s]
        m = TermIO $ \ro -> t ro{reader_sgr=s:reader_sgr ro}
        c = TermIO $ \ro st ok _ko -> ok st $ hSetSGR (reader_handle ro) $ Reset:List.reverse (reader_sgr ro)

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