vty (empty) → 3.0.0
raw patch · 14 files changed
+984/−0 lines, 14 filesdep +basedep +unixbuild-type:Customsetup-changed
Dependencies added: base, unix
Files
- .installed-pkg-config +38/−0
- .setup-config +1/−0
- Graphics/Vty.hs +98/−0
- Graphics/Vty/Cursor.hs +176/−0
- Graphics/Vty/Types.hs +167/−0
- LICENSE +31/−0
- README +56/−0
- Setup.lhs +3/−0
- TODO +4/−0
- Test.hs +28/−0
- UTF8.lhs +343/−0
- cbits/gwinsz.c +9/−0
- cbits/gwinsz.h +1/−0
- vty.cabal +29/−0
+ .installed-pkg-config view
@@ -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
+ .setup-config view
@@ -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}
+ Graphics/Vty.hs view
@@ -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'
+ Graphics/Vty/Cursor.hs view
@@ -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"
+ Graphics/Vty/Types.hs view
@@ -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)
+ LICENSE view
@@ -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.+
+ README view
@@ -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
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ TODO view
@@ -0,0 +1,4 @@+Minor:+- xterm keyboard support+- Termcap/terminfo parser+- 256 color support (xterm)
+ Test.hs view
@@ -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 ' ')) }
+ UTF8.lhs view
@@ -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 <pesco@gmx.de>+++> 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+
+ cbits/gwinsz.c view
@@ -0,0 +1,9 @@+#include <sys/ioctl.h>++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;+}
+ cbits/gwinsz.h view
@@ -0,0 +1,1 @@+unsigned long c_get_window_size(void);
+ vty.cabal view
@@ -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