{-# INCLUDE "utils.h" #-} {-# INCLUDE <signal.h> #-} {-# LINE 1 "UI/Nanocurses/Curses.hsc" #-} -- {-# LINE 2 "UI/Nanocurses/Curses.hsc" #-} -- Copyright (c) 2002-2004 John Meacham (john at repetae dot net) -- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons -- -- Permission is hereby granted, free of charge, to any person obtaining a -- copy of this software and associated documentation files (the -- "Software"), to deal in the Software without restriction, including -- without limitation the rights to use, copy, modify, merge, publish, -- distribute, sublicense, and/or sell copies of the Software, and to -- permit persons to whom the Software is furnished to do so, subject to -- the following conditions: -- -- The above copyright notice and this permission notice shall be included -- in all copies or substantial portions of the Software. -- -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY -- CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, -- TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE -- SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- -- -- | Binding to the [wn]curses library. From the ncurses man page: -- -- > The curses library routines give the user a terminal-inde- -- > pendent method of updating character screens with reason- -- > able optimization. -- -- Sections of the quoted documentation are from the OpenBSD man pages, -- which are distributed under a BSD license. -- -- A useful reference is: -- /Writing Programs with NCURSES/, by Eric S. Raymond and Zeyd -- M. Ben-Halim, <http://dickey.his.com/ncurses/> -- -- attrs dont work with Irix curses.h. This should be fixed. -- {-# LINE 43 "UI/Nanocurses/Curses.hsc" #-} module UI.Nanocurses.Curses ( initCurses, -- :: IO () -> IO () resetParams, -- :: IO () stdScr, -- :: Window endWin, -- :: IO () keypad, -- :: Window -> Bool -> IO () scrSize, -- :: IO (Int, Int) refresh, -- :: IO () getCh, -- :: IO Char -- * Line drawing waddnstr, -- :: Window -> CString -> CInt -> IO CInt bkgrndSet, -- :: Attr -> Pair -> IO () clrToEol, -- :: IO () wMove, -- :: Window -> Int -> Int -> IO () -- * Key codes keyBackspace, keyUp, keyDown, keyNPage, keyHome, keyPPage, keyEnd, keyLeft, keyRight, {-# LINE 67 "UI/Nanocurses/Curses.hsc" #-} keyResize, {-# LINE 69 "UI/Nanocurses/Curses.hsc" #-} -- * Cursor CursorVisibility(..), cursSet, -- :: CInt -> IO CInt getYX, -- :: Window -> IO (Int, Int) -- * Colours Pair(..), Color, initPair, -- :: Pair -> Color -> Color -> IO () color, -- :: String -> Maybe Color hasColors, -- :: IO Bool -- * Attributes Attr, attr0, setBold, setReverse, attrSet, attrPlus, -- :: Attr -> Attr -> Attr -- * error handling throwIfErr_, -- :: Num a => String -> IO a -> IO () ) where {-# LINE 93 "UI/Nanocurses/Curses.hsc" #-} {-# LINE 94 "UI/Nanocurses/Curses.hsc" #-} {-# LINE 95 "UI/Nanocurses/Curses.hsc" #-} import qualified Data.ByteString.Char8 as P import Prelude hiding (pi) import Data.Char (ord, chr) import Control.Monad (liftM, when) import Control.Concurrent (yield, threadWaitRead) import Foreign.C.Types (CInt, CShort) import Foreign.C.String (CString) import Foreign {-# LINE 109 "UI/Nanocurses/Curses.hsc" #-} import System.Posix.Signals (installHandler, Signal, Handler(Catch)) {-# LINE 111 "UI/Nanocurses/Curses.hsc" #-} -- -- If we have the SIGWINCH signal, we use that, with a custom handler, -- to determine when to resize the screen. Otherwise, we use a similar -- handler that looks for KEY_RESIZE in the input stream -- the result -- is a less responsive update, however. -- ------------------------------------------------------------------------ -- -- | Start it all up -- initCurses :: IO () -> IO () initCurses fn = do initScr b <- hasColors when b $ startColor >> useDefaultColors resetParams {-# LINE 130 "UI/Nanocurses/Curses.hsc" #-} -- does this still work? installHandler cursesSigWinch (Catch fn) Nothing >> return () {-# LINE 133 "UI/Nanocurses/Curses.hsc" #-} -- | A bunch of settings we need -- resetParams :: IO () resetParams = do cBreak True echo False -- don't echo to the screen nl True -- always translate enter to \n leaveOk True -- not ok to leave cursor wherever it is meta stdScr True -- ask for 8 bit chars, so we can get Meta keypad stdScr True -- enable the keypad, so things like ^L (refresh) work noDelay stdScr False -- blocking getCh, no #ERR return () -- not needed, if keypad is True: -- defineKey (#const KEY_UP) "\x1b[1;2A" -- defineKey (#const KEY_DOWN) "\x1b[1;2B" -- defineKey (#const KEY_SLEFT) "\x1b[1;2D" -- defineKey (#const KEY_SRIGHT) "\x1b[1;2C" ------------------------------------------------------------------------ fi :: (Integral a, Num b) => a -> b fi = fromIntegral {-# INLINE fi #-} ------------------------------------------------------------------------ -- -- Error handling, packed to save on all those strings -- -- | Like throwIf, but for packed error messages throwPackedIf :: (a -> Bool) -> P.ByteString -> (IO a) -> (IO a) throwPackedIf p msg action = do v <- action if p v then (fail . P.unpack $ msg) else return v {-# INLINE throwPackedIf #-} -- | Arbitrary test throwIfErr :: Num a => P.ByteString -> IO a -> IO a throwIfErr = throwPackedIf (== (-1)) {-# LINE 174 "UI/Nanocurses/Curses.hsc" #-} {-# INLINE throwIfErr #-} -- | Discard result throwIfErr_ :: Num a => P.ByteString -> IO a -> IO () throwIfErr_ a b = void $ throwIfErr a b {-# INLINE throwIfErr_ #-} -- | packed throwIfNull throwPackedIfNull :: P.ByteString -> IO (Ptr a) -> IO (Ptr a) throwPackedIfNull = throwPackedIf (== nullPtr) {-# INLINE throwPackedIfNull #-} ------------------------------------------------------------------------ type WindowTag = () type Window = Ptr WindowTag -- -- | The standard screen -- stdScr :: Window stdScr = unsafePerformIO (peek stdscr) foreign import ccall "static &stdscr" stdscr :: Ptr Window -- -- | initscr is normally the first curses routine to call when -- initializing a program. curs_initscr(3): -- -- > To initialize the routines, the routine initscr or newterm -- > must be called before any of the other routines that deal -- > with windows and screens are used. -- -- > The initscr code determines the terminal type and initial- -- > izes all curses data structures. initscr also causes the -- > first call to refresh to clear the screen. If errors -- > occur, initscr writes an appropriate error message to -- > standard error and exits; otherwise, a pointer is returned -- > to stdscr. -- initScr :: IO Window initScr = throwPackedIfNull (P.pack "initscr") c_initscr foreign import ccall unsafe "initscr" c_initscr :: IO Window -- -- |> The cbreak routine -- > disables line buffering and erase/kill character-process- -- > ing (interrupt and flow control characters are unaf- -- > fected), making characters typed by the user immediately -- > available to the program. The nocbreak routine returns -- > the terminal to normal (cooked) mode. -- cBreak :: Bool -> IO () cBreak True = throwIfErr_ (P.pack "cbreak") cbreak cBreak False = throwIfErr_ (P.pack "nocbreak") nocbreak foreign import ccall unsafe "cbreak" cbreak :: IO CInt foreign import ccall unsafe "nocbreak" nocbreak :: IO CInt -- -- |> The echo and noecho routines control whether characters -- > typed by the user are echoed by getch as they are typed. -- > Echoing by the tty driver is always disabled, but ini- -- > tially getch is in echo mode, so characters typed are -- > echoed. Authors of most interactive programs prefer to do -- > their own echoing in a controlled area of the screen, or -- > not to echo at all, so they disable echoing by calling -- > noecho. [See curs_getch(3) for a discussion of how these -- > routines interact with cbreak and nocbreak.] -- echo :: Bool -> IO () echo False = throwIfErr_ (P.pack "noecho") noecho echo True = throwIfErr_ (P.pack "echo") echo_c foreign import ccall unsafe "noecho" noecho :: IO CInt foreign import ccall unsafe "echo" echo_c :: IO CInt -- -- |> The nl and nonl routines control whether the underlying -- > display device translates the return key into newline on -- > input, and whether it translates newline into return and -- > line-feed on output (in either case, the call addch('\n') -- > does the equivalent of return and line feed on the virtual -- > screen). Initially, these translations do occur. If you -- > disable them using nonl, curses will be able to make bet- -- > ter use of the line-feed capability, resulting in faster -- > cursor motion. Also, curses will then be able to detect -- > the return key. -- > nl :: Bool -> IO () nl True = throwIfErr_ (P.pack "nl") nl_c nl False = throwIfErr_ (P.pack "nonl") nonl foreign import ccall unsafe "nl" nl_c :: IO CInt foreign import ccall unsafe "nonl" nonl :: IO CInt -- -- | Enable the keypad of the user's terminal. -- keypad :: Window -> Bool -> IO () keypad win bf = throwIfErr_ (P.pack "keypad") $ keypad_c win (if bf then 1 else 0) foreign import ccall unsafe "keypad" keypad_c :: Window -> (Word8) -> IO CInt {-# LINE 282 "UI/Nanocurses/Curses.hsc" #-} -- |> The nodelay option causes getch to be a non-blocking call. -- > If no input is ready, getch returns ERR. If disabled (bf -- > is FALSE), getch waits until a key is pressed. -- noDelay :: Window -> Bool -> IO () noDelay win bf = throwIfErr_ (P.pack "nodelay") $ nodelay win (if bf then 1 else 0) foreign import ccall unsafe nodelay :: Window -> (Word8) -> IO CInt {-# LINE 293 "UI/Nanocurses/Curses.hsc" #-} -- -- |> Normally, the hardware cursor is left at the location of -- > the window cursor being refreshed. The leaveok option -- > allows the cursor to be left wherever the update happens -- > to leave it. It is useful for applications where the cur- -- > sor is not used, since it reduces the need for cursor -- > motions. If possible, the cursor is made invisible when -- > this option is enabled. -- leaveOk :: Bool -> IO CInt leaveOk bf = leaveok_c stdScr (if bf then 1 else 0) foreign import ccall unsafe "leaveok" leaveok_c :: Window -> (Word8) -> IO CInt {-# LINE 308 "UI/Nanocurses/Curses.hsc" #-} ------------------------------------------------------------------------ -- | The use_default_colors() and assume_default_colors() func- -- tions are extensions to the curses library. They are used -- with terminals that support ISO 6429 color, or equivalent. -- -- use_default_colors() tells the curses library to assign terminal -- default foreground/background colors to color number -1. -- {-# LINE 322 "UI/Nanocurses/Curses.hsc" #-} useDefaultColors :: IO () useDefaultColors = return () {-# LINE 325 "UI/Nanocurses/Curses.hsc" #-} ------------------------------------------------------------------------ -- -- |> The program must call endwin for each terminal being used before -- > exiting from curses. -- endWin :: IO () endWin = throwIfErr_ (P.pack "endwin") endwin foreign import ccall unsafe "endwin" endwin :: IO CInt ------------------------------------------------------------------------ -- -- | get the dimensions of the screen -- scrSize :: IO (Int, Int) scrSize = do lnes <- peek linesPtr cols <- peek colsPtr return (fi lnes, fi cols) foreign import ccall "&LINES" linesPtr :: Ptr CInt foreign import ccall "&COLS" colsPtr :: Ptr CInt -- -- | refresh curses windows and lines. curs_refresh(3) -- refresh :: IO () refresh = throwIfErr_ (P.pack "refresh") refresh_c foreign import ccall unsafe "refresh" refresh_c :: IO CInt ------------------------------------------------------------------------ hasColors :: IO Bool hasColors = liftM (/= 0) has_colors foreign import ccall unsafe "has_colors" has_colors :: IO (Word8) {-# LINE 368 "UI/Nanocurses/Curses.hsc" #-} -- -- | Initialise the color settings, also sets the screen to the -- default colors (white on black) -- startColor :: IO () startColor = throwIfErr_ (P.pack "start_color") start_color foreign import ccall unsafe start_color :: IO CInt newtype Pair = Pair Int newtype Color = Color Int color :: String -> Maybe Color {-# LINE 385 "UI/Nanocurses/Curses.hsc" #-} color "black" = Just $ Color (0) {-# LINE 386 "UI/Nanocurses/Curses.hsc" #-} color "red" = Just $ Color (1) {-# LINE 387 "UI/Nanocurses/Curses.hsc" #-} color "green" = Just $ Color (2) {-# LINE 388 "UI/Nanocurses/Curses.hsc" #-} color "yellow" = Just $ Color (3) {-# LINE 389 "UI/Nanocurses/Curses.hsc" #-} color "blue" = Just $ Color (4) {-# LINE 390 "UI/Nanocurses/Curses.hsc" #-} color "magenta" = Just $ Color (5) {-# LINE 391 "UI/Nanocurses/Curses.hsc" #-} color "cyan" = Just $ Color (6) {-# LINE 392 "UI/Nanocurses/Curses.hsc" #-} color "white" = Just $ Color (7) {-# LINE 393 "UI/Nanocurses/Curses.hsc" #-} color _ = Just $ Color (0) -- NB {-# LINE 394 "UI/Nanocurses/Curses.hsc" #-} -- -- |> curses support color attributes on terminals with that -- > capability. To use these routines start_color must be -- > called, usually right after initscr. Colors are always -- > used in pairs (referred to as color-pairs). A color-pair -- > consists of a foreground color (for characters) and a -- > background color (for the blank field on which the charac- -- > ters are displayed). A programmer initializes a color- -- > pair with the routine init_pair. After it has been ini- -- > tialized, COLOR_PAIR(n), a macro defined in <curses.h>, -- > can be used as a new video attribute. -- -- > If a terminal is capable of redefining colors, the pro- -- > grammer can use the routine init_color to change the defi- -- > nition of a color. -- -- > The init_pair routine changes the definition of a color- -- > pair. It takes three arguments: the number of the color- -- > pair to be changed, the foreground color number, and the -- > background color number. For portable applications: -- -- > - The value of the first argument must be between 1 and -- > COLOR_PAIRS-1. -- -- > - The value of the second and third arguments must be -- > between 0 and COLORS (the 0 color pair is wired to -- > white on black and cannot be changed). -- -- initPair :: Pair -> Color -> Color -> IO () initPair (Pair p) (Color f) (Color b) = throwIfErr_ (P.pack "init_pair") $ init_pair (fi p) (fi f) (fi b) foreign import ccall unsafe init_pair :: CShort -> CShort -> CShort -> IO CInt -- --------------------------------------------------------------------- -- Attributes. Keep this as simple as possible for maximum portability foreign import ccall unsafe "attrset" c_attrset :: CInt -> IO CInt attrSet :: Attr -> Pair -> IO () attrSet (Attr attr) (Pair p) = do throwIfErr_ (P.pack "attrset") $ c_attrset (attr .|. fi (colorPair p)) ------------------------------------------------------------------------ newtype Attr = Attr CInt attr0 :: Attr attr0 = Attr (0) {-# LINE 448 "UI/Nanocurses/Curses.hsc" #-} setBold :: Attr -> Bool -> Attr setBold = setAttr (Attr 2097152) {-# LINE 451 "UI/Nanocurses/Curses.hsc" #-} setReverse :: Attr -> Bool -> Attr setReverse = setAttr (Attr 262144) {-# LINE 454 "UI/Nanocurses/Curses.hsc" #-} -- | bitwise combination of attributes setAttr :: Attr -> Attr -> Bool -> Attr setAttr (Attr b) (Attr a) False = Attr (a .&. complement b) setAttr (Attr b) (Attr a) True = Attr (a .|. b) attrPlus :: Attr -> Attr -> Attr attrPlus (Attr a) (Attr b) = Attr (a .|. b) ------------------------------------------------------------------------ {-# LINE 468 "UI/Nanocurses/Curses.hsc" #-} bkgrndSet :: Attr -> Pair -> IO () bkgrndSet (Attr a) (Pair p) = bkgdset $ fi (ord ' ') .|. (if a .&. 4194304 /= 0 then 4194304 else 0) .|. {-# LINE 473 "UI/Nanocurses/Curses.hsc" #-} (if a .&. 524288 /= 0 then 524288 else 0) .|. {-# LINE 474 "UI/Nanocurses/Curses.hsc" #-} (if a .&. 2097152 /= 0 then 2097152 else 0) .|. {-# LINE 475 "UI/Nanocurses/Curses.hsc" #-} (if a .&. 1048576 /= 0 then 1048576 else 0) .|. {-# LINE 476 "UI/Nanocurses/Curses.hsc" #-} (if a .&. 8388608 /= 0 then 8388608 else 0) .|. {-# LINE 477 "UI/Nanocurses/Curses.hsc" #-} (if a .&. 16777216 /= 0 then 16777216 else 0) .|. {-# LINE 478 "UI/Nanocurses/Curses.hsc" #-} (if a .&. 262144 /= 0 then 262144 else 0) .|. {-# LINE 479 "UI/Nanocurses/Curses.hsc" #-} (if a .&. 65536 /= 0 then 65536 else 0) .|. {-# LINE 480 "UI/Nanocurses/Curses.hsc" #-} (if a .&. 131072 /= 0 then 131072 else 0) .|. {-# LINE 481 "UI/Nanocurses/Curses.hsc" #-} colorPair p foreign import ccall unsafe "get_color_pair" colorPair :: Int -> (Word32) {-# LINE 485 "UI/Nanocurses/Curses.hsc" #-} foreign import ccall unsafe bkgdset :: (Word32) -> IO () {-# LINE 487 "UI/Nanocurses/Curses.hsc" #-} ------------------------------------------------------------------------ foreign import ccall threadsafe waddnstr :: Window -> CString -> CInt -> IO CInt clrToEol :: IO () clrToEol = throwIfErr_ (P.pack "clrtoeol") c_clrtoeol foreign import ccall unsafe "clrtoeol" c_clrtoeol :: IO CInt -- -- | > move the cursor associated with the window -- > to line y and column x. This routine does not move the -- > physical cursor of the terminal until refresh is called. -- > The position specified is relative to the upper left-hand -- > corner of the window, which is (0,0). -- wMove :: Window -> Int -> Int -> IO () wMove w y x = throwIfErr_ (P.pack "wmove") $ wmove w (fi y) (fi x) foreign import ccall unsafe wmove :: Window -> CInt -> CInt -> IO CInt -- --------------------------------------------------------------------- -- Cursor routines data CursorVisibility = CursorInvisible | CursorVisible | CursorVeryVisible -- -- | Set the cursor state -- -- > The curs_set routine sets the cursor state is set to -- > invisible, normal, or very visible for visibility equal to -- > 0, 1, or 2 respectively. If the terminal supports the -- > visibility requested, the previous cursor state is -- > returned; otherwise, ERR is returned. -- cursSet :: CInt -> IO CInt cursSet 0 = leaveOk True >> curs_set 0 cursSet n = leaveOk False >> curs_set n foreign import ccall unsafe "curs_set" curs_set :: CInt -> IO CInt -- -- | Get the current cursor coordinates -- getYX :: Window -> IO (Int, Int) getYX w = alloca $ \py -> -- allocate two ints on the stack alloca $ \px -> do nomacro_getyx w py px -- writes current cursor coords y <- peek py x <- peek px return (fi y, fi x) -- -- | Get the current cursor coords, written into the two argument ints. -- -- > The getyx macro places the current cursor position of the given -- > window in the two integer variables y and x. -- -- void getyx(WINDOW *win, int y, int x); -- foreign import ccall unsafe "nomacro_getyx" nomacro_getyx :: Window -> Ptr CInt -> Ptr CInt -> IO () -- -- | > The getch, wgetch, mvgetch and mvwgetch, routines read a -- > character from the window. -- foreign import ccall threadsafe getch :: IO CInt ------------------------------------------------------------------------ -- -- | Map curses keys to real chars. The lexer will like this. -- decodeKey :: CInt -> Char decodeKey = chr . fi {-# INLINE decodeKey #-} -- -- | Some constants for easy symbolic manipulation. -- NB we don't map keys to an abstract type anymore, as we can't use -- Alex lexers then. -- keyDown :: Char keyDown = chr (258) {-# LINE 576 "UI/Nanocurses/Curses.hsc" #-} keyUp :: Char keyUp = chr (259) {-# LINE 578 "UI/Nanocurses/Curses.hsc" #-} keyLeft :: Char keyLeft = chr (260) {-# LINE 580 "UI/Nanocurses/Curses.hsc" #-} keyRight :: Char keyRight = chr (261) {-# LINE 582 "UI/Nanocurses/Curses.hsc" #-} keyHome :: Char keyHome = chr (262) {-# LINE 585 "UI/Nanocurses/Curses.hsc" #-} keyBackspace :: Char keyBackspace = chr (263) {-# LINE 587 "UI/Nanocurses/Curses.hsc" #-} keyNPage :: Char keyNPage = chr (338) {-# LINE 590 "UI/Nanocurses/Curses.hsc" #-} keyPPage :: Char keyPPage = chr (339) {-# LINE 592 "UI/Nanocurses/Curses.hsc" #-} keyEnd :: Char keyEnd = chr (360) {-# LINE 594 "UI/Nanocurses/Curses.hsc" #-} {-# LINE 596 "UI/Nanocurses/Curses.hsc" #-} -- ncurses sends this keyResize :: Char keyResize = chr (410) {-# LINE 599 "UI/Nanocurses/Curses.hsc" #-} {-# LINE 600 "UI/Nanocurses/Curses.hsc" #-} -- --------------------------------------------------------------------- -- try to set the upper bits meta :: Window -> Bool -> IO () meta win bf = throwIfErr_ (P.pack "meta") $ c_meta win (if bf then 1 else 0) foreign import ccall unsafe "meta" c_meta :: Window -> CInt -> IO CInt ------------------------------------------------------------------------ -- -- | read a character from the window -- -- When 'ESC' followed by another key is pressed before the ESC timeout, -- that second character is not returned until a third character is -- pressed. wtimeout, nodelay and timeout don't appear to change this -- behaviour. -- -- On emacs, we really would want Alt to be our meta key, I think. -- -- Be warned, getCh will block the whole process without noDelay -- getCh :: IO Char getCh = do threadWaitRead 0 v <- getch case v of (-1) -> yield >> getCh {-# LINE 630 "UI/Nanocurses/Curses.hsc" #-} x -> return $ decodeKey x ------------------------------------------------------------------------ {-# LINE 635 "UI/Nanocurses/Curses.hsc" #-} cursesSigWinch :: Signal cursesSigWinch = 28 {-# LINE 637 "UI/Nanocurses/Curses.hsc" #-} {-# LINE 638 "UI/Nanocurses/Curses.hsc" #-}