diff --git a/Graphics/Vty.hs b/Graphics/Vty.hs deleted file mode 100644 --- a/Graphics/Vty.hs +++ /dev/null @@ -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' - - diff --git a/Graphics/Vty/ControlStrings.hs b/Graphics/Vty/ControlStrings.hs deleted file mode 100644 --- a/Graphics/Vty/ControlStrings.hs +++ /dev/null @@ -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" - diff --git a/Graphics/Vty/Cursor.hs b/Graphics/Vty/Cursor.hs deleted file mode 100644 --- a/Graphics/Vty/Cursor.hs +++ /dev/null @@ -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 #-} - diff --git a/Graphics/Vty/LLInput.hs b/Graphics/Vty/LLInput.hs deleted file mode 100644 --- a/Graphics/Vty/LLInput.hs +++ /dev/null @@ -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 () - diff --git a/Graphics/Vty/Output.hs b/Graphics/Vty/Output.hs deleted file mode 100644 --- a/Graphics/Vty/Output.hs +++ /dev/null @@ -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" - diff --git a/Graphics/Vty/Types.hs b/Graphics/Vty/Types.hs deleted file mode 100644 --- a/Graphics/Vty/Types.hs +++ /dev/null @@ -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" } diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -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 + diff --git a/cbits/mk_wcwidth.c b/cbits/mk_wcwidth.c new file mode 100644 --- /dev/null +++ b/cbits/mk_wcwidth.c @@ -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 + +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; +} diff --git a/src/Codec/Binary/UTF8/Debug.hs b/src/Codec/Binary/UTF8/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Binary/UTF8/Debug.hs @@ -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 + diff --git a/src/Codec/Binary/UTF8/Width.hs b/src/Codec/Binary/UTF8/Width.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Binary/UTF8/Width.hs @@ -0,0 +1,40 @@ +-- Copyright 2009 Corey O'Connor +{-# OPTIONS_GHC -D_XOPEN_SOURCE -fno-cse #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# INCLUDE #-} +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 diff --git a/src/Data/Marshalling.hs b/src/Data/Marshalling.hs new file mode 100644 --- /dev/null +++ b/src/Data/Marshalling.hs @@ -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 + diff --git a/src/Data/Terminfo/Eval.hs b/src/Data/Terminfo/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Data/Terminfo/Eval.hs @@ -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 + diff --git a/src/Data/Terminfo/Parse.hs b/src/Data/Terminfo/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Data/Terminfo/Parse.hs @@ -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) + } + diff --git a/src/Graphics/Vty.hs b/src/Graphics/Vty.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty.hs @@ -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 + } + diff --git a/src/Graphics/Vty/Attributes.hs b/src/Graphics/Vty/Attributes.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Attributes.hs @@ -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 + diff --git a/src/Graphics/Vty/Debug.hs b/src/Graphics/Vty/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Debug.hs @@ -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 ++ " ??" diff --git a/src/Graphics/Vty/DisplayRegion.hs b/src/Graphics/Vty/DisplayRegion.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/DisplayRegion.hs @@ -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 ) + diff --git a/src/Graphics/Vty/Image.hs b/src/Graphics/Vty/Image.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Image.hs @@ -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 + diff --git a/src/Graphics/Vty/LLInput.hs b/src/Graphics/Vty/LLInput.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/LLInput.hs @@ -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 () + diff --git a/src/Graphics/Vty/Picture.hs b/src/Graphics/Vty/Picture.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Picture.hs @@ -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 + } + diff --git a/src/Graphics/Vty/Span.hs b/src/Graphics/Vty/Span.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Span.hs @@ -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 () + diff --git a/src/Graphics/Vty/Terminal.hs b/src/Graphics/Vty/Terminal.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Terminal.hs @@ -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) + diff --git a/src/Graphics/Vty/Terminal/Debug.hs b/src/Graphics/Vty/Terminal/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Terminal/Debug.hs @@ -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 + diff --git a/src/Graphics/Vty/Terminal/Generic.hs b/src/Graphics/Vty/Terminal/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Terminal/Generic.hs @@ -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' + diff --git a/src/Graphics/Vty/Terminal/MacOSX.hs b/src/Graphics/Vty/Terminal/MacOSX.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Terminal/MacOSX.hs @@ -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) + diff --git a/src/Graphics/Vty/Terminal/TerminfoBased.hs b/src/Graphics/Vty/Terminal/TerminfoBased.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Terminal/TerminfoBased.hs @@ -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 ] + diff --git a/src/Graphics/Vty/Terminal/XTermColor.hs b/src/Graphics/Vty/Terminal/XTermColor.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Terminal/XTermColor.hs @@ -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) + diff --git a/test/Bench.hs b/test/Bench.hs --- a/test/Bench.hs +++ b/test/Bench.hs @@ -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 + diff --git a/test/Bench2.hs b/test/Bench2.hs new file mode 100644 --- /dev/null +++ b/test/Bench2.hs @@ -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 + diff --git a/test/BenchRenderChar.hs b/test/BenchRenderChar.hs new file mode 100644 --- /dev/null +++ b/test/BenchRenderChar.hs @@ -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) + diff --git a/test/ControlTable.hs b/test/ControlTable.hs new file mode 100644 --- /dev/null +++ b/test/ControlTable.hs @@ -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) + diff --git a/test/HereDoc.hs b/test/HereDoc.hs new file mode 100644 --- /dev/null +++ b/test/HereDoc.hs @@ -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) + diff --git a/test/Makefile b/test/Makefile new file mode 100644 --- /dev/null +++ b/test/Makefile @@ -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) $@ && ./$@ + diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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 diff --git a/test/Test2.hs b/test/Test2.hs --- a/test/Test2.hs +++ b/test/Test2.hs @@ -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 () diff --git a/test/Verify.hs b/test/Verify.hs new file mode 100644 --- /dev/null +++ b/test/Verify.hs @@ -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 diff --git a/test/Verify/Data/Terminfo/Parse.hs b/test/Verify/Data/Terminfo/Parse.hs new file mode 100644 --- /dev/null +++ b/test/Verify/Data/Terminfo/Parse.hs @@ -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 ) + ++ "]" + } + diff --git a/test/Verify/Graphics/Vty/Attributes.hs b/test/Verify/Graphics/Vty/Attributes.hs new file mode 100644 --- /dev/null +++ b/test/Verify/Graphics/Vty/Attributes.hs @@ -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 + diff --git a/test/Verify/Graphics/Vty/DisplayRegion.hs b/test/Verify/Graphics/Vty/DisplayRegion.hs new file mode 100644 --- /dev/null +++ b/test/Verify/Graphics/Vty/DisplayRegion.hs @@ -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 + diff --git a/test/Verify/Graphics/Vty/Image.hs b/test/Verify/Graphics/Vty/Image.hs new file mode 100644 --- /dev/null +++ b/test/Verify/Graphics/Vty/Image.hs @@ -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 ) + diff --git a/test/Verify/Graphics/Vty/Picture.hs b/test/Verify/Graphics/Vty/Picture.hs new file mode 100644 --- /dev/null +++ b/test/Verify/Graphics/Vty/Picture.hs @@ -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 + diff --git a/test/Verify/Graphics/Vty/Span.hs b/test/Verify/Graphics/Vty/Span.hs new file mode 100644 --- /dev/null +++ b/test/Verify/Graphics/Vty/Span.hs @@ -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 + } diff --git a/test/interactive_terminal_test.hs b/test/interactive_terminal_test.hs new file mode 100644 --- /dev/null +++ b/test/interactive_terminal_test.hs @@ -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 + } + diff --git a/test/make_tests.sh b/test/make_tests.sh deleted file mode 100644 --- a/test/make_tests.sh +++ /dev/null @@ -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 - diff --git a/test/verify_attribute_ops.hs b/test/verify_attribute_ops.hs new file mode 100644 --- /dev/null +++ b/test/verify_attribute_ops.hs @@ -0,0 +1,8 @@ +module Main where + +import Verify.Graphics.Vty.Attributes + +import Verify + +main = run_test $ do + return () diff --git a/test/verify_debug_terminal.hs b/test/verify_debug_terminal.hs new file mode 100644 --- /dev/null +++ b/test/verify_debug_terminal.hs @@ -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 () + diff --git a/test/verify_eval_terminfo_caps.hs b/test/verify_eval_terminfo_caps.hs new file mode 100644 --- /dev/null +++ b/test/verify_eval_terminfo_caps.hs @@ -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 + diff --git a/test/verify_image_ops.hs b/test/verify_image_ops.hs new file mode 100644 --- /dev/null +++ b/test/verify_image_ops.hs @@ -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 () + diff --git a/test/verify_image_trans.hs b/test/verify_image_trans.hs new file mode 100644 --- /dev/null +++ b/test/verify_image_trans.hs @@ -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 () diff --git a/test/verify_parse_terminfo_caps.hs b/test/verify_parse_terminfo_caps.hs new file mode 100644 --- /dev/null +++ b/test/verify_parse_terminfo_caps.hs @@ -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) + diff --git a/test/verify_picture_ops.hs b/test/verify_picture_ops.hs new file mode 100644 --- /dev/null +++ b/test/verify_picture_ops.hs @@ -0,0 +1,9 @@ +module Main where + +import Graphics.Vty.Picture + +import Verify + +main = run_test $ do + return () + diff --git a/test/verify_picture_to_span.hs b/test/verify_picture_to_span.hs new file mode 100644 --- /dev/null +++ b/test/verify_picture_to_span.hs @@ -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 () diff --git a/test/verify_span_ops.hs b/test/verify_span_ops.hs new file mode 100644 --- /dev/null +++ b/test/verify_span_ops.hs @@ -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 () diff --git a/test/verify_utf8_width.hs b/test/verify_utf8_width.hs new file mode 100644 --- /dev/null +++ b/test/verify_utf8_width.hs @@ -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 () + diff --git a/test/vty_issue_18.hs b/test/vty_issue_18.hs new file mode 100644 --- /dev/null +++ b/test/vty_issue_18.hs @@ -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 + diff --git a/test/yi_issue_264.hs b/test/yi_issue_264.hs new file mode 100644 --- /dev/null +++ b/test/yi_issue_264.hs @@ -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 + diff --git a/vty.cabal b/vty.cabal --- a/vty.cabal +++ b/vty.cabal @@ -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 . 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 . - ' + You can 'darcs get' it from + . © 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 +