diff --git a/.installed-pkg-config b/.installed-pkg-config deleted file mode 100644 --- a/.installed-pkg-config +++ /dev/null @@ -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 diff --git a/.setup-config b/.setup-config deleted file mode 100644 --- a/.setup-config +++ /dev/null @@ -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} diff --git a/Graphics/Vty.hs b/Graphics/Vty.hs --- a/Graphics/Vty.hs +++ b/Graphics/Vty.hs @@ -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' diff --git a/Graphics/Vty/Cursor.hs b/Graphics/Vty/Cursor.hs --- a/Graphics/Vty/Cursor.hs +++ b/Graphics/Vty/Cursor.hs @@ -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" diff --git a/Graphics/Vty/LLInput.hs b/Graphics/Vty/LLInput.hs new file mode 100644 --- /dev/null +++ b/Graphics/Vty/LLInput.hs @@ -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,[])) ] ] diff --git a/Graphics/Vty/Types.hs b/Graphics/Vty/Types.hs --- a/Graphics/Vty/Types.hs +++ b/Graphics/Vty/Types.hs @@ -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) diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -2,3 +2,6 @@ - xterm keyboard support - Termcap/terminfo parser - 256 color support (xterm) + +Major: +- Remove size fields in resize constr diff --git a/Test.hs b/Test.hs deleted file mode 100644 --- a/Test.hs +++ /dev/null @@ -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 ' ')) } diff --git a/UTF8.lhs b/UTF8.lhs deleted file mode 100644 --- a/UTF8.lhs +++ /dev/null @@ -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 - - -> 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/test/Bench.hs b/test/Bench.hs new file mode 100644 --- /dev/null +++ b/test/Bench.hs @@ -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 diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/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/vty.cabal b/vty.cabal --- a/vty.cabal +++ b/vty.cabal @@ -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 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 © 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 +