1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
|
{-# OPTIONS_GHC -fffi -Wall #-}
{-# CFILES gwinsz.c #-}
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
-- | An object representing the current state of the terminal.
data TermState = TS !Int !Int !Attr
-- | Set up the terminal for output, and create an object representing the
-- initial state. Also returns a function for shutting down the terminal access.
initTermOutput :: IO (TermState, IO ())
initTermOutput = do putStr reset
let uninit = do (_,sy) <- getwinsize_
putStr (endterm sy)
hFlush stdout
return (TS 0 0 attr, uninit)
-- | Force sent commands to be respected.
flush :: TermState -> IO TermState
flush ts = hFlush stdout >> return ts
-- | Move the cursor to (x,y); sx is the current width of the screen.
-- (this is a bit of a hack, forcing clients to cache that data)
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)
-- | Put a (char,attr) at a given (x,y) cursor position; sx is the
-- current width of the screen. (this is a bit of a hack, forcing
-- clients to cache that data)
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)
-- | Reset the screen.
clrscr :: TermState -> IO TermState
clrscr _ts = do putStr reset
return (TS 0 0 attr)
-- | Make the cursor invisible.
setCursorInvis :: TermState -> IO TermState
setCursorInvis ts = putStr civis >> return ts
-- | Make the cursor visible.
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'
-- ANSI specific bits
chgatt :: Attr -> IO ()
chgatt (Attr bf)
= putStr "\ESC[0;3" >> putShow (bf .&. 0xFF) >> putStr ";4" >> putShow ((bf `shiftR` 8) .&. 0xFF) >> 0x10000 ? ";1" >>
0x20000 ? ";5" >> 0x40000 ? ";7" >> 0x80000 ? ";2" >> 0x100000 ? ";4" >> putStr "m"
where
{-# INLINE (?) #-}
(?) :: 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
-- we always use absolute motion between lines to work around diffs
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'
{-# INLINE movcsr #-}
putShow :: Int -> IO ()
putShow n = when (ini /= 0) (putShow ini) >> putChar (toEnum (lst + 48))
where (ini, lst) = divMod n 10
-- {-# INLINE putShow #-}
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)
cvis, civis, reset :: [Char]
reset = "\ESCc\ESC%G\ESC[1;1H\ESC[2J"
-- | Make the terminal beep.
beep :: IO ()
beep = putStr "\BEL" ; cvis = "\ESC[?25h" ; civis = "\ESC[?25l"
endterm :: Int -> [Char]
endterm sy = "\ESC[" ++ show sy ++ ";1H\ESC[0;39;49m\ESC%@\CR\ESC[?25h\ESC[K"
|
