-- Copyright 2009-2010 Corey O'Connor
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
module Graphics.Vty.Terminal.XTermColor ( terminal_instance
                                        )
    where

import Graphics.Vty.Terminal.Generic
import qualified Graphics.Vty.Terminal.TerminfoBased as TerminfoBased

import Control.Applicative
import Control.Monad.Trans

import qualified Data.String.UTF8 as UTF8

import System.IO

data XTermColor = XTermColor 
    { xterm_variant :: String
    , super_term :: TerminalHandle
    }

-- Initialize the display to UTF-8
-- Regardless of what is output the text encoding is assumed to be UTF-8
terminal_instance :: ( Applicative m, MonadIO m ) => String -> m XTermColor
terminal_instance variant = do
    -- If the terminal variant is xterm-color use xterm instead since, more often than not,
    -- xterm-color is broken.
    let variant' = if variant == "xterm-color" then "xterm" else variant
    flushed_put set_utf8_char_set
    t <- TerminfoBased.terminal_instance variant' >>= new_terminal_handle
    return $ XTermColor variant' t

flushed_put :: MonadIO m => String -> m ()
flushed_put str = do
    liftIO $ hPutStr stdout str
    liftIO $ hFlush stdout

-- Since I don't know of a terminfo string cap that produces these strings these are hardcoded.
set_utf8_char_set, set_default_char_set :: String
set_utf8_char_set = "\ESC%G"
set_default_char_set = "\ESC%@"

instance Terminal XTermColor where
    terminal_ID t = (show $ xterm_variant t) ++ " :: XTermColor"

    release_terminal t = do 
        flushed_put set_default_char_set
        release_terminal $ super_term t

    reserve_display t = reserve_display (super_term t)

    release_display t = release_display (super_term t)

    display_terminal_instance t b c = do
        d <- display_context (super_term t) b
        return $ c (DisplayContext d)

    display_bounds t = display_bounds (super_term t)
        
    output_byte_buffer t = output_byte_buffer (super_term t)

    output_handle t = output_handle (super_term t)

data DisplayContext = DisplayContext
    { super_display :: DisplayHandle
    }

instance DisplayTerminal DisplayContext where
    context_region d = context_region (super_display d)

    context_color_count d = context_color_count (super_display d)

    move_cursor_required_bytes d = move_cursor_required_bytes (super_display d)
    serialize_move_cursor d = serialize_move_cursor (super_display d)

    show_cursor_required_bytes d = show_cursor_required_bytes (super_display d)
    serialize_show_cursor d = serialize_show_cursor (super_display d)

    hide_cursor_required_bytes d = hide_cursor_required_bytes (super_display d)
    serialize_hide_cursor d = serialize_hide_cursor (super_display d)

    attr_required_bytes d = attr_required_bytes (super_display d)
    serialize_set_attr d = serialize_set_attr (super_display d)

    default_attr_required_bytes d = default_attr_required_bytes (super_display d)
    serialize_default_attr d = serialize_default_attr (super_display d)

    -- I think xterm is broken: Reseting the background color as the first bytes serialized on a new
    -- line does not effect the background color xterm uses to clear the line. Which is used *after*
    -- the next newline.
    inline_hack d = do
        let t = case super_display d of
                    DisplayHandle _ t_ _ -> t_
        let s_utf8 = UTF8.fromString "\ESC[K"
        liftIO $ marshall_to_terminal t ( utf8_text_required_bytes s_utf8)
                                        ( serialize_utf8_text s_utf8 )