module Graphics.Vty.Cursor
( TermState, diffs, move, initTermOutput, clrscr, getwinsize, beep, flush,
setCursorInvis, setCursorVis ) where
import Foreign.C.Types( CLong )
import Foreign.Ptr( Ptr )
import System.IO( stdout, hFlush )
import Foreign.Storable( peekElemOff, peek )
import Foreign.Marshal.Array( advancePtr )
import Control.Monad( when )
import Data.Bits( (.|.), (.&.), shiftR )
import Graphics.Vty.Types
data TermState = TS {_tsRow :: !Int, _tsColumn :: !Int, _tsAttr :: !Attr}
initTermOutput :: IO (TermState, IO ())
initTermOutput = do putStr reset
let uninit = do (_,sy) <- getwinsize_
putStr (endterm sy)
hFlush stdout
return (TS 0 0 attr, uninit)
flush :: TermState -> IO TermState
flush ts = hFlush stdout >> return ts
move :: Int -> Int -> Int -> TermState -> IO TermState
move sx x y (TS ox oy at) = do movcsr y oy x ox sx
return (TS x y at)
mvputch :: Int -> Int -> Int -> (Char,Attr) -> TermState -> IO TermState
mvputch sx x y (ch,att) ts | sx `seq` x `seq` y `seq` ch `seq` att `seq` ts `seq` False = undefined
mvputch sx x y (ch,att) (TS ox oy oat) = do movcsr y oy x ox sx
when (att /= oat) $ chgatt att
tputchar ch
return (TS (x+1) y att)
clrscr :: TermState -> IO TermState
clrscr _ts = do putStr reset
return (TS 0 0 attr)
setCursorInvis :: TermState -> IO TermState
setCursorInvis ts = putStr civis >> return ts
setCursorVis :: TermState -> IO TermState
setCursorVis ts = putStr cvis >> return ts
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 -> mvputch w x y (toEnum nwc, Attr nwa) stat
diffs' (x+1) y (olp `advancePtr` 2) (nwp `advancePtr` 2) stat'
chgatt :: Attr -> IO ()
chgatt (Attr bf)
= putStr "\ESC[0;" >>
putShow (bf .&. 0xFF) >>
putStr ";" >> putShow ((bf `shiftR` 8) .&. 0xFF) >>
0x10000 ? ";1" >>
0x20000 ? ";5" >> 0x40000 ? ";7" >> 0x80000 ? ";2" >> 0x100000 ? ";4" >>
putStr "m"
where
(?) :: Int -> [Char] -> IO ()
field ? x | bf .&. field == 0 = return ()
| otherwise = putStr x
tputchar :: Char -> IO ()
tputchar ch | ich < 0x80 = pch ich
| ich < 0x800 = pch (0xC0 .|. (ich `usr` 6)) >> pch (0x80 .|. (0x3F .&. ich))
| ich < 0x10000 = pch (0xE0 .|. (ich `usr` 12)) >> pch (0x80 .|. (0x3F .&. (ich `usr` 6))) >>
pch (0x80 .|. (0x3F .&. ich))
| otherwise = pch (0xF0 .|. (ich `usr` 24)) >> pch (0x80 .|. (0x3F .&. (ich `usr` 12))) >>
pch (0x80 .|. (0x3F .&. (ich `usr` 6))) >> pch (0x80 .|. (0x3F .&. ich))
where ich = fromEnum ch
pch = putChar . toEnum
usr = shiftR
movcsr :: Int -> Int -> Int -> Int -> Int -> IO ()
movcsr y oy x ox wid
| y /= oy || ox == wid = putStr "\ESC[" >> putShow (y+1) >> putChar ';' >> putShow (x+1) >> putChar 'H'
| x == ox = return ()
| x == (ox + 1) = putStr "\ESC[C"
| x > ox = putStr "\ESC[" >> putShow (x ox) >> putChar 'C'
| otherwise = putStr "\ESC[" >> putShow (ox x) >> putChar 'D'
putShow :: Int -> IO ()
putShow n = when (ini /= 0) (putShow ini) >> putChar (toEnum (lst + 48))
where (ini, lst) = divMod n 10
foreign import ccall "gwinsz.h c_get_window_size" c_get_window_size :: IO CLong
getwinsize_ :: IO (Int,Int)
getwinsize_ = do (a,b) <- (`divMod` 65536) `fmap` c_get_window_size
return (fromIntegral b, fromIntegral a)
getwinsize :: TermState -> IO ((Int,Int), TermState)
getwinsize ts = do (a,b) <- (`divMod` 65536) `fmap` c_get_window_size
return ((fromIntegral b, fromIntegral a), ts)
csi, cvis, civis, reset :: String
csi = "\ESC["
reset = "\ESCc" ++
utf8CharSet ++
setCursorPosition 1 1 ++
"\ESC[2J"
setCursorPosition :: Int -> Int -> String
setCursorPosition row column = csi ++ show row ++ ";" ++ show column ++ "H"
beep :: IO ()
beep = putStr "\BEL"
cvis = csi ++ "?25h"
civis = csi ++ "?25l"
defaultCharSet, utf8CharSet :: String
defaultCharSet = "\ESC%@"
utf8CharSet = "\ESC%G"
endterm :: Int -> [Char]
endterm sy = setCursorPosition sy 1 ++
"\ESC[0;39;49m" ++
defaultCharSet ++
"\CR" ++
cvis ++
"\ESC[K"