vty 3.0.0 → 3.0.1
raw patch · 12 files changed
+314/−610 lines, 12 filesdep +bytestringdep +containersdep ~basenew-uploader
Dependencies added: bytestring, containers
Dependency ranges changed: base
Files
- .installed-pkg-config +0/−38
- .setup-config +0/−1
- Graphics/Vty.hs +24/−54
- Graphics/Vty/Cursor.hs +76/−117
- Graphics/Vty/LLInput.hs +104/−0
- Graphics/Vty/Types.hs +13/−16
- TODO +3/−0
- Test.hs +0/−28
- UTF8.lhs +0/−343
- test/Bench.hs +47/−0
- test/Test.hs +28/−0
- vty.cabal +19/−13
− .installed-pkg-config
@@ -1,38 +0,0 @@-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
@@ -1,1 +0,0 @@-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
@@ -1,16 +1,14 @@ {-# OPTIONS_GHC -fffi #-} {-# CFILES gwinsz.c #-}-module Graphics.Vty (Vty(..), beep, mkVty, module Graphics.Vty.Types) where+module Graphics.Vty (Vty(..), beep, mkVty, module Graphics.Vty.Types, Key(..), Modifier(..), Button(..), Event(..)) 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 Graphics.Vty.LLInput import Foreign.Marshal.Array import Foreign.Marshal.Alloc@@ -32,67 +30,39 @@ -- |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+mkVty = do (tstate, endo) <- initTermOutput+ (kvar, endi) <- initTermInput+ state <- newMVar =<< fmap ((,,,) tstate (-1) (-1)) (mallocArray 2)+ intMkVty kvar (endi >> endo) state - ulift_ :: (TermState -> IO TermState) -> IO ()- ulift_ f = modifyMVar_ rtstate f+intMkVty :: IO Event -> IO () -> MVar (TermState, Int, Int, Ptr Int) -> IO Vty+intMkVty kvar fend rstate = return rec where ulift :: (TermState -> IO (a, TermState)) -> IO a- ulift f = modifyMVar rtstate (\v -> fmap (\(x,y) -> (y,x)) (f v))+ ulift f = modifyMVar rstate (\(v,a,b,c) -> fmap (\(x,y) -> ((y,a,b,c),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+ 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- 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'')+ 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- writeIORef rlast l+ return (ts4, w, h, fb) - refresh = do ofb@(Pic _ (T.Image _ w h)) <- readIORef rlast ; clrscr' w h; update' ofb+ 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 (EvKey (KASCII 'l') [MCtrl]) -> refresh >> gkey- (EvResize _ _) -> refresh >> return k+ case k of (EvKey (KASCII 'l') [MCtrl]) -> inval+ (EvResize _ _) -> inval _ -> 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
@@ -1,84 +1,32 @@-{-# OPTIONS_GHC -fffi #-}+{-# OPTIONS_GHC -fffi -Wall #-} {-# CFILES gwinsz.c #-} module Graphics.Vty.Cursor- ( TermState, putch, move, initTerm, clrscr, getwinsize, beep, flush,+ ( TermState, diffs, move, initTermOutput, 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 Foreign.C.Types( CLong )+import Foreign.Ptr( Ptr )+import System.IO( stdout, hFlush )+import Foreign.Storable( peekElemOff, peek )+import Foreign.Marshal.Array( advancePtr ) import Control.Monad( when ) -import Data.Bits( (.&.), shiftR )--import Control.Concurrent-import System.Posix.Signals.Exts-import System.Posix.Signals-import System.Posix.Terminal--import qualified UTF8+import Data.Bits( (.|.), (.&.), shiftR ) 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+-- | Set up the terminal for output, and create an object representing the+-- initial state. Also returns a function for shutting down the terminal access.+initTermOutput :: IO (TermState, IO ())+initTermOutput = do putStr reset+ let uninit = do (_,sy) <- getwinsize_+ putStr (endterm sy)+ hFlush stdout+ return (TS 0 0 attr, uninit) -- | Force sent commands to be respected. flush :: TermState -> IO TermState@@ -87,14 +35,18 @@ -- | 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+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 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)+-- | Put a (char,attr) at a given (x,y) cursor position; sx is the+-- current width of the screen. (this is a bit of a hack, forcing+-- clients to cache that data)+mvputch :: Int -> Int -> Int -> (Char,Attr) -> TermState -> IO TermState+mvputch sx x y (ch,att) ts | sx `seq` x `seq` y `seq` ch `seq` att `seq` ts `seq` False = undefined+mvputch sx x y (ch,att) (TS ox oy oat) = do movcsr y oy x ox sx+ when (att /= oat) $ chgatt att+ tputchar ch+ return (TS (x+1) y att) -- | Reset the screen. clrscr :: TermState -> IO TermState@@ -108,55 +60,62 @@ -- | Make the cursor visible. setCursorVis :: TermState -> IO TermState setCursorVis ts = putStr cvis >> return ts++diffs :: Int -> Int -> Ptr Int -> Ptr Int -> TermState -> IO TermState+diffs w h old new state | w `seq` h `seq` old `seq` new `seq` state `seq` False = undefined+diffs w h old new state = diffs' 0 0 old new state+ where+ diffs' :: Int -> Int -> Ptr Int -> Ptr Int -> TermState -> IO TermState+ diffs' x y olp nwp stat+ | x `seq` y `seq` olp `seq` nwp `seq` stat `seq` False = undefined+ | y == h = return stat+ | x == w = diffs' 0 (y+1) olp nwp stat+ | otherwise = do ola <- peek olp+ nwa <- peek nwp+ olc <- peekElemOff olp 1+ nwc <- peekElemOff nwp 1+ stat' <- case (ola /= nwa || olc /= nwc) of+ False -> return stat+ True -> mvputch w x y (toEnum nwc, Attr nwa) stat+ diffs' (x+1) y (olp `advancePtr` 2) (nwp `advancePtr` 2) stat'+ -- ANSI specific bits-chgatt :: Attr -> [Char]+chgatt :: Attr -> IO () 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"+ = putStr "\ESC[0;3" >> putShow (bf .&. 0xFF) >> putStr ";4" >> putShow ((bf `shiftR` 8) .&. 0xFF) >> 0x10000 ? ";1" >>+ 0x20000 ? ";5" >> 0x40000 ? ";7" >> 0x80000 ? ";2" >> 0x100000 ? ";4" >> putStr "m" where- (?) :: Int -> Int -> [Char]- field ? x | bf .&. field == 0 = ""- | otherwise = ';' : show x+ {-# INLINE (?) #-}+ (?) :: Int -> [Char] -> IO ()+ field ? x | bf .&. field == 0 = return ()+ | otherwise = putStr 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+tputchar ch | ich < 0x80 = pch ich+ | ich < 0x800 = pch (0xC0 .|. (ich `usr` 6)) >> pch (0x80 .|. (0x3F .&. ich))+ | ich < 0x10000 = pch (0xE0 .|. (ich `usr` 12)) >> pch (0x80 .|. (0x3F .&. (ich `usr` 6))) >>+ pch (0x80 .|. (0x3F .&. ich))+ | otherwise = pch (0xF0 .|. (ich `usr` 24)) >> pch (0x80 .|. (0x3F .&. (ich `usr` 12))) >>+ pch (0x80 .|. (0x3F .&. (ich `usr` 6))) >> pch (0x80 .|. (0x3F .&. ich))+ where ich = fromEnum ch+ pch = putChar . toEnum+ usr = shiftR++ -- we always use absolute motion between lines to work around diffs-movcsr :: Int -> Int -> Int -> Int -> Int -> [Char]+movcsr :: Int -> Int -> Int -> Int -> Int -> IO () 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")+ | 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 #-} -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,[])) ] ]+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)@@ -172,5 +131,5 @@ -- | 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"+endterm :: Int -> [Char]+endterm sy = "\ESC[" ++ show sy ++ ";1H\ESC[0;39;49m\ESC%@\CR\ESC[?25h\ESC[K"
+ Graphics/Vty/LLInput.hs view
@@ -0,0 +1,104 @@+{-# OPTIONS_GHC -Wall #-}+module Graphics.Vty.LLInput+ ( Key(..), Modifier(..), Button(..), Event(..), initTermInput ) where++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.Concurrent+import System.Posix.Signals.Exts+import System.Posix.Signals+import System.Posix.Terminal++-- |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)++--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]++-- | Set up the terminal for input. Returns a function which reads key+-- events, and a function for shutting down the terminal access.+initTermInput :: IO (IO Event, IO ())+initTermInput = do+ threadName "main"+ 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"+ tryPutMVar kmv '\xFFFD'+ let e = error "(getsize in input layer)"+ setTerminalAttributes 0 nattr Immediately+ putMVar kchan (EvResize e e))+ installHandler windowChange pokeIO Nothing+ installHandler continueProcess pokeIO Nothing+ let uninit = do killThread iothr+ installHandler windowChange Ignore Nothing+ installHandler continueProcess Ignore Nothing+ setTerminalAttributes 0 oattr Immediately+ return (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" >> getChar >>= 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++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)++-- ANSI specific bits++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,[])) ] ]
Graphics/Vty/Types.hs view
@@ -67,6 +67,14 @@ -- |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@@ -77,7 +85,7 @@ 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+ (x1+x2) (max y1 y2) _ <|> _ = error "Graphics.Vty.(<|>) : image heights do not match" -- | Compose two images vertically. The images must of the same width,@@ -86,7 +94,7 @@ 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)+ (max x1 x2) (y1+y2) _ <-> _ = error "Graphics.Vty.(<->) : image widths do not match" -- | Helper - fill a buffer segment with a char\/attr.@@ -123,10 +131,13 @@ -- | 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 ()@@ -151,17 +162,3 @@ -- '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)
TODO view
@@ -2,3 +2,6 @@ - xterm keyboard support - Termcap/terminfo parser - 256 color support (xterm)++Major:+- Remove size fields in resize constr
− Test.hs
@@ -1,28 +0,0 @@-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
@@ -1,343 +0,0 @@-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-
+ test/Bench.hs view
@@ -0,0 +1,47 @@+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 args <- getArgs+ case args of+ [] -> mkVty >>= liftM2 (>>) (run False) shutdown+ ["--slow"] -> mkVty >>= liftM2 (>>) (run True ) shutdown+ _ -> fail "usage: ./Bench [--slow]"++run True vt = mapM_ (update vt) . uncurry benchgen =<< getSize vt+run False vt = mapM_ (update vt) (benchgen 200 100)++-- Currently, we just do scrolling.+takem :: (a -> Int) -> Int -> [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 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++nums :: StdGen -> [(Attr, B.ByteString)]+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++pad :: Int -> Image -> Image+pad ml img = img <|> renderHFill attr ' ' (ml - imgWidth img)++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++benchgen :: Int -> Int -> [Picture]+benchgen w h = take 1000 $ map ((\i -> pic{ pImage = i}) . vertcat . take h) $ tails $ clines (mkStdGen 42) w
+ test/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 ' ')) }
vty.cabal view
@@ -1,7 +1,11 @@ Name: vty-Version: 3.0.0-Synopsis: A simple terminal access library+Version: 3.0.1+License: BSD3+License-file: LICENSE+Author: Stefan O'Rear+Maintainer: Stefan O'Rear <stefanor@cox.net> 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@@ -12,18 +16,20 @@ Notable infelicities: requires an ANSI-type terminal, poor efficiency, requires Linux\/xterm style UTF8 support. .+ You can 'darcs get' it from <http://members.cox.net/stefanor/vty> © 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++Build-Depends: base>3, bytestring, containers, unix+Build-Type: Simple+Data-Files: README, TODO+Extra-Source-Files: test/Test.hs, cbits/gwinsz.h, test/Bench.hs+ Exposed-Modules: Graphics.Vty-C-Sources: cbits/gwinsz.c+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+Other-Modules: Graphics.Vty.Types, Graphics.Vty.Cursor, Graphics.Vty.LLInput++ghc-options: -funbox-strict-fields -Wall+ghc-prof-options: -funbox-strict-fields -auto-all -Wall+