diff --git a/.installed-pkg-config b/.installed-pkg-config new file mode 100644 --- /dev/null +++ b/.installed-pkg-config @@ -0,0 +1,38 @@ +name: vty +version: 3.0.0 +license: BSD3 +copyright: +maintainer: stefanor@cox.net +stability: +homepage: +package-url: +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. + . + If you want to use it, currently the best reference is the test module (Test.hs). + . + Notable infelicities: requires an ANSI-type terminal, poor efficiency, + requires Linux\/xterm style UTF8 support. + . + © 2006-2007 Stefan O'Rear; BSD3 license. +category: User Interfaces +author: Stefan O'Rear +exposed: True +exposed-modules: Graphics.Vty +hidden-modules: UTF8 Graphics.Vty.Types Graphics.Vty.Cursor +import-dirs: /home/dons/lib/vty-3.0.0/ghc-6.6 +library-dirs: /home/dons/lib/vty-3.0.0/ghc-6.6 +hs-libraries: HSvty-3.0.0 +extra-libraries: +extra-ghci-libraries: +include-dirs: /home/dons/lib/vty-3.0.0/ghc-6.6/include +includes: gwinsz.h +depends: base-2.0 unix-1.0 +hugs-options: +cc-options: +ld-options: +framework-dirs: +frameworks: +haddock-interfaces: /home/dons/share/vty-3.0.0/doc/html/vty.haddock +haddock-html: /home/dons/share/vty-3.0.0/doc/html diff --git a/.setup-config b/.setup-config new file mode 100644 --- /dev/null +++ b/.setup-config @@ -0,0 +1,1 @@ +LocalBuildInfo {prefix = "/home/dons", bindir = "$prefix/bin", libdir = "$prefix/lib", libsubdir = "$pkgid/$compiler", libexecdir = "$prefix/libexec", datadir = "$prefix/share", datasubdir = "$pkgid", compiler = Compiler {compilerFlavor = GHC, compilerVersion = Version {versionBranch = [6,6], versionTags = []}, compilerPath = "/home/dons/bin/ghc", compilerPkgTool = "/home/dons/bin/ghc-pkg"}, buildDir = "/usr/obj/cabal", packageDeps = [PackageIdentifier {pkgName = "base", pkgVersion = Version {versionBranch = [2,0], versionTags = []}},PackageIdentifier {pkgName = "unix", pkgVersion = Version {versionBranch = [1,0], versionTags = []}}], withPrograms = [("ar",Program {programName = "ar", programBinName = "ar", programArgs = [], programLocation = FoundOnSystem "/usr/bin/ar"}),("haddock",Program {programName = "haddock", programBinName = "haddock", programArgs = [], programLocation = FoundOnSystem "/home/dons/bin/haddock"}),("ld",Program {programName = "ld", programBinName = "ld", programArgs = [], programLocation = FoundOnSystem "/usr/bin/ld"}),("pfesetup",Program {programName = "pfesetup", programBinName = "pfesetup", programArgs = [], programLocation = EmptyLocation}),("ranlib",Program {programName = "ranlib", programBinName = "ranlib", programArgs = [], programLocation = FoundOnSystem "/usr/bin/ranlib"}),("runghc",Program {programName = "runghc", programBinName = "runghc", programArgs = [], programLocation = FoundOnSystem "/home/dons/bin/runghc"}),("runhugs",Program {programName = "runhugs", programBinName = "runhugs", programArgs = [], programLocation = FoundOnSystem "/home/dons/bin/runhugs"}),("tar",Program {programName = "tar", programBinName = "tar", programArgs = [], programLocation = FoundOnSystem "/bin/tar"})], userConf = False, withHappy = Just "/home/dons/bin/happy", withAlex = Just "/home/dons/bin/alex", withHsc2hs = Just "/home/dons/bin/hsc2hs", withC2hs = Nothing, withCpphs = Just "/home/dons/bin/cpphs", withGreencard = Nothing, withVanillaLib = True, withProfLib = False, withProfExe = False, withGHCiLib = True, splitObjs = False} diff --git a/Graphics/Vty.hs b/Graphics/Vty.hs new file mode 100644 --- /dev/null +++ b/Graphics/Vty.hs @@ -0,0 +1,98 @@ +{-# OPTIONS_GHC -fffi #-} +{-# CFILES gwinsz.c #-} +module Graphics.Vty (Vty(..), beep, mkVty, module Graphics.Vty.Types) where + +import Data.IORef( IORef, newIORef, readIORef, writeIORef ) +import Control.Concurrent + +import Control.Monad( when, liftM ) + +import Graphics.Vty.Types hiding (Color, Attr, Image, fillSeg) +import Graphics.Vty.Types (Color(), Attr(), Image()) +import qualified Graphics.Vty.Types as T(Color(..), Attr(..), Image(..), fillSeg) +import Graphics.Vty.Cursor + +import Foreign.Marshal.Array +import Foreign.Marshal.Alloc +import Foreign.Marshal.Error +import Foreign.Storable +import Foreign.Ptr + +-- |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), + -- |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 = do (tstate, kvar, end) <- initTerm + rtstate <- newMVar tstate + rlast <- newIORef pic + shadow <- newIORef =<< liftM (\x -> (,,,) x (-1) (-1) NoCursor) (mallocArray 2) + intMkVty kvar end rlast rtstate shadow + +intMkVty :: IO Event -> IO () -> IORef Picture -> MVar TermState -> IORef (Ptr Int, Int, Int, Cursor) -> IO Vty +intMkVty kvar fend rlast rtstate rshadow = ulift getwinsize >>= uncurry clrscr' >> return rec where + + ulift_ :: (TermState -> IO TermState) -> IO () + ulift_ f = modifyMVar_ rtstate f + + ulift :: (TermState -> IO (a, TermState)) -> IO a + ulift f = modifyMVar rtstate (\v -> fmap (\(x,y) -> (y,x)) (f v)) + + rec = Vty { update = update' , getEvent = gkey , getSize = ulift getwinsize , + shutdown = fend } + + clrscr' x y = do ulift_ clrscr + (old,_,_,cp) <- readIORef rshadow + free old + new <- throwIfNull "clrscr realloc" $ mallocArray (x * y * 2) + T.fillSeg attr ' ' new (new `advancePtr` (x * y * 2)) + writeIORef rshadow (new, x, y, cp) + + + update' l@(Pic nc (T.Image wr w h)) = do + do (_, fbw, fbh, _) <- readIORef rshadow + when (fbw /= w || fbh /= h) $ clrscr' w h + (shd, _, _, _) <- readIORef rshadow + fb <- throwIfNull "update alloc" $ mallocArray (w * h * 2) + wr (w * 2 * sizeOf (undefined :: Int)) fb + writeIORef rshadow (fb, w, h, nc) + ulift_ (\ st -> do st' <- diffs w h shd fb st + st'' <- case nc of NoCursor -> setCursorInvis st' + Cursor x y -> move w x y st' >>= setCursorVis + flush st'') + free shd + writeIORef rlast l + + refresh = do ofb@(Pic _ (T.Image _ w h)) <- readIORef rlast ; clrscr' w h; update' ofb + + gkey = do k <- kvar + case k of (EvKey (KASCII 'l') [MCtrl]) -> refresh >> gkey + (EvResize _ _) -> refresh >> return k + _ -> return k + +diffs :: Int -> Int -> Ptr Int -> Ptr Int -> TermState -> IO TermState +diffs w h old new state | w `seq` h `seq` old `seq` new `seq` state `seq` False = undefined +diffs w h old new state = diffs' 0 0 old new state + where + diffs' :: Int -> Int -> Ptr Int -> Ptr Int -> TermState -> IO TermState + diffs' x y olp nwp stat + | x `seq` y `seq` olp `seq` nwp `seq` stat `seq` False = undefined + | y == h = return stat + | x == w = diffs' 0 (y+1) olp nwp stat + | otherwise = do ola <- peek olp + nwa <- peek nwp + olc <- peekElemOff olp 1 + nwc <- peekElemOff nwp 1 + stat' <- case (ola /= nwa || olc /= nwc) of + False -> return stat + True -> move w x y stat >>= putch (toEnum nwc, T.Attr nwa) + diffs' (x+1) y (olp `advancePtr` 2) (nwp `advancePtr` 2) stat' diff --git a/Graphics/Vty/Cursor.hs b/Graphics/Vty/Cursor.hs new file mode 100644 --- /dev/null +++ b/Graphics/Vty/Cursor.hs @@ -0,0 +1,176 @@ +{-# OPTIONS_GHC -fffi #-} +{-# CFILES gwinsz.c #-} +module Graphics.Vty.Cursor + ( TermState, putch, move, initTerm, clrscr, getwinsize, beep, flush, + setCursorInvis, setCursorVis ) where + +import Foreign.C.Types (CLong) + +import System.IO( stdin, stdout, stderr, hGetChar, hPutStrLn, hFlush ) + +import Data.Maybe( mapMaybe ) +import Data.List( inits ) +import qualified Data.Map as M( fromList, lookup ) +import qualified Data.Set as S( fromList, member ) + +import Control.Monad( when ) + +import Data.Bits( (.&.), shiftR ) + +import Control.Concurrent +import System.Posix.Signals.Exts +import System.Posix.Signals +import System.Posix.Terminal + +import qualified UTF8 + +import Graphics.Vty.Types + +--import GHC.Conc (labelThread) +threadName :: String -> IO () +--threadName str = myThreadId >>= flip labelThread str +threadName _str = return () + +data KClass = Valid Key [Modifier] | Invalid | Prefix | MisPfx Key [Modifier] [Char] + +-- | An object representing the current state of the terminal. +data TermState = TS !Int !Int !Attr + +-- | Set up the terminal, and create an object representing the initial state. +-- Also returns a function which reads key events, and a function for shutting +-- down the terminal access. +initTerm :: IO (TermState, IO Event, IO ()) +initTerm = do threadName "main-csr" + kchan <- newEmptyMVar + kmv <- newEmptyMVar + oattr <- getTerminalAttributes 0 + let nattr = foldl withoutMode oattr [StartStopOutput, KeyboardInterrupts, + EnableEcho, ProcessInput] + setTerminalAttributes 0 nattr Immediately + iothr <- forkIO $ iothread kmv kchan + let pokeIO = (Catch $ do threadName "winch|cont" + (x,y) <- getwinsize_ + tryPutMVar kmv '\xFFFD' + setTerminalAttributes 0 nattr Immediately + putMVar kchan (EvResize x y)) + installHandler windowChange pokeIO Nothing + installHandler continueProcess pokeIO Nothing + putStr reset + let uninit = do (sx,sy) <- getwinsize_ + killThread iothr + installHandler windowChange Ignore Nothing + installHandler continueProcess Ignore Nothing + setTerminalAttributes 0 oattr Immediately + putStr (endterm sx sy) + hFlush stdout + return (TS 0 0 attr, takeMVar kchan, uninit) + +iothread :: MVar Char -> MVar Event -> IO () +iothread kmv chn = threadName "kbd" >> loop [] where + loop kb = case (classify kb) of + Prefix -> do ch <- getInput (kb == "") + loop (kb ++ [ch]) + Invalid -> loop "" + MisPfx k m s -> putMVar chn (EvKey k m) >> loop s + Valid k m -> putMVar chn (EvKey k m) >> loop "" + getInput wf = do t1 <- forkIO $ threadName "getc" >> hGetChar stdin >>= putMVar kmv + t2 <- forkIO $ threadName "sleep" >> if wf then return () else + threadDelay 50000 >> putMVar kmv '\xFFFE' + ch <- takeMVar kmv + mapM_ killThread [t1,t2] + return ch + +-- | Force sent commands to be respected. +flush :: TermState -> IO TermState +flush ts = hFlush stdout >> return ts + +-- | Move the cursor to (x,y); sx is the current width of the screen. +-- (this is a bit of a hack, forcing clients to cache that data) +move :: Int -> Int -> Int -> TermState -> IO TermState +move sx x y (TS ox oy at) = do putStr $ movcsr y oy x ox sx + return (TS x y at) + +-- | Put a (char,attr) at the current cursor position. +putch :: (Char,Attr) -> TermState -> IO TermState +putch (ch,att) (TS ox oy oat) = do when (att /= oat) $ putStr (chgatt att) + tputchar ch + return (TS (ox+1) oy att) + +-- | Reset the screen. +clrscr :: TermState -> IO TermState +clrscr _ts = do putStr reset + return (TS 0 0 attr) + +-- | Make the cursor invisible. +setCursorInvis :: TermState -> IO TermState +setCursorInvis ts = putStr civis >> return ts + +-- | Make the cursor visible. +setCursorVis :: TermState -> IO TermState +setCursorVis ts = putStr cvis >> return ts +-- ANSI specific bits +chgatt :: Attr -> [Char] +chgatt (Attr bf) + = "\ESC[0" ++ ";3" ++ show (bf .&. 0xFF) ++ ";4" ++ show ((bf `shiftR` 8) .&. 0xFF) ++ 0x10000 ? 1 ++ + 0x20000 ? 5 ++ 0x40000 ? 7 ++ 0x80000 ? 2 ++ 0x100000 ? 4 ++ "m" + where + (?) :: Int -> Int -> [Char] + field ? x | bf .&. field == 0 = "" + | otherwise = ';' : show x + +tputchar :: Char -> IO () +tputchar ch = do when ((ch < ' ') || (ch == '\DEL')) $ + hPutStrLn stderr "YIKES: tried to put nongraphic" + mapM_ (putChar . toEnum . fromIntegral) $ UTF8.encodeOne ch +-- we always use absolute motion between lines to work around diffs +movcsr :: Int -> Int -> Int -> Int -> Int -> [Char] +movcsr y oy x ox wid + | y /= oy || ox == wid = ("\ESC[" ++ (show (y+1)) ++ ';' : (show (x+1)) ++ "H") + | x == ox = "" + | x == (ox + 1) = ("\ESC[C") + | x > ox = ("\ESC[" ++ (show (x - ox)) ++ "C") + | otherwise = ("\ESC[" ++ (show (ox - x)) ++ "D") + +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' "\xFFFD" = Invalid ; cl' "\xFFFE" = Invalid + 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) +classify :: [Char] -> KClass +classify = compile $ + [ let k c s = ("\ESC["++c,(s,[])) in + [ k "A" KUp, k "B" KDown, k "C" KRight, k "D" KLeft, k "G" KNP5, k "P" KPause ], + let k n s = ("\ESC["++show n++"~",(s,[])) in zipWith k [1::Int ..6] [KHome,KIns,KDel,KEnd,KPageUp,KPageDown], + [ (x:[],(KASCII x,[])) | x <- map toEnum [0..255] ], + [ ("\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'] ], + [ ([toEnum x],(KASCII y,[MCtrl])) | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_']) ], + [ ('\ESC':[toEnum x],(KASCII y,[MMeta,MCtrl])) | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_']) ], + [ ("\ESC",(KEsc,[])) , ("\ESC\ESC",(KEsc,[MMeta])) , ("\DEL",(KBS,[])), ("\ESC\DEL",(KBS,[MMeta])), + ("\ESC\^J",(KEnter,[MMeta])), ("\^J",(KEnter,[])) ] ] + +foreign import ccall "gwinsz.h c_get_window_size" c_get_window_size :: IO CLong +getwinsize_ :: IO (Int,Int) +getwinsize_ = do (a,b) <- (`divMod` 65536) `fmap` c_get_window_size + return (fromIntegral b, fromIntegral a) +getwinsize :: TermState -> IO ((Int,Int), TermState) +getwinsize ts = do (a,b) <- (`divMod` 65536) `fmap` c_get_window_size + return ((fromIntegral b, fromIntegral a), ts) + +cvis, civis, reset :: [Char] + +reset = "\ESCc\ESC%G\ESC[1;1H\ESC[2J" +-- | Make the terminal beep. +beep :: IO () +beep = putStr "\BEL" ; cvis = "\ESC[?25h" ; civis = "\ESC[?25l" +endterm :: Int -> Int -> [Char] +endterm sx sy = movcsr (sy-1) (-1) 0 (-1) sx ++ "\ESC[0;39;49m\ESC%@\CR\ESC[?25h\ESC[K" diff --git a/Graphics/Vty/Types.hs b/Graphics/Vty/Types.hs new file mode 100644 --- /dev/null +++ b/Graphics/Vty/Types.hs @@ -0,0 +1,167 @@ +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. + +-- 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) .|. c) + +-- | Set the background color of an `Attr'. +setBG :: Color -> Attr -> Attr +setBG (Color c) (Attr a) = Attr ((a .&. 0xFFFF00FF) .|. (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 + +-- | 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) y1 +_ <|> _ = 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))) + x1 (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 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 (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" } + +-- |Representations of non-modifier keys. +data Key = KEsc | KFun Int | 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) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright Stefan O'Rear 2006 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Stefan O'Rear nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,56 @@ +vty is a very simple terminal interface library. + +Vty currently provides: + +* Automatic handling of suspend/resume (SIGTSTP+SIGCONT). + +* Automatic handling of window resizes. + +* Supports Unicode characters on output, automatically setting and + resetting UTF-8 mode (beware double width and combining characters!) + +* Automatic computation of minimal differences. + +* Minimizes repaint area, thus virtually eliminating the flicker + problem that plagues ncurses programs. + +* A pure, compositional interface for efficiently constructing display + images. + +* Automatically decodes keyboard keys into (key,[modifier]) tuples. + +* Automatically supports refresh on Ctrl-L. + +* Automatically supports timeout after 50ms for lone ESC (a barely + noticable delay) + +* Interface is designed for relatively easy compatible extension. + +* Supports all ANSI SGR-modes (defined in console_codes(4)) with + a simple type-safe interface. + +* Properly handles cleanup, leaving the cursor at the bottom of + the screen and erasing the last line. + +Current disadvantages: + +* No current support for non-ANSI terminals. + +* UTF-8 support only works properly on the linux console/xterm, + and even then only if it is not the system default. + +* Minimal support for special keys on terminals other than the + linux-console. (F1-5 and arrow keys should work, but anything + shifted isn't likely to.) + +* Uses the TIOCGWINSZ ioctl to find the current window size, which + appears to be limited to Linux and *BSD. + +darcs get --tag=rel-3.0.0 http://members.cox.net/stefanor/vty + +http://members.cox.net/stefanor/vty/dist/vty-3.0.0.tar.gz + +To compile the demonstration program: ghc --make Test.hs gwinsz.c + +The main documentation consists of the haddock-comments and the +demonstration program diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -0,0 +1,4 @@ +Minor: +- xterm keyboard support +- Termcap/terminfo parser +- 256 color support (xterm) diff --git a/Test.hs b/Test.hs new file mode 100644 --- /dev/null +++ b/Test.hs @@ -0,0 +1,28 @@ +import Graphics.Vty +import System.IO + +import qualified Data.ByteString.Char8 as B + +main = do vt <- mkVty + (sx,sy) <- getSize vt + play vt 0 0 sx sy "" + +pieceA = setFG red attr +dumpA = setRV attr + +play vt x y sx sy btl = do update vt (render x y sx sy btl) + k <- getEvent vt + case k of 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 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)) + + +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 ' ')) } diff --git a/UTF8.lhs b/UTF8.lhs new file mode 100644 --- /dev/null +++ b/UTF8.lhs @@ -0,0 +1,343 @@ +Copyright (c) 2002, members of the Haskell Internationalisation Working +Group All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +* Neither the name of the Haskell Internationalisation Working Group nor + the names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +This module provides lazy stream encoding/decoding facilities for UTF-8, +the Unicode Transformation Format with 8-bit words. + +2002-09-02 Sven Moritz Hallberg + + +> module UTF8 +> ( encode, decode, +> encodeOne, decodeOne, +> ) where + +> import Data.Char (ord, chr) +> import Data.Word (Word8, Word16, Word32) +> import Data.Bits (Bits, shiftL, shiftR, (.&.), (.|.)) + + + +///- UTF-8 in General -/// + +Adapted from the Unicode standard, version 3.2, +Table 3.1 "UTF-8 Bit Distribution" (excluded are UTF-16 encodings): + + Scalar 1st Byte 2nd Byte 3rd Byte 4th Byte + 000000000xxxxxxx 0xxxxxxx + 00000yyyyyxxxxxx 110yyyyy 10xxxxxx + zzzzyyyyyyxxxxxx 1110zzzz 10yyyyyy 10xxxxxx + 000uuuzzzzzzyyyyyyxxxxxx 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx + +Also from the Unicode standard, version 3.2, +Table 3.1B "Legal UTF-8 Byte Sequences": + + Code Points 1st Byte 2nd Byte 3rd Byte 4th Byte + U+0000..U+007F 00..7F + U+0080..U+07FF C2..DF 80..BF + U+0800..U+0FFF E0 A0..BF 80..BF + U+1000..U+CFFF E1..EC 80..BF 80..BF + U+D000..U+D7FF ED 80..9F 80..BF + U+D800..U+DFFF ill-formed + U+E000..U+FFFF EE..EF 80..BF 80..BF + U+10000..U+3FFFF F0 90..BF 80..BF 80..BF + U+40000..U+FFFFF F1..F3 80..BF 80..BF 80..BF + U+100000..U+10FFFF F4 80..8F 80..BF 80..BF + + + +///- Encoding Functions -/// + +Must the encoder ensure that no illegal byte sequences are output or +can we trust the Haskell system to supply only legal values? +For now I include error case for the surrogate values U+D800..U+DFFF and +out-of-range scalars. + +The function is pretty much a transscript of table 3.1B with error checks. +It dispatches the actual encoding to functions specific to the number of +required bytes. + +> encodeOne :: Char -> [Word8] +> encodeOne c +>-- The report guarantees in (6.1.2) that this won't happen: +>-- | n < 0 = error "encodeUTF8: ord returned a negative value" +> | n < 0x0080 = encodeOne_onebyte n8 +> | n < 0x0800 = encodeOne_twobyte n16 +> | n < 0xD800 = encodeOne_threebyte n16 +> | n < 0xE000 = error "encodeUTF8: ord returned a surrogate value" +> | n < 0x10000 = encodeOne_threebyte n16 +>-- Haskell 98 only talks about 16 bit characters, but ghc handles 20.1. +> | n < 0x10FFFF = encodeOne_fourbyte n32 +> | otherwise = error "encodeUTF8: ord returned a value above 0x10FFFF" +> where +> n = ord c :: Int +> n8 = fromIntegral n :: Word8 +> n16 = fromIntegral n :: Word16 +> n32 = fromIntegral n :: Word32 + + +With the above, a stream decoder is trivial: + +> encode :: [Char] -> [Word8] +> encode = concatMap encodeOne + + +Now follow the individual encoders for certain numbers of bytes... + _ + / | __ ___ __ __ + / ^| // /__/ // // + /.==| \\ //_ // // +It's // || // \_/_//_//_ and it's here to stay! + +> encodeOne_onebyte :: Word8 -> [Word8] +> encodeOne_onebyte cp = [cp] + + +00000yyyyyxxxxxx -> 110yyyyy 10xxxxxx + +> encodeOne_twobyte :: Word16 -> [Word8] +> encodeOne_twobyte cp = [(0xC0.|.ys), (0x80.|.xs)] +> where +> xs, ys :: Word8 +> ys = fromIntegral (shiftR cp 6) +> xs = (fromIntegral cp) .&. 0x3F + + +zzzzyyyyyyxxxxxx -> 1110zzzz 10yyyyyy 10xxxxxx + +> encodeOne_threebyte :: Word16 -> [Word8] +> encodeOne_threebyte cp = [(0xE0.|.zs), (0x80.|.ys), (0x80.|.xs)] +> where +> xs, ys, zs :: Word8 +> xs = (fromIntegral cp) .&. 0x3F +> ys = (fromIntegral (shiftR cp 6)) .&. 0x3F +> zs = fromIntegral (shiftR cp 12) + + +000uuuzzzzzzyyyyyyxxxxxx -> 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx + +> encodeOne_fourbyte :: Word32 -> [Word8] +> encodeOne_fourbyte cp = [0xF0.|.us, 0x80.|.zs, 0x80.|.ys, 0x80.|.xs] +> where +> xs, ys, zs, us :: Word8 +> xs = (fromIntegral cp) .&. 0x3F +> ys = (fromIntegral (shiftR cp 6)) .&. 0x3F +> zs = (fromIntegral (shiftR cp 12)) .&. 0x3F +> us = fromIntegral (shiftR cp 18) + + + +///- Decoding -/// + +The decoding is a bit more involved. The byte sequence could contain all +sorts of corruptions. The user must be able to either notice or ignore these +errors. + +I will first look at the decoding of a single character. The process +consumes a certain number of bytes from the input. It returns the +remaining input and either an error and the index of its occurance in the +byte sequence or the decoded character. + +> data Error + +The first byte in a sequence starts with either zero, two, three, or four +ones and one zero to indicate the length of the sequence. If it doesn't, +it is invalid. It is dropped and the next byte interpreted as the start +of a new sequence. + +> = InvalidFirstByte + +All bytes in the sequence except the first match the bit pattern 10xxxxxx. +If one doesn't, it is invalid. The sequence up to that point is dropped +and the "invalid" byte interpreted as the start of a new sequence. The error +includes the length of the partial sequence and the number of expected bytes. + +> | InvalidLaterByte Int -- the byte at relative index n was invalid + +If a sequence ends prematurely, it has been truncated. It dropped and +decoding stops. The error reports the actual and expected lengths of the +sequence. + +> | Truncated Int Int -- only n of m expected bytes were present + +Some sequences would represent code points which would be encoded as a +shorter sequence by a conformant encoder. Such non-shortest sequences are +considered erroneous and dropped. The error reports the actual and +expected number of bytes used. + +> | NonShortest Int Int -- n instead of m bytes were used + +Unicode code points are in the range of [0..0x10FFFF]. Any values outside +of those bounds are simply invalid. + +> | ValueOutOfBounds + +There is no such thing as "surrogate pairs" any more in UTF-8. The +corresponding code points now form illegal byte sequences. + +> | Surrogate +> deriving (Show, Eq) + + +Second, third, and fourth bytes share the common requirement to start +with the bit sequence 10. So, here's the function to check that property. + +> first_bits_not_10 :: Word8 -> Bool +> first_bits_not_10 b +> | (b.&.0xC0) /= 0x80 = True +> | otherwise = False + + +Erm, OK, the single-character decoding function's return type is a bit +longish. It is a tripel: + + - The first component contains the decoded character or an error + if the byte sequence was erroneous. + - The second component contains the number of bytes that were consumed + from the input. + - The third component contains the remaining bytes of input. + +> decodeOne :: [Word8] -> (Either Error Char, Int, [Word8]) +> decodeOne bs@(b1:rest) +> | b1 < 0x80 = decodeOne_onebyte bs +> | b1 < 0xC0 = (Left InvalidFirstByte, 1, rest) +> | b1 < 0xE0 = decodeOne_twobyte bs +> | b1 < 0xEE = decodeOne_threebyte bs +> | b1 < 0xF5 = decodeOne_fourbyte bs +> | otherwise = (Left ValueOutOfBounds, 1, rest) +> decodeOne [] = error "UTF8.decodeOne: No input" + + +0xxxxxxx -> 000000000xxxxxxx + +> decodeOne_onebyte :: [Word8] -> (Either Error Char, Int, [Word8]) +> decodeOne_onebyte (b:bs) = (Right (cpToChar b), 1, bs) +> decodeOne_onebyte[] = error "UTF8.decodeOne_onebyte: No input (can't happen)" + +> cpToChar :: Integral a => a -> Char +> cpToChar = chr . fromIntegral + + +110yyyyy 10xxxxxx -> 00000yyyyyxxxxxx + +> decodeOne_twobyte :: [Word8] -> (Either Error Char, Int, [Word8]) +> decodeOne_twobyte (_:[]) +> = (Left (Truncated 1 2), 1, []) +> decodeOne_twobyte (b1:b2:bs) +> | b1 < 0xC2 = (Left (NonShortest 2 1), 2, bs) +> | first_bits_not_10 b2 = (Left (InvalidLaterByte 1), 1, (b2:bs)) +> | otherwise = (Right (cpToChar result), 2, bs) +> where +> xs, ys, result :: Word32 +> xs = fromIntegral (b2.&.0x3F) +> ys = fromIntegral (b1.&.0x1F) +> result = shiftL ys 6 .|. xs +> decodeOne_twobyte[] = error "UTF8.decodeOne_twobyte: No input (can't happen)" + + +1110zzzz 10yyyyyy 10xxxxxx -> zzzzyyyyyyxxxxxx + +> decodeOne_threebyte :: [Word8] -> (Either Error Char, Int, [Word8]) +> decodeOne_threebyte (_:[]) = threebyte_truncated 1 +> decodeOne_threebyte (_:_:[]) = threebyte_truncated 2 +> decodeOne_threebyte bs@(b1:b2:b3:rest) +> | first_bits_not_10 b2 +> = (Left (InvalidLaterByte 1), 1, drop 1 bs) +> | first_bits_not_10 b3 +> = (Left (InvalidLaterByte 2), 2, drop 2 bs) +> | result < 0x0080 +> = (Left (NonShortest 3 1), 3, rest) +> | result < 0x0800 +> = (Left (NonShortest 3 2), 3, rest) +> | result >= 0xD800 && result < 0xE000 +> = (Left Surrogate, 3, rest) +> | otherwise +> = (Right (cpToChar result), 3, rest) +> where +> xs, ys, zs, result :: Word32 +> xs = fromIntegral (b3.&.0x3F) +> ys = fromIntegral (b2.&.0x3F) +> zs = fromIntegral (b1.&.0x0F) +> result = shiftL zs 12 .|. shiftL ys 6 .|. xs +> decodeOne_threebyte[] +> = error "UTF8.decodeOne_threebyte: No input (can't happen)" + +> threebyte_truncated :: Int -> (Either Error Char, Int, [Word8]) +> threebyte_truncated n = (Left (Truncated n 3), n, []) + + +11110uuu 10zzzzzz 10yyyyyy 10xxxxxx -> 000uuuzzzzzzyyyyyyxxxxxx + +> decodeOne_fourbyte :: [Word8] -> (Either Error Char, Int, [Word8]) +> decodeOne_fourbyte (_:[]) = fourbyte_truncated 1 +> decodeOne_fourbyte (_:_:[]) = fourbyte_truncated 2 +> decodeOne_fourbyte (_:_:_:[]) = fourbyte_truncated 3 +> decodeOne_fourbyte bs@(b1:b2:b3:b4:rest) +> | first_bits_not_10 b2 +> = (Left (InvalidLaterByte 1), 1, drop 1 bs) +> | first_bits_not_10 b3 +> = (Left (InvalidLaterByte 2), 2, drop 2 bs) +> | first_bits_not_10 b4 +> = (Left (InvalidLaterByte 3), 3, drop 3 bs) +> | result < 0x0080 +> = (Left (NonShortest 4 1), 4, rest) +> | result < 0x0800 +> = (Left (NonShortest 4 2), 4, rest) +> | result < 0x10000 +> = (Left (NonShortest 4 3), 4, rest) +> | result > 0x10FFFF +> = (Left ValueOutOfBounds, 4, rest) +> | otherwise +> = (Right (cpToChar result), 4, rest) +> where +> xs, ys, zs, us, result :: Word32 +> xs = fromIntegral (b4 .&. 0x3F) +> ys = fromIntegral (b3 .&. 0x3F) +> zs = fromIntegral (b2 .&. 0x3F) +> us = fromIntegral (b1 .&. 0x07) +> result = xs .|. shiftL ys 6 .|. shiftL zs 12 .|. shiftL us 18 +> decodeOne_fourbyte[] +> = error "UTF8.decodeOne_fourbyte: No input (can't happen)" + +> fourbyte_truncated :: Int -> (Either Error Char, Int, [Word8]) +> fourbyte_truncated n = (Left (Truncated n 4), n, []) + + +The decoder examines all input, recording decoded characters as well as +error-index pairs along the way. + +> decode :: [Word8] -> ([Char], [(Error,Int)]) +> decode bytes = iter 0 [] [] bytes +> where +> iter :: Int -> [Char] -> [(Error,Int)] -> [Word8] +> -> ([Char], [(Error,Int)]) +> iter _ cs es [] = (reverse cs, reverse es) +> iter idx cs es bs +> = case decodeOne bs of +> (Left e, n, rest) -> iter (idx+n) cs ((e,idx):es) rest +> (Right c, n, rest) -> iter (idx+n) (c:cs) es rest + diff --git a/cbits/gwinsz.c b/cbits/gwinsz.c new file mode 100644 --- /dev/null +++ b/cbits/gwinsz.c @@ -0,0 +1,9 @@ +#include + +unsigned long c_get_window_size(void) { + struct winsize w; + if (ioctl (0, TIOCGWINSZ, &w) >= 0) + return (w.ws_row << 16) + w.ws_col; + else + return 0x190050; +} diff --git a/cbits/gwinsz.h b/cbits/gwinsz.h new file mode 100644 --- /dev/null +++ b/cbits/gwinsz.h @@ -0,0 +1,1 @@ +unsigned long c_get_window_size(void); diff --git a/vty.cabal b/vty.cabal new file mode 100644 --- /dev/null +++ b/vty.cabal @@ -0,0 +1,29 @@ +Name: vty +Version: 3.0.0 +Synopsis: A simple terminal access library +Category: User Interfaces +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. + . + If you want to use it, currently the best reference is the test module (Test.hs). + . + Notable infelicities: requires an ANSI-type terminal, poor efficiency, + requires Linux\/xterm style UTF8 support. + . + © 2006-2007 Stefan O'Rear; BSD3 license. +License: BSD3 +License-file: LICENSE +Author: Stefan O'Rear +Maintainer: stefanor@cox.net +Build-Depends: base, unix +Homepage: http://members.cox.net/stefanor/vty/dist/doc/html/ +ghc-options: -O2 -funbox-strict-fields -Wall -Werror +ghc-prof-options: -O2 -funbox-strict-fields -auto-all -Wall -Werror +Exposed-Modules: Graphics.Vty +C-Sources: cbits/gwinsz.c +Include-Dirs: cbits +Install-Includes: gwinsz.h +Other-Modules: UTF8, Graphics.Vty.Types, Graphics.Vty.Cursor +Extra-Source-Files: README, TODO, Test.hs, cbits/gwinsz.h