vty 3.1.8.4 → 4.0.0
raw patch · 58 files changed
+5933/−816 lines, 58 filesdep +arraydep +ghc-primdep +mtldep −extensible-exceptionsdep ~base
Dependencies added: array, ghc-prim, mtl, parallel, parsec
Dependencies removed: extensible-exceptions
Dependency ranges changed: base
Files
- Graphics/Vty.hs +0/−127
- Graphics/Vty/ControlStrings.hs +0/−16
- Graphics/Vty/Cursor.hs +0/−64
- Graphics/Vty/LLInput.hs +0/−225
- Graphics/Vty/Output.hs +0/−114
- Graphics/Vty/Types.hs +0/−177
- LICENSE +1/−1
- TODO +17/−3
- cbits/mk_wcwidth.c +309/−0
- src/Codec/Binary/UTF8/Debug.hs +17/−0
- src/Codec/Binary/UTF8/Width.hs +40/−0
- src/Data/Marshalling.hs +33/−0
- src/Data/Terminfo/Eval.hs +242/−0
- src/Data/Terminfo/Parse.hs +320/−0
- src/Graphics/Vty.hs +133/−0
- src/Graphics/Vty/Attributes.hs +206/−0
- src/Graphics/Vty/Debug.hs +79/−0
- src/Graphics/Vty/DisplayRegion.hs +11/−0
- src/Graphics/Vty/Image.hs +304/−0
- src/Graphics/Vty/LLInput.hs +226/−0
- src/Graphics/Vty/Picture.hs +70/−0
- src/Graphics/Vty/Span.hs +222/−0
- src/Graphics/Vty/Terminal.hs +126/−0
- src/Graphics/Vty/Terminal/Debug.hs +115/−0
- src/Graphics/Vty/Terminal/Generic.hs +475/−0
- src/Graphics/Vty/Terminal/MacOSX.hs +92/−0
- src/Graphics/Vty/Terminal/TerminfoBased.hs +407/−0
- src/Graphics/Vty/Terminal/XTermColor.hs +81/−0
- test/Bench.hs +40/−25
- test/Bench2.hs +30/−0
- test/BenchRenderChar.hs +32/−0
- test/ControlTable.hs +14/−0
- test/HereDoc.hs +14/−0
- test/Makefile +47/−0
- test/Test.hs +31/−16
- test/Test2.hs +1/−0
- test/Verify.hs +77/−0
- test/Verify/Data/Terminfo/Parse.hs +114/−0
- test/Verify/Graphics/Vty/Attributes.hs +40/−0
- test/Verify/Graphics/Vty/DisplayRegion.hs +27/−0
- test/Verify/Graphics/Vty/Image.hs +91/−0
- test/Verify/Graphics/Vty/Picture.hs +50/−0
- test/Verify/Graphics/Vty/Span.hs +29/−0
- test/interactive_terminal_test.hs +862/−0
- test/make_tests.sh +0/−10
- test/verify_attribute_ops.hs +8/−0
- test/verify_debug_terminal.hs +115/−0
- test/verify_eval_terminfo_caps.hs +129/−0
- test/verify_image_ops.hs +124/−0
- test/verify_image_trans.hs +31/−0
- test/verify_parse_terminfo_caps.hs +158/−0
- test/verify_picture_ops.hs +9/−0
- test/verify_picture_to_span.hs +10/−0
- test/verify_span_ops.hs +179/−0
- test/verify_utf8_width.hs +17/−0
- test/vty_issue_18.hs +36/−0
- test/yi_issue_264.hs +12/−0
- vty.cabal +80/−38
− Graphics/Vty.hs
@@ -1,127 +0,0 @@-{-# 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'--
− Graphics/Vty/ControlStrings.hs
@@ -1,16 +0,0 @@-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"-
− Graphics/Vty/Cursor.hs
@@ -1,64 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-}-{-# CFILES gwinsz.c #-}-module Graphics.Vty.Cursor ( move- , setCursorInvis- , setCursorVis - , mvputch- ) - where--import Graphics.Vty.Types-import Graphics.Vty.ControlStrings-import Graphics.Vty.Output ( chgatt- ,tputchar- ,putShow- )--import Control.Monad ( when )--{--import Data.Bits ( (.|.), (.&.), shiftR )-import Data.Maybe ( maybe )--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-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 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-setCursorInvis ts = putStr civis >> return ts---- | Make the cursor visible.-setCursorVis :: TermState -> IO TermState-setCursorVis ts = putStr cvis >> return ts---- 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 #-}-
− Graphics/Vty/LLInput.hs
@@ -1,225 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE ForeignFunctionInterface #-}-module Graphics.Vty.LLInput ( Key(..)- , Modifier(..)- , Button(..)- , Event(..)- , initTermInput - ) - where--import Data.Char-import Data.Maybe ( mapMaybe - )-import Data.List( inits )-import Data.Word-import qualified Data.Map as M( fromList, lookup )-import qualified Data.Set as S( fromList, member )--import Codec.Binary.UTF8.Generic (decode)--import Control.Monad (when)-import Control.Concurrent-import Control.Exception.Extensible--import System.Console.Terminfo--import System.Posix.Signals.Exts-import System.Posix.Signals-import System.Posix.Terminal-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)---- |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)---- |Mouse buttons. Not yet used.-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)--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 :: 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- let inputToEventThread :: IO ()- 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 = loop- where - loop = do- setFdOption stdInput NonBlockingRead False- threadWaitRead stdInput- setFdOption stdInput NonBlockingRead True- try readAll :: IO (Either IOException ())- when (escDelay == 0) finishAtomicInput- loop- readAll = do- (bytes, bytes_read) <- fdRead stdInput 1- 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- pfx = S.fromList $ concatMap (init . inits . fst) $ lst'- mlst = M.fromList lst'- cl' str = case S.member str pfx of- True -> Prefix- False -> case M.lookup str mlst of- Just (k,m) -> Valid k m- Nothing -> case head $ mapMaybe (\s -> (,) s `fmap` M.lookup s mlst) $ init $ inits str of- (s,(k,m)) -> MisPfx k m (drop (length s) str)- - -- ANSI specific bits--- classify, classifyTab :: [Char] -> KClass- - -- 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- classify other = classifyTab other-- classifyUtf8 s = case decode ((map (fromIntegral . ord) s) :: [Word8]) of- Just (unicodeChar, _) -> Valid (KASCII unicodeChar) []- _ -> Invalid -- something bad happened; just ignore and continue.- - classifyTab = compile (caps_classify_table : ansi_classify_table)- - caps_tabls = [("khome", (KHome, [])), - ("kend", (KEnd, [])),- ("cbt", (KBackTab, [])),- ("kcud1", (KDown, [])),- ("kcuu1", (KUp, [])),- ("kcuf1", (KRight, [])),- ("kcub1", (KLeft, [])),-- ("kLFT", (KLeft, [MShift])),- ("kRIT", (KRight, [MShift]))- ]- - caps_classify_table = [(x,y) | (Just x,y) <- map (first (getCapability terminal . tiGetStr)) $ caps_tabls]- - ansi_classify_table :: [[([Char], (Key, [Modifier]))]]- ansi_classify_table =- [ let k c s = ("\ESC["++c,(s,[])) in [ k "G" KNP5, k "P" KPause, k "A" KUp, k "B" KDown, k "C" KRight, k "D" KLeft ],-- -- Support for arrows- [("\ESC[" ++ charCnt ++ show mc++c,(s,m)) - | charCnt <- ["1;", ""], -- we can have a count or not- (m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3), - ([MShift, MCtrl],6), ([MShift, MMeta],4)], -- modifiers and their codes- (c,s) <- [("A", KUp), ("B", KDown), ("C", KRight), ("D", KLeft)] -- directions and their codes- ],- - let k n s = ("\ESC["++show n++"~",(s,[])) in zipWith k [2::Int,3,5,6] [KIns,KDel,KPageUp,KPageDown],-- -- Support for simple characters.- [ (x:[],(KASCII x,[])) | x <- map toEnum [0..255] ],-- -- Support for function keys (should use terminfo)- [ ("\ESC[["++[toEnum(64+i)],(KFun i,[])) | i <- [1..5] ],- let f ff nrs m = [ ("\ESC["++show n++"~",(KFun (n-(nrs!!0)+ff), m)) | n <- nrs ] in- concat [ f 6 [17..21] [], f 11 [23,24] [], f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ],- [ ('\ESC':[x],(KASCII x,[MMeta])) | x <- '\ESC':'\t':[' ' .. '\DEL'] ],-- -- Ctrl+Char- [ ([toEnum x],(KASCII y,[MCtrl])) - | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_']),- y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.- ],- - -- Ctrl+Meta+Char- [ ('\ESC':[toEnum x],(KASCII y,[MMeta,MCtrl])) | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_']) ],-- -- Special support- [ -- special support for ESC - ("\ESC",(KEsc,[])) , ("\ESC\ESC",(KEsc,[MMeta])), -- -- Special support for backspace- ("\DEL",(KBS,[])), ("\ESC\DEL",(KBS,[MMeta])),- - -- Special support for Enter- ("\ESC\^J",(KEnter,[MMeta])), ("\^J",(KEnter,[])) ] - ]- - eventThreadId <- forkIO $ inputToEventThread- inputThreadId <- forkIO $ inputThread- 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- return (readChan eventChannel, uninit)--first :: (a -> b) -> (a,c) -> (b,c)-first f (x,y) = (f x, y)--utf8Length :: (Num t, Ord a, Num a) => a -> t-utf8Length c - | c < 0x80 = 1- | c < 0xE0 = 2- | c < 0xF0 = 3- | otherwise = 4--foreign import ccall "set_term_timing" set_term_timing :: IO ()-
− Graphics/Vty/Output.hs
@@ -1,114 +0,0 @@-{-# 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"-
− Graphics/Vty/Types.hs
@@ -1,177 +0,0 @@-module Graphics.Vty.Types - where--import Data.Bits( (.&.), (.|.), shiftL )--import Foreign.Ptr-import Foreign.Storable-import Foreign.C.Types (CChar)-import Foreign.Marshal.Array-import qualified Data.ByteString as B--infixr 5 <|>-infixr 4 <->---- |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 :(---- | Opaque data type representing character attributes.-newtype Attr = Attr Int deriving (Eq)---- | Set the foreground color of an `Attr'.-setFG :: Color -> Attr -> Attr-setFG (Color c) (Attr a) = Attr ((a .&. 0xFFFFFF00) .|. (30 + c))---- | Set the background color of an `Attr'.-setBG :: Color -> Attr -> Attr-setBG (Color c) (Attr a) = Attr ((a .&. 0xFFFF00FF) .|. ((40 + c) `shiftL` 8))---- | Set the foreground color of an `Attr'.-setFGVivid :: Color -> Attr -> Attr-setFGVivid (Color c) (Attr a) = Attr ((a .&. 0xFFFFFF00) .|. (90 + c))---- | Set the background color of an `Attr'.-setBGVivid :: Color -> Attr -> Attr-setBGVivid (Color c) (Attr a) = Attr ((a .&. 0xFFFF00FF) .|. ((100 + c) `shiftL` 8))-- --- | Set bold attribute of an `Attr'.-setBold :: Attr -> Attr-setBold (Attr a) = Attr (a .|. 0x10000)---- | Set blink attribute of an `Attr'.-setBlink :: Attr -> Attr-setBlink (Attr a) = Attr (a .|. 0x20000)---- | Set reverse-video attribute of an `Attr'.-setRV :: Attr -> Attr-setRV (Attr a) = Attr (a .|. 0x40000)---- | Set half-bright attribute of an `Attr'.-setHalfBright :: Attr -> Attr-setHalfBright (Attr a) = Attr (a .|. 0x80000)---- | Set underline attribute of an `Attr'.-setUnderline :: Attr -> Attr-setUnderline (Attr a) = Attr (a .|. 0x100000)---- |'Attr' with all default values.-attr :: Attr-attr = Attr 0x909---- |Abstract data type representing a color.-newtype Color = Color Int deriving(Eq)---- FIXME: this assumes a 8-color terminal.--- |Basic color definitions.-black, red, green, yellow, blue, magenta, cyan, white, def :: Color-black = Color 0 ; red = Color 1 ; green = Color 2 ; yellow = Color 3-blue = Color 4 ; magenta= Color 5 ; cyan = Color 6 ; white = Color 7-def = Color 9---- This uses a somewhat tricky implementation, for efficiency.---- |A two-dimensional array of (Char,Attr) pairs.-data Image = Image (Int -> Ptr Int -> IO ()) !Int !Int---- | Access the width of an Image.-imgWidth :: Image -> Int-imgWidth (Image _ w _) = w---- | Access the height of an Image.-imgHeight :: Image -> Int-imgHeight (Image _ _ h) = h---- | The empty image.-empty :: Image-empty = Image (\_ _ -> return ()) 0 0---- | Compose two images side by side. The images must of the same height,--- or one must be empty.-(<|>) :: Image -> Image -> Image-Image f1 x1 y1 <|> Image f2 x2 y2 | y1 == y2 || x1 == 0 || x2 == 0 =- Image (\stride ptr -> do f1 stride ptr- f2 stride (ptr `plusPtr` ((sizeOf (undefined :: Int) * 2) * x1)))- (x1+x2) (max y1 y2)-_ <|> _ = error "Graphics.Vty.(<|>) : image heights do not match"---- | Compose two images vertically. The images must of the same width,--- or one must be empty.-(<->) :: Image -> Image -> Image-Image f1 x1 y1 <-> Image f2 x2 y2 | x1 == x2 || y1 == 0 || y2 == 0 =- Image (\stride ptr -> do f1 stride ptr- f2 stride (ptr `plusPtr` (stride * y1)))- (max x1 x2) (y1+y2)-_ <-> _ = error "Graphics.Vty.(<->) : image widths do not match"---- | Helper - fill a buffer segment with a char\/attr.-fillSeg :: Attr -> Char -> Ptr Int -> Ptr Int -> IO ()-fillSeg (Attr a) ch p1 pe = a `seq` ch `seq` pe `seq` worker p1- where- worker p | p == pe = return ()- | otherwise = do pokeElemOff p 0 a- pokeElemOff p 1 (fromEnum ch)- worker (p `advancePtr` 2)---- | Compose any number of images horizontally.-horzcat :: [Image] -> Image-horzcat = foldr (<|>) empty---- | Compose any number of images vertically.-vertcat :: [Image] -> Image-vertcat = foldr (<->) empty---- | Create an `Image' from a `B.ByteString' with a single uniform `Attr'.-renderBS :: Attr -> B.ByteString -> Image-renderBS (Attr a) bs = a `seq` Image (\ _stride ptr -> B.useAsCStringLen bs (worker ptr)) (B.length bs) 1- where- worker :: Ptr Int -> (Ptr CChar, Int) -> IO ()- worker _op (_ip, 0) = return ()- worker op (ip, ct) = do inp <- peek ip- pokeElemOff op 0 a- pokeElemOff op 1 (fromIntegral inp)- worker (op `advancePtr` 2) ((ip `advancePtr` 1), (ct - 1))---- | Create a 1x1 image. Warning, this is likely to be inefficient.-renderChar :: Attr -> Char -> Image-renderChar (Attr a) ch = a `seq` ch `seq` Image (\ _stride ptr -> pokeElemOff ptr 0 a >> pokeElemOff ptr 1 (fromEnum ch)) 1 1---- | Create an image by repeating a single character and attribute horizontally.-renderHFill :: Attr -> Char -> Int -> Image-renderHFill _ _ w | w < 0 || w > 10000 = error "renderHFill: bizarre width"-renderHFill a ch w = a `seq` ch `seq` Image (\ _stride ptr -> fillSeg a ch ptr (ptr `advancePtr` (2*w))) w 1---- | Create an image by repeating a single character and attribute.-renderFill :: Attr -> Char -> Int -> Int -> Image-renderFill _ _ w _ | w < 0 || w > 10000 = error "renderFill: bizarre width"-renderFill _ _ _ h | h < 0 || h > 10000 = error "renderFill: bizarre height"-renderFill (Attr a) ch w h = a `seq` ch `seq` Image (worker h) w h- where- worker :: Int -> Int -> Ptr Int -> IO ()- worker 0 _stride _ptr = return ()- worker ct stride ptr = do let ptr2 = ptr `advancePtr` (2 * w)- fillSeg (Attr a) ch ptr ptr2- worker (ct - 1) stride ptr2---- |The type of images to be displayed using 'update'. You probably shouldn't--- create this directly if you care about compatibility with future versions of--- vty; instead use 'pic' and record update syntax.-data Picture = Pic { -- |The position and visibility status of the virtual- -- cursor.- pCursor :: Cursor,- -- |A 2d array of (character,attribute) pairs, representing- -- the screen image.- pImage :: Image }---- |Create a 'Picture' object with all default values. By using this and record--- update, rather than directly using the Pic constructor, your code will be--- compatible with additions to the Picture object. You must specify at least--- 'pImage'.-pic :: Picture-pic = Pic { pCursor = NoCursor, pImage = error "Pic.pImage not initialized" }
LICENSE view
@@ -1,4 +1,4 @@-Copyright Stefan O'Rear 2006+Copyright Stefan O'Rear 2006, Corey O'Connor 2008, Corey O'Connor 2009 All rights reserved.
TODO view
@@ -1,8 +1,22 @@ Minor:-- xterm keyboard support-- Termcap/terminfo parser-- 256 color support (xterm)+- input parser uses similar interface to DisplayHandle. Derive instance from terminfo - Improve input handling performance.+ - base off of haskeline input system. The haskeline input system appears to be excellent and+ satisfy all of Vty's input requirements. The current haskeline distribution does not appear to+ export the required modules. Either:+ 0. Add the required exports to the haskeline distribution. + - fine for development but complicates the UI for production clients. Though, exposing+ the modules would only complicate the appearance of haskeline's interface. + 1. Partition the backend of haskeline into a separate package usable by both vty and+ haskeline.+- use compact-string for character encoding handling+- xterm cursor foreground handling.+ - specific color?+ - reverse video?+ - auto?+- resolve gnome-terminal performance.+ - too much output per update? Diff the previous versus the requested to reduce? Major: - Remove size fields in resize constr+
+ cbits/mk_wcwidth.c view
@@ -0,0 +1,309 @@+/*+ * This is an implementation of wcwidth() and wcswidth() (defined in+ * IEEE Std 1002.1-2001) for Unicode.+ *+ * http://www.opengroup.org/onlinepubs/007904975/functions/wcwidth.html+ * http://www.opengroup.org/onlinepubs/007904975/functions/wcswidth.html+ *+ * In fixed-width output devices, Latin characters all occupy a single+ * "cell" position of equal width, whereas ideographic CJK characters+ * occupy two such cells. Interoperability between terminal-line+ * applications and (teletype-style) character terminals using the+ * UTF-8 encoding requires agreement on which character should advance+ * the cursor by how many cell positions. No established formal+ * standards exist at present on which Unicode character shall occupy+ * how many cell positions on character terminals. These routines are+ * a first attempt of defining such behavior based on simple rules+ * applied to data provided by the Unicode Consortium.+ *+ * For some graphical characters, the Unicode standard explicitly+ * defines a character-cell width via the definition of the East Asian+ * FullWidth (F), Wide (W), Half-width (H), and Narrow (Na) classes.+ * In all these cases, there is no ambiguity about which width a+ * terminal shall use. For characters in the East Asian Ambiguous (A)+ * class, the width choice depends purely on a preference of backward+ * compatibility with either historic CJK or Western practice.+ * Choosing single-width for these characters is easy to justify as+ * the appropriate long-term solution, as the CJK practice of+ * displaying these characters as double-width comes from historic+ * implementation simplicity (8-bit encoded characters were displayed+ * single-width and 16-bit ones double-width, even for Greek,+ * Cyrillic, etc.) and not any typographic considerations.+ *+ * Much less clear is the choice of width for the Not East Asian+ * (Neutral) class. Existing practice does not dictate a width for any+ * of these characters. It would nevertheless make sense+ * typographically to allocate two character cells to characters such+ * as for instance EM SPACE or VOLUME INTEGRAL, which cannot be+ * represented adequately with a single-width glyph. The following+ * routines at present merely assign a single-cell width to all+ * neutral characters, in the interest of simplicity. This is not+ * entirely satisfactory and should be reconsidered before+ * establishing a formal standard in this area. At the moment, the+ * decision which Not East Asian (Neutral) characters should be+ * represented by double-width glyphs cannot yet be answered by+ * applying a simple rule from the Unicode database content. Setting+ * up a proper standard for the behavior of UTF-8 character terminals+ * will require a careful analysis not only of each Unicode character,+ * but also of each presentation form, something the author of these+ * routines has avoided to do so far.+ *+ * http://www.unicode.org/unicode/reports/tr11/+ *+ * Markus Kuhn -- 2007-05-26 (Unicode 5.0)+ *+ * Permission to use, copy, modify, and distribute this software+ * for any purpose and without fee is hereby granted. The author+ * disclaims all warranties with regard to this software.+ *+ * Latest version: http://www.cl.cam.ac.uk/~mgk25/ucs/wcwidth.c+ */++#include <wchar.h>++struct interval {+ int first;+ int last;+};++/* auxiliary function for binary search in interval table */+static int bisearch(wchar_t ucs, const struct interval *table, int max) {+ int min = 0;+ int mid;++ if (ucs < table[0].first || ucs > table[max].last)+ return 0;+ while (max >= min) {+ mid = (min + max) / 2;+ if (ucs > table[mid].last)+ min = mid + 1;+ else if (ucs < table[mid].first)+ max = mid - 1;+ else+ return 1;+ }++ return 0;+}+++/* The following two functions define the column width of an ISO 10646+ * character as follows:+ *+ * - The null character (U+0000) has a column width of 0.+ *+ * - Other C0/C1 control characters and DEL will lead to a return+ * value of -1.+ *+ * - Non-spacing and enclosing combining characters (general+ * category code Mn or Me in the Unicode database) have a+ * column width of 0.+ *+ * - SOFT HYPHEN (U+00AD) has a column width of 1.+ *+ * - Other format characters (general category code Cf in the Unicode+ * database) and ZERO WIDTH SPACE (U+200B) have a column width of 0.+ *+ * - Hangul Jamo medial vowels and final consonants (U+1160-U+11FF)+ * have a column width of 0.+ *+ * - Spacing characters in the East Asian Wide (W) or East Asian+ * Full-width (F) category as defined in Unicode Technical+ * Report #11 have a column width of 2.+ *+ * - All remaining characters (including all printable+ * ISO 8859-1 and WGL4 characters, Unicode control characters,+ * etc.) have a column width of 1.+ *+ * This implementation assumes that wchar_t characters are encoded+ * in ISO 10646.+ */++int mk_wcwidth(wchar_t ucs)+{+ /* sorted list of non-overlapping intervals of non-spacing characters */+ /* generated by "uniset +cat=Me +cat=Mn +cat=Cf -00AD +1160-11FF +200B c" */+ static const struct interval combining[] = {+ { 0x0300, 0x036F }, { 0x0483, 0x0486 }, { 0x0488, 0x0489 },+ { 0x0591, 0x05BD }, { 0x05BF, 0x05BF }, { 0x05C1, 0x05C2 },+ { 0x05C4, 0x05C5 }, { 0x05C7, 0x05C7 }, { 0x0600, 0x0603 },+ { 0x0610, 0x0615 }, { 0x064B, 0x065E }, { 0x0670, 0x0670 },+ { 0x06D6, 0x06E4 }, { 0x06E7, 0x06E8 }, { 0x06EA, 0x06ED },+ { 0x070F, 0x070F }, { 0x0711, 0x0711 }, { 0x0730, 0x074A },+ { 0x07A6, 0x07B0 }, { 0x07EB, 0x07F3 }, { 0x0901, 0x0902 },+ { 0x093C, 0x093C }, { 0x0941, 0x0948 }, { 0x094D, 0x094D },+ { 0x0951, 0x0954 }, { 0x0962, 0x0963 }, { 0x0981, 0x0981 },+ { 0x09BC, 0x09BC }, { 0x09C1, 0x09C4 }, { 0x09CD, 0x09CD },+ { 0x09E2, 0x09E3 }, { 0x0A01, 0x0A02 }, { 0x0A3C, 0x0A3C },+ { 0x0A41, 0x0A42 }, { 0x0A47, 0x0A48 }, { 0x0A4B, 0x0A4D },+ { 0x0A70, 0x0A71 }, { 0x0A81, 0x0A82 }, { 0x0ABC, 0x0ABC },+ { 0x0AC1, 0x0AC5 }, { 0x0AC7, 0x0AC8 }, { 0x0ACD, 0x0ACD },+ { 0x0AE2, 0x0AE3 }, { 0x0B01, 0x0B01 }, { 0x0B3C, 0x0B3C },+ { 0x0B3F, 0x0B3F }, { 0x0B41, 0x0B43 }, { 0x0B4D, 0x0B4D },+ { 0x0B56, 0x0B56 }, { 0x0B82, 0x0B82 }, { 0x0BC0, 0x0BC0 },+ { 0x0BCD, 0x0BCD }, { 0x0C3E, 0x0C40 }, { 0x0C46, 0x0C48 },+ { 0x0C4A, 0x0C4D }, { 0x0C55, 0x0C56 }, { 0x0CBC, 0x0CBC },+ { 0x0CBF, 0x0CBF }, { 0x0CC6, 0x0CC6 }, { 0x0CCC, 0x0CCD },+ { 0x0CE2, 0x0CE3 }, { 0x0D41, 0x0D43 }, { 0x0D4D, 0x0D4D },+ { 0x0DCA, 0x0DCA }, { 0x0DD2, 0x0DD4 }, { 0x0DD6, 0x0DD6 },+ { 0x0E31, 0x0E31 }, { 0x0E34, 0x0E3A }, { 0x0E47, 0x0E4E },+ { 0x0EB1, 0x0EB1 }, { 0x0EB4, 0x0EB9 }, { 0x0EBB, 0x0EBC },+ { 0x0EC8, 0x0ECD }, { 0x0F18, 0x0F19 }, { 0x0F35, 0x0F35 },+ { 0x0F37, 0x0F37 }, { 0x0F39, 0x0F39 }, { 0x0F71, 0x0F7E },+ { 0x0F80, 0x0F84 }, { 0x0F86, 0x0F87 }, { 0x0F90, 0x0F97 },+ { 0x0F99, 0x0FBC }, { 0x0FC6, 0x0FC6 }, { 0x102D, 0x1030 },+ { 0x1032, 0x1032 }, { 0x1036, 0x1037 }, { 0x1039, 0x1039 },+ { 0x1058, 0x1059 }, { 0x1160, 0x11FF }, { 0x135F, 0x135F },+ { 0x1712, 0x1714 }, { 0x1732, 0x1734 }, { 0x1752, 0x1753 },+ { 0x1772, 0x1773 }, { 0x17B4, 0x17B5 }, { 0x17B7, 0x17BD },+ { 0x17C6, 0x17C6 }, { 0x17C9, 0x17D3 }, { 0x17DD, 0x17DD },+ { 0x180B, 0x180D }, { 0x18A9, 0x18A9 }, { 0x1920, 0x1922 },+ { 0x1927, 0x1928 }, { 0x1932, 0x1932 }, { 0x1939, 0x193B },+ { 0x1A17, 0x1A18 }, { 0x1B00, 0x1B03 }, { 0x1B34, 0x1B34 },+ { 0x1B36, 0x1B3A }, { 0x1B3C, 0x1B3C }, { 0x1B42, 0x1B42 },+ { 0x1B6B, 0x1B73 }, { 0x1DC0, 0x1DCA }, { 0x1DFE, 0x1DFF },+ { 0x200B, 0x200F }, { 0x202A, 0x202E }, { 0x2060, 0x2063 },+ { 0x206A, 0x206F }, { 0x20D0, 0x20EF }, { 0x302A, 0x302F },+ { 0x3099, 0x309A }, { 0xA806, 0xA806 }, { 0xA80B, 0xA80B },+ { 0xA825, 0xA826 }, { 0xFB1E, 0xFB1E }, { 0xFE00, 0xFE0F },+ { 0xFE20, 0xFE23 }, { 0xFEFF, 0xFEFF }, { 0xFFF9, 0xFFFB },+ { 0x10A01, 0x10A03 }, { 0x10A05, 0x10A06 }, { 0x10A0C, 0x10A0F },+ { 0x10A38, 0x10A3A }, { 0x10A3F, 0x10A3F }, { 0x1D167, 0x1D169 },+ { 0x1D173, 0x1D182 }, { 0x1D185, 0x1D18B }, { 0x1D1AA, 0x1D1AD },+ { 0x1D242, 0x1D244 }, { 0xE0001, 0xE0001 }, { 0xE0020, 0xE007F },+ { 0xE0100, 0xE01EF }+ };++ /* test for 8-bit control characters */+ if (ucs == 0)+ return 0;+ if (ucs < 32 || (ucs >= 0x7f && ucs < 0xa0))+ return -1;++ /* binary search in table of non-spacing characters */+ if (bisearch(ucs, combining,+ sizeof(combining) / sizeof(struct interval) - 1))+ return 0;++ /* if we arrive here, ucs is not a combining or C0/C1 control character */++ return 1 + + (ucs >= 0x1100 &&+ (ucs <= 0x115f || /* Hangul Jamo init. consonants */+ ucs == 0x2329 || ucs == 0x232a ||+ (ucs >= 0x2e80 && ucs <= 0xa4cf &&+ ucs != 0x303f) || /* CJK ... Yi */+ (ucs >= 0xac00 && ucs <= 0xd7a3) || /* Hangul Syllables */+ (ucs >= 0xf900 && ucs <= 0xfaff) || /* CJK Compatibility Ideographs */+ (ucs >= 0xfe10 && ucs <= 0xfe19) || /* Vertical forms */+ (ucs >= 0xfe30 && ucs <= 0xfe6f) || /* CJK Compatibility Forms */+ (ucs >= 0xff00 && ucs <= 0xff60) || /* Fullwidth Forms */+ (ucs >= 0xffe0 && ucs <= 0xffe6) ||+ (ucs >= 0x20000 && ucs <= 0x2fffd) ||+ (ucs >= 0x30000 && ucs <= 0x3fffd)));+}+++int mk_wcswidth(const wchar_t *pwcs, size_t n)+{+ int w, width = 0;++ for (;*pwcs && n-- > 0; pwcs++)+ if ((w = mk_wcwidth(*pwcs)) < 0)+ return -1;+ else+ width += w;++ return width;+}+++/*+ * The following functions are the same as mk_wcwidth() and+ * mk_wcswidth(), except that spacing characters in the East Asian+ * Ambiguous (A) category as defined in Unicode Technical Report #11+ * have a column width of 2. This variant might be useful for users of+ * CJK legacy encodings who want to migrate to UCS without changing+ * the traditional terminal character-width behaviour. It is not+ * otherwise recommended for general use.+ */+int mk_wcwidth_cjk(wchar_t ucs)+{+ /* sorted list of non-overlapping intervals of East Asian Ambiguous+ * characters, generated by "uniset +WIDTH-A -cat=Me -cat=Mn -cat=Cf c" */+ static const struct interval ambiguous[] = {+ { 0x00A1, 0x00A1 }, { 0x00A4, 0x00A4 }, { 0x00A7, 0x00A8 },+ { 0x00AA, 0x00AA }, { 0x00AE, 0x00AE }, { 0x00B0, 0x00B4 },+ { 0x00B6, 0x00BA }, { 0x00BC, 0x00BF }, { 0x00C6, 0x00C6 },+ { 0x00D0, 0x00D0 }, { 0x00D7, 0x00D8 }, { 0x00DE, 0x00E1 },+ { 0x00E6, 0x00E6 }, { 0x00E8, 0x00EA }, { 0x00EC, 0x00ED },+ { 0x00F0, 0x00F0 }, { 0x00F2, 0x00F3 }, { 0x00F7, 0x00FA },+ { 0x00FC, 0x00FC }, { 0x00FE, 0x00FE }, { 0x0101, 0x0101 },+ { 0x0111, 0x0111 }, { 0x0113, 0x0113 }, { 0x011B, 0x011B },+ { 0x0126, 0x0127 }, { 0x012B, 0x012B }, { 0x0131, 0x0133 },+ { 0x0138, 0x0138 }, { 0x013F, 0x0142 }, { 0x0144, 0x0144 },+ { 0x0148, 0x014B }, { 0x014D, 0x014D }, { 0x0152, 0x0153 },+ { 0x0166, 0x0167 }, { 0x016B, 0x016B }, { 0x01CE, 0x01CE },+ { 0x01D0, 0x01D0 }, { 0x01D2, 0x01D2 }, { 0x01D4, 0x01D4 },+ { 0x01D6, 0x01D6 }, { 0x01D8, 0x01D8 }, { 0x01DA, 0x01DA },+ { 0x01DC, 0x01DC }, { 0x0251, 0x0251 }, { 0x0261, 0x0261 },+ { 0x02C4, 0x02C4 }, { 0x02C7, 0x02C7 }, { 0x02C9, 0x02CB },+ { 0x02CD, 0x02CD }, { 0x02D0, 0x02D0 }, { 0x02D8, 0x02DB },+ { 0x02DD, 0x02DD }, { 0x02DF, 0x02DF }, { 0x0391, 0x03A1 },+ { 0x03A3, 0x03A9 }, { 0x03B1, 0x03C1 }, { 0x03C3, 0x03C9 },+ { 0x0401, 0x0401 }, { 0x0410, 0x044F }, { 0x0451, 0x0451 },+ { 0x2010, 0x2010 }, { 0x2013, 0x2016 }, { 0x2018, 0x2019 },+ { 0x201C, 0x201D }, { 0x2020, 0x2022 }, { 0x2024, 0x2027 },+ { 0x2030, 0x2030 }, { 0x2032, 0x2033 }, { 0x2035, 0x2035 },+ { 0x203B, 0x203B }, { 0x203E, 0x203E }, { 0x2074, 0x2074 },+ { 0x207F, 0x207F }, { 0x2081, 0x2084 }, { 0x20AC, 0x20AC },+ { 0x2103, 0x2103 }, { 0x2105, 0x2105 }, { 0x2109, 0x2109 },+ { 0x2113, 0x2113 }, { 0x2116, 0x2116 }, { 0x2121, 0x2122 },+ { 0x2126, 0x2126 }, { 0x212B, 0x212B }, { 0x2153, 0x2154 },+ { 0x215B, 0x215E }, { 0x2160, 0x216B }, { 0x2170, 0x2179 },+ { 0x2190, 0x2199 }, { 0x21B8, 0x21B9 }, { 0x21D2, 0x21D2 },+ { 0x21D4, 0x21D4 }, { 0x21E7, 0x21E7 }, { 0x2200, 0x2200 },+ { 0x2202, 0x2203 }, { 0x2207, 0x2208 }, { 0x220B, 0x220B },+ { 0x220F, 0x220F }, { 0x2211, 0x2211 }, { 0x2215, 0x2215 },+ { 0x221A, 0x221A }, { 0x221D, 0x2220 }, { 0x2223, 0x2223 },+ { 0x2225, 0x2225 }, { 0x2227, 0x222C }, { 0x222E, 0x222E },+ { 0x2234, 0x2237 }, { 0x223C, 0x223D }, { 0x2248, 0x2248 },+ { 0x224C, 0x224C }, { 0x2252, 0x2252 }, { 0x2260, 0x2261 },+ { 0x2264, 0x2267 }, { 0x226A, 0x226B }, { 0x226E, 0x226F },+ { 0x2282, 0x2283 }, { 0x2286, 0x2287 }, { 0x2295, 0x2295 },+ { 0x2299, 0x2299 }, { 0x22A5, 0x22A5 }, { 0x22BF, 0x22BF },+ { 0x2312, 0x2312 }, { 0x2460, 0x24E9 }, { 0x24EB, 0x254B },+ { 0x2550, 0x2573 }, { 0x2580, 0x258F }, { 0x2592, 0x2595 },+ { 0x25A0, 0x25A1 }, { 0x25A3, 0x25A9 }, { 0x25B2, 0x25B3 },+ { 0x25B6, 0x25B7 }, { 0x25BC, 0x25BD }, { 0x25C0, 0x25C1 },+ { 0x25C6, 0x25C8 }, { 0x25CB, 0x25CB }, { 0x25CE, 0x25D1 },+ { 0x25E2, 0x25E5 }, { 0x25EF, 0x25EF }, { 0x2605, 0x2606 },+ { 0x2609, 0x2609 }, { 0x260E, 0x260F }, { 0x2614, 0x2615 },+ { 0x261C, 0x261C }, { 0x261E, 0x261E }, { 0x2640, 0x2640 },+ { 0x2642, 0x2642 }, { 0x2660, 0x2661 }, { 0x2663, 0x2665 },+ { 0x2667, 0x266A }, { 0x266C, 0x266D }, { 0x266F, 0x266F },+ { 0x273D, 0x273D }, { 0x2776, 0x277F }, { 0xE000, 0xF8FF },+ { 0xFFFD, 0xFFFD }, { 0xF0000, 0xFFFFD }, { 0x100000, 0x10FFFD }+ };++ /* binary search in table of non-spacing characters */+ if (bisearch(ucs, ambiguous,+ sizeof(ambiguous) / sizeof(struct interval) - 1))+ return 2;++ return mk_wcwidth(ucs);+}+++int mk_wcswidth_cjk(const wchar_t *pwcs, size_t n)+{+ int w, width = 0;++ for (;*pwcs && n-- > 0; pwcs++)+ if ((w = mk_wcwidth_cjk(*pwcs)) < 0)+ return -1;+ else+ width += w;++ return width;+}
+ src/Codec/Binary/UTF8/Debug.hs view
@@ -0,0 +1,17 @@+-- Copyright 2009 Corey O'Connor+module Codec.Binary.UTF8.Debug + where++import Codec.Binary.UTF8.String ( encode )++import Data.Word++import Numeric++-- Converts an array of ISO-10464 characters (Char type) to an array of Word8 bytes that is the+-- corresponding UTF8 byte sequence+utf8_from_iso :: Integral i => [i] -> [Word8]+utf8_from_iso = encode . map toEnum++pp_utf8 = print . map (\f -> f "") . map showHex . utf8_from_iso+
+ src/Codec/Binary/UTF8/Width.hs view
@@ -0,0 +1,40 @@+-- Copyright 2009 Corey O'Connor+{-# OPTIONS_GHC -D_XOPEN_SOURCE -fno-cse #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# INCLUDE <wchar.h> #-}+module Codec.Binary.UTF8.Width ( wcwidth+ , wcswidth+ )+ where++import Foreign.C.Types+import Foreign.C.String+import Foreign.Storable+import Foreign.Ptr++-- import Numeric ( showHex )++import System.IO.Unsafe++wcwidth :: Char -> Int+wcwidth c = unsafePerformIO (withCWString [c] $ \ws -> do+ wc <- peek ws+ -- putStr $ "wcwidth(0x" ++ showHex (fromEnum wc) "" ++ ")"+ w <- wcwidth' wc >>= return . fromIntegral+ -- putStrLn $ " -> " ++ show w+ return w+ )+{-# NOINLINE wcwidth #-}++foreign import ccall unsafe "mk_wcwidth" wcwidth' :: CWchar -> IO CInt++wcswidth :: String -> Int+wcswidth str = unsafePerformIO (withCWString str $ \ws -> do+ -- putStr $ "wcswidth(...)"+ w <- wcswidth' ws >>= return . fromIntegral+ -- putStrLn $ " -> " ++ show w+ return w+ )+{-# NOINLINE wcswidth #-}++foreign import ccall unsafe "mk_wcswidth" wcswidth' :: Ptr CWchar -> IO CInt
+ src/Data/Marshalling.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE BangPatterns #-}+-- Copyright 2009 Corey O'Connor+module Data.Marshalling ( module Data.Marshalling+ , module Data.Word+ , module Foreign.Ptr+ , module Foreign.ForeignPtr+ , module Foreign.Marshal+ , module Foreign.Storable+ )+ where++import Control.Monad ( foldM )+import Control.Monad.Trans++import Data.Word++import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.Marshal+import Foreign.Storable++type OutputBuffer = Ptr Word8++string_to_bytes :: String -> [Word8]+string_to_bytes str = map (toEnum . fromEnum) str++serialize_bytes :: MonadIO m => [Word8] -> OutputBuffer -> m OutputBuffer+serialize_bytes bytes !out_ptr = foldM ( \ptr b -> liftIO (poke ptr b) + >> ( return $! ( ptr `plusPtr` 1 ) ) + ) + out_ptr + bytes+
+ src/Data/Terminfo/Eval.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# OPTIONS_GHC -funbox-strict-fields -O #-}+{- Evaluates the paramaterized terminfo string capability with the given parameters.+ -+ - todo: This can be greatly simplified.+ -}+module Data.Terminfo.Eval ( cap_expression_required_bytes+ , serialize_cap_expression+ , bytes_for_range+ )+ where++import Data.Marshalling+import Data.Terminfo.Parse++import Control.Monad.Reader+import Control.Monad.State.Strict++import Data.Array.Unboxed+import Data.Bits ( (.|.), (.&.), xor )+import Data.List ++import GHC.Prim+import GHC.Word++type Eval a = ReaderT (CapExpression,[CapParam]) (State [CapParam]) a+type EvalIO a = ReaderT (CapExpression,[CapParam]) (StateT [CapParam] IO) a++pop :: MonadState [CapParam] m => m CapParam+pop = do+ v : stack <- get+ put stack+ return v++read_param :: MonadReader (CapExpression, [CapParam]) m => Word -> m CapParam+read_param pn = do+ (_,params) <- ask+ return $! genericIndex params pn++push :: MonadState [CapParam] m => CapParam -> m ()+push !v = do+ stack <- get+ put (v : stack)++apply_param_ops :: CapExpression -> [CapParam] -> [CapParam]+apply_param_ops cap params = foldl apply_param_op params (param_ops cap)++apply_param_op :: [CapParam] -> ParamOp -> [CapParam]+apply_param_op params IncFirstTwo = map (+ 1) params++-- | range is 0-based offset into cap_bytes and count+-- +-- todo: The returned list is not assured to have a length st. length == count+bytes_for_range :: CapExpression -> Word8 -> Word8 -> [Word8]+bytes_for_range cap !offset !count + = take (fromEnum count) + $ drop (fromEnum offset) + $ elems + $ cap_bytes cap++cap_expression_required_bytes :: CapExpression -> [CapParam] -> Word+cap_expression_required_bytes cap params = + let params' = apply_param_ops cap params+ in fst $! runState (runReaderT (cap_ops_required_bytes $ cap_ops cap) (cap, params')) []++cap_ops_required_bytes :: CapOps -> Eval Word+cap_ops_required_bytes ops = do+ counts <- mapM cap_op_required_bytes ops+ return $ sum counts++cap_op_required_bytes :: CapOp -> Eval Word+cap_op_required_bytes (Bytes _ c) = return $ toEnum $ fromEnum c+cap_op_required_bytes DecOut = do+ p <- pop+ return $ toEnum $ length $ show p+cap_op_required_bytes CharOut = do+ pop+ return 1+cap_op_required_bytes (PushParam pn) = do+ read_param pn >>= push+ return 0+cap_op_required_bytes (PushValue v) = do+ push v+ return 0+cap_op_required_bytes (Conditional expr parts) = do+ c_expr <- cap_ops_required_bytes expr+ c_parts <- cond_parts_required_bytes parts+ return $ c_expr + c_parts+ where + cond_parts_required_bytes [] = return 0+ cond_parts_required_bytes ( (true_ops, false_ops) : false_parts ) = do+ -- (man 5 terminfo)+ -- Usually the %? expr part pushes a value onto the stack, and %t pops it from the+ -- stack, testing if it is nonzero (true). If it is zero (false), control+ -- passes to the %e (else) part.+ v <- pop+ c_total <- if v /= 0+ then cap_ops_required_bytes true_ops+ else do+ c_false <- cap_ops_required_bytes false_ops+ c_remain <- cond_parts_required_bytes false_parts+ return $ c_false + c_remain+ return c_total+cap_op_required_bytes BitwiseOr = do+ v_1 <- pop+ v_0 <- pop+ push $ v_0 .|. v_1+ return 0+cap_op_required_bytes BitwiseAnd = do+ v_1 <- pop+ v_0 <- pop+ push $ v_0 .&. v_1+ return 0+cap_op_required_bytes BitwiseXOr = do+ v_1 <- pop+ v_0 <- pop+ push $ v_0 `xor` v_1+ return 0+cap_op_required_bytes ArithPlus = do+ v_1 <- pop+ v_0 <- pop+ push $ v_0 + v_1+ return 0+cap_op_required_bytes ArithMinus = do+ v_1 <- pop+ v_0 <- pop+ push $ v_0 - v_1+ return 0+cap_op_required_bytes CompareEq = do+ v_1 <- pop+ v_0 <- pop+ push $ if v_0 == v_1 then 1 else 0+ return 0+cap_op_required_bytes CompareLt = do+ v_1 <- pop+ v_0 <- pop+ push $ if v_0 < v_1 then 1 else 0+ return 0+cap_op_required_bytes CompareGt = do+ v_1 <- pop+ v_0 <- pop+ push $ if v_0 > v_1 then 1 else 0+ return 0++serialize_cap_expression :: CapExpression -> [CapParam] -> OutputBuffer -> IO OutputBuffer+serialize_cap_expression cap params out_ptr = do+ let params' = apply_param_ops cap params+ (!out_ptr', _) <- runStateT (runReaderT (serialize_cap_ops out_ptr (cap_ops cap)) (cap, params')) []+ return out_ptr'++serialize_cap_ops :: OutputBuffer -> CapOps -> EvalIO OutputBuffer+serialize_cap_ops out_ptr ops = foldM serialize_cap_op out_ptr ops++serialize_cap_op :: OutputBuffer -> CapOp -> EvalIO OutputBuffer+serialize_cap_op out_ptr (Bytes offset c) = do+ (cap, _) <- ask+ let out_bytes = bytes_for_range cap offset c+ serialize_bytes out_bytes out_ptr+serialize_cap_op out_ptr DecOut = do+ p <- pop+ let out_str = show p+ out_bytes = string_to_bytes out_str+ serialize_bytes out_bytes out_ptr+serialize_cap_op out_ptr CharOut = do+ W# p <- pop+ -- todo? Truncate the character value to a single byte?+ let !out_byte = W8# (and# p 0xFF##)+ !out_ptr' = out_ptr `plusPtr` 1+ liftIO $ poke out_ptr out_byte+ return out_ptr'+serialize_cap_op out_ptr (PushParam pn) = do+ read_param pn >>= push+ return out_ptr+serialize_cap_op out_ptr (PushValue v) = do+ push v+ return out_ptr+serialize_cap_op out_ptr (Conditional expr parts) = do+ out_ptr' <- serialize_cap_ops out_ptr expr+ out_ptr'' <- serialize_cond_parts out_ptr' parts+ return out_ptr''+ where + serialize_cond_parts ptr [] = return ptr+ serialize_cond_parts ptr ( (true_ops, false_ops) : false_parts ) = do+ -- (man 5 terminfo)+ -- Usually the %? expr part pushes a value onto the stack, and %t pops it from the+ -- stack, testing if it is nonzero (true). If it is zero (false), control+ -- passes to the %e (else) part.+ v <- pop+ ptr'' <- if v /= 0+ then serialize_cap_ops ptr true_ops+ else do+ ptr' <- serialize_cap_ops ptr false_ops+ serialize_cond_parts ptr' false_parts+ return ptr''++serialize_cap_op out_ptr BitwiseOr = do+ v_0 <- pop+ v_1 <- pop+ push $ v_0 .|. v_1+ return out_ptr+serialize_cap_op out_ptr BitwiseAnd = do+ v_0 <- pop+ v_1 <- pop+ push $ v_0 .&. v_1+ return out_ptr+serialize_cap_op out_ptr BitwiseXOr = do+ v_1 <- pop+ v_0 <- pop+ push $ v_0 `xor` v_1+ return out_ptr+serialize_cap_op out_ptr ArithPlus = do+ v_1 <- pop+ v_0 <- pop+ push $ v_0 + v_1+ return out_ptr+serialize_cap_op out_ptr ArithMinus = do+ v_1 <- pop+ v_0 <- pop+ push $ v_0 - v_1+ return out_ptr+serialize_cap_op out_ptr CompareEq = do+ v_1 <- pop+ v_0 <- pop+ push $ if v_0 == v_1 then 1 else 0+ return out_ptr+serialize_cap_op out_ptr CompareLt = do+ v_1 <- pop+ v_0 <- pop+ push $ if v_0 < v_1 then 1 else 0+ return out_ptr+serialize_cap_op out_ptr CompareGt = do+ v_1 <- pop+ v_0 <- pop+ push $ if v_0 > v_1 then 1 else 0+ return out_ptr+
+ src/Data/Terminfo/Parse.hs view
@@ -0,0 +1,320 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# OPTIONS_GHC -funbox-strict-fields -O #-}+module Data.Terminfo.Parse ( module Data.Terminfo.Parse+ , Text.ParserCombinators.Parsec.ParseError+ )+ where++import Control.Monad ( liftM )+import Control.Parallel.Strategies++import Data.Array.Unboxed+import Data.Monoid+import Data.Word++import Text.ParserCombinators.Parsec++type BytesLength = Word8+type BytesOffset = Word8+type CapBytes = UArray Word8 Word8++data CapExpression = CapExpression+ { cap_ops :: !CapOps+ , cap_bytes :: !CapBytes+ , source_string :: !String+ , param_count :: !Word+ , param_ops :: !ParamOps+ }++instance NFData CapExpression where+ rnf (CapExpression ops !_bytes !_str !_c !_p_ops) + = rnf ops ++type CapParam = Word++type CapOps = [CapOp]+data CapOp = + Bytes !BytesOffset !BytesLength+ | DecOut | CharOut+ -- This stores a 0-based index to the parameter. However the operation that implies this op is+ -- 1-based+ | PushParam !Word | PushValue !Word+ -- The conditional parts are the sequence of (%t expression, %e expression) pairs.+ -- The %e expression may be NOP+ | Conditional + { conditional_expr :: !CapOps+ , conditional_parts :: ![(CapOps, CapOps)]+ }+ | BitwiseOr | BitwiseXOr | BitwiseAnd+ | ArithPlus | ArithMinus+ | CompareEq | CompareLt | CompareGt+ deriving ( Show )++instance NFData CapOp where+ rnf (Bytes offset c) = rnf offset >| rnf c+ rnf (PushParam !_pn) = ()+ rnf (PushValue !_v) = ()+ rnf (Conditional c_expr c_parts) = rnf c_expr >| rnf c_parts+ rnf _ = ()++type ParamOps = [ParamOp]+data ParamOp =+ IncFirstTwo+ deriving ( Show )++parse_cap_expression :: String -> Either ParseError CapExpression+parse_cap_expression cap_string = + let v = runParser cap_expression_parser+ initial_build_state+ "terminfo cap" + cap_string + in case v of+ Left e -> Left e+ Right build_results -> + Right $! ( CapExpression+ { cap_ops = out_cap_ops build_results+ -- The cap bytes are the lower 8 bits of the input string's characters.+ -- \todo Verify the input string actually contains an 8bit byte per character.+ , cap_bytes = listArray (0, toEnum $ length cap_string - 1) + $ map (toEnum . fromEnum) cap_string+ , source_string = cap_string+ , param_count = out_param_count build_results+ , param_ops = out_param_ops build_results+ } + `using` rnf+ )++type CapParser a = GenParser Char BuildState a ++cap_expression_parser :: CapParser BuildResults+cap_expression_parser = do+ rs <- many $ param_escape_parser <|> bytes_op_parser + return $ mconcat rs++param_escape_parser :: CapParser BuildResults+param_escape_parser = do+ char '%'+ inc_offset 1+ literal_percent_parser <|> param_op_parser ++literal_percent_parser :: CapParser BuildResults+literal_percent_parser = do+ char '%'+ start_offset <- getState >>= return . next_offset+ inc_offset 1+ return $ BuildResults 0 [Bytes start_offset 1] []++param_op_parser :: CapParser BuildResults+param_op_parser+ = increment_op_parser + <|> push_op_parser+ <|> dec_out_parser+ <|> char_out_parser+ <|> conditional_op_parser+ <|> bitwise_op_parser+ <|> arith_op_parser+ <|> literal_int_op_parser+ <|> compare_op_parser+ <|> char_const_parser++increment_op_parser :: CapParser BuildResults+increment_op_parser = do+ char 'i'+ inc_offset 1+ return $ BuildResults 0 [] [ IncFirstTwo ]++push_op_parser :: CapParser BuildResults+push_op_parser = do+ char 'p'+ param_n <- digit >>= return . (\d -> read [d])+ inc_offset 2+ return $ BuildResults param_n [ PushParam $ param_n - 1 ] []++dec_out_parser :: CapParser BuildResults+dec_out_parser = do+ char 'd'+ inc_offset 1+ return $ BuildResults 0 [ DecOut ] []++char_out_parser :: CapParser BuildResults+char_out_parser = do+ char 'c'+ inc_offset 1+ return $ BuildResults 0 [ CharOut ] []++conditional_op_parser :: CapParser BuildResults+conditional_op_parser = do+ char '?'+ inc_offset 1+ cond_part <- many_expr conditional_true_parser+ parts <- many_p + ( do+ true_part <- many_expr $ choice [ try $ lookAhead conditional_end_parser+ , conditional_false_parser + ]+ false_part <- many_expr $ choice [ try $ lookAhead conditional_end_parser+ , conditional_true_parser+ ]+ return ( true_part, false_part )+ ) + conditional_end_parser++ let true_parts = map fst parts+ false_parts = map snd parts+ BuildResults n cond cond_param_ops = cond_part++ let n' = maximum $ n : map out_param_count true_parts+ n'' = maximum $ n' : map out_param_count false_parts++ let true_ops = map out_cap_ops true_parts+ false_ops = map out_cap_ops false_parts+ cond_parts = zip true_ops false_ops++ let true_param_ops = mconcat $ map out_param_ops true_parts+ false_param_ops = mconcat $ map out_param_ops false_parts+ p_ops = mconcat [cond_param_ops, true_param_ops, false_param_ops]++ return $ BuildResults n'' [ Conditional cond cond_parts ] p_ops++ where + many_p !p !end = choice + [ try end >> return []+ , do !v <- p + !vs <- many_p p end+ return $! v : vs+ ]+ many_expr end = liftM mconcat $ many_p ( param_escape_parser <|> bytes_op_parser ) end++conditional_true_parser :: CapParser ()+conditional_true_parser = do+ string "%t"+ inc_offset 2++conditional_false_parser :: CapParser ()+conditional_false_parser = do+ string "%e"+ inc_offset 2++conditional_end_parser :: CapParser ()+conditional_end_parser = do+ string "%;"+ inc_offset 2++bitwise_op_parser :: CapParser BuildResults+bitwise_op_parser + = bitwise_or_parser+ <|> bitwise_and_parser+ <|> bitwise_xor_parser++bitwise_or_parser :: CapParser BuildResults+bitwise_or_parser = do+ char '|'+ inc_offset 1+ return $ BuildResults 0 [ BitwiseOr ] [ ]++bitwise_and_parser :: CapParser BuildResults+bitwise_and_parser = do+ char '&'+ inc_offset 1+ return $ BuildResults 0 [ BitwiseAnd ] [ ]++bitwise_xor_parser :: CapParser BuildResults+bitwise_xor_parser = do+ char '^'+ inc_offset 1+ return $ BuildResults 0 [ BitwiseXOr ] [ ]++arith_op_parser :: CapParser BuildResults+arith_op_parser + = plus_op + <|> minus_op + where+ plus_op = do+ char '+'+ inc_offset 1+ return $ BuildResults 0 [ ArithPlus ] [ ]+ minus_op = do+ char '-'+ inc_offset 1+ return $ BuildResults 0 [ ArithMinus ] [ ]++literal_int_op_parser :: CapParser BuildResults+literal_int_op_parser = do+ char '{'+ inc_offset 1+ n_str <- many1 digit+ inc_offset $ toEnum $ length n_str+ let n :: Word = read n_str+ char '}'+ inc_offset 1+ return $ BuildResults 0 [ PushValue n ] [ ]++compare_op_parser :: CapParser BuildResults+compare_op_parser + = compare_eq_op+ <|> compare_lt_op + <|> compare_gt_op + where+ compare_eq_op = do+ char '='+ inc_offset 1+ return $ BuildResults 0 [ CompareEq ] [ ]+ compare_lt_op = do+ char '<'+ inc_offset 1+ return $ BuildResults 0 [ CompareLt ] [ ]+ compare_gt_op = do+ char '>'+ inc_offset 1+ return $ BuildResults 0 [ CompareGt ] [ ]++bytes_op_parser :: CapParser BuildResults+bytes_op_parser = do+ bytes <- many1 $ satisfy (/= '%')+ start_offset <- getState >>= return . next_offset+ let !c = toEnum $ length bytes+ !s <- getState+ let s' = s { next_offset = start_offset + c }+ setState s'+ return $ BuildResults 0 [Bytes start_offset c] []++char_const_parser :: CapParser BuildResults+char_const_parser = do+ char '\''+ char_value <- liftM (toEnum . fromEnum) anyChar + char '\''+ inc_offset 3+ return $ BuildResults 0 [ PushValue char_value ] [ ]++data BuildState = BuildState + { next_offset :: Word8+ } ++inc_offset :: Word8 -> CapParser ()+inc_offset n = do+ s <- getState+ let s' = s { next_offset = next_offset s + n }+ setState s'++initial_build_state :: BuildState+initial_build_state = BuildState 0++data BuildResults = BuildResults+ { out_param_count :: !Word+ , out_cap_ops :: !CapOps+ , out_param_ops :: !ParamOps+ }++instance Monoid BuildResults where+ mempty = BuildResults 0 [] []+ v0 `mappend` v1 + = BuildResults+ { out_param_count = (out_param_count v0) `max` (out_param_count v1)+ , out_cap_ops = (out_cap_ops v0) `mappend` (out_cap_ops v1)+ , out_param_ops = (out_param_ops v0) `mappend` (out_param_ops v1)+ }+
+ src/Graphics/Vty.hs view
@@ -0,0 +1,133 @@+-- Copyright 2009 Corey O'Connor+{-# LANGUAGE ForeignFunctionInterface, BangPatterns, UnboxedTuples #-}+{-# 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(..)+ , mkVty+ , mkVtyEscDelay+ , module Graphics.Vty.Terminal+ , module Graphics.Vty.Picture+ , module Graphics.Vty.DisplayRegion+ , Key(..)+ , Modifier(..)+ , Button(..)+ , Event(..)+ ) + where+++import Graphics.Vty.Terminal+import Graphics.Vty.Picture+import Graphics.Vty.DisplayRegion+import Graphics.Vty.LLInput++import Data.IORef++import Data.Maybe ( maybe )++import qualified System.Console.Terminfo as Terminfo+import System.IO++-- | The main object. At most one should be created.+-- An alternative is to use unsafePerformIO to automatically create a singleton Vty instance when+-- required.+--+-- This does not assure any thread safety. In theory, as long as an update action is not executed+-- when another update action is already then it's safe to call this on multiple threads.+-- +-- todo: Once the Terminal interface encompasses input this interface will be deprecated.+-- Currently, just using the Terminal interface there is no support for input events.+data Vty = Vty + { -- | Outputs the given Picture. Equivalent to output_picture applied to a display context+ -- implicitly managed by Vty. + update :: Picture -> IO ()+ -- | Get one Event object, blocking if necessary.+ , next_event :: IO Event+ -- | Handle to the terminal interface. See `Terminal`+ --+ -- The use of Vty typically follows this process:+ --+ -- 0. initialize vty+ --+ -- 1. use the update equation of Vty to display a picture+ --+ -- 2. repeat+ --+ -- 3. shutdown vty. + -- + -- todo: provide a similar abstraction to Graphics.Vty.Terminal for input. Use haskeline's+ -- input backend for implementation.+ -- + -- todo: remove explicit `shutdown` requirement. + , terminal :: TerminalHandle+ -- | 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 + term_info <- Terminfo.setupTermFromEnv + t <- terminal_handle+ reserve_display t+ (kvar, endi) <- initTermInput escDelay term_info+ intMkVty kvar ( endi >> release_display t >> release_terminal t ) t++intMkVty :: IO Event -> IO () -> TerminalHandle -> IO Vty+intMkVty kvar fend t = do+ last_pic_ref <- newIORef undefined+ last_update_ref <- newIORef Nothing++ let inner_update in_pic = do+ b <- display_bounds t+ mlast_update <- readIORef last_update_ref+ update_data <- case mlast_update of+ Nothing -> do+ d <- display_context t b+ output_picture d in_pic+ return (b, d)+ Just (last_bounds, last_context) -> do+ if b /= last_bounds+ then do+ d <- display_context t b+ output_picture d in_pic+ return (b, d)+ else do+ output_picture last_context in_pic+ return (b, last_context)+ writeIORef last_update_ref $ Just update_data+ writeIORef last_pic_ref $ Just in_pic++ let inner_refresh + = writeIORef last_update_ref Nothing+ >> readIORef last_pic_ref + >>= maybe ( return () ) ( \pic -> inner_update pic ) ++ let gkey = do k <- kvar+ case k of + (EvResize _ _) -> inner_refresh + >> display_bounds t + >>= return . ( \(DisplayRegion w h) + -> EvResize (fromEnum w) (fromEnum h)+ )+ _ -> return k++ return $ Vty { update = inner_update+ , next_event = gkey+ , terminal = t+ , refresh = inner_refresh+ , shutdown = fend + }+
+ src/Graphics/Vty/Attributes.hs view
@@ -0,0 +1,206 @@+-- Copyright 2009 Corey O'Connor+-- Display attributes+--+-- For efficiency this can be, in the future, encoded into a single 32 bit word. The 32 bit word is+-- first divided into 4 groups of 8 bits where:+-- The first group codes what action should be taken with regards to the other groups.+-- XXYYZZ__+-- XX - style action+-- 00 => reset to default+-- 01 => unchanged+-- 10 => set+-- YY - foreground color action+-- 00 => reset to default+-- 01 => unchanged+-- 10 => set+-- ZZ - background color action+-- 00 => reset to default+-- 01 => unchanged+-- 10 => set+-- __ - unused+--+-- Next is the style flags+-- SURBDO__+-- S - standout+-- U - underline+-- R - reverse video+-- B - blink+-- D - dim+-- O - bold+-- __ - unused+--+-- Then the foreground color encoded into 8 bits.+-- Then the background color encoded into 8 bits.+--+module Graphics.Vty.Attributes+ where++import Data.Bits++import Data.Word++-- | A display attribute defines the Color and Style of all the characters rendered after the+-- attribute is applied.+--+-- At most 256 colors, picked from a 240 and 16 color palette, are possible for the background and+-- foreground. The 240 colors and 16 colors are points in different palettes. See Color for more+-- information.+data Attr = Attr + { style :: !(MaybeDefault Style)+ , fore_color :: !(MaybeDefault Color)+ , back_color :: !(MaybeDefault Color)+ } deriving ( Eq, Show )++-- | Specifies the display attributes such that the final style and color values do not depend on+-- the previously applied display attribute. The display attributes can still depend on the+-- terminal's default colors (unfortunately).+data FixedAttr = FixedAttr+ { fixed_style :: !Style+ , fixed_fore_color :: !(Maybe Color)+ , fixed_back_color :: !(Maybe Color)+ } deriving ( Eq, Show )++-- | The style and color attributes can either be the terminal defaults. Or be equivalent to the+-- previously applied style. Or be a specific value.+data Eq v => MaybeDefault v = Default | KeepCurrent | SetTo !v+ deriving ( Eq, Show )++-- | Abstract data type representing a color.+-- +-- Currently the foreground and background color are specified as points in either a:+--+-- * 16 color palette. Where the first 8 colors are equal to the 8 colors of the ISO 6429 (ANSI) 8+-- color palette and the second 8 colors are bright/vivid versions of the first 8 colors.+--+-- * 240 color palette. This palette is a regular sampling of the full RGB colorspace. +-- +-- The 8 ISO 6429 (ANSI) colors are as follows:+--+-- 0. black+--+-- 1. red+--+-- 2. green+--+-- 3. yellow+--+-- 4. blue+--+-- 5. magenta+--+-- 6. cyan+--+-- 7. white+--+-- The mapping from points in the 240 color palette to colors actually displayable by the terminal+-- depends on the number of colors the terminal claims to support. Which is usually determined by+-- the terminfo "colors" property. If this property is not being accurately reported then the color+-- reproduction will be incorrect.+--+-- If the terminal reports <= 16 colors then the 240 color palette points are only mapped to the 8+-- color pallete. I'm not sure of the RGB points for the "bright" colors which is why they are not+-- addressable via the 240 color palette. +--+-- If the terminal reports > 16 colors then the 240 color palette points are mapped to the nearest+-- points in a ("color count" - 16) subsampling of the 240 color palette.+--+-- All of this assumes the terminals are behaving similarly to xterm and rxvt when handling colors.+-- And that the individual colors have not been remapped by the user. There may be a way to verify+-- this through terminfo but I don't know it.+--+-- Seriously, terminal color support is INSANE.+data Color = ISOColor !Word8 | Color240 !Word8+ deriving ( Eq, Show )++-- | Standard 8-color ANSI terminal color codes.+black, red, green, yellow, blue, magenta, cyan, white :: Color+black = ISOColor 0+red = ISOColor 1+green = ISOColor 2+yellow = ISOColor 3+blue = ISOColor 4+magenta= ISOColor 5+cyan = ISOColor 6+white = ISOColor 7++-- | Bright/Vivid variants of the standard 8-color ANSI +bright_black, bright_red, bright_green, bright_yellow :: Color+bright_blue, bright_magenta, bright_cyan, bright_white :: Color+bright_black = ISOColor 8+bright_red = ISOColor 9+bright_green = ISOColor 10+bright_yellow = ISOColor 11+bright_blue = ISOColor 12+bright_magenta= ISOColor 13+bright_cyan = ISOColor 14+bright_white = ISOColor 15++-- | Styles are represented as an 8 bit word. Each bit in the word is 1 if the style attribute+-- assigned to that bit should be applied and 0 if the style attribute should not be applied.+type Style = Word8++-- | The 6 possible style attributes:+--+-- * standout+--+-- * underline+--+-- * reverse_video+--+-- * blink+--+-- * dim+--+-- * bold/bright+--+-- ( The invisible, protect, and altcharset display attributes some terminals support are not+-- supported via VTY.)+standout, underline, reverse_video, blink, dim, bold :: Style+standout = 0x01+underline = 0x02+reverse_video = 0x04+blink = 0x08+dim = 0x10+bold = 0x20++default_style_mask :: Style+default_style_mask = 0x00++style_mask :: Attr -> Word8+style_mask attr + = case style attr of+ Default -> 0+ KeepCurrent -> 0+ SetTo v -> v++-- | true if the given Style value has the specified Style set.+has_style :: Style -> Style -> Bool+has_style s bit_mask = ( s .&. bit_mask ) /= 0++-- | Set the foreground color of an `Attr'.+with_fore_color :: Attr -> Color -> Attr+with_fore_color attr c = attr { fore_color = SetTo c }++-- | Set the background color of an `Attr'.+with_back_color :: Attr -> Color -> Attr+with_back_color attr c = attr { back_color = SetTo c }++-- | Add the given style attribute+with_style :: Attr -> Style -> Attr+with_style attr style_flag = attr { style = SetTo $ style_mask attr .|. style_flag }++-- | Sets the style, background color and foreground color to the default values for the terminal.+-- There is no easy way to determine what the default background and foreground colors are.+def_attr :: Attr+def_attr = Attr Default Default Default++-- | Keeps the style, background color and foreground color that was previously set. Used to+-- override some part of the previous style.+--+-- EG: current_style `with_fore_color` bright_magenta+--+-- Would be the currently applied style (be it underline, bold, etc) but with the foreground color+-- set to bright_magenta.+current_attr :: Attr+current_attr = Attr KeepCurrent KeepCurrent KeepCurrent+
+ src/Graphics/Vty/Debug.hs view
@@ -0,0 +1,79 @@+-- Copyright 2009 Corey O'Connor+{-# LANGUAGE ScopedTypeVariables #-}+module Graphics.Vty.Debug ( module Graphics.Vty.Debug+ )+where++import Graphics.Vty.Attributes+import Graphics.Vty.Image+import Graphics.Vty.Picture+import Graphics.Vty.Span+import Graphics.Vty.DisplayRegion++import Control.Monad+import Data.Array+import Data.Word++instance Show SpanOpSequence where+ show (SpanOpSequence _ row_ops)+ = concat $ ["{ "] ++ map (\ops -> show ops ++ "; " ) (elems row_ops) ++ [" }"]++instance Show SpanOp where+ show (AttributeChange attr) = show attr+ show (TextSpan ow cw _) = "TextSpan " ++ show ow ++ " " ++ show cw++row_ops_effected_columns :: SpanOpSequence -> [Word]+row_ops_effected_columns spans + = map span_ops_effected_columns (elems $ row_ops spans)++all_spans_have_width spans expected+ = all (== expected) ( map span_ops_effected_columns (elems $ row_ops spans) )++span_ops_effected_rows :: SpanOpSequence -> Word+span_ops_effected_rows (SpanOpSequence _ row_ops) + = toEnum $ length (filter (not . null) (elems row_ops))+ +type SpanConstructLog = [SpanConstructEvent]+data SpanConstructEvent = SpanSetAttr Attr++is_set_attr :: Attr -> SpanConstructEvent -> Bool+is_set_attr expected_attr (SpanSetAttr in_attr)+ | in_attr == expected_attr = True+is_set_attr _attr _event = False++data DebugWindow = DebugWindow Word Word+ deriving (Show, Eq)++region_for_window :: DebugWindow -> DisplayRegion+region_for_window (DebugWindow w h) = DisplayRegion w h++type TestWindow = DebugWindow++type ImageConstructLog = [ImageConstructEvent]+data ImageConstructEvent = ImageConstructEvent+ deriving ( Show, Eq )++forward_image_ops = map forward_transform debug_image_ops++forward_transform, reverse_transform :: ImageOp -> (Image -> Image)++forward_transform (ImageOp f _) = f+reverse_transform (ImageOp _ r) = r++data ImageOp = ImageOp ImageEndo ImageEndo+type ImageEndo = Image -> Image++debug_image_ops = + [ id_image_op+ -- , render_single_column_char_op+ -- , render_double_column_char_op+ ]++id_image_op :: ImageOp+id_image_op = ImageOp id id++-- render_char_op :: ImageOp+-- render_char_op = ImageOp id id+ +instance Show Picture where+ show (Picture _ image _ ) = "Picture ?? " ++ show image ++ " ??"
+ src/Graphics/Vty/DisplayRegion.hs view
@@ -0,0 +1,11 @@+-- Copyright 2009 Corey O'Connor+module Graphics.Vty.DisplayRegion+ where++import Data.Word++data DisplayRegion = DisplayRegion + { region_width :: !Word + , region_height :: !Word+ } deriving ( Show, Eq )+
+ src/Graphics/Vty/Image.hs view
@@ -0,0 +1,304 @@+-- Copyright 2009 Corey O'Connor+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE DisambiguateRecordFields #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}+module Graphics.Vty.Image ( Image(..)+ , image_width+ , image_height+ , (<|>)+ , (<->)+ , horiz_cat+ , vert_cat+ , background_fill+ , char+ , string+ , iso_10464_string+ , utf8_string+ , utf8_bytestring+ , char_fill+ -- | The possible display attributes used in constructing an `Image`.+ , module Graphics.Vty.Attributes+ )+ where++import Graphics.Vty.Attributes++import Codec.Binary.UTF8.Width++import Codec.Binary.UTF8.String ( decode )++import qualified Data.ByteString as BS+import qualified Data.Sequence as Seq+import qualified Data.String.UTF8 as UTF8+import Data.Word++infixr 5 <|>+infixr 4 <->++type StringSeq = Seq.Seq Char++-- | An image in VTY defines:+--+-- * properties required to display the image. These are properties that effect the output image+-- but are independent of position +--+-- * A set of position-dependent text and attribute regions. The possible regions are:+--+-- * a point. ( char )+--+-- * a horizontal line of characters with a single attribute. (string, utf8_string,+-- utf8_bytestring )+--+-- * a fill of a single character. (char_fill)+--+-- * a fill of the picture's background. (background_fill)+--+-- todo: increase the number of encoded bytestring formats supported.+data Image = + -- A horizontal text span is always >= 1 column and has a row height of 1.+ HorizText+ { attr :: !Attr+ -- All character data is stored as Char sequences with the ISO-10646 encoding.+ , text :: StringSeq+ -- in columns+ , output_width :: !Word -- >= 0+ , char_width :: !Word -- >= 1+ }+ -- A horizontal join can be constructed between any two images. However a HorizJoin instance is+ -- required to be between two images of equal height. The horiz_join constructor adds background+ -- filles to the provided images that assure this is true for the HorizJoin value produced.+ | HorizJoin+ { part_left :: Image + , part_right :: Image+ , output_width :: !Word -- >= 1+ , output_height :: !Word -- >= 1+ }+ -- A veritical join can be constructed between any two images. However a VertJoin instance is+ -- required to be between two images of equal width. The vert_join constructor adds background+ -- fills to the provides images that assure this is true for the VertJoin value produced.+ | VertJoin+ { part_top :: Image+ , part_bottom :: Image+ , output_width :: !Word -- >= 1+ , output_height :: !Word -- >= 1+ }+ -- A background fill will be filled with the background pattern. The background pattern is+ -- defined as a property of the Picture this Image is used to form. + | BGFill+ { output_width :: !Word -- >= 1+ , output_height :: !Word -- >= 1+ }+ -- Any image of zero size equals the id image+ | IdImage+ deriving Eq++instance Show Image where+ show ( HorizText { output_width = ow, text = txt } ) + = "HorizText [" ++ show ow ++ "] (" ++ show txt ++ ")"+ show ( BGFill { output_width = c, output_height = r } ) + = "BGFill (" ++ show c ++ "," ++ show r ++ ")"+ show ( HorizJoin { part_left = l, part_right = r, output_width = c } ) + = "HorizJoin " ++ show c ++ " ( " ++ show l ++ " <|> " ++ show r ++ " )"+ show ( VertJoin { part_top = t, part_bottom = b, output_width = c, output_height = r } ) + = "VertJoin (" ++ show c ++ ", " ++ show r ++ ") ( " ++ show t ++ " ) <-> ( " ++ show b ++ " )"+ show ( IdImage ) = "IdImage"++-- A horizontal text image of 0 characters in width simplifies to the IdImage+horiz_text :: Attr -> StringSeq -> Word -> Image+horiz_text a txt ow+ | ow == 0 = IdImage+ | otherwise = HorizText a txt ow (toEnum $ Seq.length txt)++horiz_join :: Image -> Image -> Word -> Word -> Image+horiz_join i_0 i_1 w h+ -- A horiz join of two 0 width images simplifies to the IdImage+ | w == 0 = IdImage+ -- A horizontal join where either part is 0 columns in width simplifies to the other part.+ -- This covers the case where one part is the IdImage.+ | image_width i_0 == 0 = i_1+ | image_width i_1 == 0 = i_0+ -- If the images are of the same height then no BG padding is required+ | image_height i_0 == image_height i_1 = HorizJoin i_0 i_1 w h+ -- otherwise one of the imagess needs to be padded to the right size.+ | image_height i_0 < image_height i_1 -- Pad i_0+ = let pad_amount = image_height i_1 - image_height i_0+ in horiz_join ( vert_join i_0 + ( BGFill ( image_width i_0 ) pad_amount ) + ( image_width i_0 )+ ( image_height i_1 )+ ) + i_1 + w h+ | image_height i_0 > image_height i_1 -- Pad i_1+ = let pad_amount = image_height i_0 - image_height i_1+ in horiz_join i_0 + ( vert_join i_1 + ( BGFill ( image_width i_1 ) pad_amount ) + ( image_width i_1 )+ ( image_height i_0 )+ )+ w h+horiz_join _ _ _ _ = error "horiz_join applied to undefined values."++vert_join :: Image -> Image -> Word -> Word -> Image+vert_join i_0 i_1 w h+ -- A vertical join of two 0 height images simplifies to the IdImage+ | h == 0 = IdImage+ -- A vertical join where either part is 0 rows in height simplifies to the other part.+ -- This covers the case where one part is the IdImage+ | image_height i_0 == 0 = i_1+ | image_height i_1 == 0 = i_0+ -- If the images are of the same height then no background padding is required+ | image_width i_0 == image_width i_1 = VertJoin i_0 i_1 w h+ -- Otherwise one of the images needs to be padded to the size of the other image.+ | image_width i_0 < image_width i_1+ = let pad_amount = image_width i_1 - image_width i_0+ in vert_join ( horiz_join i_0+ ( BGFill pad_amount ( image_height i_0 ) )+ ( image_width i_1 )+ ( image_height i_0 )+ )+ i_1+ w h+ | image_width i_0 > image_width i_1+ = let pad_amount = image_width i_0 - image_width i_1+ in vert_join i_0+ ( horiz_join i_1+ ( BGFill pad_amount ( image_height i_1 ) )+ ( image_width i_0 )+ ( image_height i_1 )+ )+ w h+vert_join _ _ _ _ = error "vert_join applied to undefined values."++-- | An area of the picture's bacground (See Background) of w columns and h rows.+background_fill :: Word -> Word -> Image+background_fill w h + | w == 0 = IdImage+ | h == 0 = IdImage+ | otherwise = BGFill w h++-- | The width of an Image. This is the number display columns the image will occupy.+image_width :: Image -> Word+image_width HorizText { output_width = w } = w+image_width HorizJoin { output_width = w } = w+image_width VertJoin { output_width = w } = w+image_width BGFill { output_width = w } = w+image_width IdImage = 0++-- | The height of an Image. This is the number of display rows the image will occupy.+image_height :: Image -> Word+image_height HorizText {} = 1+image_height HorizJoin { output_height = r } = r+image_height VertJoin { output_height = r } = r+image_height BGFill { output_height = r } = r+image_height IdImage = 0++-- | Combines two images side by side.+--+-- The result image will have a width equal to the sum of the two images width. And the height will+-- equal the largest height of the two images. The area not defined in one image due to a height+-- missmatch will be filled with the background pattern.+(<|>) :: Image -> Image -> Image++-- Two horizontal text spans with the same attributes can be merged.+h0@(HorizText attr_0 text_0 ow_0 _) <|> h1@(HorizText attr_1 text_1 ow_1 _) + | attr_0 == attr_1 = horiz_text attr_0 (text_0 Seq.>< text_1) (ow_0 + ow_1)+ | otherwise = horiz_join h0 h1 (ow_0 + ow_1) 1++-- Anything placed to the right of a join wil be joined to the right sub image.+-- The total columns for the join is the sum of the two arguments columns+h0@( HorizJoin {} ) <|> h1 + = horiz_join ( part_left h0 ) + ( part_right h0 <|> h1 )+ ( image_width h0 + image_width h1 )+ ( max (image_height h0) (image_height h1) )++-- Anything but a join placed to the left of a join wil be joined to the left sub image.+-- The total columns for the join is the sum of the two arguments columns+h0 <|> h1@( HorizJoin {} ) + = horiz_join ( h0 <|> part_left h1 ) + ( part_right h1 )+ ( image_width h0 + image_width h1 )+ ( max (image_height h0) (image_height h1) )++h0 <|> h1 + = horiz_join h0 + h1 + ( image_width h0 + image_width h1 )+ ( max (image_height h0) (image_height h1) )++-- | Combines two images vertically.+-- The result image will have a height equal to the sum of the heights of both images.+-- The width will equal the largest width of the two images.+-- The area not defined in one image due to a width missmatch will be filled with the background+-- pattern.+(<->) :: Image -> Image -> Image+im_t <-> im_b + = vert_join im_t + im_b + ( max (image_width im_t) (image_width im_b) ) + ( image_height im_t + image_height im_b )++-- | Compose any number of images horizontally.+horiz_cat :: [Image] -> Image+horiz_cat = foldr (<|>) IdImage++-- | Compose any number of images vertically.+vert_cat :: [Image] -> Image+vert_cat = foldr (<->) IdImage++-- | an image of a single character. This is a standard Haskell 31-bit character assumed to be in+-- the ISO-10464 encoding.+char :: Attr -> Char -> Image+char !a !c = HorizText a (Seq.singleton c) (safe_wcwidth c) 1++-- | A string of characters layed out on a single row with the same display attribute. The string is+-- assumed to be a sequence of ISO-10464 characters. +--+-- Note: depending on how the Haskell compiler represents string literals a string literal in a+-- UTF-8 encoded source file, for example, may be represented as a ISO-10464 string. +-- That is, I think, the case with GHC 6.10. This means, for the most part, you don't need to worry+-- about the encoding format when outputting string literals. Just provide the string literal+-- directly to iso_10464_string or string.+-- +iso_10464_string :: Attr -> String -> Image+iso_10464_string !a !str = horiz_text a (Seq.fromList str) (safe_wcswidth str)++-- | Alias for iso_10646_string. Since the usual case is that a literal string like "foo" is+-- represented internally as a list of ISO 10646 31 bit characters. +--+-- Note: Keep in mind that GHC will compile source encoded as UTF-8 but the literal strings, while+-- UTF-8 encoded in the source, will be transcoded to a ISO 10646 31 bit characters runtime+-- representation.+string :: Attr -> String -> Image+string = iso_10464_string++-- | A string of characters layed out on a single row. The string is assumed to be a sequence of+-- UTF-8 characters.+utf8_string :: Attr -> [Word8] -> Image+utf8_string !a !str = string a ( decode str )++safe_wcwidth :: Char -> Word+safe_wcwidth c = case wcwidth c of+ i | i < 0 -> 0 -- error "negative wcwidth"+ | otherwise -> toEnum i++safe_wcswidth :: String -> Word+safe_wcswidth str = case wcswidth str of+ i | i < 0 -> 0 -- error "negative wcswidth"+ | otherwise -> toEnum i++-- | Renders a UTF-8 encoded bytestring. +utf8_bytestring :: Attr -> BS.ByteString -> Image+utf8_bytestring !a !bs = string a (UTF8.toString $ UTF8.fromRep bs)++-- | creates a fill of the specified character. The dimensions are in number of characters wide and+-- number of rows high.+--+-- Unlike the Background fill character this character can have double column display width.+char_fill :: Enum d => Attr -> Char -> d -> d -> Image+char_fill !a !c w h = + vert_cat $ replicate (fromEnum h) $ horiz_cat $ replicate (fromEnum w) $ char a c+
+ src/Graphics/Vty/LLInput.hs view
@@ -0,0 +1,226 @@+-- Copyright 2009 Corey O'Connor+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Graphics.Vty.LLInput ( Key(..)+ , Modifier(..)+ , Button(..)+ , Event(..)+ , initTermInput + ) + where++import Data.Char+import Data.Maybe ( mapMaybe + )+import Data.List( inits )+import Data.Word+import qualified Data.Map as M( fromList, lookup )+import qualified Data.Set as S( fromList, member )++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.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)++-- |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)++-- |Mouse buttons. Not yet used.+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)++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 :: 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, ExtendedFunctions]+ setTerminalAttributes stdInput nattr Immediately+ set_term_timing+ let inputToEventThread :: IO ()+ 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 = loop+ where + loop = do+ setFdOption stdInput NonBlockingRead False+ threadWaitRead stdInput+ setFdOption stdInput NonBlockingRead True+ try readAll :: IO (Either IOException ())+ when (escDelay == 0) finishAtomicInput+ loop+ readAll = do+ (bytes, bytes_read) <- fdRead stdInput 1+ 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+ pfx = S.fromList $ concatMap (init . inits . fst) $ lst'+ mlst = M.fromList lst'+ cl' str = case S.member str pfx of+ True -> Prefix+ False -> case M.lookup str mlst of+ Just (k,m) -> Valid k m+ Nothing -> case head $ mapMaybe (\s -> (,) s `fmap` M.lookup s mlst) $ init $ inits str of+ (s,(k,m)) -> MisPfx k m (drop (length s) str)+ + -- ANSI specific bits+++ classify, classifyTab :: [Char] -> KClass+ + -- 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+ classify other = classifyTab other++ classifyUtf8 s = case decode ((map (fromIntegral . ord) s) :: [Word8]) of+ Just (unicodeChar, _) -> Valid (KASCII unicodeChar) []+ _ -> Invalid -- something bad happened; just ignore and continue.+ + classifyTab = compile (caps_classify_table : ansi_classify_table)+ + caps_tabls = [("khome", (KHome, [])), + ("kend", (KEnd, [])),+ ("cbt", (KBackTab, [])),+ ("kcud1", (KDown, [])),+ ("kcuu1", (KUp, [])),+ ("kcuf1", (KRight, [])),+ ("kcub1", (KLeft, [])),++ ("kLFT", (KLeft, [MShift])),+ ("kRIT", (KRight, [MShift]))+ ]+ + caps_classify_table = [(x,y) | (Just x,y) <- map (first (getCapability terminal . tiGetStr)) $ caps_tabls]+ + ansi_classify_table :: [[([Char], (Key, [Modifier]))]]+ ansi_classify_table =+ [ let k c s = ("\ESC["++c,(s,[])) in [ k "G" KNP5, k "P" KPause, k "A" KUp, k "B" KDown, k "C" KRight, k "D" KLeft ],++ -- Support for arrows+ [("\ESC[" ++ charCnt ++ show mc++c,(s,m)) + | charCnt <- ["1;", ""], -- we can have a count or not+ (m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3), + ([MShift, MCtrl],6), ([MShift, MMeta],4)], -- modifiers and their codes+ (c,s) <- [("A", KUp), ("B", KDown), ("C", KRight), ("D", KLeft)] -- directions and their codes+ ],+ + let k n s = ("\ESC["++show n++"~",(s,[])) in zipWith k [2::Int,3,5,6] [KIns,KDel,KPageUp,KPageDown],++ -- Support for simple characters.+ [ (x:[],(KASCII x,[])) | x <- map toEnum [0..255] ],++ -- Support for function keys (should use terminfo)+ [ ("\ESC[["++[toEnum(64+i)],(KFun i,[])) | i <- [1..5] ],+ let f ff nrs m = [ ("\ESC["++show n++"~",(KFun (n-(nrs!!0)+ff), m)) | n <- nrs ] in+ concat [ f 6 [17..21] [], f 11 [23,24] [], f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ],+ [ ('\ESC':[x],(KASCII x,[MMeta])) | x <- '\ESC':'\t':[' ' .. '\DEL'] ],++ -- Ctrl+Char+ [ ([toEnum x],(KASCII y,[MCtrl])) + | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_']),+ y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.+ ],+ + -- Ctrl+Meta+Char+ [ ('\ESC':[toEnum x],(KASCII y,[MMeta,MCtrl])) | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_']) ],++ -- Special support+ [ -- special support for ESC + ("\ESC",(KEsc,[])) , ("\ESC\ESC",(KEsc,[MMeta])), ++ -- Special support for backspace+ ("\DEL",(KBS,[])), ("\ESC\DEL",(KBS,[MMeta])),+ + -- Special support for Enter+ ("\ESC\^J",(KEnter,[MMeta])), ("\^J",(KEnter,[])) ] + ]+ + eventThreadId <- forkIO $ inputToEventThread+ inputThreadId <- forkIO $ inputThread+ 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+ return (readChan eventChannel, uninit)++first :: (a -> b) -> (a,c) -> (b,c)+first f (x,y) = (f x, y)++utf8Length :: (Num t, Ord a, Num a) => a -> t+utf8Length c + | c < 0x80 = 1+ | c < 0xE0 = 2+ | c < 0xF0 = 3+ | otherwise = 4++foreign import ccall "set_term_timing" set_term_timing :: IO ()+
+ src/Graphics/Vty/Picture.hs view
@@ -0,0 +1,70 @@+-- Copyright 2009 Corey O'Connor+module Graphics.Vty.Picture ( module Graphics.Vty.Picture+ , Image+ , image_width+ , image_height+ , (<|>)+ , (<->)+ , horiz_cat+ , vert_cat+ , background_fill+ , char+ , string+ , iso_10464_string+ , utf8_string+ , utf8_bytestring+ , char_fill+ -- | The possible display attributes used in constructing an `Image`.+ , module Graphics.Vty.Attributes+ )+ where++import Graphics.Vty.Attributes+import Graphics.Vty.Image hiding ( attr )++import Data.Word++-- |The type of images to be displayed using 'update'. +-- Can be constructed directly or using `pic_for_image`. Which provides an initial instance with+-- reasonable defaults for pic_cursor and pic_background.+data Picture = Picture+ { pic_cursor :: Cursor+ , pic_image :: Image + , pic_background :: Background+ }++-- | Create a picture for display for the given image. The picture will not have a displayed cursor+-- and the background display attribute will be `current_attr`.+pic_for_image :: Image -> Picture+pic_for_image i = Picture + { pic_cursor = NoCursor+ , pic_image = i+ , pic_background = Background ' ' current_attr+ }++-- | A picture can be configured either to not show the cursor or show the cursor at the specified+-- character position. +--+-- There is not a 1 to 1 map from character positions to a row and column on the screen due to+-- characters that take more than 1 column.+--+-- todo: The Cursor can be given a (character,row) offset outside of the visible bounds of the+-- output region. In this case the cursor will not be shown.+data Cursor = + NoCursor+ | Cursor Word Word++-- | Unspecified regions are filled with the picture's background pattern. The background pattern+-- can specify a character and a display attribute. If the display attribute used previously should+-- be used for a background fill then use `current_attr` for the background attribute. This is the+-- default background display attribute.+--+-- (tofix) The current attribute is always set to the default attributes at the start of updating the+-- screen to a picture.+--+-- (tofix) The background character *must* occupy a single column and no more. +data Background = Background + { background_char :: Char + , background_attr :: Attr+ }+
+ src/Graphics/Vty/Span.hs view
@@ -0,0 +1,222 @@+-- Copyright 2009 Corey O'Connor+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- The ops to define the content for an output region. +module Graphics.Vty.Span+ where++import Codec.Binary.UTF8.Width ( wcwidth )++import Graphics.Vty.Image+import Graphics.Vty.Picture+import Graphics.Vty.DisplayRegion++import Codec.Binary.UTF8.String ( encode )++import Control.Monad ( forM_ )+import Control.Monad.ST.Strict++import Data.Array.ST+import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as BInt+import qualified Data.Foldable as Foldable+import Data.Function+import Data.List+import Data.Word+import qualified Data.ByteString.UTF8 as BSUTF8 +import qualified Data.String.UTF8 as UTF8++import Foreign.Storable ( pokeByteOff )++import GHC.Arr++{- | A picture is translated into a sequences of state changes and character spans.+ - State changes are currently limited to new attribute values. The attribute is applied to all+ - following spans. Including spans of the next row. The nth element of the sequence represents the+ - nth row (from top to bottom) of the picture to render.+ -+ - A span op sequence will be defined for all rows and columns (and no more) of the region provided+ - with the picture to spans_for_pic.+ -+ - + - todo: Partition attribute changes into multiple categories according to the serialized+ - representation of the various attributes.+ -}+data SpanOpSequence = SpanOpSequence + { effected_region :: DisplayRegion+ , row_ops :: RowOps + } ++type RowOps = Array Word SpanOps+type SpanOps = [SpanOp]++span_ops_columns :: SpanOpSequence -> Word+span_ops_columns ops = region_width $ effected_region ops++span_ops_rows :: SpanOpSequence -> Word+span_ops_rows ops = region_height $ effected_region ops++span_ops_effected_columns :: [SpanOp] -> Word+span_ops_effected_columns in_ops = span_ops_effected_columns' 0 in_ops+ where + span_ops_effected_columns' t [] = t+ span_ops_effected_columns' t (TextSpan w _ _ : r) = span_ops_effected_columns' (t + w) r+ span_ops_effected_columns' t (_ : r) = span_ops_effected_columns' t r++-- |+-- +-- todo: This type may need to be restructured to increase sharing in the bytestring+-- +-- todo: Make foldable+data SpanOp =+ AttributeChange !Attr+ -- | a span of UTF-8 text occupies a specific number of screen space columns. A single UTF+ -- character does not necessarially represent 1 colunm. See Codec.Binary.UTF8.Width+ -- TextSpan [output width in columns] [number of characters] [data]+ | TextSpan !Word !Word (UTF8.UTF8 B.ByteString)+ deriving Eq++span_op_has_width :: SpanOp -> Maybe (Word, Word)+span_op_has_width (TextSpan ow cw _) = Just (cw, ow)+span_op_has_width _ = Nothing++columns_to_char_offset :: Word -> SpanOp -> Word+columns_to_char_offset cx (TextSpan _ _ utf8_str) =+ let str = UTF8.toString utf8_str+ in toEnum $ sum $ map wcwidth $ take (fromEnum cx) str+columns_to_char_offset _cx _ = error "columns_to_char_offset applied to span op without width"++-- | Produces the span ops that will render the given picture, possibly cropped or padded, into the+-- specified region.+spans_for_pic :: Picture -> DisplayRegion -> SpanOpSequence+spans_for_pic pic r = SpanOpSequence r $ runSTArray (build_spans pic r)++build_spans :: Picture -> DisplayRegion -> ST s (STArray s Word [SpanOp])+build_spans pic region = do+ -- m for mutable+ mrow_ops <- newSTArray (0, region_height region - 1) []+ -- I think this can be better optimized if the build produced span operations in display order.+ -- However, I got stuck trying to implement an algorithm that did this. This will be considered+ -- as a possible future optimization. + --+ -- A depth first traversal of the image is performed.+ -- ordered according to the column range defined by the image from least to greatest.+ -- The output row ops will at least have the region of the image specified. Iterate over all+ -- output rows and output background fills for all unspecified columns.+ if region_height region > 0+ then do + -- The ops builder recursively descends the image and outputs span ops that would+ -- display that image. The number of columns remaining in this row before exceeding the+ -- bounds is also provided. This is used to clip the span ops produced.+ ops_for_row mrow_ops (pic_background pic) region (pic_image pic) 0 (region_width region)+ -- Fill in any unspecified columns with the background pattern.+ forM_ [0 .. region_height region - 1] $ \row -> do+ end_x <- readSTArray mrow_ops row >>= return . span_ops_effected_columns+ if end_x < region_width region + then snoc_bg_fill mrow_ops (pic_background pic) (region_width region - end_x) row+ else return ()+ else return ()+ return mrow_ops++type MRowOps s = STArray s Word SpanOps++ops_for_row :: MRowOps s -> Background -> DisplayRegion -> Image -> Word -> Word -> ST s ()+ops_for_row mrow_ops bg region image y remaining_columns+ | remaining_columns == 0 = return ()+ | y >= region_height region = return ()+ | otherwise = case image of+ IdImage -> return ()+ -- The width provided is the number of columns this text span will occupy when displayed.+ -- if this is greater than the number of remaining columsn the output has to be produced a+ -- character at a time.+ HorizText a text_str ow cw -> do+ snoc_text_span a text_str ow cw mrow_ops y remaining_columns+ VertJoin t b _ _ -> do+ ops_for_row mrow_ops bg region t y remaining_columns+ ops_for_row mrow_ops bg region b (y + image_height t) remaining_columns+ HorizJoin l r _ _ -> do+ ops_for_row mrow_ops bg region l y remaining_columns+ -- Don't output the right part unless there is at least a single column left after+ -- outputting the left part.+ if image_width l < remaining_columns+ then ops_for_row mrow_ops bg region r y (remaining_columns - image_width l)+ else return ()+ BGFill width height -> do+ let actual_height = if y + height > region_height region + then region_height region - y+ else height+ actual_width = if width > remaining_columns+ then remaining_columns+ else width+ forM_ [y .. y + actual_height - 1] $ \y' -> snoc_bg_fill mrow_ops bg actual_width y'++snoc_text_span :: (Foldable.Foldable t) + => Attr + -> t Char + -> Word -- width of text span in output display columns+ -> Word -- width of text span in characters+ -> MRowOps s + -> Word + -> Word + -> ST s ()+snoc_text_span a text_str ow cw mrow_ops y remaining_columns = do+ if ow > remaining_columns+ then do+ snoc_op mrow_ops y $ AttributeChange a+ let (ow', cw', txt) = Foldable.foldl' + build_cropped_txt+ ( 0, 0, B.empty )+ text_str+ snoc_op mrow_ops y $ TextSpan ow' cw' (UTF8.fromRep txt)+ else do+ snoc_op mrow_ops y $ AttributeChange a+ let utf8_bs = ({-# SCC "BSUTF8.fromString" #-} BSUTF8.fromString) $ Foldable.foldMap (\c -> [c]) text_str+ snoc_op mrow_ops y $ TextSpan ow cw (UTF8.fromRep utf8_bs)+ where+ build_cropped_txt (ow', char_count', b0) c = {-# SCC "build_cropped_txt" #-}+ let w = wcwidth c+ -- Characters with unknown widths occupy 1 column. + -- + -- todo: Not sure if this is actually correct.+ -- I presume there is a replacement character that is output by the terminal instead of+ -- the character. If so then this replacement process may need to be implemented+ -- manually for consistent behavior across terminals.+ w' = toEnum $ if w < 0 then 1 else w+ in if (w' + ow') > remaining_columns+ then ( ow', char_count', b0 )+ else ( ow' + w', char_count' + 1, B.append b0 $ B.pack $ encode [c] )++snoc_bg_fill :: MRowOps s -> Background -> Word -> Word -> ST s ()+snoc_bg_fill _row_ops _bg 0 _row + = return ()+snoc_bg_fill mrow_ops (Background c back_attr) fill_length row + = do+ snoc_op mrow_ops row $ AttributeChange back_attr+ -- By all likelyhood the background character will be an ASCII character. Which is a single+ -- byte in utf8. Optimize for this special case.+ utf8_bs <- if c <= (toEnum 255 :: Char)+ then+ let !(c_byte :: Word8) = BInt.c2w c+ in unsafeIOToST $ do+ BInt.create ( fromEnum fill_length ) + $ \ptr -> mapM_ (\i -> pokeByteOff ptr i c_byte)+ [0 .. fromEnum (fill_length - 1)]+ else + let !(c_bytes :: [Word8]) = encode [c]+ in unsafeIOToST $ do+ BInt.create (fromEnum fill_length * length c_bytes) + $ \ptr -> mapM_ (\(i,b) -> pokeByteOff ptr i b)+ $ zip [0 .. fromEnum (fill_length - 1)] (cycle c_bytes)+ snoc_op mrow_ops row $ TextSpan fill_length fill_length (UTF8.fromRep utf8_bs)++snoc_op :: MRowOps s -> Word -> SpanOp -> ST s ()+snoc_op !mrow_ops !row !op = do+ ops <- readSTArray mrow_ops row+ let ops' = ops ++ [op]+ writeSTArray mrow_ops row ops'+ return ()+
+ src/Graphics/Vty/Terminal.hs view
@@ -0,0 +1,126 @@+-- Copyright 2009 Corey O'Connor+-- * Graphics.Vty.Terminal: This instantiates an abtract interface to the terminal interface+-- based on the TERM and COLORTERM environment variables. +-- * Graphics.Vty.Terminal.Generic: Defines the generic interface all terminals need to implement.+-- * Graphics.Vty.Terminal.TerminfoBased: Defines a terminal instance that uses terminfo for all+-- control strings. +-- - No attempt is made to change the character set to UTF-8 for these terminals. I don't+-- know a way to reliably determine if that is required or how to do so.+-- * Graphics.Vty.Terminal.XTermColor: This module contains an interface suitable for+-- xterm-like terminals. These are the terminals where TERM == xterm. This does use terminfo+-- for as many control codes as possible. H: This should derive functionality from the+-- TerminfoBased terminal.+--+--+{-# LANGUAGE ScopedTypeVariables #-}+module Graphics.Vty.Terminal ( module Graphics.Vty.Terminal+ , Terminal(..)+ , TerminalHandle(..)+ , DisplayHandle(..)+ , output_picture+ , display_context+ )+ where+++import Graphics.Vty.Terminal.Generic+import Graphics.Vty.Terminal.MacOSX as MacOSX+import Graphics.Vty.Terminal.XTermColor as XTermColor+import Graphics.Vty.Terminal.TerminfoBased as TerminfoBased++import Control.Exception ( SomeException, try )+import Data.Either+import Data.List ( isPrefixOf )+import Data.Word++import System.Environment++-- | Returns a TerminalHandle (an abstract Terminal instance) for the current terminal.+--+-- The specific Terminal implementation used is hidden from the API user. All terminal+-- implementations are assumed to perform more, or less, the same. Currently all implementations use+-- terminfo for at least some terminal specific information. This is why platforms without terminfo+-- are not supported. However, as mentioned before, any specifics about it being based on terminfo+-- are hidden from the API user. If a terminal implementation is developed for a terminal for a+-- platform without terminfo support then Vty should work as expected on that terminal.+--+-- Selection of a terminal is done as follows:+--+-- * If TERM == xterm+-- then the terminal might be one of the Mac OS X .app terminals. Check if that might be+-- the case and use MacOSX if so.+-- otherwise use XTermColor.+--+-- * for any other TERM value TerminfoBased is used.+--+--+-- The terminal has to be determined dynamically at runtime. To satisfy this requirement all+-- terminals instances are lifted into an abstract terminal handle via existential qualification.+-- This implies that the only equations that can used are those in the terminal class.+--+-- To differentiate between Mac OS X terminals this uses the TERM_PROGRAM environment variable.+-- However, an xterm started by Terminal or iTerm *also* has TERM_PROGRAM defined since the+-- environment variable is not reset/cleared by xterm. However a Terminal.app or iTerm.app started+-- from an xterm under X11 on mac os x will likely be done via open. Since this does not propogate+-- environment variables (I think?) this assumes that XTERM_VERSION will never be set for a true+-- Terminal.app or iTerm.app session.+--+-- todo: add an implementation for windows that does not depend on terminfo. Should be installable+-- with only what is provided in the haskell platform.+--+-- todo: The Terminal interface does not provide any input support.+terminal_handle :: IO TerminalHandle+terminal_handle = do+ term_type <- getEnv "TERM"+ t <- if "xterm" `isPrefixOf` term_type+ then do+ maybe_terminal_app <- get_env "TERM_PROGRAM"+ case maybe_terminal_app of+ Nothing + -> XTermColor.terminal_instance term_type >>= new_terminal_handle+ Just v | v == "Apple_Terminal" || v == "iTerm.app" + -> do+ maybe_xterm <- get_env "XTERM_VERSION"+ case maybe_xterm of+ Nothing -> MacOSX.terminal_instance v >>= new_terminal_handle+ Just _ -> XTermColor.terminal_instance term_type >>= new_terminal_handle+ -- Assume any other terminal that sets TERM_PROGRAM to not be an OS X terminal.app+ -- like terminal?+ _ -> XTermColor.terminal_instance term_type >>= new_terminal_handle+ -- Not an xterm-like terminal. try for generic terminfo.+ else TerminfoBased.terminal_instance term_type >>= new_terminal_handle+ return t+ where+ get_env var = do+ mv <- try $ getEnv var+ case mv of+ Left (_e :: SomeException) -> return $ Nothing+ Right v -> return $ Just v++-- | Sets the cursor position to the given output column and row. +--+-- This is not necessarially the same as the character position with the same coordinates.+-- Characters can be a variable number of columns in width.+--+-- Currently, the only way to set the cursor position to a given character coordinate is to specify+-- the coordinate in the Picture instance provided to output_picture or refresh.+set_cursor_pos :: TerminalHandle -> Word -> Word -> IO ()+set_cursor_pos t x y = do+ bounds <- display_bounds t+ d <- display_context t bounds+ marshall_to_terminal t (move_cursor_required_bytes d x y) (serialize_move_cursor d x y)++-- | Hides the cursor+hide_cursor :: TerminalHandle -> IO ()+hide_cursor t = do+ bounds <- display_bounds t+ d <- display_context t bounds+ marshall_to_terminal t (hide_cursor_required_bytes d) (serialize_hide_cursor d) + +-- | Shows the cursor+show_cursor :: TerminalHandle -> IO ()+show_cursor t = do+ bounds <- display_bounds t+ d <- display_context t bounds+ marshall_to_terminal t (show_cursor_required_bytes d) (serialize_show_cursor d) +
+ src/Graphics/Vty/Terminal/Debug.hs view
@@ -0,0 +1,115 @@+-- Copyright 2009 Corey O'Connor+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+module Graphics.Vty.Terminal.Debug ( DebugTerminal(..)+ , DebugDisplay(..)+ , terminal_instance+ , dehandle+ )+ where++import Graphics.Vty.DisplayRegion+import Graphics.Vty.Terminal.Generic++import Control.Monad.State.Strict++import qualified Data.ByteString.UTF8 as BS+import qualified Data.ByteString as BSCore+import Data.IORef+import qualified Data.Sequence as Seq+import qualified Data.String.UTF8 as UTF8+import Data.Word++import Foreign.Marshal.Array ( peekArray )+import Foreign.Ptr ( plusPtr )+import Foreign.Storable ( poke )++import Unsafe.Coerce++-- | The debug display terminal produces a string representation of the requested picture. There is+-- *not* an isomorphism between the string representation and the picture. The string+-- representation is a simplification of the picture that is only useful in debugging VTY without+-- considering terminal specific issues.+--+-- The debug implementation is useful in manually determining if the sequence of terminal operations+-- matches the expected sequence. So requirement of the produced representation is simplicity in+-- parsing the text representation and determining how the picture was mapped to terminal+-- operations.+--+-- All terminals support the operations specified in the Terminal class defined in+-- Graphics.Vty.Terminal. As an instance of the Terminal class is also an instance of the Monad+-- class there exists a monoid that defines it's algebra. The string representation is a sequence of+-- identifiers where each identifier is the name of an operation in the algebra.++data DebugTerminal = DebugTerminal+ { debug_terminal_last_output :: IORef (UTF8.UTF8 BS.ByteString)+ , debug_terminal_bounds :: DisplayRegion+ } ++instance Terminal DebugTerminal where+ terminal_ID _t = "debug_terminal"+ release_terminal _t = return ()+ reserve_display _t = return ()+ release_display _t = return ()+ display_bounds t = return $ debug_terminal_bounds t+ display_terminal_instance t r c = return $ c (DebugDisplay r)+ output_byte_buffer t out_buffer buffer_size + = do+ putStrLn $ "output_byte_buffer ?? " ++ show buffer_size+ peekArray (fromEnum buffer_size) out_buffer + >>= return . UTF8.fromRep . BSCore.pack+ >>= writeIORef (debug_terminal_last_output t)++data DebugDisplay = DebugDisplay+ { debug_display_bounds :: DisplayRegion+ } ++terminal_instance :: DisplayRegion -> IO TerminalHandle+terminal_instance r = do+ output_ref <- newIORef undefined+ new_terminal_handle $ DebugTerminal output_ref r++dehandle :: TerminalHandle -> DebugTerminal+dehandle (TerminalHandle t _) = unsafeCoerce t++instance DisplayTerminal DebugDisplay where+ -- | Provide the current bounds of the output terminal.+ context_region d = debug_display_bounds d++ -- | A cursor move is always visualized as the single character 'M'+ move_cursor_required_bytes _d _x _y = 1++ -- | A cursor move is always visualized as the single character 'M'+ serialize_move_cursor _d _x _y ptr = do+ poke ptr (toEnum $ fromEnum 'M') + return $ ptr `plusPtr` 1++ -- | Show cursor is always visualized as the single character 'S'+ show_cursor_required_bytes _d = 1++ -- | Show cursor is always visualized as the single character 'S'+ serialize_show_cursor _d ptr = do+ poke ptr (toEnum $ fromEnum 'S') + return $ ptr `plusPtr` 1++ -- | Hide cursor is always visualized as the single character 'H'+ hide_cursor_required_bytes _d = 1++ -- | Hide cursor is always visualized as the single character 'H'+ serialize_hide_cursor _d ptr = do+ poke ptr (toEnum $ fromEnum 'H') + return $ ptr `plusPtr` 1++ -- | An attr change is always visualized as the single character 'A'+ attr_required_bytes _d _fattr _diffs _attr = 1++ -- | An attr change is always visualized as the single character 'A'+ serialize_set_attr _d _fattr _diffs _attr ptr = do+ poke ptr (toEnum $ fromEnum 'A')+ return $ ptr `plusPtr` 1++ default_attr_required_bytes _d = 1+ serialize_default_attr _d ptr = do+ poke ptr (toEnum $ fromEnum 'D')+ return $ ptr `plusPtr` 1+
+ src/Graphics/Vty/Terminal/Generic.hs view
@@ -0,0 +1,475 @@+-- Copyright 2009 Corey O'Connor+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+module Graphics.Vty.Terminal.Generic ( module Graphics.Vty.Terminal.Generic+ , OutputBuffer+ )+ where++import Data.Marshalling++import Graphics.Vty.Picture+import Graphics.Vty.Span+import Graphics.Vty.DisplayRegion++import Control.Monad ( liftM )++import Data.Array+import Data.Bits ( (.&.) )+import qualified Data.ByteString.Internal as BSCore+import Data.Foldable+import Data.IORef+import Data.Monoid ( mconcat )+import Data.Word+import Data.String.UTF8 hiding ( foldl )++import System.IO++data TerminalHandle where+ TerminalHandle :: Terminal t => t -> TerminalState -> TerminalHandle++terminal_state :: TerminalHandle -> TerminalState+terminal_state (TerminalHandle _ s) = s++new_terminal_handle :: forall t. Terminal t => t -> IO TerminalHandle+new_terminal_handle t = liftM (TerminalHandle t) initial_terminal_state++data TerminalState = TerminalState++initial_terminal_state :: IO TerminalState+initial_terminal_state = return $ TerminalState ++class Terminal t where+ -- | Text identifier for the terminal. Used for debugging.+ terminal_ID :: t -> String+ -- | + release_terminal :: t -> IO ()+ -- | Clear the display and initialize the terminal to some initial display state. + --+ -- The expectation of a program is that the display starts in some initial state. + -- The initial state would consist of fixed values + -- - cursor at top left+ -- - UTF-8 character encoding+ -- - drawing characteristics are the default+ -- The abstract operation I think all these behaviors are instances of is reserving exclusive+ -- access to a display such that:+ -- - The previous state cannot be determined+ -- - When exclusive access to a display is release the display returns to the previous state.+ --+ reserve_display :: t -> IO ()++ -- | Return the display to the state before reserve_display+ -- If no previous state then set the display state to the initial state.+ release_display :: t -> IO ()+ + -- | Returns the current display bounds.+ display_bounds :: t -> IO DisplayRegion++ -- Internal method used to provide the DisplayTerminal instance to the DisplayHandle+ -- constructor.+ display_terminal_instance :: t + -> DisplayRegion + -> (forall d. DisplayTerminal d => d -> DisplayHandle) + -> IO DisplayHandle++ -- | Output the byte buffer of the specified size to the terminal device. The size is equal to+ -- end_ptr - start_ptr+ output_byte_buffer :: t -> OutputBuffer -> Word -> IO ()++instance Terminal TerminalHandle where+ terminal_ID (TerminalHandle t _) = terminal_ID t+ release_terminal (TerminalHandle t _) = release_terminal t+ reserve_display (TerminalHandle t _) = reserve_display t+ release_display (TerminalHandle t _) = release_display t+ display_bounds (TerminalHandle t _) = display_bounds t+ display_terminal_instance (TerminalHandle t _) = display_terminal_instance t+ output_byte_buffer (TerminalHandle t _) = output_byte_buffer t++data DisplayHandle where+ DisplayHandle :: DisplayTerminal d => d -> TerminalHandle -> DisplayState -> DisplayHandle++-- | Acquire display access to the given region of the display.+-- Currently all regions have the upper left corner of (0,0) and the lower right corner at +-- (max display_width provided_width, max display_height provided_height)+display_context :: TerminalHandle -> DisplayRegion -> IO DisplayHandle+display_context t b = do+ s <- initial_display_state+ let c d = DisplayHandle d t s+ display_terminal_instance t b c++data DisplayState = DisplayState+ { previous_output_ref :: IORef (Maybe SpanOpSequence)+ }++initial_display_state :: IO DisplayState+initial_display_state = liftM DisplayState $ newIORef Nothing++class DisplayTerminal d where+ -- | Provide the bounds of the display context. + context_region :: d -> DisplayRegion++ -- | Maximum number of colors supported by the context.+ context_color_count :: d -> Word++ -- | sets the output position to the specified row and column. Where the number of bytes+ -- required for the control codes can be specified seperate from the actual byte sequence.+ move_cursor_required_bytes :: d -> Word -> Word -> Word+ serialize_move_cursor :: d -> Word -> Word -> OutputBuffer -> IO OutputBuffer++ show_cursor_required_bytes :: d -> Word+ serialize_show_cursor :: d -> OutputBuffer -> IO OutputBuffer++ hide_cursor_required_bytes :: d -> Word+ serialize_hide_cursor :: d -> OutputBuffer -> IO OutputBuffer++ -- | Assure the specified output attributes will be applied to all the following text until the+ -- next output attribute change. Where the number of bytes required for the control codes can+ -- be specified seperate from the actual byte sequence. The required number of bytes must be+ -- at least the maximum number of bytes required by any attribute changes. The serialization+ -- equations must provide the ptr to the next byte to be specified in the output buffer.+ --+ -- The currently applied display attributes are provided as well. The Attr data type can+ -- specify the style or color should not be changed from the currently applied display+ -- attributes. In order to support this the currently applied display attributes are required.+ -- In addition it may be possible to optimize the state changes based off the currently applied+ -- display attributes.+ attr_required_bytes :: d -> FixedAttr -> Attr -> DisplayAttrDiffs -> Word+ serialize_set_attr :: d -> FixedAttr -> Attr -> DisplayAttrDiffs -> OutputBuffer -> IO OutputBuffer++ -- | Reset the display attributes to the default display attributes+ default_attr_required_bytes :: d -> Word+ serialize_default_attr :: d -> OutputBuffer -> IO OutputBuffer+++instance DisplayTerminal DisplayHandle where+ context_region (DisplayHandle d _ _) = context_region d+ context_color_count (DisplayHandle d _ _) = context_color_count d+ move_cursor_required_bytes (DisplayHandle d _ _) = move_cursor_required_bytes d+ serialize_move_cursor (DisplayHandle d _ _) = serialize_move_cursor d+ show_cursor_required_bytes (DisplayHandle d _ _) = show_cursor_required_bytes d+ serialize_show_cursor (DisplayHandle d _ _) = serialize_show_cursor d+ hide_cursor_required_bytes (DisplayHandle d _ _) = hide_cursor_required_bytes d+ serialize_hide_cursor (DisplayHandle d _ _) = serialize_hide_cursor d+ attr_required_bytes (DisplayHandle d _ _) = attr_required_bytes d+ serialize_set_attr (DisplayHandle d _ _) = serialize_set_attr d+ default_attr_required_bytes (DisplayHandle d _ _) = default_attr_required_bytes d+ serialize_default_attr (DisplayHandle d _ _) = serialize_default_attr d+ +-- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.+utf8_text_required_bytes :: UTF8 BSCore.ByteString -> Word+utf8_text_required_bytes str =+ let (_, _, src_bytes_length) = BSCore.toForeignPtr (toRep str)+ in toEnum src_bytes_length++-- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.+serialize_utf8_text :: UTF8 BSCore.ByteString -> OutputBuffer -> IO OutputBuffer+serialize_utf8_text str dest_ptr = + let (src_fptr, src_ptr_offset, src_bytes_length) = BSCore.toForeignPtr (toRep str)+ in withForeignPtr src_fptr $ \src_ptr -> do+ let src_ptr' = src_ptr `plusPtr` src_ptr_offset+ BSCore.memcpy dest_ptr src_ptr' (toEnum src_bytes_length) + return (dest_ptr `plusPtr` src_bytes_length)+++-- | Displays the given `Picture`.+--+-- 0. The image is cropped to the display size. +--+-- 1. Converted into a sequence of attribute changes and text spans.+-- +-- 2. The cursor is hidden.+--+-- 3. Serialized to the display.+--+-- 4. The cursor is then shown and positioned or kept hidden.+--+-- +-- todo: specify possible IO exceptions.+-- abstract from IO monad to a MonadIO instance.+output_picture :: DisplayHandle -> Picture -> IO ()+output_picture (DisplayHandle d t s) pic = do+ let !r = context_region d+ let !ops = spans_for_pic pic r+ let !initial_attr = FixedAttr default_style_mask Nothing Nothing+ -- Diff the previous output against the requested output. Differences are currently on a per-row+ -- basis.+ diffs :: [Bool]+ <- readIORef (previous_output_ref s) + >>= \mprevious_ops -> case mprevious_ops of+ Nothing + -> return $ replicate ( fromEnum $ region_height $ effected_region ops ) + True+ Just previous_ops + -> if effected_region previous_ops /= effected_region ops+ then return $ replicate ( fromEnum $ region_height $ effected_region ops ) + True+ else return $ zipWith (/=) ( elems $ row_ops previous_ops ) + ( elems $ row_ops ops )++ -- determine the number of bytes required to completely serialize the output ops.+ let total = hide_cursor_required_bytes d + + default_attr_required_bytes d+ + required_bytes d initial_attr diffs ops + + case pic_cursor pic of+ NoCursor -> 0+ Cursor x y -> show_cursor_required_bytes d+ + move_cursor_required_bytes d x y++ -- ... then serialize+ start_ptr <- mallocBytes (fromEnum total)+ ptr <- serialize_hide_cursor d start_ptr+ ptr' <- serialize_default_attr d ptr+ ptr'' <- serialize_output_ops d ptr' initial_attr diffs ops+ end_ptr <- case pic_cursor pic of+ NoCursor -> return ptr''+ Cursor x y -> do+ let m = cursor_output_map ops $ pic_cursor pic+ (ox, oy) = char_to_output_pos m (x,y)+ serialize_show_cursor d ptr'' >>= serialize_move_cursor d ox oy+ -- todo: How to handle exceptions?+ case end_ptr `minusPtr` start_ptr of+ count | count < 0 -> fail "End pointer before start of buffer."+ | toEnum count > total -> fail $ "End pointer past end of buffer by " ++ show (toEnum count - total)+ | otherwise -> output_byte_buffer t start_ptr (toEnum count)+ free start_ptr+ -- Cache the output spans.+ writeIORef (previous_output_ref s) (Just ops)+ return ()++required_bytes :: DisplayTerminal d => d -> FixedAttr -> [Bool] -> SpanOpSequence -> Word+required_bytes d in_fattr diffs ops = + let (_, n, _, _) = foldl' required_bytes' (0, 0, in_fattr, diffs) ( row_ops ops )+ in n+ where + required_bytes' (y, current_sum, fattr, True : diffs') span_ops+ = let (s, fattr') = span_ops_required_bytes d y fattr span_ops + in ( y + 1, s + current_sum, fattr', diffs' )+ required_bytes' (y, current_sum, fattr, False : diffs') _span_ops+ = ( y + 1, current_sum, fattr, diffs' )+ required_bytes' (_y, _current_sum, _fattr, [] ) _span_ops+ = error "shouldn't be possible"++span_ops_required_bytes :: DisplayTerminal d => d -> Word -> FixedAttr -> SpanOps -> (Word, FixedAttr)+span_ops_required_bytes d y in_fattr span_ops = + -- The first operation is to set the cursor to the start of the row+ let header_required_bytes = move_cursor_required_bytes d 0 y+ -- then the span ops are serialized in the order specified+ in foldl' ( \(current_sum, fattr) op -> let (c, fattr') = span_op_required_bytes d fattr op + in (c + current_sum, fattr') + ) + (header_required_bytes, in_fattr)+ span_ops++span_op_required_bytes :: DisplayTerminal d => d -> FixedAttr -> SpanOp -> (Word, FixedAttr)+span_op_required_bytes d fattr (AttributeChange attr) = + let attr' = limit_attr_for_display d attr+ c = attr_required_bytes d fattr attr' (display_attr_diffs fattr fattr')+ fattr' = fix_display_attr fattr attr'+ in (c, fattr')+span_op_required_bytes _d fattr (TextSpan _ _ str) = (utf8_text_required_bytes str, fattr)++serialize_output_ops :: DisplayTerminal d + => d + -> OutputBuffer + -> FixedAttr + -> [Bool]+ -> SpanOpSequence + -> IO OutputBuffer+serialize_output_ops d start_ptr in_fattr diffs ops = do+ (_, end_ptr, _, _) <- foldlM serialize_output_ops' + ( 0, start_ptr, in_fattr, diffs ) + ( row_ops ops )+ return end_ptr+ where + serialize_output_ops' ( y, out_ptr, fattr, True : diffs' ) span_ops+ = serialize_span_ops d y out_ptr fattr span_ops + >>= return . ( \(out_ptr', fattr') -> ( y + 1, out_ptr', fattr', diffs' ) )+ serialize_output_ops' ( y, out_ptr, fattr, False : diffs' ) _span_ops+ = return ( y + 1, out_ptr, fattr, diffs' )+ serialize_output_ops' (_y, _out_ptr, _fattr, [] ) _span_ops+ = error "shouldn't be possible"++serialize_span_ops :: DisplayTerminal d + => d + -> Word + -> OutputBuffer + -> FixedAttr + -> SpanOps + -> IO (OutputBuffer, FixedAttr)+serialize_span_ops d y out_ptr in_fattr span_ops = do+ -- The first operation is to set the cursor to the start of the row+ out_ptr' <- serialize_move_cursor d 0 y out_ptr+ -- then the span ops are serialized in the order specified+ foldlM ( \(out_ptr'', fattr) op -> serialize_span_op d op out_ptr'' fattr ) + (out_ptr', in_fattr)+ span_ops++serialize_span_op :: DisplayTerminal d + => d + -> SpanOp + -> OutputBuffer + -> FixedAttr+ -> IO (OutputBuffer, FixedAttr)+serialize_span_op d (AttributeChange attr) out_ptr fattr = do+ let attr' = limit_attr_for_display d attr+ fattr' = fix_display_attr fattr attr'+ out_ptr' <- serialize_set_attr d fattr attr' (display_attr_diffs fattr fattr') out_ptr+ return (out_ptr', fattr')+serialize_span_op _d (TextSpan _ _ str) out_ptr fattr = do+ out_ptr' <- serialize_utf8_text str out_ptr+ return (out_ptr', fattr)++marshall_to_terminal :: Terminal t => t -> Word -> (Ptr Word8 -> IO (Ptr Word8)) -> IO ()+marshall_to_terminal t c f = do+ start_ptr <- mallocBytes (fromEnum c)+ -- + -- todo: capture exceptions?+ end_ptr <- f start_ptr+ case end_ptr `minusPtr` start_ptr of+ count | count < 0 -> fail "End pointer before start pointer."+ | toEnum count > c -> fail $ "End pointer past end of buffer by " ++ show (toEnum count - c)+ | otherwise -> output_byte_buffer t start_ptr (toEnum count)+ free start_ptr+ return ()+++-- | Given the previously applied display attributes as a FixedAttr and the current display+-- attributes as an Attr produces a FixedAttr that represents the current display attributes. This+-- is done by using the previously applied display attributes to remove the "KeepCurrent"+-- abstraction.+fix_display_attr :: FixedAttr -> Attr -> FixedAttr+fix_display_attr fattr attr + = FixedAttr ( fix_style (fixed_style fattr) (style attr) )+ ( fix_color (fixed_fore_color fattr) (fore_color attr) )+ ( fix_color (fixed_back_color fattr) (back_color attr) )+ where+ fix_style _s Default = default_style_mask+ fix_style s KeepCurrent = s+ fix_style _s (SetTo new_style) = new_style+ fix_color _c Default = Nothing+ fix_color c KeepCurrent = c+ fix_color _c (SetTo c) = Just c++data DisplayAttrDiffs = DisplayAttrDiffs + { style_diffs :: [ StyleStateChange ]+ , fore_color_diff :: DisplayColorDiff+ , back_color_diff :: DisplayColorDiff+ }++data DisplayColorDiff + = ColorToDefault+ | NoColorChange+ | SetColor !Color+ deriving Eq++data StyleStateChange + = ApplyStandout+ | RemoveStandout+ | ApplyUnderline+ | RemoveUnderline+ | ApplyReverseVideo+ | RemoveReverseVideo+ | ApplyBlink+ | RemoveBlink+ | ApplyDim+ | RemoveDim+ | ApplyBold+ | RemoveBold++display_attr_diffs :: FixedAttr -> FixedAttr -> DisplayAttrDiffs+display_attr_diffs attr attr' = DisplayAttrDiffs+ { style_diffs = diff_styles ( fixed_style attr ) ( fixed_style attr' )+ , fore_color_diff = diff_color ( fixed_fore_color attr ) ( fixed_fore_color attr' )+ , back_color_diff = diff_color ( fixed_back_color attr ) ( fixed_back_color attr' )+ }++diff_color :: Maybe Color -> Maybe Color -> DisplayColorDiff+diff_color Nothing (Just c') = SetColor c'+diff_color (Just c) (Just c') + | c == c' = NoColorChange+ | otherwise = SetColor c'+diff_color Nothing Nothing = NoColorChange+diff_color (Just _) Nothing = ColorToDefault++diff_styles :: Style -> Style -> [StyleStateChange]+diff_styles prev cur + = mconcat + [ style_diff standout ApplyStandout RemoveStandout+ , style_diff underline ApplyUnderline RemoveUnderline+ , style_diff reverse_video ApplyReverseVideo RemoveReverseVideo+ , style_diff blink ApplyBlink RemoveBlink+ , style_diff dim ApplyDim RemoveDim+ , style_diff bold ApplyBold RemoveBold+ ]+ where + style_diff s sm rm + = case ( 0 == prev .&. s, 0 == cur .&. s ) of+ -- not set in either+ ( True, True ) -> []+ -- set in both+ ( False, False ) -> []+ -- now set+ ( True, False) -> [ sm ]+ -- now unset+ ( False, True) -> [ rm ]++data CursorOutputMap = CursorOutputMap+ { char_to_output_pos :: (Word, Word) -> (Word, Word)+ } ++cursor_output_map :: SpanOpSequence -> Cursor -> CursorOutputMap+cursor_output_map span_ops _cursor = CursorOutputMap+ { char_to_output_pos = \(cx, cy) -> (cursor_column_offset span_ops cx cy, cy)+ }++cursor_column_offset :: SpanOpSequence -> Word -> Word -> Word+cursor_column_offset span_ops cx cy =+ let cursor_row_ops = row_ops span_ops ! cy+ (out_offset, _, _) + = foldl' ( \(d, current_cx, done) op -> + if done then (d, current_cx, done) else case span_op_has_width op of+ Nothing -> (d, current_cx, False)+ Just (cw, ow) -> case compare cx (current_cx + cw) of+ GT -> ( d + ow+ , current_cx + cw+ , False + )+ EQ -> ( d + ow+ , current_cx + cw+ , True + )+ LT -> ( d + columns_to_char_offset (cx - current_cx) op+ , current_cx + cw+ , True+ )+ )+ (0, 0, False)+ cursor_row_ops+ in out_offset++limit_attr_for_display :: DisplayTerminal d => d -> Attr -> Attr+limit_attr_for_display d attr + = attr { fore_color = clamp_color $ fore_color attr+ , back_color = clamp_color $ back_color attr+ }+ where+ clamp_color Default = Default+ clamp_color KeepCurrent = KeepCurrent+ clamp_color (SetTo c) = clamp_color' c+ clamp_color' (ISOColor v) + | context_color_count d < 8 = Default+ | context_color_count d < 16 && v >= 8 = SetTo $ ISOColor (v - 8)+ | otherwise = SetTo $ ISOColor v+ clamp_color' (Color240 v)+ -- TODO: Choose closes ISO color?+ | context_color_count d < 8 = Default+ | context_color_count d < 16 = Default+ | context_color_count d == 240 = SetTo $ Color240 v+ | otherwise + = let p :: Double = fromIntegral v / 240.0 + v' = floor $ p * (fromIntegral $ context_color_count d)+ in SetTo $ Color240 v'+
+ src/Graphics/Vty/Terminal/MacOSX.hs view
@@ -0,0 +1,92 @@+-- Copyright 2009 Corey O'Connor+-- The standard Mac OS X terminals Terminal.app and iTerm both declare themselves to be+-- "xterm-color" by default. However the terminfo database for xterm-color included with OS X is+-- incomplete. +--+-- This terminal implementation modifies the standard terminfo terminal as required for complete OS+-- X support.+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+module Graphics.Vty.Terminal.MacOSX ( terminal_instance+ )+ where++import Graphics.Vty.Terminal.Generic+import qualified Graphics.Vty.Terminal.TerminfoBased as TerminfoBased++import System.IO++data Term = Term + { super_term :: TerminalHandle+ , term_app :: String+ }++-- for Terminal.app use "xterm". For iTerm.app use "xterm-256color"+terminal_instance :: String -> IO Term+terminal_instance v = do+ let base_term "iTerm.app" = "xterm-256color"+ base_term _ = "xterm"+ t <- TerminfoBased.terminal_instance (base_term v) >>= new_terminal_handle+ return $ Term t v++flushed_put :: String -> IO ()+flushed_put str = do+ hPutStr stdout str+ hFlush stdout++-- Terminal.app really does want the xterm-color smcup and rmcup caps. Not the generic xterm ones.+smcup_str, rmcup_str :: String+smcup_str = "\ESC7\ESC[?47h"+rmcup_str = "\ESC[2J\ESC[?47l\ESC8"++-- iTerm needs a clear screen after smcup as well?+clear_screen_str :: String+clear_screen_str = "\ESC[H\ESC[2J"++instance Terminal Term where+ terminal_ID t = term_app t ++ " :: MacOSX"++ release_terminal t = do + release_terminal $ super_term t++ reserve_display _t = do+ flushed_put smcup_str+ flushed_put clear_screen_str++ release_display _t = do+ flushed_put rmcup_str++ display_terminal_instance t b c = do+ d <- display_context (super_term t) b+ return $ c (DisplayContext d)++ display_bounds t = display_bounds (super_term t)+ + output_byte_buffer t = output_byte_buffer (super_term t)++data DisplayContext = DisplayContext+ { super_display :: DisplayHandle+ }++instance DisplayTerminal DisplayContext where+ context_region d = context_region (super_display d)+ context_color_count d = context_color_count (super_display d)++ move_cursor_required_bytes d = move_cursor_required_bytes (super_display d)+ serialize_move_cursor d = serialize_move_cursor (super_display d)++ show_cursor_required_bytes d = show_cursor_required_bytes (super_display d)+ serialize_show_cursor d = serialize_show_cursor (super_display d)++ hide_cursor_required_bytes d = hide_cursor_required_bytes (super_display d)+ serialize_hide_cursor d = serialize_hide_cursor (super_display d)++ attr_required_bytes d = attr_required_bytes (super_display d)+ serialize_set_attr d = serialize_set_attr (super_display d)++ default_attr_required_bytes d = default_attr_required_bytes (super_display d)+ serialize_default_attr d = serialize_default_attr (super_display d)+
+ src/Graphics/Vty/Terminal/TerminfoBased.hs view
@@ -0,0 +1,407 @@+-- Copyright 2009 Corey O'Connor+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+module Graphics.Vty.Terminal.TerminfoBased ( terminal_instance+ )+ where++import Data.Terminfo.Parse+import Data.Terminfo.Eval++import Graphics.Vty.Attributes+import Graphics.Vty.Terminal.Generic+import Graphics.Vty.DisplayRegion++import Control.Applicative +import Control.Monad ( foldM )++import Data.Bits ( (.&.) )+import Data.Maybe ( isJust, isNothing, fromJust )+import Data.Word++import Foreign.C.Types ( CLong )++import qualified System.Console.Terminfo as Terminfo+import System.IO++data Term = Term + { term_info_ID :: String+ , term_info :: Terminfo.Terminal+ , smcup :: Maybe CapExpression+ , rmcup :: Maybe CapExpression+ , cup :: CapExpression+ , cnorm :: CapExpression+ , civis :: CapExpression+ , set_fore_color :: CapExpression+ , set_back_color :: CapExpression+ , set_default_attr :: CapExpression+ , clear_screen :: CapExpression+ , display_attr_caps :: DisplayAttrCaps+ }++data DisplayAttrCaps = DisplayAttrCaps+ { set_attr_states :: Maybe CapExpression+ , enter_standout :: Maybe CapExpression+ , exit_standout :: Maybe CapExpression+ , enter_underline :: Maybe CapExpression+ , exit_underline :: Maybe CapExpression+ , enter_reverse_video :: Maybe CapExpression+ , enter_dim_mode :: Maybe CapExpression+ , enter_bold_mode :: Maybe CapExpression+ }+ +marshall_cap_to_terminal :: Term -> (Term -> CapExpression) -> [CapParam] -> IO ()+marshall_cap_to_terminal t cap_selector cap_params = do+ marshall_to_terminal t (cap_expression_required_bytes (cap_selector t) cap_params)+ (serialize_cap_expression (cap_selector t) cap_params)+ return ()++{- | Uses terminfo for all control codes. While this should provide the most compatible terminal+ - terminfo does not support some features that would increase efficiency and improve compatibility:+ - * determine the character encoding supported by the terminal. Should this be taken from the LANG+ - environment variable? + - * Provide independent string capabilities for all display attributes.+ -+ - + - todo: Some display attributes like underline and bold have independent string capabilities that+ - should be used instead of the generic "sgr" string capability.+ -}+terminal_instance :: String -> IO Term+terminal_instance in_ID = do+ ti <- Terminfo.setupTerm in_ID+ let require_cap str + = case Terminfo.getCapability ti (Terminfo.tiGetStr str) of+ Nothing -> fail $ "Terminal does not define required capability \"" ++ str ++ "\""+ Just cap_str -> case parse_cap_expression cap_str of+ Left e -> fail $ show e+ Right cap -> return cap+ probe_cap cap_name + = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of+ Nothing -> return Nothing+ Just cap_str -> case parse_cap_expression cap_str of+ Left e -> fail $ show e+ Right cap -> return $ Just cap+ pure Term+ <*> pure in_ID+ <*> pure ti+ <*> probe_cap "smcup"+ <*> probe_cap "rmcup"+ <*> require_cap "cup"+ <*> require_cap "cnorm"+ <*> require_cap "civis"+ <*> require_cap "setaf"+ <*> require_cap "setab"+ <*> require_cap "sgr0"+ <*> require_cap "clear"+ <*> current_display_attr_caps ti++current_display_attr_caps :: Terminfo.Terminal -> IO DisplayAttrCaps+current_display_attr_caps ti + = pure DisplayAttrCaps + <*> probe_cap "sgr"+ <*> probe_cap "smso"+ <*> probe_cap "rmso"+ <*> probe_cap "smul"+ <*> probe_cap "rmul"+ <*> probe_cap "rev"+ <*> probe_cap "dim"+ <*> probe_cap "bold"+ where probe_cap cap_name + = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of+ Nothing -> return Nothing+ Just cap_str -> case parse_cap_expression cap_str of+ Left e -> fail $ show e+ Right cap -> return $ Just cap++instance Terminal Term where+ terminal_ID t = term_info_ID t ++ " :: TerminfoBased"++ release_terminal t = do + marshall_cap_to_terminal t set_default_attr []+ marshall_cap_to_terminal t cnorm []+ return ()++ reserve_display t = do+ if (isJust $ smcup t)+ then marshall_cap_to_terminal t (fromJust . smcup) []+ else return ()+ -- Screen on OS X does not appear to support smcup?+ -- To approximate the expected behavior: clear the screen and then move the mouse to the+ -- home position.+ marshall_cap_to_terminal t clear_screen []+ return ()++ release_display t = do+ if (isJust $ rmcup t)+ then marshall_cap_to_terminal t (fromJust . rmcup) []+ else return ()+ marshall_cap_to_terminal t cnorm []+ return ()++ display_terminal_instance t b c = do+ let color_count + = case Terminfo.getCapability (term_info t) (Terminfo.tiGetNum "colors" ) of+ Nothing -> 8+ Just v -> toEnum v+ return $ c (DisplayContext b t color_count)++ display_bounds _t = do+ raw_size <- get_window_size+ case raw_size of+ ( w, h ) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show raw_size+ | otherwise -> return $ DisplayRegion (toEnum w) (toEnum h)++ -- Output the byte buffer of the specified size to the terminal device.+ output_byte_buffer _t out_ptr out_byte_count = do+ hPutBuf stdout out_ptr (fromEnum out_byte_count) + hFlush stdout++foreign import ccall "gwinsz.h c_get_window_size" c_get_window_size :: IO CLong++get_window_size :: IO (Int,Int)+get_window_size = do + (a,b) <- (`divMod` 65536) `fmap` c_get_window_size+ return (fromIntegral b, fromIntegral a)++data DisplayContext = DisplayContext+ { bounds :: DisplayRegion+ , term :: Term+ , supported_colors :: Word+ }++instance DisplayTerminal DisplayContext where+ context_region d = bounds d++ context_color_count d = supported_colors d++ move_cursor_required_bytes d x y + = cap_expression_required_bytes (cup $ term d) [y, x]+ serialize_move_cursor d x y out_ptr + = serialize_cap_expression (cup $ term d) [y, x] out_ptr++ show_cursor_required_bytes d + = cap_expression_required_bytes (cnorm $ term d) []+ serialize_show_cursor d out_ptr + = serialize_cap_expression (cnorm $ term d) [] out_ptr++ hide_cursor_required_bytes d + = cap_expression_required_bytes (civis $ term d) []+ serialize_hide_cursor d out_ptr + = serialize_cap_expression (civis $ term d) [] out_ptr++ -- Instead of evaluating all the rules related to setting display attributes twice (once in+ -- required bytes and again in serialize) or some memoization scheme just return a size+ -- requirement as big the longest possible control string.+ -- + -- Which is assumed to the be less than 512 for now. + --+ -- \todo Not verified as safe and wastes memory.+ attr_required_bytes _d _prev_attr _req_attr _diffs = 512++ -- Portably setting the display attributes is a giant pain in the ass.+ -- If the terminal supports the sgr capability (which sets the on/off state of each style+ -- directly ; and, for no good reason, resets the colors to the default) this always works:+ -- 0. set the style attributes. This resets the fore and back color.+ -- 1, If a foreground color is to be set then set the foreground color+ -- 2. likewise with the background color+ -- + -- If the terminal does not support the sgr then + -- if there is a change from an applied color to the default (in either the fore or back color)+ -- then:+ -- 0. reset all display attributes (sgr0)+ -- 1. enter required style modes+ -- 2. set the fore color if required+ -- 3. set the back color if required+ --+ -- Entering the required style modes could require a reset of the display attributes. If this is+ -- the case then the back and fore colors always need to be set if not default.+ --+ -- All this (I think) is satisfied by the following logic:+ serialize_set_attr d prev_attr req_attr diffs out_ptr = do+ case (fore_color_diff diffs == ColorToDefault) || (back_color_diff diffs == ColorToDefault) of+ -- The only way to reset either color, portably, to the default is to use either the set+ -- state capability or the set default capability.+ True -> do+ case req_display_cap_seq_for ( display_attr_caps $ term d )+ ( fixed_style attr )+ ( style_to_apply_seq $ fixed_style attr )+ of+ EnterExitSeq caps + -- only way to reset a color to the defaults+ -> serialize_default_attr d out_ptr+ >>= (\out_ptr' -> foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr' caps)+ >>= set_colors+ SetState state+ -- implicitly resets the colors to the defaults+ -> serialize_cap_expression ( fromJust $ set_attr_states + $ display_attr_caps + $ term d + )+ ( sgr_args_for_state state )+ out_ptr+ >>= set_colors+ -- Otherwise the display colors are not changing or changing between two non-default+ -- points.+ False -> do+ -- Still, it could be the case that the change in display attributes requires the+ -- colors to be reset because the required capability was not available.+ case req_display_cap_seq_for ( display_attr_caps $ term d )+ ( fixed_style attr )+ ( style_diffs diffs )+ of+ -- Really, if terminals were re-implemented with modern concepts instead of+ -- bowing down to 40 yr old dumb terminal requirements this would be the+ -- only case ever reached! + -- Changes the style and color states according to the differences with the+ -- currently applied states.+ EnterExitSeq caps + -> foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr caps+ >>= apply_color_diff set_fore_color ( fore_color_diff diffs )+ >>= apply_color_diff set_back_color ( back_color_diff diffs )+ SetState state+ -- implicitly resets the colors to the defaults+ -> serialize_cap_expression ( fromJust $ set_attr_states + $ display_attr_caps+ $ term d+ )+ ( sgr_args_for_state state )+ out_ptr+ >>= set_colors+ where + attr = fix_display_attr prev_attr req_attr+ set_colors ptr = do+ ptr' <- case fixed_fore_color attr of+ Just c -> serialize_cap_expression ( set_fore_color $ term d ) + [ ansi_color_index c ]+ ptr+ Nothing -> return ptr+ ptr'' <- case fixed_back_color attr of+ Just c -> serialize_cap_expression ( set_back_color $ term d ) + [ ansi_color_index c ]+ ptr'+ Nothing -> return ptr'+ return ptr''+ apply_color_diff _f NoColorChange ptr+ = return ptr+ apply_color_diff _f ColorToDefault _ptr+ = fail "ColorToDefault is not a possible case for apply_color_diffs"+ apply_color_diff f ( SetColor c ) ptr+ = serialize_cap_expression ( f $ term d ) + [ ansi_color_index c ]+ ptr++ default_attr_required_bytes d + = cap_expression_required_bytes (set_default_attr $ term d) []+ serialize_default_attr d out_ptr = do+ out_ptr' <- serialize_cap_expression (set_default_attr $ term d) [] out_ptr+ return out_ptr'++ansi_color_index :: Color -> Word+ansi_color_index (ISOColor v) = toEnum $ fromEnum v+ansi_color_index (Color240 v) = 16 + ( toEnum $ fromEnum v )++{- The sequence of terminfo caps to apply a given style are determined according to these rules.+ -+ - 1. The assumption is that it's preferable to use the simpler enter/exit mode capabilities than+ - the full set display attribute state capability. + -+ - 2. If a mode is supposed to be removed but there is not an exit capability defined then the+ - display attributes are reset to defaults then the display attribute state is set.+ -+ - 3. If a mode is supposed to be applied but there is not an enter capability defined then then+ - display attribute state is set if possible. Otherwise the mode is not applied.+ -+ - 4. If the display attribute state is being set then just update the arguments to that for any+ - apply/remove.+ -+ -}++data DisplayAttrSeq+ = EnterExitSeq [CapExpression]+ | SetState DisplayAttrState++data DisplayAttrState = DisplayAttrState+ { apply_standout :: Bool+ , apply_underline :: Bool+ , apply_reverse_video :: Bool+ , apply_blink :: Bool+ , apply_dim :: Bool+ , apply_bold :: Bool+ }++sgr_args_for_state :: DisplayAttrState -> [CapParam]+sgr_args_for_state attr_state = map (\b -> if b then 1 else 0)+ [ apply_standout attr_state+ , apply_underline attr_state+ , apply_reverse_video attr_state+ , apply_blink attr_state+ , apply_dim attr_state+ , apply_bold attr_state+ , False -- invis+ , False -- protect+ , False -- alt char set+ ]++req_display_cap_seq_for :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq+req_display_cap_seq_for caps s diffs+ -- if the state transition implied by any diff cannot be supported with an enter/exit mode cap+ -- then either the state needs to be set or the attribute change ignored.+ = case (any no_enter_exit_cap diffs, isJust $ set_attr_states caps) of+ -- If all the diffs have an enter-exit cap then just use those+ ( False, _ ) -> EnterExitSeq $ map enter_exit_cap diffs+ -- If not all the diffs have an enter-exit cap and there is no set state cap then filter out+ -- all unsupported diffs and just apply the rest+ ( True, False ) -> EnterExitSeq $ map enter_exit_cap + $ filter (not . no_enter_exit_cap) diffs+ -- if not all the diffs have an enter-exit can and there is a set state cap then just use+ -- the set state cap.+ ( True, True ) -> SetState $ state_for_style s+ where+ no_enter_exit_cap ApplyStandout = isNothing $ enter_standout caps+ no_enter_exit_cap RemoveStandout = isNothing $ exit_standout caps+ no_enter_exit_cap ApplyUnderline = isNothing $ enter_underline caps+ no_enter_exit_cap RemoveUnderline = isNothing $ exit_underline caps+ no_enter_exit_cap ApplyReverseVideo = isNothing $ enter_reverse_video caps+ no_enter_exit_cap RemoveReverseVideo = True+ no_enter_exit_cap ApplyBlink = True+ no_enter_exit_cap RemoveBlink = True+ no_enter_exit_cap ApplyDim = isNothing $ enter_dim_mode caps+ no_enter_exit_cap RemoveDim = True+ no_enter_exit_cap ApplyBold = isNothing $ enter_bold_mode caps+ no_enter_exit_cap RemoveBold = True+ enter_exit_cap ApplyStandout = fromJust $ enter_standout caps+ enter_exit_cap RemoveStandout = fromJust $ exit_standout caps+ enter_exit_cap ApplyUnderline = fromJust $ enter_underline caps+ enter_exit_cap RemoveUnderline = fromJust $ exit_underline caps+ enter_exit_cap ApplyReverseVideo = fromJust $ enter_reverse_video caps+ enter_exit_cap ApplyDim = fromJust $ enter_dim_mode caps+ enter_exit_cap ApplyBold = fromJust $ enter_bold_mode caps+ enter_exit_cap _ = error "enter_exit_cap applied to diff that was known not to have one."++state_for_style :: Style -> DisplayAttrState+state_for_style s = DisplayAttrState+ { apply_standout = is_style_set standout+ , apply_underline = is_style_set underline+ , apply_reverse_video = is_style_set reverse_video+ , apply_blink = is_style_set blink+ , apply_dim = is_style_set dim+ , apply_bold = is_style_set bold+ }+ where is_style_set = has_style s++style_to_apply_seq :: Style -> [StyleStateChange]+style_to_apply_seq s = concat+ [ apply_if_required ApplyStandout standout+ , apply_if_required ApplyUnderline underline+ , apply_if_required ApplyReverseVideo reverse_video+ , apply_if_required ApplyBlink blink+ , apply_if_required ApplyDim dim+ , apply_if_required ApplyBlink bold+ ]+ where + apply_if_required ap flag + = if 0 == ( flag .&. s )+ then []+ else [ ap ]+
+ src/Graphics/Vty/Terminal/XTermColor.hs view
@@ -0,0 +1,81 @@+-- Copyright 2009 Corey O'Connor+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+module Graphics.Vty.Terminal.XTermColor ( terminal_instance+ )+ where++import Graphics.Vty.Terminal.Generic+import qualified Graphics.Vty.Terminal.TerminfoBased as TerminfoBased++import System.IO++data XTermColor = XTermColor + { xterm_variant :: String+ , super_term :: TerminalHandle+ }++-- Initialize the display to UTF-8+-- Regardless of what is output the text encoding is assumed to be UTF-8+terminal_instance :: String -> IO XTermColor+terminal_instance variant = do+ flushed_put set_utf8_char_set+ t <- TerminfoBased.terminal_instance variant >>= new_terminal_handle+ return $ XTermColor variant t++flushed_put :: String -> IO ()+flushed_put str = do+ hPutStr stdout str+ hFlush stdout++-- Since I don't know of a terminfo string cap that produces these strings these are hardcoded.+set_utf8_char_set, set_default_char_set :: String+set_utf8_char_set = "\ESC%G"+set_default_char_set = "\ESC%@"++instance Terminal XTermColor where+ terminal_ID t = (show $ xterm_variant t) ++ " :: XTermColor"++ release_terminal t = do + flushed_put set_default_char_set+ release_terminal $ super_term t++ reserve_display t = reserve_display (super_term t)++ release_display t = release_display (super_term t)++ display_terminal_instance t b c = do+ d <- display_context (super_term t) b+ return $ c (DisplayContext d)++ display_bounds t = display_bounds (super_term t)+ + output_byte_buffer t = output_byte_buffer (super_term t)++data DisplayContext = DisplayContext+ { super_display :: DisplayHandle+ }++instance DisplayTerminal DisplayContext where+ context_region d = context_region (super_display d)++ context_color_count d = context_color_count (super_display d)++ move_cursor_required_bytes d = move_cursor_required_bytes (super_display d)+ serialize_move_cursor d = serialize_move_cursor (super_display d)++ show_cursor_required_bytes d = show_cursor_required_bytes (super_display d)+ serialize_show_cursor d = serialize_show_cursor (super_display d)++ hide_cursor_required_bytes d = hide_cursor_required_bytes (super_display d)+ serialize_hide_cursor d = serialize_hide_cursor (super_display d)++ attr_required_bytes d = attr_required_bytes (super_display d)+ serialize_set_attr d = serialize_set_attr (super_display d)++ default_attr_required_bytes d = default_attr_required_bytes (super_display d)+ serialize_default_attr d = serialize_default_attr (super_display d)+
test/Bench.hs view
@@ -1,47 +1,62 @@+module Main where+ import Graphics.Vty-import System.IO-import System.Environment( getArgs )+ import Control.Concurrent( threadDelay )-import System.Random-import Data.List import Control.Monad( liftM2 ) -import qualified Data.ByteString.Char8 as B+import Data.List+import Data.Word -main = do args <- getArgs- case args of- [] -> mkVty >>= liftM2 (>>) (run False) shutdown- ["--slow"] -> mkVty >>= liftM2 (>>) (run True ) shutdown- _ -> fail "usage: ./Bench [--slow]"+import System.Environment( getArgs )+import System.IO+import System.Random -run True vt = mapM_ (update vt) . uncurry benchgen =<< getSize vt-run False vt = mapM_ (update vt) (benchgen 200 100) +main = do + let fixed_gen = mkStdGen 0+ setStdGen fixed_gen+ args <- getArgs+ case args of+ [] -> mkVty >>= liftM2 (>>) (run $ Just 0) shutdown+ ["--delay"] -> mkVty >>= liftM2 (>>) (run $ Just 1000000) shutdown+ ["--slow"] -> mkVty >>= liftM2 (>>) (run Nothing ) shutdown+ _ -> fail "usage: ./Bench [--slow|--delay]"++run (Just delay) vt = mapM_ (\p -> update vt p >> threadDelay delay) . benchgen =<< display_bounds (terminal vt)+run Nothing vt = mapM_ (update vt) (benchgen $ DisplayRegion 200 100)+ -- Currently, we just do scrolling.-takem :: (a -> Int) -> Int -> [a] -> ([a],[a])+takem :: (a -> Word) -> Word -> [a] -> ([a],[a]) takem len n [] = ([],[]) takem len n (x:xs) | lx > n = ([], x:xs) | True = let (tk,dp) = takem len (n - lx) xs in (x:tk,dp) where lx = len x -fold :: (a -> Int) -> [Int] -> [a] -> [[a]]+fold :: (a -> Word) -> [Word] -> [a] -> [[a]] fold len [] xs = [] fold len (ll:lls) xs = let (tk,dp) = takem len ll xs in tk : fold len lls dp -lengths :: Int -> StdGen -> [Int]-lengths ml g = let (x,g2) = randomR (0,ml) g ; (y,g3) = randomR (0,x) g2 in y : lengths ml g3+lengths :: Word -> StdGen -> [Word]+lengths ml g = + let (x,g2) = randomR (0,fromEnum ml) g + (y,g3) = randomR (0,x) g2 + in (toEnum y) : lengths ml g3 -nums :: StdGen -> [(Attr, B.ByteString)]+nums :: StdGen -> [(Attr, String)] nums g = let (x,g2) = (random g :: (Int, StdGen)) (c,g3) = random g2- in (if c then setFG red attr else attr, B.pack (shows x " ")) : nums g3+ in ( if c then def_attr `with_fore_color` red else def_attr+ , shows x " "+ ) : nums g3 -pad :: Int -> Image -> Image-pad ml img = img <|> renderHFill attr ' ' (ml - imgWidth img)+pad :: Word -> Image -> Image+pad ml img = img <|> char_fill def_attr ' ' (ml - image_width img) 1 -clines :: StdGen -> Int -> [Image]-clines g maxll = map (pad maxll . horzcat . map (uncurry renderBS)) $ fold (B.length . snd) (lengths maxll g1) (nums g2)- where (g1,g2) =split g+clines :: StdGen -> Word -> [Image]+clines g maxll = map (pad maxll . horiz_cat . map (uncurry string)) $ fold (toEnum . length . snd) (lengths maxll g1) (nums g2)+ where (g1,g2) = split g -benchgen :: Int -> Int -> [Picture]-benchgen w h = take 1000 $ map ((\i -> pic{ pImage = i}) . vertcat . take h) $ tails $ clines (mkStdGen 42) w+benchgen :: DisplayRegion -> [Picture]+benchgen (DisplayRegion w h) = take 500 $ map ((\i -> pic_for_image i) . vert_cat . take (fromEnum h)) $ tails $ clines (mkStdGen 42) w+
+ test/Bench2.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE BangPatterns #-}+import Graphics.Vty+import System.IO+import System.Environment( getArgs )+import Control.Concurrent( threadDelay )+import System.Random+import Data.List+import Control.Monad( liftM2 )++import qualified Data.ByteString.Char8 as B++main = do + let fixed_gen = mkStdGen 0+ setStdGen fixed_gen+ args <- getArgs+ vt <- mkVty+ (w, h) <- getSize vt+ let !image_0 = renderFill attr 'X' w h+ let !image_1 = renderFill attr '0' w h+ run vt image_0 image_1+ shutdown vt++run vt image_0 image_1 = run' vt 300 image_0 image_1++run' vt 0 image_0 image_1 = return ()+run' vt n image_0 image_1 = do+ let p = pic { pImage = image_0 }+ update vt p+ run' vt (n - 1) image_1 image_0+
+ test/BenchRenderChar.hs view
@@ -0,0 +1,32 @@+{- benchmarks composing images using the renderChar operation.+ - This is what Yi uses in Yi.UI.Vty.drawText. Ideally a sequence of renderChar images horizontally+ - composed should provide no worse performance than a fill render op.+ -}+import Graphics.Vty++import Control.Monad ( forM_ )++import System.Time++main = do+ vty <- mkVty+ (w, h) <- getSize vty+ let test_chars = take 500 $ cycle $ [ c | c <- ['a'..'z']]+ start_time_0 <- getClockTime+ forM_ test_chars $ \test_char -> do+ let test_image = test_image_using_renderChar test_char w h+ out_pic = pic { pImage = test_image }+ update vty out_pic+ end_time_0 <- getClockTime+ let start_time_1 = end_time_0+ forM_ test_chars $ \test_char -> do+ let test_image = renderFill attr test_char w h+ out_pic = pic { pImage = test_image }+ update vty out_pic+ end_time_1 <- getClockTime+ shutdown vty+ putStrLn $ timeDiffToString $ diffClockTimes end_time_0 start_time_0+ putStrLn $ timeDiffToString $ diffClockTimes end_time_1 start_time_1++test_image_using_renderChar c w h = vertcat $ replicate h $ horzcat $ map (renderChar attr) (replicate w c)+
+ test/ControlTable.hs view
@@ -0,0 +1,14 @@+module Main where++import Graphics.Vty.ControlStrings++import System.Console.Terminfo++main = do+ terminal <- setupTermFromEnv + control_table <- init_control_table terminal+ putStrLn $ "ANSI terminal show cursor string: " ++ show cvis+ putStrLn $ "Current terminal show cursor string: " ++ show (show_cursor_str control_table)+ putStrLn $ "ANSI terminal hide cursor string: " ++ show civis+ putStrLn $ "Current terminal hide cursor string: " ++ show (hide_cursor_str control_table)+
+ test/HereDoc.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{- From http://www.reddit.com/r/haskell/comments/8ereh/a_here_document_syntax/+ - copyright unknown?+ -}+module HereDoc (heredoc) where++import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Lib++heredoc :: QuasiQuoter+heredoc = QuasiQuoter (litE . stringL) (litP . stringL)+
+ test/Makefile view
@@ -0,0 +1,47 @@+VERIF_TESTS := \+verify_attribute_ops \+verify_parse_terminfo_caps \+verify_eval_terminfo_caps \+verify_utf8_width \+verify_image_ops \+verify_image_trans \+verify_picture_ops \+verify_span_ops \+verify_debug_terminal++TESTS :=\+Bench \+Bench2 \+BenchRenderChar \+Test \+Test2 \+yi_issue_264 \+vty_issue_18 \+$(VERIF_TESTS)++$(shell mkdir -p objects )++# TODO: Tests should also be buildable referencing the currently installed vty+GHC_ARGS=--make -i../src -hide-package transformers -hide-package monads-fd -hide-package monads-tf -package QuickCheck-2.1.0.1 -ignore-package vty ../cbits/gwinsz.c ../cbits/set_term_timing.c ../cbits/mk_wcwidth.c -O -funbox-strict-fields -Wall -threaded -fno-full-laziness -fspec-constr -odir objects -hidir objects++GHC_PROF_ARGS=-prof -auto-all $(GHC_ARGS)++SOURCE := $(shell find ../src ../cbits -name '*.hs' -print -or -name '*.c' -print -or -name '*.h' -print)++.PHONY: all+all : $(VERIF_TESTS)++.PHONY: $(TESTS)+.SECONDEXPANSION:+$(TESTS) : + @echo running test $@+ @mkdir -p results/$@+ ( ghc $(GHC_PROF_ARGS) $@ \+ && time ./$@ +RTS -p -sresults/$@/mem_report \+ && cp $@.prof results/$@/profile \+ )++.PHONY: interactive_terminal_test+interactive_terminal_test : + ghc $(GHC_ARGS) $@ && ./$@+
test/Test.hs view
@@ -1,29 +1,44 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Main where+ import Graphics.Vty++import qualified Data.ByteString as B+import Data.Word+ import System.IO -import qualified Data.ByteString.Char8 as B -main = do vt <- mkVty- (sx,sy) <- getSize vt- play vt 0 0 sx sy ""+main = do + vt <- mkVty+ DisplayRegion w h <- display_bounds $ terminal vt+ putStrLn $ show $ DisplayRegion w h+ play vt 0 1 w h "" -pieceA = setFG red attr-dumpA = setRV attr+pieceA = def_attr `with_fore_color` red+dumpA = def_attr `with_style` reverse_video -play vt x y sx sy btl = do update vt (render x y sx sy btl)- k <- getEvent vt+play :: Vty -> Word -> Word -> Word -> Word -> String -> IO ()+play vt x y sx sy btl = do update vt (current_pic x y sx sy btl)+ k <- next_event vt case k of EvKey (KASCII 'r') [MCtrl] -> refresh vt >> play vt x y sx sy btl EvKey KLeft [] | x /= 0 -> play vt (x-1) y sx sy btl EvKey KRight [] | x /= (sx-1) -> play vt (x+1) y sx sy btl- EvKey KUp [] | y /= 0 -> play vt x (y-1) sx sy btl+ EvKey KUp [] | y /= 1 -> play vt x (y-1) sx sy btl EvKey KDown [] | y /= (sy-2) -> play vt x (y+1) sx sy btl EvKey KEsc [] -> shutdown vt >> return ()- EvResize nx ny -> play vt (min x (nx-1)) (min y (ny-2)) nx ny btl- _ -> play vt x y sx sy (take sx (show k ++ btl))+ EvResize nx ny -> play vt (min x (toEnum nx - 1)) + (min y (toEnum ny - 2)) + (toEnum nx) + (toEnum ny) + btl+ _ -> play vt x y sx sy (take (fromEnum sx) (show k ++ btl)) -render x y sx sy btl = pic { pCursor = Cursor x y,- pImage = renderFill pieceA ' ' sx y <->- renderHFill pieceA ' ' x <|> renderChar pieceA '@' <|> renderHFill pieceA ' ' (sx - x - 1) <->- renderFill pieceA ' ' sx (sy - y - 1) <->- renderBS dumpA (B.pack $ take sx (btl ++ repeat ' ')) }+current_pic :: Word -> Word -> Word -> Word -> String -> Picture+current_pic x y sx sy btl = pic_for_image i+ where i = string def_attr "Move the @ character around with the arrow keys. Escape exits."+ <-> char_fill pieceA ' ' sx (y - 1) + <-> char_fill pieceA ' ' x 1 <|> char pieceA '@' <|> char_fill pieceA ' ' (sx - x - 1) 1 + <-> char_fill pieceA ' ' sx (sy - y - 2) + <-> iso_10464_string dumpA btl
test/Test2.hs view
@@ -6,6 +6,7 @@ (sx,sy) <- getSize vty update vty (pic { pImage = renderFill (setBG red attr) 'X' sx sy }) refresh vty+ getEvent vty shutdown vty putStrLn "Done!" return ()
+ test/Verify.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}+module Verify ( module Verify+ , module Test.QuickCheck+ , succeeded+ , failed+ , Result(..)+ , monadicIO+ , liftIO+ , liftIOResult+ , liftResult+ , liftBool+ )+ where++import Test.QuickCheck hiding ( Result(..) )+import qualified Test.QuickCheck as QC+import Test.QuickCheck.Property +import Test.QuickCheck.Monadic ( monadicIO ) ++import qualified Codec.Binary.UTF8.String as UTF8++import Control.Monad.State.Strict+import Control.Monad.Trans ( liftIO )++import Data.IORef+import Data.Word++import Numeric ( showHex )++import System.IO++type Test v = StateT TestState IO v++data TestState = TestState+ { results_ref :: IORef [QC.Result]+ }++run_test :: Test () -> IO ()+run_test t = do+ s <- newIORef [] >>= return . TestState+ s' <- runStateT t s >>= return . snd+ results <- readIORef $ results_ref s'+ let fail_results = [ fail_result | fail_result@(QC.Failure {}) <- results ]+ case fail_results of+ [] -> putStrLn "state: PASS"+ rs -> do+ putStrLn "state: FAIL"+ putStrLn $ "fail_count: " ++ show (length rs)++verify :: Testable prop => String -> prop -> Test QC.Result+verify prop_name prop = do+ liftIO $ putStrLn $ "verify " ++ prop_name+ get >>= \s -> do+ r <- liftIO $ quickCheckResult prop + liftIO $ modifyIORef (results_ref s) (\rs -> r : rs)+ return r++data SingleColumnChar = SingleColumnChar Char+ deriving (Show, Eq)++instance Arbitrary SingleColumnChar where+ arbitrary = elements $ map SingleColumnChar [toEnum 0x21 .. toEnum 0x7E]++data DoubleColumnChar = DoubleColumnChar Char+ deriving (Eq)++instance Show DoubleColumnChar where+ show (DoubleColumnChar c) = "(0x" ++ showHex (fromEnum c) "" ++ ") ->" ++ UTF8.encodeString [c]++instance Arbitrary DoubleColumnChar where+ arbitrary = elements $ map DoubleColumnChar $ + [ toEnum 0x3040 .. toEnum 0x3098 ] + ++ [ toEnum 0x309B .. toEnum 0xA4CF]++instance Arbitrary Word where+ arbitrary = choose (0, 1024) >>= return . toEnum
+ test/Verify/Data/Terminfo/Parse.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Verify.Data.Terminfo.Parse ( module Verify.Data.Terminfo.Parse+ , module Data.Terminfo.Parse+ )+ where++import Data.Terminfo.Parse+import Data.Terminfo.Eval+import Verify++import Data.Array.Unboxed+import Data.Word++import Numeric++instance Show CapExpression where+ show c + = "CapExpression { " ++ show (cap_ops c) ++ " }"+ ++ " <- [" ++ hex_dump (cap_bytes c) ++ "]"+ ++ " <= " ++ show (source_string c) ++hex_dump :: CapBytes -> String+hex_dump bytes = foldr (\b s -> showHex b s) "" $ elems bytes++data NonParamCapString = NonParamCapString String+ deriving Show++instance Arbitrary NonParamCapString where+ arbitrary + = ( do+ s <- listOf1 $ (choose (0, 255) >>= return . toEnum) `suchThat` (/= '%')+ return $ NonParamCapString s+ ) `suchThat` ( \(NonParamCapString str) -> length str < 255 ) ++data LiteralPercentCap = LiteralPercentCap String [Word8]+ deriving ( Show )++instance Arbitrary LiteralPercentCap where+ arbitrary + = ( do+ NonParamCapString s <- arbitrary+ (s', bytes) <- insert_escape_op "%" [toEnum $ fromEnum '%'] s+ return $ LiteralPercentCap s' bytes+ ) `suchThat` ( \(LiteralPercentCap str _) -> length str < 255 ) ++data IncFirstTwoCap = IncFirstTwoCap String [Word8]+ deriving ( Show )++instance Arbitrary IncFirstTwoCap where+ arbitrary+ = ( do+ NonParamCapString s <- arbitrary+ (s', bytes) <- insert_escape_op "i" [] s+ return $ IncFirstTwoCap s' bytes+ ) `suchThat` ( \(IncFirstTwoCap str _) -> length str < 255 ) ++data PushParamCap = PushParamCap String Word [Word8]+ deriving ( Show )++instance Arbitrary PushParamCap where+ arbitrary+ = ( do+ NonParamCapString s <- arbitrary+ n :: Word <- choose (1,9) >>= return . toEnum+ (s', bytes) <- insert_escape_op ("p" ++ show n) [] s+ return $ PushParamCap s' n bytes+ ) `suchThat` ( \(PushParamCap str _ _) -> length str < 255 ) ++data DecPrintCap = DecPrintCap String Word [Word8]+ deriving ( Show )++instance Arbitrary DecPrintCap where+ arbitrary+ = ( do+ NonParamCapString s <- arbitrary+ n :: Word <- choose (1,9) >>= return . toEnum+ (s', bytes) <- insert_escape_op ("p" ++ show n ++ "%d") [] s+ return $ DecPrintCap s' n bytes+ ) `suchThat` ( \(DecPrintCap str _ _) -> length str < 255 ) ++insert_escape_op op_str repl_bytes s = do+ insert_points <- listOf1 $ elements [0 .. length s - 1]+ let s' = f s ('%' : op_str)+ remaining_bytes = f (map (toEnum . fromEnum) s) repl_bytes+ f in_vs out_v = concat [ vs+ | vi <- zip in_vs [0 .. length s - 1]+ , let vs = fst vi : ( if snd vi `elem` insert_points+ then out_v+ else []+ )+ ]+ return (s', remaining_bytes)++is_bytes_op :: CapOp -> Bool+is_bytes_op (Bytes {}) = True+-- is_bytes_op _ = False++collect_bytes :: CapExpression -> [Word8]+collect_bytes e = concat [ bytes + | Bytes offset c <- cap_ops e+ , let bytes = bytes_for_range e offset c+ ]++verify_bytes_equal out_bytes expected_bytes + = if out_bytes == expected_bytes+ then liftResult succeeded+ else liftResult $ failed + { reason = "out_bytes [" + ++ hex_dump ( listArray (0, toEnum $ length out_bytes - 1) out_bytes )+ ++ "] /= expected_bytes ["+ ++ hex_dump ( listArray (0, toEnum $ length expected_bytes - 1) expected_bytes )+ ++ "]"+ }+
+ test/Verify/Graphics/Vty/Attributes.hs view
@@ -0,0 +1,40 @@+module Verify.Graphics.Vty.Attributes ( module Verify.Graphics.Vty.Attributes+ , module Graphics.Vty.Attributes+ )+ where++import Graphics.Vty.Attributes+import Verify++import Data.List ( delete )++-- Limit the possible attributes to just a few for now.+possible_attr_mods :: [ AttrOp ]+possible_attr_mods = + [ set_bold_op+ , id_op + ]++instance Arbitrary Attr where+ arbitrary = elements possible_attr_mods >>= return . flip apply_op def_attr++data DiffAttr = DiffAttr Attr Attr++instance Arbitrary DiffAttr where+ arbitrary = do+ op0 <- elements possible_attr_mods+ let possible_attr_mods' = delete op0 possible_attr_mods+ op1 <- elements possible_attr_mods'+ return $ DiffAttr (apply_op op0 def_attr) (apply_op op1 def_attr)++data AttrOp = AttrOp String (Attr -> Attr)++instance Eq AttrOp where+ AttrOp n0 _ == AttrOp n1 _ = n0 == n1++set_bold_op = AttrOp "set_bold" (flip with_style bold)+id_op = AttrOp "id" id++apply_op :: AttrOp -> Attr -> Attr+apply_op (AttrOp _ f) a = f a+
+ test/Verify/Graphics/Vty/DisplayRegion.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Verify.Graphics.Vty.DisplayRegion ( module Verify.Graphics.Vty.DisplayRegion+ , module Graphics.Vty.DisplayRegion+ )+ where++import Graphics.Vty.Debug+import Graphics.Vty.DisplayRegion++import Verify++import Data.Word++data EmptyWindow = EmptyWindow DebugWindow++instance Arbitrary EmptyWindow where+ arbitrary = return $ EmptyWindow (DebugWindow (0 :: Word) (0 :: Word))++instance Show EmptyWindow where+ show (EmptyWindow _) = "EmptyWindow"++instance Arbitrary DebugWindow where+ arbitrary = do+ w <- suchThat arbitrary (/= 0)+ h <- suchThat arbitrary (/= 0)+ return $ DebugWindow w h+
+ test/Verify/Graphics/Vty/Image.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE DisambiguateRecordFields #-}+module Verify.Graphics.Vty.Image ( module Verify.Graphics.Vty.Image+ , module Graphics.Vty.Image+ )+ where++import Graphics.Vty.Debug+import Graphics.Vty.Image+import Graphics.Vty.DisplayRegion++import Verify+import Verify.Graphics.Vty.Attributes++import Data.Word++data UnitImage = UnitImage Char Image++instance Arbitrary UnitImage where+ arbitrary = do+ SingleColumnChar c <- arbitrary+ return $ UnitImage c (char def_attr c)++instance Show UnitImage where+ show (UnitImage c _) = "UnitImage " ++ show c++data DefaultImage = DefaultImage Image ImageConstructLog++instance Show DefaultImage where+ show (DefaultImage i image_log) + = "DefaultImage (" ++ show i ++ ") " ++ show (image_width i, image_height i) ++ " " ++ show image_log++instance Arbitrary DefaultImage where+ arbitrary = do+ i <- return $ char def_attr 'X' -- elements forward_image_ops >>= return . (\op -> op empty_image)+ return $ DefaultImage i []++data SingleRowSingleAttrImage + = SingleRowSingleAttrImage + { expected_attr :: Attr+ , expected_columns :: Word+ , row_image :: Image+ }++instance Show SingleRowSingleAttrImage where+ show (SingleRowSingleAttrImage attr columns image) + = "SingleRowSingleAttrImage (" ++ show attr ++ ") " ++ show columns ++ " ( " ++ show image ++ " )"++instance Arbitrary SingleRowSingleAttrImage where+ arbitrary = do+ -- The text must contain at least one character. Otherwise the image simplifies to the+ -- IdImage which has a height of 0. If this is to represent a single row then the height+ -- must be 1+ single_column_row_text <- listOf1 arbitrary+ attr <- arbitrary+ return $ SingleRowSingleAttrImage + attr + ( fromIntegral $ length single_column_row_text )+ ( horiz_cat $ [ char attr c | SingleColumnChar c <- single_column_row_text ] )++data SingleRowTwoAttrImage + = SingleRowTwoAttrImage + { part_0 :: SingleRowSingleAttrImage+ , part_1 :: SingleRowSingleAttrImage+ , join_image :: Image+ } deriving Show++instance Arbitrary SingleRowTwoAttrImage where+ arbitrary = do+ p0 <- arbitrary+ p1 <- arbitrary+ return $ SingleRowTwoAttrImage p0 p1 (row_image p0 <|> row_image p1)++data SingleAttrSingleSpanStack = SingleAttrSingleSpanStack + { stack_image :: Image + , stack_source_images :: [SingleRowSingleAttrImage]+ , stack_width :: Word+ , stack_height :: Word+ }+ deriving Show++instance Arbitrary SingleAttrSingleSpanStack where+ arbitrary = do+ NonEmpty image_list <- arbitrary+ let image = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- image_list ]+ return $ SingleAttrSingleSpanStack + image + image_list + ( maximum $ map expected_columns image_list )+ ( toEnum $ length image_list )+
+ test/Verify/Graphics/Vty/Picture.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE DisambiguateRecordFields #-}+module Verify.Graphics.Vty.Picture ( module Verify.Graphics.Vty.Picture+ , module Graphics.Vty.Picture+ )+ where++import Graphics.Vty.Picture+import Graphics.Vty.Debug++import Verify.Graphics.Vty.Attributes+import Verify.Graphics.Vty.Image+import Verify.Graphics.Vty.DisplayRegion++import Verify++data DefaultPic = DefaultPic + { default_pic :: Picture+ , default_win :: DebugWindow + , default_construct_log :: ImageConstructLog+ }++instance Show DefaultPic where+ show (DefaultPic pic win image_log) + = "DefaultPic\n\t( " ++ show pic ++ ")\n\t" ++ show win ++ "\n\t" ++ show image_log ++ "\n"++instance Arbitrary DefaultPic where+ arbitrary = do+ DefaultImage image image_construct_events <- arbitrary+ let win = DebugWindow (image_width image) (image_height image)+ return $ DefaultPic (pic_for_image image) + win + image_construct_events++data PicWithBGAttr = PicWithBGAttr + { with_attr_pic :: Picture+ , with_attr_win :: DebugWindow+ , with_attr_construct_log :: ImageConstructLog+ , with_attr_specified_attr :: Attr+ } deriving ( Show )++instance Arbitrary PicWithBGAttr where+ arbitrary = do+ DefaultImage image image_construct_events <- arbitrary+ let win = DebugWindow (image_width image) (image_height image)+ attr <- arbitrary+ return $ PicWithBGAttr (pic_for_image image) + win + image_construct_events+ attr+
+ test/Verify/Graphics/Vty/Span.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE FlexibleInstances #-}+module Verify.Graphics.Vty.Span ( module Verify.Graphics.Vty.Span+ , module Graphics.Vty.Span+ )+ where++import Graphics.Vty.Debug+import Graphics.Vty.Span++import Verify.Graphics.Vty.Picture++import Data.Word++import Verify++is_attr_span_op :: SpanOp -> Bool+is_attr_span_op AttributeChange {} = True+is_attr_span_op _ = False++verify_all_spans_have_width i spans w+ = case all_spans_have_width spans w of+ True -> succeeded+ False -> failed { reason = "Not all spans contained operations defining exactly " + ++ show w+ ++ " columns of output -\n"+ ++ show i+ ++ "\n->\n"+ ++ show spans+ }
+ test/interactive_terminal_test.hs view
@@ -0,0 +1,862 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Main where++import Graphics.Vty.Attributes+import Graphics.Vty.Image+import Graphics.Vty.Picture+import Graphics.Vty.Terminal+import Graphics.Vty.DisplayRegion++import Control.Monad++import Data.List ( lookup )+import Data.Maybe ( isJust, fromJust )+import Data.Monoid+import Data.Word++import Foreign.Marshal.Array +import HereDoc++import qualified System.Environment as Env++import System.IO ( hFlush, hPutStr, hPutBuf, stdout )++main = do+ print_intro++output_file_path = "test_results.list"++print_intro = do+ putStr $ [$heredoc| +This is an interactive verification program for the terminal input and output+support of the VTY library. This will ask a series of questions about what you+see on screen. The goal is to verify that VTY's output and input support+performs as expected with your terminal.++This program produces a file named + |] ++ output_file_path ++ [$heredoc| +in the current directory that contains the results for each test assertion. This+can be emailed to coreyoconnor@gmail.com and used by the VTY authors to improve+support for your terminal. No personal information is contained in the report.++Each test follows, more or less, the following format:+ 0. A description of the test is printed which will include a detailed+ description of what VTY is going to try and what the expected results are.+ Press return to move on.+ 1. The program will produce some output or ask for you to press a key.+ 2. You will then be asked to confirm if the behavior matched the provided+ description. Just pressing enter implies the default response that+ everything was as expected. ++All the tests assume the following about the terminal display:+ 0. The terminal display will not be resized during a test and is at least 80 + characters in width. + 1. The terminal display is using a monospaced font for both single width and+ double width characters.+ 2. A double width character is displayed with exactly twice the width of a + single column character. This may require adjusting the font used by the+ terminal. At least, that is the case using xterm. + 3. Fonts are installed, and usable by the terminal, that define glyphs for+ a good range of the unicode characters. Each test involving unicode display+ describes the expected appearance of each glyph. ++Thanks for the help! :-D +To exit the test early enter "q" anytime at the following menu screen. Even if+you exit the test early please email the test_results.list file to+coreyoconnor@gmail.com. The results file will still contain information useful+to debug terminal support.++|]+ wait_for_return+ results <- do_test_menu 1+ env_attributes <- mapM ( \env_name -> catch ( Env.getEnv env_name >>= return . (,) env_name ) + ( const $ return (env_name, "") ) + ) + [ "TERM", "COLORTERM", "LANG", "TERM_PROGRAM", "XTERM_VERSION" ]+ t <- terminal_handle+ let results_txt = show env_attributes ++ "\n" + ++ terminal_ID t ++ "\n"+ ++ show results ++ "\n"+ release_terminal t+ writeFile output_file_path results_txt++wait_for_return = do+ putStr "\n(press return to continue)"+ hFlush stdout+ getLine++test_menu :: [(String, Test)]+test_menu = zip (map show [1..]) all_tests++do_test_menu :: Int -> IO [(String, Bool)]+do_test_menu next_ID + | next_ID > length all_tests = do+ putStrLn $ "Done! Please email the " ++ output_file_path ++ " file to coreyoconnor@gmail.com"+ return []+ | otherwise = do+ display_test_menu+ putStrLn $ "Press return to start with #" ++ show next_ID ++ "."+ putStrLn "Enter a test number to perform only that test."+ putStrLn "q (or control-C) to quit."+ putStr "> "+ hFlush stdout+ s <- getLine >>= return . filter (/= '\n')+ case s of+ "q" -> return mempty+ "" -> do + r <- run_test $ show next_ID + rs <- do_test_menu ( next_ID + 1 )+ return $ r : rs+ i | isJust ( lookup i test_menu ) -> do+ r <- run_test i + rs <- do_test_menu ( read i + 1 )+ return $ r : rs+ where+ display_test_menu + = mapM_ display_test_menu' test_menu+ display_test_menu' ( i, t ) + = putStrLn $ ( if i == show next_ID + then "> " + else " "+ ) ++ i ++ ". " ++ test_name t++run_test :: String -> IO (String, Bool)+run_test i = do+ let t = fromJust $ lookup i test_menu + print_summary t+ wait_for_return+ test_action t+ r <- confirm_results t+ return (test_ID t, r)++default_success_confirm_results = do+ putStr "\n"+ putStr "[Y/n] "+ hFlush stdout+ r <- getLine+ case r of+ "" -> return True+ "y" -> return True+ "Y" -> return True+ "n" -> return False++data Test = Test+ { test_name :: String+ , test_ID :: String+ , test_action :: IO ()+ , print_summary :: IO ()+ , confirm_results :: IO Bool+ }++all_tests + = [ reserve_output_test + , display_bounds_test_0+ , display_bounds_test_1+ , display_bounds_test_2+ , display_bounds_test_3+ , unicode_single_width_0+ , unicode_single_width_1+ , unicode_double_width_0+ , unicode_double_width_1+ , attributes_test_0+ , attributes_test_1+ , attributes_test_2+ , attributes_test_3+ , attributes_test_4+ , attributes_test_5+ ]++reserve_output_test = Test + { test_name = "Initialize and reserve terminal output then restore previous state."+ , test_ID = "reserve_output_test"+ , test_action = do+ t <- terminal_handle+ reserve_display t+ putStrLn "Line 1"+ putStrLn "Line 2"+ putStrLn "Line 3"+ putStrLn "Line 4 (press return)"+ hFlush stdout+ getLine+ release_display t+ release_terminal t+ return ()+ , print_summary = do+ putStr $ [$heredoc|+Once return is pressed:+ 0. The screen will be cleared. + 1. Four lines of text should be visible.+ 1. The cursor should be visible and at the start of the fifth line.++After return is pressed for the second time this test then:+ * The screen containing the test summary should be restored;+ * The cursor is visible.+|]+ , confirm_results = do+ putStr $ [$heredoc|+Did the test output match the description?+|]+ default_success_confirm_results+ }++display_bounds_test_0 = Test+ { test_name = "Verify display bounds are correct test 0: Using spaces."+ , test_ID = "display_bounds_test_0"+ , test_action = do+ t <- terminal_handle+ reserve_display t+ DisplayRegion w h <- display_bounds t+ let row_0 = replicate (fromEnum w) 'X' ++ "\n"+ row_h = replicate (fromEnum w - 1) 'X'+ row_n = "X" ++ replicate (fromEnum w - 2) ' ' ++ "X\n"+ image = row_0 ++ (concat $ replicate (fromEnum h - 2) row_n) ++ row_h+ putStr image+ hFlush stdout+ getLine+ release_display t+ release_terminal t+ return ()+ , print_summary = display_bounds_test_summary True+ , confirm_results = generic_output_match_confirm+ }++display_bounds_test_1 = Test+ { test_name = "Verify display bounds are correct test 0: Using cursor movement."+ , test_ID = "display_bounds_test_1"+ , test_action = do+ t <- terminal_handle+ reserve_display t+ DisplayRegion w h <- display_bounds t+ set_cursor_pos t 0 0+ let row_0 = replicate (fromEnum w) 'X' ++ "\n"+ putStr row_0+ forM_ [1 .. h - 2] $ \y -> do+ set_cursor_pos t 0 y+ putStr "X"+ set_cursor_pos t (w - 1) y+ putStr "X"+ set_cursor_pos t 0 (h - 1)+ let row_h = replicate (fromEnum w - 1) 'X'+ putStr row_h+ hFlush stdout+ getLine+ release_display t+ release_terminal t+ return ()+ , print_summary = display_bounds_test_summary True+ , confirm_results = generic_output_match_confirm+ }++display_bounds_test_2 = Test+ { test_name = "Verify display bounds are correct test 0: Using Image ops."+ , test_ID = "display_bounds_test_2"+ , test_action = do+ t <- terminal_handle+ reserve_display t+ bounds@(DisplayRegion w h) <- display_bounds t+ let first_row = horiz_cat $ replicate (fromEnum w) (char def_attr 'X')+ middle_rows = vert_cat $ replicate (fromEnum h - 2) middle_row+ middle_row = (char def_attr 'X') <|> background_fill (w - 2) 1 <|> (char def_attr 'X')+ end_row = first_row+ image = first_row <-> middle_rows <-> end_row+ pic = (pic_for_image image) { pic_cursor = Cursor (w - 1) (h - 1) }+ d <- display_context t bounds+ output_picture d pic+ getLine+ release_display t+ release_terminal t+ return ()+ , print_summary = display_bounds_test_summary True+ , confirm_results = generic_output_match_confirm+ }++display_bounds_test_3 = Test+ { test_name = "Verify display bounds are correct test 0: Hide cursor; Set cursor pos."+ , test_ID = "display_bounds_test_3"+ , test_action = do+ t <- terminal_handle+ reserve_display t+ DisplayRegion w h <- display_bounds t+ hide_cursor t+ set_cursor_pos t 0 0+ let row_0 = replicate (fromEnum w) 'X'+ putStrLn row_0+ forM_ [1 .. h - 2] $ \y -> do+ set_cursor_pos t 0 y+ putStr "X"+ set_cursor_pos t (w - 1) y+ putStr "X"+ set_cursor_pos t 0 (h - 1)+ let row_h = row_0+ putStr row_h+ hFlush stdout+ getLine+ show_cursor t+ release_display t+ release_terminal t+ return ()+ , print_summary = display_bounds_test_summary False+ , confirm_results = generic_output_match_confirm+ }++display_bounds_test_summary has_cursor = do+ putStr $ [$heredoc|+Once return is pressed:+ 0. The screen will be cleared.+|]+ if has_cursor+ then putStr " 1. The cursor will be visible."+ else putStr " 1. The cursor will NOT be visible."+ putStr [$heredoc|+ 2. The border of the display will be outlined in Xs. + So if - and | represented the edge of the terminal window:+ |-------------|+ |XXXXXXXXXXXXX|+ |X X||]++ if has_cursor+ then putStr $ [$heredoc|+ |XXXXXXXXXXXXC| |]+ else putStr $ [$heredoc|+ |XXXXXXXXXXXXX| |]++ putStr $ [$heredoc|+ |-------------|++ ( Where C is the final position of the cursor. There may be an X drawn+ under the cursor. )+ 3. The display will remain in this state until return is pressed again.++After return is pressed for the second time:+ 0. The screen containing the test summary should be restored.+ 1. The cursor should be visible.+|]++generic_output_match_confirm = do+ putStr $ [$heredoc|+Did the test output match the description?+|]+ default_success_confirm_results++-- Explicitely definethe bytes that encode each example text.+-- This avoids any issues with how the compiler represents string literals.+--+-- This document is UTF-8 encoded so the UTF-8 string is still included for+-- reference+--+-- It's assumed the compiler will at least not barf on UTF-8 encoded text in+-- comments ;-)+--+-- txt_0 = ↑↑↓↓←→←→BA++utf8_txt_0 :: [[Word8]]+utf8_txt_0 = [ [ 0xe2 , 0x86 , 0x91 ]+ , [ 0xe2 , 0x86 , 0x91 ]+ , [ 0xe2 , 0x86 , 0x93 ]+ , [ 0xe2 , 0x86 , 0x93 ]+ , [ 0xe2 , 0x86 , 0x90 ]+ , [ 0xe2 , 0x86 , 0x92 ]+ , [ 0xe2 , 0x86 , 0x90 ]+ , [ 0xe2 , 0x86 , 0x92 ]+ , [ 0x42 ]+ , [ 0x41 ]+ ]++iso_10464_txt_0 :: String+iso_10464_txt_0 = map toEnum+ [ 8593 + , 8593+ , 8595+ , 8595+ , 8592+ , 8594+ , 8592+ , 8594+ , 66+ , 65+ ]++unicode_single_width_0 = Test+ { test_name = "Verify terminal can display unicode single-width characters. (Direct UTF-8)"+ , test_ID = "unicode_single_width_0"+ , test_action = do+ t <- terminal_handle+ reserve_display t+ hide_cursor t+ withArrayLen (concat utf8_txt_0) (flip $ hPutBuf stdout)+ hPutStr stdout "\n"+ hPutStr stdout "0123456789\n"+ hFlush stdout+ getLine+ release_display t+ release_terminal t+ return ()+ , print_summary = unicode_single_width_summary+ , confirm_results = generic_output_match_confirm+ }++unicode_single_width_1 = Test+ { test_name = "Verify terminal can display unicode single-width characters. (Image ops)"+ , test_ID = "unicode_single_width_1"+ , test_action = do+ t <- terminal_handle+ reserve_display t+ let pic = pic_for_image image+ image = line_0 <-> line_1+ line_0 = iso_10464_string def_attr iso_10464_txt_0+ line_1 = string def_attr "0123456789"+ d <- display_bounds t >>= display_context t+ output_picture d pic+ getLine+ release_display t+ release_terminal t+ return ()+ , print_summary = unicode_single_width_summary+ , confirm_results = generic_output_match_confirm+ }++unicode_single_width_summary = putStr [$heredoc|+Once return is pressed:+ 0. The screen will be cleared.+ 1. The cursor will be hidden.+ 2. Two horizontal lines of text will be displayed:+ a. The first will be a sequence of glyphs in UTF-8 encoding. Each glyph+ will occupy one column of space. The order and appearance of the glyphs+ will be:+ | column | appearance |+ ==========================+ | 0 | up arrow |+ | 1 | up arrow |+ | 2 | down arrow |+ | 3 | down arrow |+ | 4 | left arrow |+ | 5 | right arrow |+ | 6 | left arrow |+ | 7 | right arrow |+ | 8 | B |+ | 9 | A |+ ( see: http://en.wikipedia.org/wiki/Arrow_(symbol) )+ b. The second will be: 0123456789. ++Verify: + * The far right extent of the glyphs on both lines are equal; + * The glyphs are as described.++After return is pressed for the second time:+ 0. The screen containing the test summary should be restored.+ 1. The cursor should be visible.+|]++-- The second example is a unicode string containing double-width glyphs+-- 你好吗+utf8_txt_1 :: [[Word8]]+utf8_txt_1 = [ [0xe4,0xbd,0xa0]+ , [0xe5,0xa5,0xbd]+ , [0xe5,0x90,0x97]+ ]++iso_10464_txt_1 :: String+iso_10464_txt_1 = map toEnum [20320,22909,21527]++unicode_double_width_0 = Test+ { test_name = "Verify terminal can display unicode double-width characters. (Direct UTF-8)"+ , test_ID = "unicode_double_width_0"+ , test_action = do+ t <- terminal_handle+ reserve_display t+ hide_cursor t+ withArrayLen (concat utf8_txt_1) (flip $ hPutBuf stdout)+ hPutStr stdout "\n"+ hPutStr stdout "012345\n"+ hFlush stdout+ getLine+ release_display t+ release_terminal t+ return ()+ , print_summary = unicode_double_width_summary+ , confirm_results = generic_output_match_confirm+ }++unicode_double_width_1 = Test+ { test_name = "Verify terminal can display unicode double-width characters. (Image ops)"+ , test_ID = "unicode_double_width_1"+ , test_action = do+ t <- terminal_handle+ reserve_display t+ let pic = pic_for_image image+ image = line_0 <-> line_1+ line_0 = iso_10464_string def_attr iso_10464_txt_1+ line_1 = string def_attr "012345"+ d <- display_bounds t >>= display_context t+ output_picture d pic+ getLine+ release_display t+ release_terminal t+ return ()+ , print_summary = unicode_double_width_summary+ , confirm_results = generic_output_match_confirm+ }++unicode_double_width_summary = putStr [$heredoc|+Once return is pressed:+ 0. The screen will be cleared.+ 1. The cursor will be hidden.+ 2. Two horizontal lines of text will be displayed:+ a. The first will be a sequence of glyphs in UTF-8 encoding. Each glyph+ will occupy two columns of space. The order and appearance of the glyphs+ will be:+ | column | appearance |+ ======================================+ | 0 | first half of ni3 |+ | 1 | second half of ni3 |+ | 2 | first half of hao3 |+ | 3 | second half of hao3 |+ | 4 | first half of ma |+ | 5 | second half of ma |+ b. The second will be: 012345. ++Verify: + * The far right extent of the glyphs on both lines are equal; + * The glyphs are as described.++After return is pressed for the second time:+ 0. The screen containing the test summary should be restored.+ 1. The cursor should be visible.+|]++all_colors = zip [ black, red, green, yellow, blue, magenta, cyan, white ]+ [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ]++all_bright_colors + = zip [ bright_black, bright_red, bright_green, bright_yellow, bright_blue, bright_magenta, bright_cyan, bright_white ]+ [ "bright black", "bright red", "bright green", "bright yellow", "bright blue", "bright magenta", "bright cyan", "bright white" ]++attributes_test_0 = Test + { test_name = "Character attributes: foreground colors."+ , test_ID = "attributes_test_0"+ , test_action = do+ t <- terminal_handle+ reserve_display t+ let pic = pic_for_image image+ image = border <|> column_0 <|> border <|> column_1 <|> border+ column_0 = vert_cat $ map line_with_color all_colors+ border = vert_cat $ replicate (length all_colors) $ string def_attr " | "+ column_1 = vert_cat $ map (string def_attr . snd) all_colors+ line_with_color (c, c_name) = string (def_attr `with_fore_color` c) c_name+ d <- display_bounds t >>= display_context t+ output_picture d pic+ getLine+ release_display t+ release_terminal t+ return ()+ , print_summary = do+ putStr $ [$heredoc|+Once return is pressed:+ 0. The screen will be cleared.+ 1. The cursor will be hidden.+ 2. 9 lines of text in two columns will be drawn. The first column will be a+ name of a standard color (for an 8 color terminal) rendered in that color.+ For instance, one line will be the word "magenta" and that word should be+ rendered in the magenta color. The second column will be the name of a+ standard color rendered with the default attributes.++Verify: + * In the first column: The foreground color matches the named color.+ * The second column: All text is rendered with the default attributes.+ * The vertical bars used in each line to mark the border of a column are+ lined up.++After return is pressed for the second time:+ 0. The screen containing the test summary should be restored.+ 1. The cursor should be visible.+|]+ , confirm_results = do+ putStr $ [$heredoc|+Did the test output match the description?+|]+ default_success_confirm_results+ }++attributes_test_1 = Test + { test_name = "Character attributes: background colors."+ , test_ID = "attributes_test_1"+ , test_action = do+ t <- terminal_handle+ reserve_display t+ let pic = pic_for_image image+ image = border <|> column_0 <|> border <|> column_1 <|> border+ column_0 = vert_cat $ map line_with_color all_colors+ border = vert_cat $ replicate (length all_colors) $ string def_attr " | "+ column_1 = vert_cat $ map (string def_attr . snd) all_colors+ line_with_color (c, c_name) = string (def_attr `with_back_color` c) c_name+ d <- display_bounds t >>= display_context t+ output_picture d pic+ getLine+ release_display t+ release_terminal t+ return ()+ , print_summary = do+ putStr $ [$heredoc|+Once return is pressed:+ 0. The screen will be cleared.+ 1. The cursor will be hidden.+ 2. 9 lines of text in two columns will be drawn. The first column will+ contain be a name of a standard color for an 8 color terminal rendered with+ the default foreground color with a background the named color. For+ instance, one line will contain be the word "magenta" and the word should+ be rendered in the default foreground color over a magenta background. The+ second column will be the name of a standard color rendered with the default+ attributes.++Verify: + * The first column: The background color matches the named color.+ * The second column: All text is rendered with the default attributes.+ * The vertical bars used in each line to mark the border of a column are+ lined up.++Note: I haven't decided if, in this case, the background color should extend to+fills added for alignment. Right now the selected background color is only+applied to the background where the word is actually rendered. Since each word+is not of the same length VTY adds background fills to make the width of each+row effectively the same. These added fills are all currently rendered with the+default background pattern.++After return is pressed for the second time:+ 0. The screen containing the test summary should be restored.+ 1. The cursor should be visible.+|]+ , confirm_results = do+ putStr $ [$heredoc|+Did the test output match the description?+|]+ default_success_confirm_results+ }++attributes_test_2 = Test + { test_name = "Character attributes: Vivid foreground colors."+ , test_ID = "attributes_test_2"+ , test_action = do+ t <- terminal_handle+ reserve_display t+ let pic = pic_for_image image+ image = horiz_cat [border, column_0, border, column_1, border, column_2, border]+ border = vert_cat $ replicate (length all_colors) $ string def_attr " | "+ column_0 = vert_cat $ map line_with_color_0 all_colors+ column_1 = vert_cat $ map line_with_color_1 all_bright_colors+ column_2 = vert_cat $ map (string def_attr . snd) all_colors+ line_with_color_0 (c, c_name) = string (def_attr `with_fore_color` c) c_name+ line_with_color_1 (c, c_name) = string (def_attr `with_fore_color` c) c_name+ d <- display_bounds t >>= display_context t+ output_picture d pic+ getLine+ release_display t+ release_terminal t+ return ()+ , print_summary = do+ putStr $ [$heredoc|+Once return is pressed:+ 0. The screen will be cleared.+ 1. The cursor will be hidden.+ 2. 9 lines of text in three columns will be drawn:+ a. The first column will be a name of a standard color (for an 8 color+ terminal) rendered with that color as the foreground color. + b. The next column will be also be the name of a standard color rendered+ with that color as the foreground color but the shade used should be+ more vivid than the shade used in the first column. + c. The final column will be the name of a color rendered with the+ default attributes.++For instance, one line will be the word "magenta" and that word should be+rendered in the magenta color. ++I'm not actually sure exactly what "vivid" means in this context. For xterm the+vivid colors are brighter. ++Verify: + * The first column: The foreground color matches the named color.+ * The second column: The foreground color matches the named color but is+ more vivid than the color used in the first column. + * The third column: All text is rendered with the default attributes.+ * The vertical bars used in each line to mark the border of a column are+ lined up.++After return is pressed for the second time:+ 0. The screen containing the test summary should be restored.+ 1. The cursor should be visible.+|]+ , confirm_results = do+ putStr $ [$heredoc|+Did the test output match the description?+|]+ default_success_confirm_results+ }++attributes_test_3 = Test + { test_name = "Character attributes: Vivid background colors."+ , test_ID = "attributes_test_3"+ , test_action = do+ t <- terminal_handle+ reserve_display t+ let pic = pic_for_image image+ image = horiz_cat [border, column_0, border, column_1, border, column_2, border]+ border = vert_cat $ replicate (length all_colors) $ string def_attr " | "+ column_0 = vert_cat $ map line_with_color_0 all_colors+ column_1 = vert_cat $ map line_with_color_1 all_bright_colors+ column_2 = vert_cat $ map (string def_attr . snd) all_colors+ line_with_color_0 (c, c_name) = string (def_attr `with_back_color` c) c_name+ line_with_color_1 (c, c_name) = string (def_attr `with_back_color` c) c_name+ d <- display_bounds t >>= display_context t+ output_picture d pic+ getLine+ release_display t+ release_terminal t+ return ()+ , print_summary = do+ putStr $ [$heredoc|+Once return is pressed:+ 0. The screen will be cleared.+ 1. The cursor will be hidden.+ 2. 9 lines of text in three columns will be drawn:+ a. The first column will contain be a name of a standard color for an 8+ color terminal rendered with the default foreground color with a+ background the named color. + b. The first column will contain be a name of a standard color for an 8+ color terminal rendered with the default foreground color with the+ background a vivid version of the named color. + c. The third column will be the name of a standard color rendered with+ the default attributes.+ +For instance, one line will contain be the word "magenta" and the word should+be rendered in the default foreground color over a magenta background. ++I'm not actually sure exactly what "vivid" means in this context. For xterm the+vivid colors are brighter.++Verify: + * The first column: The background color matches the named color.+ * The second column: The background color matches the named color and is+ more vivid than the color used in the first column. + * The third column column: All text is rendered with the default attributes.+ * The vertical bars used in each line to mark the border of a column are+ lined up.++Note: I haven't decided if, in this case, the background color should extend to+fills added for alignment. Right now the selected background color is only+applied to the background where the word is actually rendered. Since each word+is not of the same length VTY adds background fills to make the width of each+row effectively the same. These added fills are all currently rendered with the+default background pattern.++After return is pressed for the second time:+ 0. The screen containing the test summary should be restored.+ 1. The cursor should be visible.+|]+ , confirm_results = do+ putStr $ [$heredoc|+Did the test output match the description?+|]+ default_success_confirm_results+ }++attr_combos = + [ ( "default", id )+ , ( "bold", flip with_style bold )+ , ( "blink", flip with_style blink )+ , ( "underline", flip with_style underline )+ , ( "bold + blink", flip with_style (bold + blink) )+ , ( "bold + underline", flip with_style (bold + underline) )+ , ( "underline + blink", flip with_style (underline + blink) )+ , ( "bold + blink + underline", flip with_style (bold + blink + underline) )+ ]++attributes_test_4 = Test + { test_name = "Character attributes: Bold; Blink; Underline."+ , test_ID = "attributes_test_4"+ , test_action = do+ t <- terminal_handle+ reserve_display t+ let pic = pic_for_image image+ image = horiz_cat [border, column_0, border, column_1, border]+ border = vert_cat $ replicate (length attr_combos) $ string def_attr " | "+ column_0 = vert_cat $ map line_with_attrs attr_combos+ column_1 = vert_cat $ map (string def_attr . fst) attr_combos+ line_with_attrs (desc, attr_f) = string (attr_f def_attr) desc+ d <- display_bounds t >>= display_context t+ output_picture d pic+ getLine+ release_display t+ release_terminal t+ return ()+ , print_summary = do+ putStr $ [$heredoc|+Once return is pressed:+ 0. The screen will be cleared.+ 1. The cursor will be hidden.+ 2. 8 rows of text in two columns. + The rows will contain the following text:+ default+ bold + blink+ underline+ bold + blink+ bold + underline+ underline + blink+ bold + blink + underline+ The first column will be rendered with the described attributes. The second+ column will be rendered with the default attributes.+ +Verify: + * The vertical bars used in each line to mark the border of a column are+ lined up.+ * The text in the first column is rendered as described.++After return is pressed for the second time:+ 0. The screen containing the test summary should be restored.+ 1. The cursor should be visible.+|]+ , confirm_results = do+ putStr $ [$heredoc|+Did the test output match the description?+|]+ default_success_confirm_results+ }++attributes_test_5 = Test + { test_name = "Character attributes: 240 color palette"+ , test_ID = "attributes_test_5"+ , test_action = do+ t <- terminal_handle+ reserve_display t+ let pic = pic_for_image image+ image = vert_cat $ map horiz_cat $ split_color_images color_images+ color_images = map (\i -> string (current_attr `with_back_color` Color240 i) " ") [0..239]+ split_color_images [] = []+ split_color_images is = (take 20 is ++ [string def_attr " "]) : (split_color_images (drop 20 is))+ d <- display_bounds t >>= display_context t+ output_picture d pic+ getLine+ release_display t+ release_terminal t+ return ()+ , print_summary = do+ putStr $ [$heredoc|+Once return is pressed:+ 0. The screen will be cleared.+ 1. The cursor will be hidden.+ 2. A 20 character wide and 12 row high block of color squares. This should look like a palette+ of some sort. I'm not exactly sure if all color terminals use the same palette. I doubt it...++Verify: ++After return is pressed for the second time:+ 0. The screen containing the test summary should be restored.+ 1. The cursor should be visible.+|]+ , confirm_results = do+ putStr $ [$heredoc|+Did the test output match the description?+|]+ default_success_confirm_results+ }+
− test/make_tests.sh
@@ -1,10 +0,0 @@-#!/bin/sh-rm -f Test.o Test.hi Test-ghc --make Test--rm -f Test2.o Test2.hi Test2-ghc --make Test2--rm -f Bench.o Bench.hi Bench-ghc --make Bench-
+ test/verify_attribute_ops.hs view
@@ -0,0 +1,8 @@+module Main where++import Verify.Graphics.Vty.Attributes++import Verify++main = run_test $ do+ return ()
+ test/verify_debug_terminal.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Main where++import Verify.Graphics.Vty.DisplayRegion+import Verify.Graphics.Vty.Picture+import Verify.Graphics.Vty.Image+import Verify.Graphics.Vty.Span+import Graphics.Vty.Terminal+import Graphics.Vty.Terminal.Debug++import Graphics.Vty.Debug++import Verify++import qualified Data.ByteString as BS+import Data.IORef+import qualified Data.String.UTF8 as UTF8++import System.IO++unit_image_unit_bounds :: UnitImage -> Property+unit_image_unit_bounds (UnitImage _ i) = liftIOResult $ do+ t <- terminal_instance (DisplayRegion 1 1)+ d <- display_bounds t >>= display_context t+ let pic = pic_for_image i+ output_picture d pic+ return succeeded++unit_image_arb_bounds :: UnitImage -> DebugWindow -> Property+unit_image_arb_bounds (UnitImage _ i) (DebugWindow w h) = liftIOResult $ do+ t <- terminal_instance (DisplayRegion w h)+ d <- display_bounds t >>= display_context t+ let pic = pic_for_image i+ output_picture d pic+ return succeeded++single_T_row :: DebugWindow -> Property+single_T_row (DebugWindow w h) = liftIOResult $ do+ t <- terminal_instance (DisplayRegion w h)+ d <- display_bounds t >>= display_context t+ -- create an image that contains just the character T repeated for a single row+ let i = horiz_cat $ replicate (fromEnum w) (char def_attr 'T')+ pic = (pic_for_image i) { pic_background = Background 'B' def_attr }+ output_picture d pic+ out_bytes <- readIORef (debug_terminal_last_output $ dehandle t) >>= return . UTF8.toRep+ -- The UTF8 string that represents the output bytes a single line containing the T string:+ let expected = "HD" ++ "MA" ++ replicate (fromEnum w) 'T'+ -- Followed by h - 1 lines of a change to the background attribute and then the background+ -- character+ ++ concat (replicate (fromEnum h - 1) $ "MA" ++ replicate (fromEnum w) 'B')+ expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected+ if out_bytes /= expected_bytes+ then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes }+ else return succeeded+ +many_T_rows :: DebugWindow -> Property+many_T_rows (DebugWindow w h) = liftIOResult $ do+ t <- terminal_instance (DisplayRegion w h)+ d <- display_bounds t >>= display_context t+ -- create an image that contains the character 'T' repeated for all the rows+ let i = vert_cat $ replicate (fromEnum h) $ horiz_cat $ replicate (fromEnum w) (char def_attr 'T')+ pic = (pic_for_image i) { pic_background = Background 'B' def_attr }+ output_picture d pic+ out_bytes <- readIORef (debug_terminal_last_output $ dehandle t) >>= return . UTF8.toRep+ -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an+ -- attribute change. 'A', followed by w 'T's+ let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T')+ expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected+ if out_bytes /= expected_bytes+ then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes }+ else return succeeded++many_T_rows_cropped_width :: DebugWindow -> Property+many_T_rows_cropped_width (DebugWindow w h) = liftIOResult $ do+ t <- terminal_instance (DisplayRegion w h)+ d <- display_bounds t >>= display_context t+ -- create an image that contains the character 'T' repeated for all the rows+ let i = vert_cat $ replicate (fromEnum h) $ horiz_cat $ replicate (fromEnum w * 2) (char def_attr 'T')+ pic = (pic_for_image i) { pic_background = Background 'B' def_attr }+ output_picture d pic+ out_bytes <- readIORef (debug_terminal_last_output $ dehandle t) >>= return . UTF8.toRep+ -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an+ -- attribute change. 'A', followed by w 'T's+ let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T')+ expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected+ if out_bytes /= expected_bytes+ then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes }+ else return succeeded++many_T_rows_cropped_height :: DebugWindow -> Property+many_T_rows_cropped_height (DebugWindow w h) = liftIOResult $ do+ t <- terminal_instance (DisplayRegion w h)+ d <- display_bounds t >>= display_context t+ -- create an image that contains the character 'T' repeated for all the rows+ let i = vert_cat $ replicate (fromEnum h * 2) $ horiz_cat $ replicate (fromEnum w) (char def_attr 'T')+ pic = (pic_for_image i) { pic_background = Background 'B' def_attr }+ output_picture d pic+ out_bytes <- readIORef (debug_terminal_last_output $ dehandle t) >>= return . UTF8.toRep+ -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an+ -- attribute change. 'A', followed by w count 'T's+ let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T')+ expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected+ if out_bytes /= expected_bytes+ then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes }+ else return succeeded++main = run_test $ do+ verify "unit_image_unit_bounds" unit_image_unit_bounds+ verify "unit_image_arb_bounds" unit_image_arb_bounds+ verify "single_T_row" single_T_row+ verify "many_T_rows" many_T_rows+ verify "many_T_rows_cropped_width" many_T_rows_cropped_width+ verify "many_T_rows_cropped_height" many_T_rows_cropped_height+ return ()+
+ test/verify_eval_terminfo_caps.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+module Main where++import Data.Marshalling++import Data.Terminfo.Eval +import Data.Terminfo.Parse++import qualified System.Console.Terminfo as Terminfo++import Verify++import Control.Exception ( try, SomeException(..) )++import Control.Monad ( mapM_, forM_ )++import Data.Array.Unboxed+import Data.Maybe ( fromJust )+import Data.Word++import Numeric++-- A list of terminals that ubuntu includes a terminfo cap file for. +-- Assuming that is a good place to start.+terminals_of_interest = + [ "wsvt25"+ , "wsvt25m"+ , "vt52"+ , "vt100"+ , "vt220"+ , "vt102"+ , "xterm-r5"+ , "xterm-xfree86"+ , "xterm-r6"+ , "xterm-256color"+ , "xterm-vt220"+ , "xterm-debian"+ , "xterm-mono"+ , "xterm-color"+ , "xterm"+ , "mach"+ , "mach-bold"+ , "mach-color"+ , "linux"+ , "ansi"+ , "hurd"+ , "Eterm"+ , "pcansi"+ , "screen-256color"+ , "screen-bce"+ , "screen-s"+ , "screen-w"+ , "screen"+ , "screen-256color-bce"+ , "sun"+ , "rxvt"+ , "rxvt-unicode"+ , "rxvt-basic"+ , "cygwin"+ , "cons25"+ , "dumb"+ ]++-- If a terminal defines one of the caps then it's expected to be parsable.+caps_of_interest = + [ "cup"+ , "sc"+ , "rc"+ , "setf"+ , "setb"+ , "setaf"+ , "setab"+ , "op"+ , "cnorm"+ , "civis"+ , "smcup"+ , "rmcup"+ , "clear"+ , "hpa"+ , "vpa"+ , "sgr"+ , "sgr0"+ ]++from_capname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name)++main = do+ run_test $ do+ forM_ terminals_of_interest $ \term_name -> do+ liftIO $ putStrLn $ "testing parsing of caps for terminal: " ++ term_name+ mti <- liftIO $ try $ Terminfo.setupTerm term_name+ case mti of+ Left (_e :: SomeException) + -> return ()+ Right ti -> do+ forM_ caps_of_interest $ \cap_name -> do+ liftIO $ putStrLn $ "\tevaluating cap: " ++ cap_name+ case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of+ Just cap_def -> do+ verify ( "\teval cap " ++ cap_name ++ " -> " ++ show cap_def )+ ( verify_eval_cap cap_def )+ return ()+ Nothing -> do+ return ()+ return ()+ return ()++verify_eval_cap cap_string+ = case parse_cap_expression cap_string of+ Left error -> + liftResult $ failed { reason = "parse error " ++ show error }+ Right expr -> + forAll (vector 9) $ \input_values -> + let byte_count = cap_expression_required_bytes expr input_values+ in liftIOResult $ do+ start_ptr :: Ptr Word8 <- mallocBytes (fromEnum byte_count)+ end_ptr <- serialize_cap_expression expr input_values start_ptr+ free start_ptr+ case end_ptr `minusPtr` start_ptr of+ count | count < 0 -> + return $ failed { reason = "End pointer before start pointer." }+ | toEnum count > byte_count -> + return $ failed { reason = "End pointer past end of buffer by " + ++ show (toEnum count - byte_count) + }+ | otherwise -> + return succeeded+
+ test/verify_image_ops.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Main where+import Graphics.Vty.Attributes+import Verify.Graphics.Vty.Image++import Verify++import Data.Word++two_sw_horiz_concat :: SingleColumnChar -> SingleColumnChar -> Bool+two_sw_horiz_concat (SingleColumnChar c1) (SingleColumnChar c2) = + image_width (char def_attr c1 <|> char def_attr c2) == 2++many_sw_horiz_concat :: [SingleColumnChar] -> Bool+many_sw_horiz_concat cs = + let chars = [ char | SingleColumnChar char <- cs ]+ l = fromIntegral $ length cs+ in image_width ( horiz_cat $ map (char def_attr) chars ) == l++two_sw_vert_concat :: SingleColumnChar -> SingleColumnChar -> Bool+two_sw_vert_concat (SingleColumnChar c1) (SingleColumnChar c2) = + image_height (char def_attr c1 <-> char def_attr c2) == 2++horiz_concat_sw_assoc :: SingleColumnChar -> SingleColumnChar -> SingleColumnChar -> Bool+horiz_concat_sw_assoc (SingleColumnChar c0) (SingleColumnChar c1) (SingleColumnChar c2) = + (char def_attr c0 <|> char def_attr c1) <|> char def_attr c2 + == + char def_attr c0 <|> (char def_attr c1 <|> char def_attr c2)++two_dw_horiz_concat :: DoubleColumnChar -> DoubleColumnChar -> Bool+two_dw_horiz_concat (DoubleColumnChar c1) (DoubleColumnChar c2) = + image_width (char def_attr c1 <|> char def_attr c2) == 4++many_dw_horiz_concat :: [DoubleColumnChar] -> Bool+many_dw_horiz_concat cs = + let chars = [ char | DoubleColumnChar char <- cs ]+ l = fromIntegral $ length cs+ in image_width ( horiz_cat $ map (char def_attr) chars ) == l * 2++two_dw_vert_concat :: DoubleColumnChar -> DoubleColumnChar -> Bool+two_dw_vert_concat (DoubleColumnChar c1) (DoubleColumnChar c2) = + image_height (char def_attr c1 <-> char def_attr c2) == 2++horiz_concat_dw_assoc :: DoubleColumnChar -> DoubleColumnChar -> DoubleColumnChar -> Bool+horiz_concat_dw_assoc (DoubleColumnChar c0) (DoubleColumnChar c1) (DoubleColumnChar c2) = + (char def_attr c0 <|> char def_attr c1) <|> char def_attr c2 + == + char def_attr c0 <|> (char def_attr c1 <|> char def_attr c2)++vert_contat_single_row :: NonEmptyList SingleRowSingleAttrImage -> Bool+vert_contat_single_row (NonEmpty stack) =+ let expected_height :: Word = fromIntegral $ length stack+ stack_image = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack ]+ in image_height stack_image == expected_height++disjoint_height_horiz_join :: NonEmptyList SingleRowSingleAttrImage + -> NonEmptyList SingleRowSingleAttrImage+ -> Bool+disjoint_height_horiz_join (NonEmpty stack_0) (NonEmpty stack_1) =+ let expected_height :: Word = fromIntegral $ max (length stack_0) (length stack_1)+ stack_image_0 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]+ stack_image_1 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]+ in image_height (stack_image_0 <|> stack_image_1) == expected_height+++disjoint_height_horiz_join_bg_fill :: NonEmptyList SingleRowSingleAttrImage + -> NonEmptyList SingleRowSingleAttrImage+ -> Bool+disjoint_height_horiz_join_bg_fill (NonEmpty stack_0) (NonEmpty stack_1) =+ let stack_image_0 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]+ stack_image_1 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]+ image = stack_image_0 <|> stack_image_1+ expected_height = image_height image+ in case image of+ HorizJoin {} -> ( expected_height == (image_height $ part_left image) )+ && + ( expected_height == (image_height $ part_right image) )+ _ -> True++disjoint_width_vert_join :: NonEmptyList SingleRowSingleAttrImage + -> NonEmptyList SingleRowSingleAttrImage+ -> Bool+disjoint_width_vert_join (NonEmpty stack_0) (NonEmpty stack_1) =+ let expected_width = maximum $ map image_width (stack_0_images ++ stack_1_images)+ stack_0_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]+ stack_1_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]+ stack_0_image = vert_cat stack_0_images + stack_1_image = vert_cat stack_1_images + image = stack_0_image <-> stack_1_image+ in image_width image == expected_width++disjoint_width_vert_join_bg_fill :: NonEmptyList SingleRowSingleAttrImage + -> NonEmptyList SingleRowSingleAttrImage+ -> Bool+disjoint_width_vert_join_bg_fill (NonEmpty stack_0) (NonEmpty stack_1) =+ let expected_width = maximum $ map image_width (stack_0_images ++ stack_1_images)+ stack_0_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]+ stack_1_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]+ stack_0_image = vert_cat stack_0_images + stack_1_image = vert_cat stack_1_images + image = stack_0_image <-> stack_1_image+ in case image of+ VertJoin {} -> ( expected_width == (image_width $ part_top image) )+ &&+ ( expected_width == (image_width $ part_bottom image) )+ _ -> True++main = run_test $ do+ verify "two_sw_horiz_concat" two_sw_horiz_concat+ verify "many_sw_horiz_concat" many_sw_horiz_concat+ verify "two_sw_vert_concat" two_sw_vert_concat+ verify "horiz_concat_sw_assoc" horiz_concat_sw_assoc+ verify "many_dw_horiz_concat" many_dw_horiz_concat+ verify "two_dw_horiz_concat" two_dw_horiz_concat+ verify "two_dw_vert_concat" two_dw_vert_concat+ verify "horiz_concat_dw_assoc" horiz_concat_dw_assoc+ liftIO $ putStrLn $ replicate 80 '-'+ verify "single row vert concats to correct height" vert_contat_single_row+ verify "disjoint_height_horiz_join" disjoint_height_horiz_join+ verify "disjoint_height_horiz_join BG fill" disjoint_height_horiz_join_bg_fill+ verify "disjoint_width_vert_join" disjoint_width_vert_join+ verify "disjoint_width_vert_join BG fill" disjoint_width_vert_join_bg_fill+ return ()+
+ test/verify_image_trans.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE NamedFieldPuns #-}+module Main where++import Verify.Graphics.Vty.Image+import Graphics.Vty.Debug++import Verify++import Data.Word++is_horiz_text_of_columns :: Image -> Word -> Bool+is_horiz_text_of_columns (HorizText { output_width = in_w }) expected_w = in_w == expected_w+is_horiz_text_of_columns (BGFill { output_width = in_w }) expected_w = in_w == expected_w+is_horiz_text_of_columns _image _expected_w = False++verify_horiz_contat_wo_attr_change_simplifies :: SingleRowSingleAttrImage -> Bool+verify_horiz_contat_wo_attr_change_simplifies (SingleRowSingleAttrImage _attr char_count image) =+ is_horiz_text_of_columns image char_count++verify_horiz_contat_w_attr_change_simplifies :: SingleRowTwoAttrImage -> Bool+verify_horiz_contat_w_attr_change_simplifies ( SingleRowTwoAttrImage (SingleRowSingleAttrImage attr0 char_count0 image0)+ (SingleRowSingleAttrImage attr1 char_count1 image1)+ i+ ) + | char_count0 == 0 || char_count1 == 0 || attr0 == attr1 = is_horiz_text_of_columns i (char_count0 + char_count1)+ | otherwise = False == is_horiz_text_of_columns i (char_count0 + char_count1)++main = run_test $ do+ verify "verify_horiz_contat_wo_attr_change_simplifies" verify_horiz_contat_wo_attr_change_simplifies+ verify "verify_horiz_contat_w_attr_change_simplifies" verify_horiz_contat_w_attr_change_simplifies+ return ()
+ test/verify_parse_terminfo_caps.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+module Main where++import Prelude hiding ( catch )++import Data.Terminfo.Eval ( bytes_for_range )++import qualified System.Console.Terminfo as Terminfo++import Verify.Data.Terminfo.Parse+import Verify++import Control.Exception ( try, SomeException(..) )+import Control.Monad ( mapM_, forM_ )++import Data.Array.Unboxed+import Data.Maybe ( fromJust )+import Data.Word++import Numeric++-- A list of terminals that ubuntu includes a terminfo cap file for. +-- Assuming that is a good place to start.+terminals_of_interest = + [ "wsvt25"+ , "wsvt25m"+ , "vt52"+ , "vt100"+ , "vt220"+ , "vt102"+ , "xterm-r5"+ , "xterm-xfree86"+ , "xterm-r6"+ , "xterm-256color"+ , "xterm-vt220"+ , "xterm-debian"+ , "xterm-mono"+ , "xterm-color"+ , "xterm"+ , "mach"+ , "mach-bold"+ , "mach-color"+ , "linux"+ , "ansi"+ , "hurd"+ , "Eterm"+ , "pcansi"+ , "screen-256color"+ , "screen-bce"+ , "screen-s"+ , "screen-w"+ , "screen"+ , "screen-256color-bce"+ , "sun"+ , "rxvt"+ , "rxvt-unicode"+ , "rxvt-basic"+ , "cygwin"+ , "cons25"+ , "dumb"+ ]++-- If a terminal defines one of the caps then it's expected to be parsable.+caps_of_interest = + [ "cup"+ , "sc"+ , "rc"+ , "setf"+ , "setb"+ , "setaf"+ , "setab"+ , "op"+ , "cnorm"+ , "civis"+ , "smcup"+ , "rmcup"+ , "clear"+ , "hpa"+ , "vpa"+ , "sgr"+ , "sgr0"+ ]++from_capname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name)++main = do+ run_test $ do+ forM_ terminals_of_interest $ \term_name -> do+ liftIO $ putStrLn $ "testing parsing of caps for terminal: " ++ term_name+ mti <- liftIO $ try $ Terminfo.setupTerm term_name+ case mti of+ Left (_e :: SomeException) + -> return ()+ Right ti -> do+ forM_ caps_of_interest $ \cap_name -> do+ liftIO $ putStrLn $ "\tparsing cap: " ++ cap_name+ case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of+ Just cap_def -> do+ verify ( "\tparse cap " ++ cap_name ++ " -> " ++ show cap_def )+ ( verify_parse_cap cap_def $ const (liftResult succeeded) ) + return ()+ Nothing -> do+ return ()+ -- The quickcheck tests+ verify "parse_non_paramaterized_caps" non_paramaterized_caps+ verify "parse cap string with literal %" literal_percent_caps+ verify "parse cap string with %i op" inc_first_two_caps+ verify "parse cap string with %pN op" push_param_caps+ return ()+ return ()++verify_parse_cap cap_string on_parse = do+ case parse_cap_expression cap_string of+ Left error -> liftResult $ failed { reason = "parse error " ++ show error }+ Right e -> on_parse e++non_paramaterized_caps (NonParamCapString cap) = do+ verify_parse_cap cap $ \e -> + let expected_count :: Word8 = toEnum $ length cap+ expected_bytes = map (toEnum . fromEnum) cap+ out_bytes = bytes_for_range e 0 expected_count+ in verify_bytes_equal out_bytes expected_bytes++literal_percent_caps (LiteralPercentCap cap_string expected_bytes) = do+ verify_parse_cap cap_string $ \e ->+ let expected_count :: Word8 = toEnum $ length expected_bytes+ out_bytes = collect_bytes e+ in verify_bytes_equal out_bytes expected_bytes++inc_first_two_caps (IncFirstTwoCap cap_string expected_bytes) = do+ verify_parse_cap cap_string $ \e ->+ let expected_count :: Word8 = toEnum $ length expected_bytes+ out_bytes = collect_bytes e+ in verify_bytes_equal out_bytes expected_bytes+ +push_param_caps (PushParamCap cap_string expected_param_count expected_bytes) = do+ verify_parse_cap cap_string $ \e ->+ let expected_count :: Word8 = toEnum $ length expected_bytes+ out_bytes = collect_bytes e+ out_param_count = param_count e+ in verify_bytes_equal out_bytes expected_bytes+ .&. out_param_count == expected_param_count++dec_print_param_caps (DecPrintCap cap_string expected_param_count expected_bytes) = do+ verify_parse_cap cap_string $ \e ->+ let expected_count :: Word8 = toEnum $ length expected_bytes+ out_bytes = collect_bytes e+ out_param_count = param_count e+ in verify_bytes_equal out_bytes expected_bytes+ .&. out_param_count == expected_param_count++print_cap ti cap_name = do+ putStrLn $ cap_name ++ ": " ++ show (from_capname ti cap_name)++print_expression ti cap_name = do+ putStrLn $ cap_name ++ ": " ++ show (parse_cap_expression $ from_capname ti cap_name)+
+ test/verify_picture_ops.hs view
@@ -0,0 +1,9 @@+module Main where++import Graphics.Vty.Picture++import Verify++main = run_test $ do+ return ()+
+ test/verify_picture_to_span.hs view
@@ -0,0 +1,10 @@+module Main where++import Graphics.Vty.Picture+import Graphics.Vty.Span+import Graphics.Vty.PictureToSpans++import Verify++main = run_test $ do+ return ()
+ test/verify_span_ops.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}+module Main where++import Verify.Graphics.Vty.Picture+import Verify.Graphics.Vty.Image+import Verify.Graphics.Vty.Span+import Verify.Graphics.Vty.DisplayRegion++import Graphics.Vty.Debug++import Verify++import Data.Array++unit_image_and_zero_window_0 :: UnitImage -> EmptyWindow -> Bool+unit_image_and_zero_window_0 (UnitImage _ i) (EmptyWindow w) = + let p = pic_for_image i+ spans = spans_for_pic p (region_for_window w)+ in span_ops_columns spans == 0 && span_ops_rows spans == 0++unit_image_and_zero_window_1 :: UnitImage -> EmptyWindow -> Bool+unit_image_and_zero_window_1 (UnitImage _ i) (EmptyWindow w) = + let p = pic_for_image i+ spans = spans_for_pic p (region_for_window w)+ in ( span_ops_effected_rows spans == 0 ) && ( all_spans_have_width spans 0 )++horiz_span_image_and_zero_window_0 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool+horiz_span_image_and_zero_window_0 (SingleRowSingleAttrImage { row_image = i }) (EmptyWindow w) = + let p = pic_for_image i+ spans = spans_for_pic p (region_for_window w)+ in span_ops_columns spans == 0 && span_ops_rows spans == 0++horiz_span_image_and_zero_window_1 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool+horiz_span_image_and_zero_window_1 (SingleRowSingleAttrImage { row_image = i }) (EmptyWindow w) = + let p = pic_for_image i+ spans = spans_for_pic p (region_for_window w)+ in ( span_ops_effected_rows spans == 0 ) && ( all_spans_have_width spans 0 )++horiz_span_image_and_equal_window_0 :: SingleRowSingleAttrImage -> Result+horiz_span_image_and_equal_window_0 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) =+ let p = pic_for_image i+ w = DebugWindow c 1+ spans = spans_for_pic p (region_for_window w)+ in verify_all_spans_have_width i spans c++horiz_span_image_and_equal_window_1 :: SingleRowSingleAttrImage -> Bool+horiz_span_image_and_equal_window_1 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) =+ let p = pic_for_image i+ w = DebugWindow c 1+ spans = spans_for_pic p (region_for_window w)+ in span_ops_effected_rows spans == 1++horiz_span_image_and_lesser_window_0 :: SingleRowSingleAttrImage -> Result+horiz_span_image_and_lesser_window_0 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) =+ let p = pic_for_image i+ lesser_width = c `div` 2+ w = DebugWindow lesser_width 1+ spans = spans_for_pic p (region_for_window w)+ in verify_all_spans_have_width i spans lesser_width++single_attr_single_span_stack_cropped_0 :: SingleAttrSingleSpanStack -> Result+single_attr_single_span_stack_cropped_0 stack =+ let p = pic_for_image (stack_image stack)+ w = DebugWindow (stack_width stack `div` 2) (stack_height stack)+ spans = spans_for_pic p (region_for_window w)+ in verify_all_spans_have_width (stack_image stack) spans (stack_width stack `div` 2)++single_attr_single_span_stack_cropped_1 :: SingleAttrSingleSpanStack -> Bool+single_attr_single_span_stack_cropped_1 stack =+ let p = pic_for_image (stack_image stack)+ expected_row_count = stack_height stack `div` 2+ w = DebugWindow (stack_width stack) expected_row_count+ spans = spans_for_pic p (region_for_window w)+ actual_row_count = span_ops_effected_rows spans+ in expected_row_count == actual_row_count++single_attr_single_span_stack_cropped_2 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result+single_attr_single_span_stack_cropped_2 stack_0 stack_1 =+ let p = pic_for_image (stack_image stack_0 <|> stack_image stack_1)+ w = DebugWindow (stack_width stack_0) (image_height (pic_image p))+ spans = spans_for_pic p (region_for_window w)+ in verify_all_spans_have_width (pic_image p) spans (stack_width stack_0)++single_attr_single_span_stack_cropped_3 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool+single_attr_single_span_stack_cropped_3 stack_0 stack_1 =+ let p = pic_for_image (stack_image stack_0 <|> stack_image stack_1)+ w = DebugWindow (image_width (pic_image p)) expected_row_count+ spans = spans_for_pic p (region_for_window w)+ expected_row_count = image_height (pic_image p) `div` 2+ actual_row_count = span_ops_effected_rows spans+ in expected_row_count == actual_row_count++single_attr_single_span_stack_cropped_4 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result+single_attr_single_span_stack_cropped_4 stack_0 stack_1 =+ let p = pic_for_image (stack_image stack_0 <-> stack_image stack_1)+ w = DebugWindow expected_width (image_height (pic_image p))+ spans = spans_for_pic p (region_for_window w)+ expected_width = image_width (pic_image p) `div` 2+ in verify_all_spans_have_width (pic_image p) spans expected_width++single_attr_single_span_stack_cropped_5 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool+single_attr_single_span_stack_cropped_5 stack_0 stack_1 =+ let p = pic_for_image (stack_image stack_0 <-> stack_image stack_1)+ w = DebugWindow (image_width (pic_image p)) (stack_height stack_0)+ spans = spans_for_pic p (region_for_window w)+ expected_row_count = stack_height stack_0+ actual_row_count = span_ops_effected_rows spans+ in expected_row_count == actual_row_count++horiz_span_image_and_greater_window_0 :: SingleRowSingleAttrImage -> Result+horiz_span_image_and_greater_window_0 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) =+ let p = pic_for_image i+ -- SingleRowSingleAttrImage always has width >= 1+ greater_width = c * 2+ w = DebugWindow greater_width 1+ spans = spans_for_pic p (region_for_window w)+ in verify_all_spans_have_width i spans greater_width++arb_image_is_cropped :: DefaultImage -> DebugWindow -> Bool+arb_image_is_cropped (DefaultImage image _) win@(DebugWindow w h) =+ let pic = pic_for_image image+ spans = spans_for_pic pic (region_for_window win)+ in ( span_ops_effected_rows spans == h ) && ( all_spans_have_width spans w )++span_ops_actually_fill_rows :: DefaultPic -> Bool+span_ops_actually_fill_rows (DefaultPic pic win _) =+ let spans = spans_for_pic pic (region_for_window win)+ expected_row_count = region_height (region_for_window win)+ actual_row_count = span_ops_effected_rows spans+ in expected_row_count == actual_row_count++span_ops_actually_fill_columns :: DefaultPic -> Bool+span_ops_actually_fill_columns (DefaultPic pic win _) =+ let spans = spans_for_pic pic (region_for_window win)+ expected_column_count = region_width (region_for_window win)+ in all_spans_have_width spans expected_column_count++first_span_op_sets_attr :: DefaultPic -> Bool+first_span_op_sets_attr DefaultPic { default_pic = pic, default_win = win } = + let spans = spans_for_pic pic (region_for_window win)+ in all ( is_attr_span_op . head ) ( elems $ row_ops spans )++single_attr_single_span_stack_op_coverage :: SingleAttrSingleSpanStack -> Result+single_attr_single_span_stack_op_coverage stack =+ let p = pic_for_image (stack_image stack)+ w = DebugWindow (stack_width stack) (stack_height stack)+ spans = spans_for_pic p (region_for_window w)+ in verify_all_spans_have_width (stack_image stack) spans (stack_width stack)++main :: IO ()+main = run_test $ do+ verify "unit image is cropped when window size == (0,0) [0]" unit_image_and_zero_window_0+ verify "unit image is cropped when window size == (0,0) [1]" unit_image_and_zero_window_1+ verify "horiz span image is cropped when window size == (0,0) [0]" horiz_span_image_and_zero_window_0+ verify "horiz span image is cropped when window size == (0,0) [1]" horiz_span_image_and_zero_window_1+ verify "horiz span image is not cropped when window size == size of image [width]" horiz_span_image_and_equal_window_0+ verify "horiz span image is not cropped when window size == size of image [height]" horiz_span_image_and_equal_window_1+ verify "horiz span image is not cropped when window size < size of image [width]" horiz_span_image_and_lesser_window_0+ verify "horiz span image is not cropped when window size > size of image [width]" horiz_span_image_and_greater_window_0+ verify "arbitrary image is padded or cropped" arb_image_is_cropped+ verify "The span ops actually define content for all the rows in the output region" span_ops_actually_fill_rows+ verify "The span ops actually define content for all the columns in the output region" span_ops_actually_fill_columns+ verify "first span op is always to set the text attribute" first_span_op_sets_attr+ verify "a stack of single attr text spans should define content for all the columns [output region == size of stack]"+ single_attr_single_span_stack_op_coverage+ verify "a single attr text span is cropped when window size < size of stack image [width]"+ single_attr_single_span_stack_cropped_0 + verify "a single attr text span is cropped when window size < size of stack image [height]"+ single_attr_single_span_stack_cropped_1+ verify "single attr text span <|> single attr text span cropped. [width]"+ single_attr_single_span_stack_cropped_2+ verify "single attr text span <|> single attr text span cropped. [height]"+ single_attr_single_span_stack_cropped_3+ verify "single attr text span <-> single attr text span cropped. [width]"+ single_attr_single_span_stack_cropped_4+ verify "single attr text span <-> single attr text span cropped. [height]"+ single_attr_single_span_stack_cropped_5+ return ()
+ test/verify_utf8_width.hs view
@@ -0,0 +1,17 @@+module Main where+import Verify++import Graphics.Vty.Attributes+import Graphics.Vty.Picture++sw_is_1_column :: SingleColumnChar -> Bool+sw_is_1_column (SingleColumnChar c) = image_width (char def_attr c) == 1++dw_is_2_column :: DoubleColumnChar -> Bool+dw_is_2_column (DoubleColumnChar c) = image_width (char def_attr c) == 2++main = run_test $ do+ verify "sw_is_1_column" sw_is_1_column+ verify "dw_is_2_column" dw_is_2_column+ return ()+
+ test/vty_issue_18.hs view
@@ -0,0 +1,36 @@+module Main+ where++import Graphics.Vty+import Graphics.Vty.Debug++import System.IO++main :: IO ()+main = do+ vty <- mkVty+ (sx, sy) <- getSize vty+ play vty sx sy++play :: Vty -> Int -> Int -> IO ()+play vty sx sy = + let + testScreen = pic {+ pCursor = NoCursor+ , pImage = box 10 10 }+ in do+ update vty testScreen+ getEvent vty+ shutdown vty+ return ()++box :: Int -> Int -> Image+box w h =+ let+ corner = renderChar attr '+'+ vertLine = renderFill attr '|' 1 (h - 2)+ horizLine = corner <|> renderHFill attr '-' (w - 2) <|> corner+ centerArea = vertLine <|> renderFill attr 'X' (w - 2) (h - 2) <|> vertLine+ in + horizLine <-> centerArea <-> horizLine+
+ test/yi_issue_264.hs view
@@ -0,0 +1,12 @@+module Main where+import Graphics.Vty+import Control.Exception++catchLog = handle (\except -> do putStrLn $ show (except :: IOException))++main = do+ vty <- mkVty+ catchLog $ update vty pic { pImage = empty, pCursor = NoCursor }+ catchLog $ update vty pic { pImage = empty, pCursor = NoCursor }+ shutdown vty+
vty.cabal view
@@ -1,57 +1,99 @@ Name: vty-Version: 3.1.8.4+Version: 4.0.0 License: BSD3 License-file: LICENSE-Author: Stefan O'Rear+Author: Stefan O'Rear, Corey O'Connor Maintainer: Corey O'Connor (coreyoconnor@gmail.com) Homepage: http://trac.haskell.org/vty/ Category: User Interfaces Synopsis: A simple terminal access library Description:- vty is a *very* simplistic library in the niche of ncurses. It is intended- to be easy to use, have no confusing corner cases, and good support for common- terminal types.+ vty is terminal GUI library in the niche of ncurses. It is intended to be easy to use, have no+ confusing corner cases, and good support for common terminal types. .- If you want to use it, currently the best reference is the test module (Test.hs).+ Included in the source distribution is a program test/interactive_terminal_test.hs that+ demonstrates the various features. .- Notable infelicities: requires an ANSI-type terminal, poor efficiency,- requires Linux\/xterm style UTF8 support.+ If your terminal is not behaving as expected the results of the test/interactive_terminal_test.hs+ program should be sent to the Vty maintainter to aid in debugging the issue. .- The latest code is in a darcs repo at <http://code.haskell.org/vty/>. This is only- compatible with GHC 6.10+.+ Notable infelicities: Sometimes poor efficiency; Assumes UTF-8 character encoding support by the+ terminal; .- The 3.1.8.* line of vty which is compatable with GHC 6.8 and GHC 6.10 is currently - in the darcs repo at <http://www.tothepowerofdisco.com/repo/vty-compat>.- '+ You can 'darcs get' it from <http://code.haskell.org/vty/>+ . © 2006-2007 Stefan O'Rear; BSD3 license.+ .+ © 2008-2009 Corey O'Connor; BSD3 license. +Build-Depends: base >= 4 && < 5, bytestring, containers, unix+Build-Depends: terminfo >= 0.3 && < 0.4+Build-Depends: utf8-string >= 0.3 && < 0.4+Build-Depends: mtl >= 1.1.0.0 && < 1.2+Build-Depends: ghc-prim, parallel+Build-Depends: array+Build-Depends: parsec >= 2 && < 4 Build-Type: Simple Data-Files: README, TODO-Extra-Source-Files: test/Test.hs, test/Bench.hs, test/Test2.hs, test/make_tests.sh-Extra-Source-Files: cbits/gwinsz.h-cabal-version: >=1.2+Exposed-Modules: Graphics.Vty+ Graphics.Vty.Terminal+ Graphics.Vty.LLInput+ Graphics.Vty.Attributes+ Graphics.Vty.Picture+ Graphics.Vty.DisplayRegion -Library {- if impl(ghc>=6.9)- Build-Depends: base >= 4 && < 5- else- Build-Depends: base < 4- Build-Depends: extensible-exceptions- Build-Depends: bytestring, containers, unix- Build-Depends: terminfo >= 0.3 && < 0.4- Build-Depends: utf8-string >= 0.3 && < 0.4+other-modules: Codec.Binary.UTF8.Width+ Data.Marshalling+ Data.Terminfo.Parse+ Data.Terminfo.Eval+ Graphics.Vty.Image+ Graphics.Vty.Span+ Graphics.Vty.Terminal.Generic+ Graphics.Vty.Terminal.MacOSX+ Graphics.Vty.Terminal.XTermColor+ Graphics.Vty.Terminal.TerminfoBased - Exposed-Modules: Graphics.Vty- C-Sources: cbits/gwinsz.c- cbits/set_term_timing.c- Include-Dirs: cbits- Install-Includes: gwinsz.h- Other-Modules: Graphics.Vty.Types- Graphics.Vty.Cursor- Graphics.Vty.LLInput- Graphics.Vty.Output- Graphics.Vty.ControlStrings+C-Sources: cbits/gwinsz.c+ cbits/set_term_timing.c+ cbits/mk_wcwidth.c+Include-Dirs: cbits+hs-source-dirs: src+Extra-Source-Files: test/Makefile+ test/Bench2.hs+ test/Bench.hs+ test/BenchRenderChar.hs+ test/ControlTable.hs+ test/HereDoc.hs+ test/interactive_terminal_test.hs+ test/Test2.hs+ test/Test.hs+ test/verify_attribute_ops.hs+ test/verify_debug_terminal.hs+ test/verify_eval_terminfo_caps.hs+ test/Verify.hs+ test/verify_image_ops.hs+ test/verify_image_trans.hs+ test/verify_parse_terminfo_caps.hs+ test/verify_picture_ops.hs+ test/verify_picture_to_span.hs+ test/verify_span_ops.hs+ test/verify_utf8_width.hs+ test/vty_issue_18.hs+ test/yi_issue_264.hs+ test/Verify/Graphics/Vty/Attributes.hs+ test/Verify/Graphics/Vty/Picture.hs+ test/Verify/Graphics/Vty/Span.hs+ test/Verify/Graphics/Vty/DisplayRegion.hs+ test/Verify/Graphics/Vty/Image.hs+ test/Verify/Data/Terminfo/Parse.hs+ src/Codec/Binary/UTF8/Debug.hs+ src/Graphics/Vty/Terminal/Debug.hs+ src/Graphics/Vty/Debug.hs+ cbits/gwinsz.c+ cbits/mk_wcwidth.c+ cbits/set_term_timing.c+ cbits/gwinsz.h - ghc-options: -funbox-strict-fields -Wall -threaded -fno-full-laziness -fspec-constr- ghc-prof-options: -funbox-strict-fields -prof -auto-all -Wall -fno-full-laziness -fspec-constr-}+ghc-options: -funbox-strict-fields -Wall -fno-full-laziness -fspec-constr+ghc-prof-options: -funbox-strict-fields -auto-all -Wall -fno-full-laziness -fspec-constr+