vty-3.0.0: Graphics/Vty.hs

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

import Data.IORef( IORef, newIORef, readIORef, writeIORef )
import Control.Concurrent

import Control.Monad( when, liftM )

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 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, kvar, end) <- initTerm
           rtstate <- newMVar tstate
           rlast <- newIORef pic
           shadow <- newIORef =<< liftM (\x -> (,,,) x (-1) (-1) NoCursor) (mallocArray 2)
           intMkVty kvar end rlast rtstate shadow

intMkVty :: IO Event -> IO () -> IORef Picture -> MVar TermState -> IORef (Ptr Int, Int, Int, Cursor) -> IO Vty
intMkVty kvar fend rlast rtstate rshadow = ulift getwinsize >>= uncurry clrscr' >> return rec where

 ulift_ :: (TermState -> IO TermState) -> IO ()
 ulift_ f = modifyMVar_ rtstate f

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

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

 clrscr' x y = do ulift_ clrscr
                  (old,_,_,cp) <- readIORef rshadow
                  free old
                  new <- throwIfNull "clrscr realloc" $ mallocArray (x * y * 2)
                  T.fillSeg attr ' ' new (new `advancePtr` (x * y * 2))
                  writeIORef rshadow (new, x, y, cp)


 update' l@(Pic nc (T.Image wr w h)) = do
   do (_, fbw, fbh, _) <- readIORef rshadow
      when (fbw /= w || fbh /= h) $ clrscr' w h
   (shd, _, _, _) <- readIORef rshadow
   fb <- throwIfNull "update alloc" $ mallocArray (w * h * 2)
   wr (w * 2 * sizeOf (undefined :: Int)) fb
   writeIORef rshadow (fb, w, h, nc)
   ulift_ (\ st -> do st' <- diffs w h shd fb st
                      st'' <- case nc of NoCursor   -> setCursorInvis st'
                                         Cursor x y -> move w x y st' >>= setCursorVis
                      flush st'')
   free shd
   writeIORef rlast l

 refresh = do ofb@(Pic _ (T.Image _ w h)) <- readIORef rlast ; clrscr' w h; update' ofb

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

diffs :: Int -> Int -> Ptr Int -> Ptr Int -> TermState -> IO TermState
diffs w h old new state | w `seq` h `seq` old `seq` new `seq` state `seq` False = undefined
diffs w h old new state = diffs' 0 0 old new state
    where
      diffs' :: Int -> Int -> Ptr Int -> Ptr Int -> TermState -> IO TermState
      diffs' x y olp nwp stat
          | x `seq` y `seq` olp `seq` nwp `seq` stat `seq` False = undefined
          | y == h = return stat
          | x == w = diffs' 0 (y+1) olp nwp stat
          | otherwise = do ola <- peek olp
                           nwa <- peek nwp
                           olc <- peekElemOff olp 1
                           nwc <- peekElemOff nwp 1
                           stat' <- case (ola /= nwa || olc /= nwc) of
                                      False -> return stat
                                      True  -> move w x y stat >>= putch (toEnum nwc, T.Attr nwa)
                           diffs' (x+1) y (olp `advancePtr` 2) (nwp `advancePtr` 2) stat'