module Graphics.Vty.Types where

import Data.Bits( (.&.), (.|.), shiftL )

import Foreign.Ptr
import Foreign.Storable
import Foreign.C.Types (CChar)
import Foreign.Marshal.Array
import qualified Data.ByteString as B

infixr 5 <|>
infixr 4 <->

-- |This type represents the visible cursor state.
data Cursor = NoCursor -- ^ Hide the cursor.
            | Cursor Int Int -- ^ Display the cursor at the given XY position.

-- Gah. GHC can't unbox bitfields itself :(

-- | Opaque data type representing character attributes.
newtype Attr = Attr Int deriving (Eq)

-- | Set the foreground color of an `Attr'.
setFG :: Color -> Attr -> Attr
setFG (Color c) (Attr a) = Attr ((a .&. 0xFFFFFF00) .|. c)

-- | Set the background color of an `Attr'.
setBG :: Color -> Attr -> Attr
setBG (Color c) (Attr a) = Attr ((a .&. 0xFFFF00FF) .|. (c `shiftL` 8))

-- | Set bold attribute of an `Attr'.
setBold :: Attr -> Attr
setBold (Attr a) = Attr (a .|. 0x10000)

-- | Set blink attribute of an `Attr'.
setBlink :: Attr -> Attr
setBlink (Attr a) = Attr (a .|. 0x20000)

-- | Set reverse-video attribute of an `Attr'.
setRV :: Attr -> Attr
setRV (Attr a) = Attr (a .|. 0x40000)

-- | Set half-bright attribute of an `Attr'.
setHalfBright :: Attr -> Attr
setHalfBright (Attr a) = Attr (a .|. 0x80000)

-- | Set underline attribute of an `Attr'.
setUnderline :: Attr -> Attr
setUnderline (Attr a) = Attr (a .|. 0x100000)

-- |'Attr' with all default values.
attr :: Attr
attr = Attr 0x909

-- |Abstract data type representing a color.
newtype Color = Color Int deriving(Eq)

-- FIXME: this assumes a 8-color terminal.
-- |Basic color definitions.
black, red, green, yellow, blue, magenta, cyan, white, def :: Color
black  = Color 0 ; red    = Color 1 ; green  = Color 2 ; yellow = Color 3
blue   = Color 4 ; magenta= Color 5 ; cyan   = Color 6 ; white  = Color 7
def    = Color 9

-- This uses a somewhat tricky implementation, for efficiency.

-- |A two-dimensional array of (Char,Attr) pairs.
data Image = Image (Int -> Ptr Int -> IO ()) !Int !Int

-- | The empty image.
empty :: Image
empty = Image (\_ _ -> return ()) 0 0

-- | Compose two images side by side.  The images must of the same height,
-- or one must be empty.
(<|>) :: Image -> Image -> Image
Image f1 x1 y1 <|> Image f2 x2 y2 | y1 == y2 || x1 == 0 || x2 == 0 =
                 Image (\stride ptr -> do f1 stride ptr
                                          f2 stride (ptr `plusPtr` ((sizeOf (undefined :: Int) * 2) * x1)))
                       (x1+x2) y1
_ <|> _ = error "Graphics.Vty.(<|>) : image heights do not match"

-- | Compose two images vertically.  The images must of the same width,
-- or one must be empty.
(<->) :: Image -> Image -> Image
Image f1 x1 y1 <-> Image f2 x2 y2 | x1 == x2 || y1 == 0 || y2 == 0 =
                 Image (\stride ptr -> do f1 stride ptr
                                          f2 stride (ptr `plusPtr` (stride * y1)))
                       x1 (y1+y2)
_ <-> _ = error "Graphics.Vty.(<->) : image widths do not match"

-- | Helper - fill a buffer segment with a char\/attr.
fillSeg :: Attr -> Char -> Ptr Int -> Ptr Int -> IO ()
fillSeg (Attr a) ch p1 pe = a `seq` ch `seq` pe `seq` worker p1
    where
      worker p | p == pe   = return ()
               | otherwise = do pokeElemOff p 0 a
                                pokeElemOff p 1 (fromEnum ch)
                                worker (p `advancePtr` 2)

-- | Compose any number of images horizontally.
horzcat :: [Image] -> Image
horzcat = foldr (<|>) empty

-- | Compose any number of images vertically.
vertcat :: [Image] -> Image
vertcat = foldr (<->) empty

-- | Create an `Image' from a `B.ByteString' with a single uniform `Attr'.
renderBS :: Attr -> B.ByteString -> Image
renderBS (Attr a) bs = a `seq` Image (\ _stride ptr -> B.useAsCStringLen bs (worker ptr)) (B.length bs) 1
    where
      worker :: Ptr Int -> (Ptr CChar, Int) -> IO ()
      worker _op (_ip, 0) = return ()
      worker op (ip, ct)  = do inp <- peek ip
                               pokeElemOff op 0 a
                               pokeElemOff op 1 (fromIntegral inp)
                               worker (op `advancePtr` 2) ((ip `advancePtr` 1), (ct - 1))

-- | Create a 1x1 image.  Warning, this is likely to be inefficient.
renderChar :: Attr -> Char -> Image
renderChar (Attr a) ch = a `seq` ch `seq` Image (\ _stride ptr -> pokeElemOff ptr 0 a >> pokeElemOff ptr 1 (fromEnum ch)) 1 1

-- | Create an image by repeating a single character and attribute horizontally.
renderHFill :: Attr -> Char -> Int -> Image
renderHFill a ch w = a `seq` ch `seq` Image (\ _stride ptr -> fillSeg a ch ptr (ptr `advancePtr` (2*w))) w 1

-- | Create an image by repeating a single character and attribute.
renderFill :: Attr -> Char -> Int -> Int -> Image
renderFill (Attr a) ch w h = a `seq` ch `seq` Image (worker h) w h
    where
      worker :: Int -> Int -> Ptr Int -> IO ()
      worker 0 _stride _ptr = return ()
      worker ct stride ptr = do let ptr2 = ptr `advancePtr` (2 * w)
                                fillSeg (Attr a) ch ptr ptr2
                                worker (ct - 1) stride ptr2

-- |The type of images to be displayed using 'update'.  You probably shouldn't
-- create this directly if you care about compatibility with future versions of
-- vty; instead use 'pic' and record update syntax.
data Picture = Pic { -- |The position and visibility status of the virtual
                     -- cursor.
                     pCursor :: Cursor,
                     -- |A 2d array of (character,attribute) pairs, representing
                     -- the screen image.
                     pImage :: Image }

-- |Create a 'Picture' object with all default values.  By using this and record
-- update, rather than directly using the Pic constructor, your code will be
-- compatible with additions to the Picture object. You must specify at least
-- 'pImage'.
pic :: Picture
pic = Pic { pCursor = NoCursor, pImage = error "Pic.pImage not initialized" }

-- |Representations of non-modifier keys.
data Key = KEsc | KFun Int | KPrtScr | KPause | KASCII Char | KBS | KIns
         | KHome | KPageUp | KDel | KEnd | KPageDown | KNP5 | KUp | KMenu
         | KLeft | KDown | KRight | KEnter deriving (Eq,Show,Ord)
-- |Modifier keys.  Key codes are interpreted such that users are more likely to
-- have Meta than Alt; for instance on the PC Linux console, 'MMeta' will
-- generally correspond to the physical Alt key.
data Modifier = MShift | MCtrl | MMeta | MAlt deriving (Eq,Show,Ord)
-- |Mouse buttons.  Not yet used.
data Button = BLeft | BMiddle | BRight deriving (Eq,Show,Ord)
-- |Generic events.
data Event = EvKey Key [Modifier] | EvMouse Int Int Button [Modifier]
           | EvResize Int Int deriving (Eq,Show,Ord)