{-# OPTIONS_GHC -fffi #-}
{-# CFILES gwinsz.c #-}
module Graphics.Vty (Vty(..), beep, mkVty, module Graphics.Vty.Types, Key(..), Modifier(..), Button(..), Event(..)) where

import Control.Concurrent

import Graphics.Vty.Types hiding (Color, Attr, Image, fillSeg)
import Graphics.Vty.Types (Color(), Attr(), Image())
import qualified Graphics.Vty.Types as T(Color(..), Attr(..), Image(..), fillSeg)
import Graphics.Vty.Cursor
import Graphics.Vty.LLInput

import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import Foreign.Marshal.Error
import Foreign.Storable
import Foreign.Ptr

-- |The main object.  At most one should be created.
data Vty = Vty { -- |Update the screen to reflect the contents of a 'Picture'.
                 -- This is not currently threadsafe.
                 update :: Picture -> IO (),
                 -- |Get one Event object, blocking if necessary.
		 getEvent :: IO Event,
                 -- |Get the size of the display.
                 getSize :: IO (Int,Int),
                 -- |Clean up after vty.
                 shutdown :: IO () }

-- |Set up the state object for using vty.  At most one state object should be
-- created at a time.
mkVty :: IO Vty
mkVty = do (tstate, endo) <- initTermOutput
           (kvar, endi) <- initTermInput
           state <- newMVar =<< fmap ((,,,) tstate (-1) (-1)) (mallocArray 2)
           intMkVty kvar (endi >> endo) state

intMkVty :: IO Event -> IO () -> MVar (TermState, Int, Int, Ptr Int) -> IO Vty
intMkVty kvar fend rstate = return rec where

 ulift :: (TermState -> IO (a, TermState)) -> IO a
 ulift f = modifyMVar rstate (\(v,a,b,c) -> fmap (\(x,y) -> ((y,a,b,c),x)) (f v))

 rec = Vty { update = update' , getEvent = gkey , getSize = ulift getwinsize ,
             shutdown = fend }

 update' (Pic nc (T.Image wr w h)) = modifyMVar_ rstate $ \(ts0, fbw, fbh, oldptr) -> do
   (shd,ts1) <- case (fbw,fbh) == (w,h) of
                  True -> return (oldptr,ts0)
                  False -> do new <- throwIfNull "clrscr realloc" $ reallocArray oldptr (w * h * 2)
                              T.fillSeg attr ' ' new (new `advancePtr` (w * h * 2))
                              fmap ((,) new) (clrscr ts0)
   fb <- throwIfNull "update alloc" $ mallocArray (w * h * 2)
   wr (w * 2 * sizeOf (undefined :: Int)) fb
   ts2 <- diffs w h shd fb ts1
   ts3 <- case nc of NoCursor   -> setCursorInvis ts2
                     Cursor x y -> move w x y ts2 >>= setCursorVis
   ts4 <- flush ts3
   free shd
   return (ts4, w, h, fb)

 inval = modifyMVar rstate $ \(ts0,_,_,p) ->
         fmap (\((x,y),ts1) -> ((ts1,(-1),(-1),p),EvResize x y)) (getwinsize ts0)

 gkey = do k <- kvar
           case k of (EvKey (KASCII 'l') [MCtrl]) -> inval
                     (EvResize _ _)               -> inval
                     _                            -> return k