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
data Vty = Vty {
update :: Picture -> IO (),
getEvent :: IO Event,
getSize :: IO (Int,Int),
refresh :: IO (),
shutdown :: IO ()
}
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)
refr = modifyMVar_ rstate $ \(ts0,_,_,p) ->
fmap (\(_,ts1) -> (ts1,(1),(1),p)) (getwinsize ts0)
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
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'