diff --git a/Graphics/Vty.hs b/Graphics/Vty.hs --- a/Graphics/Vty.hs +++ b/Graphics/Vty.hs @@ -1,19 +1,29 @@ -{-# LANGUAGE ForeignFunctionInterface #-} +{-# 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, module Graphics.Vty.Types, Key(..), Modifier(..), Button(..), Event(..)) where +module Graphics.Vty ( Vty(..) + , beep + , mkVty + , mkVtyEscDelay + , module Graphics.Vty.Types + , Key(..) + , Modifier(..) + , Button(..) + , Event(..) + ) + where import Control.Concurrent -import Graphics.Vty.Types hiding (Color, Attr, Image, fillSeg) -import Graphics.Vty.Types (Color(), Attr(), Image()) +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 @@ -21,12 +31,14 @@ 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, + getEvent :: IO Event, -- |Get the size of the display. getSize :: IO (Int,Int), -- |Refresh the display. Normally the library takes care of refreshing. @@ -34,51 +46,82 @@ -- In that case the user might want to force a refresh. refresh :: IO (), -- |Clean up after vty. - shutdown :: IO () } + 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, endo) <- initTermOutput - (kvar, endi) <- initTermInput - state <- newMVar =<< fmap ((,,,) tstate (-1) (-1)) (mallocArray 2) - intMkVty kvar (endi >> endo) state +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 rec where +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)) - 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) - rec = Vty { update = update' - , getEvent = gkey - , getSize = ulift getwinsize - , refresh = refr - , shutdown = fend } + -- just refresh + refr = modifyMVar_ rstate $ \(ts0,_,_,p) -> + fmap (\(_,ts1) -> (ts1,(-1),(-1),p)) (getwinsize ts0) - 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) + -- refresh and return a state event + inval = modifyMVar rstate $ \(ts0,_,_,p) -> + fmap (\((x,y),ts1) -> ((ts1,(-1),(-1),p),EvResize x y)) (getwinsize ts0) - -- just refresh - refr = modifyMVar_ rstate $ \(ts0,_,_,p) -> - fmap (\(_,ts1) -> (ts1,(-1),(-1),p)) (getwinsize ts0) + gkey = do k <- kvar + case k of + (EvResize _ _) -> inval + _ -> return k - -- refresh and return a state event - inval = modifyMVar rstate $ \(ts0,_,_,p) -> - fmap (\((x,y),ts1) -> ((ts1,(-1),(-1),p),EvResize x y)) (getwinsize ts0) +{- |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' - gkey = do k <- kvar - case k of (EvResize _ _) -> inval - _ -> return k + diff --git a/Graphics/Vty/ControlStrings.hs b/Graphics/Vty/ControlStrings.hs new file mode 100644 --- /dev/null +++ b/Graphics/Vty/ControlStrings.hs @@ -0,0 +1,16 @@ +module Graphics.Vty.ControlStrings + where + +csi, cvis, civis :: String + +csi = "\ESC[" + +setCursorPosition :: Int -> Int -> String +setCursorPosition row column = csi ++ show row ++ ";" ++ show column ++ "H" + +-- | Show the cursor +cvis = csi ++ "?25h" + +-- | Hide the cursor +civis = csi ++ "?25l" + diff --git a/Graphics/Vty/Cursor.hs b/Graphics/Vty/Cursor.hs --- a/Graphics/Vty/Cursor.hs +++ b/Graphics/Vty/Cursor.hs @@ -1,37 +1,33 @@ -{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-} {-# 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 ) +module Graphics.Vty.Cursor ( move + , setCursorInvis + , setCursorVis + , mvputch + ) + where import Graphics.Vty.Types +import Graphics.Vty.ControlStrings +import Graphics.Vty.Output ( chgatt + ,tputchar + ,putShow + ) --- | An object representing the current state of the terminal. -data TermState = TS {_tsRow :: !Int, _tsColumn :: !Int, _tsAttr :: !Attr} +import Control.Monad ( when ) --- | 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) +{- +import Data.Bits ( (.|.), (.&.), shiftR ) +import Data.Maybe ( maybe ) --- | Force sent commands to be respected. -flush :: TermState -> IO TermState -flush ts = hFlush stdout >> return ts +import Foreign.C.Types ( CLong ) +import Foreign.Ptr ( Ptr ) +import Foreign.Storable ( peekElemOff, peek ) +import Foreign.Marshal.Array ( advancePtr ) +import System.IO ( stdout, hFlush ) +-} + -- | 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 @@ -41,17 +37,12 @@ -- | 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) +mvputch :: Int -> Int -> Int -> Char -> Attr -> TermState -> IO TermState +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) -- | Make the cursor invisible. setCursorInvis :: TermState -> IO TermState @@ -61,51 +52,6 @@ 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;" >> - putShow (bf .&. 0xFF) >> - putStr ";" >> 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 @@ -115,55 +61,4 @@ | 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) - - -csi, cvis, civis, reset :: String - -csi = "\ESC[" - -reset = "\ESCc" ++ -- full reset - utf8CharSet ++ - setCursorPosition 1 1 ++ - "\ESC[2J" -- erase all - -setCursorPosition :: Int -> Int -> String -setCursorPosition row column = csi ++ show row ++ ";" ++ show column ++ "H" - --- | Make the terminal beep. -beep :: IO () -beep = putStr "\BEL" - --- | Show the cursor -cvis = csi ++ "?25h" - --- | Hide the cursor -civis = csi ++ "?25l" - -defaultCharSet, utf8CharSet :: String -defaultCharSet = "\ESC%@" -utf8CharSet = "\ESC%G" - --- | Restore the terminal to a good state for the shell. --- Parameter is the line where the cursor should appear. -endterm :: Int -> [Char] -endterm sy = setCursorPosition sy 1 ++ - "\ESC[0;39;49m" ++ -- graphic rendition - defaultCharSet ++ - "\CR" ++ - cvis ++ - "\ESC[K" -- erase line - diff --git a/Graphics/Vty/LLInput.hs b/Graphics/Vty/LLInput.hs --- a/Graphics/Vty/LLInput.hs +++ b/Graphics/Vty/LLInput.hs @@ -1,10 +1,16 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE ForeignFunctionInterface #-} -module Graphics.Vty.LLInput - ( Key(..), Modifier(..), Button(..), Event(..), initTermInput ) where +module Graphics.Vty.LLInput ( Key(..) + , Modifier(..) + , Button(..) + , Event(..) + , initTermInput + ) + where import Data.Char -import Data.Maybe( mapMaybe ) +import Data.Maybe ( mapMaybe + ) import Data.List( inits ) import Data.Word import qualified Data.Map as M( fromList, lookup ) @@ -12,76 +18,97 @@ import Codec.Binary.UTF8.Generic (decode) +import Control.Monad (when) import Control.Concurrent import Control.Exception + +import System.Console.Terminfo + import System.Posix.Signals.Exts import System.Posix.Signals import System.Posix.Terminal -import System.Console.Terminfo - -import System.Posix.IO (stdInput, fdRead, setFdOption, FdOption(..)) +import System.Posix.IO ( stdInput + ,fdRead + ,setFdOption + ,FdOption(..) + ) -- |Representations of non-modifier keys. data Key = KEsc | KFun Int | KBackTab | KPrtScr | KPause | KASCII Char | KBS | KIns | KHome | KPageUp | KDel | KEnd | KPageDown | KNP5 | KUp | KMenu - | KLeft | KDown | KRight | KEnter deriving (Eq,Show,Ord) + | KLeft | KDown | KRight | KEnter + deriving (Eq,Show,Ord) + -- |Modifier keys. Key codes are interpreted such that users are more likely to -- have Meta than Alt; for instance on the PC Linux console, 'MMeta' will -- generally correspond to the physical Alt key. -data Modifier = MShift | MCtrl | MMeta | MAlt deriving (Eq,Show,Ord) +data Modifier = MShift | MCtrl | MMeta | MAlt + deriving (Eq,Show,Ord) + -- |Mouse buttons. Not yet used. -data Button = BLeft | BMiddle | BRight deriving (Eq,Show,Ord) +data Button = BLeft | BMiddle | BRight + deriving (Eq,Show,Ord) + -- |Generic events. data Event = EvKey Key [Modifier] | EvMouse Int Int Button [Modifier] - | EvResize Int Int deriving (Eq,Show,Ord) - ---import GHC.Conc (labelThread) -threadName :: String -> IO () ---threadName str = myThreadId >>= flip labelThread str -threadName _str = return () + | EvResize Int Int + deriving (Eq,Show,Ord) data KClass = Valid Key [Modifier] | Invalid | Prefix | MisPfx Key [Modifier] [Char] deriving(Show) -- | Set up the terminal for input. Returns a function which reads key -- events, and a function for shutting down the terminal access. -initTermInput :: IO (IO Event, IO ()) -initTermInput = do - threadName "main" +initTermInput :: Int -> Terminal -> IO (IO Event, IO ()) +initTermInput escDelay terminal = do eventChannel <- newChan inputChannel <- newChan + hadInput <- newEmptyMVar oattr <- getTerminalAttributes stdInput let nattr = foldl withoutMode oattr [StartStopOutput, KeyboardInterrupts, EnableEcho, ProcessInput] setTerminalAttributes stdInput nattr Immediately set_term_timing - terminal <- setupTermFromEnv - let inputToEventThread :: IO () - inputToEventThread = threadName "input_to_event" >> loop [] + inputToEventThread = loop [] where loop kb = case (classify kb) of Prefix -> do c <- readChan inputChannel loop (kb ++ [c]) Invalid -> loop "" MisPfx k m s -> writeChan eventChannel (EvKey k m) >> loop s Valid k m -> writeChan eventChannel (EvKey k m) >> loop "" + + finishAtomicInput = writeChan inputChannel '\xFFFE' + inputThread :: IO () - inputThread = threadName "input" >> loop + inputThread = loop where loop = do setFdOption stdInput NonBlockingRead False threadWaitRead stdInput setFdOption stdInput NonBlockingRead True try readAll :: IO (Either IOException ()) - writeChan inputChannel '\xFFFE' + when (escDelay == 0) finishAtomicInput loop readAll = do (bytes, bytes_read) <- fdRead stdInput 1 - if bytes_read > 0 - then writeChan inputChannel (head bytes) - else return () + when (bytes_read > 0) $ do + tryPutMVar hadInput () -- signal input + writeChan inputChannel (head bytes) readAll - + -- | If there is no input for some time, this thread puts '\xFFFE' in the + -- inputChannel. + noInputThread :: IO () + noInputThread = when (escDelay > 0) loop + where loop = do + takeMVar hadInput -- wait for some input + threadDelay escDelay -- microseconds + hadNoInput <- isEmptyMVar hadInput -- no input yet? + when hadNoInput $ do + finishAtomicInput + loop + + compile :: [[([Char],(Key,[Modifier]))]] -> [Char] -> KClass compile lst = cl' where lst' = concat lst @@ -99,7 +126,7 @@ classify, classifyTab :: [Char] -> KClass - classify "\xFFFD" = Invalid + -- As soon as classify "\xFFFE" = Invalid classify s@(c:_) | ord c >= 0xC2 = if utf8Length (ord c) > length s then Prefix else classifyUtf8 s -- beginning of an utf8 sequence @@ -170,14 +197,15 @@ eventThreadId <- forkIO $ inputToEventThread inputThreadId <- forkIO $ inputThread - let pokeIO = (Catch $ do threadName "winch|cont" - let e = error "(getsize in input layer)" + noInputThreadId <- forkIO $ noInputThread + let pokeIO = (Catch $ do let e = error "(getsize in input layer)" setTerminalAttributes stdInput nattr Immediately writeChan eventChannel (EvResize e e)) installHandler windowChange pokeIO Nothing installHandler continueProcess pokeIO Nothing let uninit = do killThread eventThreadId killThread inputThreadId + killThread noInputThreadId installHandler windowChange Ignore Nothing installHandler continueProcess Ignore Nothing setTerminalAttributes stdInput oattr Immediately diff --git a/Graphics/Vty/Output.hs b/Graphics/Vty/Output.hs new file mode 100644 --- /dev/null +++ b/Graphics/Vty/Output.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# CFILES gwinsz.c #-} +module Graphics.Vty.Output ( initTermOutput + , clrscr + , getwinsize + , beep + , flush + , tputchar + , chgatt + , putShow + ) + where + +import Graphics.Vty.Types +import Graphics.Vty.ControlStrings + +import Control.Monad ( when ) +import Data.Bits ( (.|.), (.&.), shiftR ) + +import Foreign.C.Types ( CLong ) + +import System.Console.Terminfo +import System.IO ( stdout, hFlush ) + +-- | 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 :: Terminal -> IO (TermState, IO ()) +initTermOutput terminal = do + let cap_smcup = getCapability terminal $ tiGetStr "smcup" + maybe (return ()) putStr cap_smcup + putStr reset + hFlush stdout + return (TS 0 0 attr, uninitTermOutput terminal) + +uninitTermOutput :: Terminal -> IO () +uninitTermOutput terminal = do + (_,sy) <- getwinsize_ + putStr (endterm sy) + let cap_rmcup = getCapability terminal $ tiGetStr "rmcup" + maybe (return ()) putStr cap_rmcup + hFlush stdout + +-- | Force sent commands to be respected. +flush :: TermState -> IO TermState +flush ts = hFlush stdout >> return ts + +-- | Reset the screen. +clrscr :: TermState -> IO TermState +clrscr _ts = do putStr reset + return (TS 0 0 attr) + +-- ANSI specific bits +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 + {-# 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 + +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) + +reset :: String +reset = -- "\ESCc" ++ -- full reset + utf8CharSet ++ + setCursorPosition 1 1 ++ + "\ESC[2J" -- erase all + +-- | Make the terminal beep. +beep :: IO () +beep = putStr "\BEL" + +-- | Restore the terminal to a good state for the shell. +-- Parameter is the line where the cursor should appear. +endterm :: Int -> [Char] +endterm sy = setCursorPosition sy 1 ++ + "\ESC[0;39;49m" ++ -- graphic rendition + defaultCharSet ++ + "\CR" ++ + cvis ++ + "\ESC[K" -- erase line + +defaultCharSet, utf8CharSet :: String +defaultCharSet = "\ESC%@" +utf8CharSet = "\ESC%G" + diff --git a/Graphics/Vty/Types.hs b/Graphics/Vty/Types.hs --- a/Graphics/Vty/Types.hs +++ b/Graphics/Vty/Types.hs @@ -1,4 +1,5 @@ -module Graphics.Vty.Types where +module Graphics.Vty.Types + where import Data.Bits( (.&.), (.|.), shiftL ) @@ -14,6 +15,9 @@ -- |This type represents the visible cursor state. data Cursor = NoCursor -- ^ Hide the cursor. | Cursor Int Int -- ^ Display the cursor at the given XY position. + +-- | An object representing the current state of the terminal. +data TermState = TS {_tsRow :: !Int, _tsColumn :: !Int, _tsAttr :: !Attr} -- Gah. GHC can't unbox bitfields itself :( diff --git a/vty.cabal b/vty.cabal --- a/vty.cabal +++ b/vty.cabal @@ -1,5 +1,5 @@ Name: vty -Version: 3.1.6 +Version: 3.1.8 License: BSD3 License-file: LICENSE Author: Stefan O'Rear @@ -33,7 +33,11 @@ cbits/set_term_timing.c Include-Dirs: cbits Install-Includes: gwinsz.h -Other-Modules: Graphics.Vty.Types, Graphics.Vty.Cursor, Graphics.Vty.LLInput +Other-Modules: Graphics.Vty.Types + Graphics.Vty.Cursor + Graphics.Vty.LLInput + Graphics.Vty.Output + Graphics.Vty.ControlStrings ghc-options: -funbox-strict-fields -Wall -threaded ghc-prof-options: -funbox-strict-fields -auto-all -Wall -threaded