vty-3.1.8: Graphics/Vty.hs

{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-}
{-# CFILES gwinsz.c #-}

-- Good sources of documentation for terminal programming are:
-- vt100 control sequences: http://vt100.net/docs/vt100-ug/chapter3.html#S3.3.3
-- Xterm control sequences: http://invisible-island.net/xterm/ctlseqs/ctlseqs.html

module Graphics.Vty ( Vty(..)
                    , beep
                    , mkVty
                    , mkVtyEscDelay
                    , module Graphics.Vty.Types
                    , Key(..)
                    , Modifier(..)
                    , Button(..)
                    , Event(..)
                    ) 
    where

import Control.Concurrent

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

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

import System.Console.Terminfo

-- |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),
                 -- |Refresh the display. Normally the library takes care of refreshing. 
                 -- Nonetheless, some other program might output to the terminal and mess the display.
                 -- In that case the user might want to force a refresh.
                 refresh :: IO (),
                 -- |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 = mkVtyEscDelay 0

mkVtyEscDelay :: Int -> IO Vty
mkVtyEscDelay escDelay = do 
    terminal <- setupTermFromEnv 
    (tstate, endo) <- initTermOutput terminal
    (kvar, endi) <- initTermInput escDelay terminal
    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 $ Vty { update = update' 
                 , getEvent = gkey
                 , getSize = ulift getwinsize
                 , refresh = refr
                 , shutdown = fend 
                 }
    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))

        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)

        -- just refresh
        refr = modifyMVar_ rstate $ \(ts0,_,_,p) -> 
            fmap (\(_,ts1) -> (ts1,(-1),(-1),p)) (getwinsize ts0)

        -- refresh and return a state event
        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 
                    (EvResize _ _)  -> inval
                    _               -> return k

{- |Given the width and height of a text region along with the old text for the region and the new
 - text for the region this only outputs the changes between the two regions to the terminal.
 - TODO: This needs to be updated to account for issue #10. 
 -}
diffs :: Int -> Int -> Ptr Int -> Ptr Int -> TermState -> IO TermState
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
            | 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  -> mvputch w x y (toEnum nwc) (Attr nwa) stat
                             diffs' (x+1) y (olp `advancePtr` 2) (nwp `advancePtr` 2) stat'