diff --git a/UI/NCurses.chs b/UI/NCurses.chs deleted file mode 100644 --- a/UI/NCurses.chs +++ /dev/null @@ -1,1078 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} ------------------------------------------------------------------------------ --- Copyright (C) 2010 John Millikin --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program. If not, see . ------------------------------------------------------------------------------ --- | --- Module: UI.NCurses --- Copyright: 2010 John Millikin --- License: GPL-3 --- --- Maintainer: jmillikin@gmail.com --- Portability: portable (requires FFI) --- ------------------------------------------------------------------------------ -module UI.NCurses - ( - -- * Primary types - Curses - , Update - , Window - - -- * Initialization - , runCurses - , defaultWindow - - -- * Window management - , newWindow - , closeWindow - , cloneWindow - - -- * Drawing to the screen - , updateWindow - , render - , moveCursor - , setColor - , drawText - , drawBorder - , drawBox - , drawLineH - , drawLineV - , setBackground - - -- * Attributes - , Attribute (..) - , setAttribute - , setAttributes - - -- * Colors - , Color (..) - , ColorID - , supportsColor - , canDefineColor - , defineColor - , queryColor - , defaultColorID - , newColorID - , setColorID - , maxColorID - - -- * Glyphs - , Glyph (..) - - -- ** VT100 drawing glyphs - , glyphCornerUL - , glyphCornerLL - , glyphCornerUR - , glyphCornerLR - , glyphTeeL - , glyphTeeR - , glyphTeeB - , glyphTeeT - , glyphLineH - , glyphLineV - , glyphPlus - , glyphScan1 - , glyphScan9 - , glyphDiamond - , glyphStipple - , glyphDegree - , glyphPlusMinus - , glyphBullet - - -- ** Teletype 5410v1 symbols - , glyphArrowL - , glyphArrowR - , glyphArrowD - , glyphArrowU - , glyphBoard - , glyphLantern - , glyphBlock - - -- ** Other glyphs - , glyphS3 - , glyphS7 - , glyphNE - , glyphLTE - , glyphGTE - , glyphPi - , glyphSterling - - -- * Event handling - , Event (..) - , getEvent - - -- ** Keyboard events - , Key (..) - - -- ** Mouse events - , ButtonState (..) - , MouseState (..) - - -- * misc - , setRaw - , setCBreak - , setEcho - , baudrate - , beep - , flash - , hasMouse - , enclosed - , screenSize - , setTouched - , setRowsTouched - , setKeypad - , getCursor - ) where --- Imports {{{ -import Control.Exception (bracket_) -import Control.Monad (when, unless) -import qualified Control.Monad.Trans.Reader as R -import Data.Char (chr, ord) -import Data.List (foldl') -import Data.Maybe (catMaybes) -import qualified Data.Map as M -import qualified Data.Text as T -import UI.NCurses.Types -import qualified UI.NCurses.Enums as E --- }}} - --- c2hs setup {{{ -#define NCURSES_ENABLE_STDBOOL_H 0 -#define _XOPEN_SOURCE_EXTENDED -#define NCURSES_NOMACROS -#include -#include -#include - -import Foreign hiding (shift) -import Foreign.C - -{# pointer *WINDOW as Window nocode #} -{# pointer *cchar_t as CCharT newtype #} -{# pointer *wchar_t as CWString nocode #} - -type AttrT = {# type attr_t #} -type MMaskT = {# type mmask_t #} --- }}} - --- Initialization {{{ - --- | Put the terminal in graphical mode, including enabling special keys, --- colors, and mouse events (if supported). --- --- After the 'Curses' block has finished running, the terminal is reset --- to text mode. -runCurses :: Curses a -> IO a -runCurses = bracket_ initCurses {# call endwin #} . unCurses where - allEvents = fromInteger (E.fromEnum E.ALL_MOUSE_EVENTS) - initCurses = do - void {# call initscr #} - void {# call cbreak #} - void $ {# call mousemask #} allEvents nullPtr - hasColor <- {# call has_colors #} - when (hasColor == 1) $ do - void {# call start_color #} - void {# call use_default_colors #} - stdscr <- peek c_stdscr - void $ {# call keypad #} (Window stdscr) 1 - void $ {# call meta #} (Window stdscr) 1 - {# call wtimeout #} (Window stdscr) (- 1) - --- | The default window created when @ncurses@ is initialized, also known --- as @stdscr@. -defaultWindow :: Curses Window -defaultWindow = Curses (Window `fmap` peek c_stdscr) - -foreign import ccall "static &stdscr" - c_stdscr :: Ptr (Ptr Window) - --- }}} - --- Window management {{{ - --- | Create a new 'Window', with the given dimensions. To create a --- fullscreen window, use @'newWindow' 0 0 0 0@. --- --- When the window is no longer needed, call 'closeWindow'. Windows are not --- garbage–collected, because there’s no way to know if --- they’re still in use (as a background, or event source, etc). -newWindow :: Integer -- ^ Rows - -> Integer -- ^ Columns - -> Integer -- ^ Begin Y - -> Integer -- ^ Begin X - -> Curses Window -newWindow rows cols x y = Curses $ do - win <- {# call newwin #} - (fromInteger rows) - (fromInteger cols) - (fromInteger x) - (fromInteger y) - if windowPtr win == nullPtr - then error "newWindow: newwin() returned NULL" - else do - void $ {# call keypad #} win 1 - void $ {# call meta #} win 1 - {# call wtimeout #} win (- 1) - return win - --- | Close a window, and free all resources associated with it. Once a --- window has been closed, it is no longer safe to use. --- --- Note: this computation will not automatically clear the window from the --- screen. -closeWindow :: Window -> Curses () -closeWindow win = Curses ({# call delwin #} win >>= checkRC "closeWindow") - --- | Create a separate window, initialised with the state of an existing --- window. -cloneWindow :: Window -> Curses Window -cloneWindow old = Curses $ do - win <- {# call dupwin #} old - if windowPtr win == nullPtr - then error "cloneWindow: dupwin() returned NULL" - else return win - --- }}} - --- Drawing to the screen {{{ - --- | Apply a window update to the window. After all of an --- application’s windows have been updated, call 'render' to update --- the terminal’s contents. -updateWindow :: Window -> Update a -> Curses a -updateWindow win (Update reader) = do - a <- R.runReaderT reader win - Curses ({# call wnoutrefresh #} win >>= checkRC "updateWindow") - return a - --- | Re–draw any portions of the screen which have changed since the --- last render. -render :: Curses () -render = Curses ({# call doupdate #} >>= checkRC "render") - --- | Set the current foreground and background colors. See 'newColorID' --- for how to create color IDs. -setColor :: ColorID -> Update () -setColor (ColorID pair) = withWindow_ "setColor" $ \win -> - {# call wcolor_set #} win pair nullPtr - --- | Move the window’s cursor position to the given row and column. -moveCursor :: Integer -- ^ Row - -> Integer -- ^ Column - -> Update () -moveCursor y x = withWindow_ "moveCursor" $ \win -> - {# call wmove #} win (fromInteger y) (fromInteger x) - --- | Add some text to the window, at the current cursor position. -drawText :: T.Text -> Update () -drawText txt = withWindow_ "drawText" $ \win -> - withCWString (T.unpack txt) ({# call waddwstr #} win) - --- | Draw a border around the edge of the window. For any edge, passing --- 'Nothing' means to use the default glyph. -drawBorder :: Maybe Glyph -- ^ Left edge - -> Maybe Glyph -- ^ Right edge - -> Maybe Glyph -- ^ Top edge - -> Maybe Glyph -- ^ Bottom edge - -> Maybe Glyph -- ^ Top left corner - -> Maybe Glyph -- ^ Top right corner - -> Maybe Glyph -- ^ Bottom left corner - -> Maybe Glyph -- ^ Bottom right corner - -> Update () -drawBorder le re te be tl tr bl br = - withWindow_ "drawBorder" $ \win -> - withGlyph le $ \pLE -> - withGlyph re $ \pRE -> - withGlyph te $ \pTE -> - withGlyph be $ \pBE -> - withGlyph tl $ \pTL -> - withGlyph tr $ \pTR -> - withGlyph bl $ \pBL -> - withGlyph br $ \pBR -> - {# call wborder_set #} win pLE pRE pTE pBE pTL pTR pBL pBR - --- | @drawBox v h = drawBorder v v h h Nothing Nothing Nothing Nothing@ -drawBox :: Maybe Glyph -> Maybe Glyph -> Update () -drawBox v h = drawBorder v v h h Nothing Nothing Nothing Nothing - --- | Draw a horizontal line from left to right, using the given glyph and --- maximum character count. The cursor position is not changed. -drawLineH :: Maybe Glyph -> Integer -> Update () -drawLineH g n = withWindow_ "drawLineH" $ \win -> - withGlyph g $ \pChar -> - {# call whline_set #} win pChar (fromInteger n) - --- | Draw a vertical line from top to bottom, using the given glyph and --- maximum character count. The cursor position is not changed. -drawLineV :: Maybe Glyph -> Integer -> Update () -drawLineV g n = withWindow_ "drawLineV" $ \win -> - withGlyph g $ \pChar -> - {# call wvline_set #} win pChar (fromInteger n) - --- | Set the window’s background glyph. The glyph will be drawn in --- place of any blank characters, and the glyph’s attributes will be --- combined with those of every character. -setBackground :: Glyph -> Update () -setBackground g = withWindow_ "setBackground" $ \win -> - withGlyph (Just g) $ \pChar -> - {# call wbkgrndset #} win pChar >> return 0 - --- }}} - --- Attributes {{{ - -data Attribute - = AttributeStandout - | AttributeUnderline - | AttributeReverse - | AttributeBlink - | AttributeDim - | AttributeBold - | AttributeAltCharset - | AttributeInvisible - | AttributeProtect - deriving (Show, Eq) - -attrEnum :: E.Attribute -> AttrT -attrEnum = fromInteger . E.fromEnum - -attrToInt :: Attribute -> AttrT -attrToInt x = case x of - AttributeStandout -> attrEnum E.WA_STANDOUT - AttributeUnderline -> attrEnum E.WA_UNDERLINE - AttributeReverse -> attrEnum E.WA_REVERSE - AttributeBlink -> attrEnum E.WA_BLINK - AttributeDim -> attrEnum E.WA_DIM - AttributeBold -> attrEnum E.WA_BOLD - AttributeAltCharset -> attrEnum E.WA_ALTCHARSET - AttributeInvisible -> attrEnum E.WA_INVIS - AttributeProtect -> attrEnum E.WA_PROTECT - --- | Set a single 'Attribute' on the current window. No other attributes --- are modified. -setAttribute :: Attribute -> Bool -> Update () -setAttribute attr on = withWindow_ "setAttribute" $ \win -> - let c = if on then {# call wattr_on #} else {# call wattr_off #} in - c win (attrToInt attr) nullPtr - --- | Set all 'Attribute's at once on the current window. Any attributes not --- included in the list will be unset. -setAttributes :: [Attribute] -> Update () -setAttributes attrs = withWindow_ "setAttributes" $ \win -> - let cint = foldl' (\acc a -> acc .|. attrToInt a) 0 attrs in - alloca $ \pPair -> do - {# call wattr_get #} win nullPtr pPair nullPtr >>= checkRC "setAttributes" - colorPair <- peek pPair - {# call wattr_set #} win cint colorPair nullPtr - --- }}} - --- Colors {{{ - -data Color - = ColorBlack - | ColorRed - | ColorGreen - | ColorYellow - | ColorBlue - | ColorMagenta - | ColorCyan - | ColorWhite - deriving (Show, Eq) - --- | A wrapper around 'Integer' to ensure clients don’t use an --- uninitialized color in an attribute. -newtype ColorID = ColorID CShort - deriving (Show, Eq) - -colorEnum :: E.Color -> CShort -colorEnum = fromInteger . E.fromEnum - -colorToShort :: Color -> CShort -colorToShort x = case x of - ColorBlack -> colorEnum E.COLOR_BLACK - ColorRed -> colorEnum E.COLOR_RED - ColorGreen -> colorEnum E.COLOR_GREEN - ColorYellow -> colorEnum E.COLOR_YELLOW - ColorBlue -> colorEnum E.COLOR_BLUE - ColorMagenta -> colorEnum E.COLOR_MAGENTA - ColorCyan -> colorEnum E.COLOR_CYAN - ColorWhite -> colorEnum E.COLOR_WHITE - --- | Check if the terminal supports color. If it doesn’t, --- alternative indicators (such as underlines or bold) should be used. -supportsColor :: Curses Bool -supportsColor = Curses (fmap cToBool {# call has_colors #}) - --- | Check if the terminal supports changing color defintiions. -canDefineColor :: Curses Bool -canDefineColor = Curses (fmap cToBool {# call can_change_color #}) - --- | Change the definition of an existing color. Use 'canDefineColor' to --- determine whether changing color values is possible. -defineColor :: Color - -> Integer -- ^ Red (0 – 1000) - -> Integer -- ^ Green (0 – 1000) - -> Integer -- ^ Blue (0 – 1000) - -> Curses () -defineColor c r g b = Curses $ do - rc <- {# call init_color #} - (colorToShort c) - (fromInteger r) - (fromInteger g) - (fromInteger b) - checkRC "defineColor" rc - --- | Query the current definition of the given color (see 'defineColor'). --- The returned tuple is (red, green, blue), with values 0 – 1000. -queryColor :: Color -> Curses (Integer, Integer, Integer) -queryColor c = Curses $ - alloca $ \pRed -> - alloca $ \pGreen -> - alloca $ \pBlue -> do - rc <- {# call color_content #} (colorToShort c) pRed pGreen pBlue - checkRC "queryColor" rc - red <- fmap toInteger (peek pRed) - green <- fmap toInteger (peek pGreen) - blue <- fmap toInteger (peek pBlue) - return (red, green, blue) - --- | The default color ID -defaultColorID :: ColorID -defaultColorID = ColorID 0 - --- | Assign a new 'ColorID' to some (foreground, background) color pair. --- The user may pick which color ID is assigned, but it must be valid. Use --- 'maxColorID' to determine how many colors the current terminal supports. -newColorID :: Color -- ^ Foreground - -> Color -- ^ Background - -> Integer -- ^ A value /n/, such that - -- (0 < /n/ ≤ 'maxColorID') - -> Curses ColorID -newColorID fg bg n = Curses $ do - unless (n > 0) $ error "newColorID: n must be > 0" - maxColor <- unCurses maxColorID - unless (n <= maxColor) $ error "newColorID: n must be <= maxColorID" - checkRC "newColorID" =<< {# call init_pair #} - (fromInteger n) - (colorToShort fg) - (colorToShort bg) - return (ColorID (fromInteger n)) - --- Change the definition of an existing 'ColorID' -setColorID :: Color -- ^ Foreground - -> Color -- ^ Background - -> ColorID -- ^ The 'ColorID' to change - -> Curses () -setColorID fg bg (ColorID n) = Curses $ - checkRC "setColorID" =<< {# call init_pair #} n - (colorToShort fg) - (colorToShort bg) - --- | Get the maximum color ID supported by the current terminal -maxColorID :: Curses Integer -maxColorID = Curses $ do - pairs <- toInteger `fmap` peek c_COLOR_PAIRS - return (pairs - 1) - -foreign import ccall "static &COLOR_PAIRS" - c_COLOR_PAIRS :: Ptr CInt - --- }}} - --- Glyphs {{{ - --- | A glyph is a character, typically spacing, combined with a set of --- attributes. -data Glyph = Glyph - { glyphCharacter :: Char - , glyphAttributes :: [Attribute] - } - deriving (Show, Eq) - -withGlyph :: Maybe Glyph -> (CCharT -> IO a) -> IO a -withGlyph Nothing io = io (CCharT nullPtr) -withGlyph (Just (Glyph char attrs)) io = - let cAttrs = foldl' (\acc a -> acc .|. attrToInt a) 0 attrs in - - allocaBytes {# sizeof cchar_t #} $ \pBuf -> do - void $ {# call memset #} (castPtr pBuf) 0 {# sizeof cchar_t #} - {# set cchar_t->attr #} pBuf cAttrs - {# set cchar_t->chars #} pBuf (wordPtrToPtr (fromIntegral (ord char))) - io (CCharT pBuf) - --- VT100 drawing glyphs {{{ - --- | Upper left corner -glyphCornerUL :: Glyph -glyphCornerUL = Glyph '\x250C' [] - --- | Lower left corner -glyphCornerLL :: Glyph -glyphCornerLL = Glyph '\x2514' [] - --- | Upper right corner -glyphCornerUR :: Glyph -glyphCornerUR = Glyph '\x2510' [] - --- | Lower right corner -glyphCornerLR :: Glyph -glyphCornerLR = Glyph '\x2518' [] - --- | Tee pointing right -glyphTeeL :: Glyph -glyphTeeL = Glyph '\x251C' [] - --- | Tee pointing left -glyphTeeR :: Glyph -glyphTeeR = Glyph '\x2524' [] - --- | Tee pointing up -glyphTeeB :: Glyph -glyphTeeB = Glyph '\x2534' [] - --- | Tee pointing down -glyphTeeT :: Glyph -glyphTeeT = Glyph '\x252C' [] - --- | Horizontal line -glyphLineH :: Glyph -glyphLineH = Glyph '\x2500' [] - --- | Vertical line -glyphLineV :: Glyph -glyphLineV = Glyph '\x2502' [] - --- | Large plus or crossover -glyphPlus :: Glyph -glyphPlus = Glyph '\x253C' [] - --- | Scan line 1 -glyphScan1 :: Glyph -glyphScan1 = Glyph '\x23BA' [] - --- | Scan line 9 -glyphScan9 :: Glyph -glyphScan9 = Glyph '\x23BD' [] - --- | Diamond -glyphDiamond :: Glyph -glyphDiamond = Glyph '\x25C6' [] - --- | Stipple, or checker board -glyphStipple :: Glyph -glyphStipple = Glyph '\x2592' [] - --- | Degree symbol -glyphDegree :: Glyph -glyphDegree = Glyph '\xb0' [] - --- | Plus/minus -glyphPlusMinus :: Glyph -glyphPlusMinus = Glyph '\xb1' [] - --- | Bullet -glyphBullet :: Glyph -glyphBullet = Glyph '\xb7' [] - --- }}} - --- Teletype 5410v1 symbols {{{ - --- | Arrow pointing left -glyphArrowL :: Glyph -glyphArrowL = Glyph '\x2190' [] - --- | Arrow pointing right -glyphArrowR :: Glyph -glyphArrowR = Glyph '\x2192' [] - --- | Arrow pointing down -glyphArrowD :: Glyph -glyphArrowD = Glyph '\x2193' [] - --- | Arrow pointing up -glyphArrowU :: Glyph -glyphArrowU = Glyph '\x2191' [] - --- | Board of squares -glyphBoard :: Glyph -glyphBoard = Glyph '\x2592' [] - --- | Lantern symbol -glyphLantern :: Glyph -glyphLantern = Glyph '\x2603' [] - --- | Solid square block -glyphBlock :: Glyph -glyphBlock = Glyph '\x25AE' [] - --- }}} - --- Other glyphs {{{ - --- | Scan line 3 -glyphS3 :: Glyph -glyphS3 = Glyph '\x23BB' [] - --- | Scan line 7 -glyphS7 :: Glyph -glyphS7 = Glyph '\x23BC' [] - --- | Not equal -glyphNE :: Glyph -glyphNE = Glyph '\x2260' [] - --- | Less than or equal -glyphLTE :: Glyph -glyphLTE = Glyph '\x2264' [] - --- | Greater than or equal -glyphGTE :: Glyph -glyphGTE = Glyph '\x2265' [] - --- | Pi -glyphPi :: Glyph -glyphPi = Glyph '\x3c0' [] - --- | UK pounds sterling symbol -glyphSterling :: Glyph -glyphSterling = Glyph '\xa3' [] - --- }}} - --- }}} - --- Event handling {{{ - -data Event - = EventCharacter Char - | EventSpecialKey Key - | EventMouse Integer MouseState - | EventResized - | EventUnknown Integer - deriving (Show, Eq) - --- | Get the next 'Event' from a given window. --- --- If the timeout is specified, and no event is received within the timeout, --- @getEvent@ returns 'Nothing'. If the timeout is 0 or less, @getEvent@ --- will not block at all. -getEvent :: Window - -> Maybe Integer -- ^ Timeout, in milliseconds - -> Curses (Maybe Event) -getEvent win timeout = Curses io where - io = alloca $ \ptr -> do - {# call wtimeout #} win $ case timeout of - Nothing -> -1 - Just n | n <= 0 -> 0 - Just n -> fromInteger n - rc <- {# call wget_wch #} win ptr - if toInteger rc == E.fromEnum E.ERR - then return Nothing - else fmap Just (parseCode ptr rc) - - parseCode ptr rc = do - code <- toInteger `fmap` peek ptr - if rc == 0 - then return (charEvent code) - else if code == E.fromEnum E.KEY_MOUSE - then mouseEvent - else if code == E.fromEnum E.KEY_RESIZE - then return EventResized - else keyEvent code - - charEvent = EventCharacter . chr . fromInteger - - mouseEvent = allocaBytes {# sizeof MEVENT #} $ \pEv -> do - {# call getmouse #} pEv >>= checkRC "getEvent" - evID <- fmap toInteger ({# get MEVENT->id #} pEv) - x <- fmap toInteger ({# get MEVENT->x #} pEv) - y <- fmap toInteger ({# get MEVENT->y #} pEv) - z <- fmap toInteger ({# get MEVENT->z #} pEv) - - mask <- {# get MEVENT->bstate #} pEv - let state = parseMouseState mask - - return (EventMouse evID (state { mouseCoordinates = (x, y, z) })) - - codeF0 = E.fromEnum E.KEY_F0 - codeF64 = codeF0 + 64 - keyEvent code = return $ if code >= codeF0 && code <= codeF64 - then EventSpecialKey (KeyFunction (code - codeF0)) - else case M.lookup code keyMap of - Just key -> EventSpecialKey key - Nothing -> EventUnknown code - --- Keyboard events {{{ - -data Key - = KeyUpArrow - | KeyDownArrow - | KeyLeftArrow - | KeyRightArrow - | KeyHome - | KeyBackspace - | KeyFunction Integer -- ^ Function keys, F0 – F64 - | KeyDeleteLine - | KeyInsertLine - | KeyDeleteCharacter - | KeyInsertCharacter - | KeyEIC -- ^ Sent by rmir or smir in insert mode - | KeyClear -- ^ Clear screen - | KeyEOS -- ^ Clear to end of screen - | KeyEOL -- ^ Clear to end of line - | KeyScrollForward - | KeyScrollBackward - | KeyNextPage - | KeyPreviousPage - | KeySetTab - | KeyClearTab - | KeyClearAllTabs - | KeyEnter - | KeyPrint - | KeyHomeDown - | KeyA1 -- ^ Upper left of keypad - | KeyA3 -- ^ Upper right of keypad - | KeyB2 -- ^ Center of keypad - | KeyC1 -- ^ Lower left of keypad - | KeyC3 -- ^ Lower right of keypad - | KeyBackTab - | KeyBegin - | KeyCancel - | KeyClose - | KeyCommand - | KeyCopy - | KeyCreate - | KeyEnd - | KeyExit - | KeyFind - | KeyHelp - | KeyMark - | KeyMessage - | KeyMove - | KeyNext - | KeyOpen - | KeyOptions - | KeyPrevious - | KeyRedo - | KeyReference - | KeyRefresh - | KeyReplace - | KeyRestart - | KeyResume - | KeySave - | KeyShiftedBegin - | KeyShiftedCancel - | KeyShiftedCommand - | KeyShiftedCopy - | KeyShiftedCreate - | KeyShiftedDeleteCharacter - | KeyShiftedDeleteLine - | KeySelect - | KeyShiftedEnd - | KeyShiftedEOL - | KeyShiftedExit - | KeyShiftedFind - | KeyShiftedHelp - | KeyShiftedHome - | KeyShiftedInsertCharacter - | KeyShiftedLeftArrow - | KeyShiftedMessage - | KeyShiftedMove - | KeyShiftedNext - | KeyShiftedOptions - | KeyShiftedPrevious - | KeyShiftedPrint - | KeyShiftedRedo - | KeyShiftedReplace - | KeyShiftedRightArrow - | KeyShiftedResume - | KeyShiftedSave - | KeyShiftedSuspend - | KeyShiftedUndo - | KeySuspend - | KeyUndo - deriving (Show, Eq) - -keyMap :: M.Map Integer Key -keyMap = M.fromList $ map (\(enum, key) -> (E.fromEnum enum, key)) - [ (E.KEY_DOWN, KeyDownArrow) - , (E.KEY_UP, KeyUpArrow) - , (E.KEY_LEFT, KeyLeftArrow) - , (E.KEY_RIGHT, KeyRightArrow) - , (E.KEY_HOME, KeyHome) - , (E.KEY_BACKSPACE, KeyBackspace) - , (E.KEY_DL, KeyDeleteLine) - , (E.KEY_IL, KeyInsertLine) - , (E.KEY_DC, KeyDeleteCharacter) - , (E.KEY_IC, KeyInsertCharacter) - , (E.KEY_EIC, KeyEIC) - , (E.KEY_CLEAR, KeyClear) - , (E.KEY_EOS, KeyEOS) - , (E.KEY_EOL, KeyEOL) - , (E.KEY_SF, KeyScrollForward) - , (E.KEY_SR, KeyScrollBackward) - , (E.KEY_NPAGE, KeyNextPage) - , (E.KEY_PPAGE, KeyPreviousPage) - , (E.KEY_STAB, KeySetTab) - , (E.KEY_CTAB, KeyClearTab) - , (E.KEY_CATAB, KeyClearAllTabs) - , (E.KEY_ENTER, KeyEnter) - , (E.KEY_PRINT, KeyPrint) - , (E.KEY_LL, KeyHomeDown) - , (E.KEY_A1, KeyA1) - , (E.KEY_A3, KeyA3) - , (E.KEY_B2, KeyB2) - , (E.KEY_C1, KeyC1) - , (E.KEY_C3, KeyC3) - , (E.KEY_BTAB, KeyBackTab) - , (E.KEY_BEG, KeyBegin) - , (E.KEY_CANCEL, KeyCancel) - , (E.KEY_CLOSE, KeyClose) - , (E.KEY_COMMAND, KeyCommand) - , (E.KEY_COPY, KeyCopy) - , (E.KEY_CREATE, KeyCreate) - , (E.KEY_END, KeyEnd) - , (E.KEY_EXIT, KeyExit) - , (E.KEY_FIND, KeyFind) - , (E.KEY_HELP, KeyHelp) - , (E.KEY_MARK, KeyMark) - , (E.KEY_MESSAGE, KeyMessage) - , (E.KEY_MOVE, KeyMove) - , (E.KEY_NEXT, KeyNext) - , (E.KEY_OPEN, KeyOpen) - , (E.KEY_OPTIONS, KeyOptions) - , (E.KEY_PREVIOUS, KeyPrevious) - , (E.KEY_REDO, KeyRedo) - , (E.KEY_REFERENCE, KeyReference) - , (E.KEY_REFRESH, KeyRefresh) - , (E.KEY_REPLACE, KeyReplace) - , (E.KEY_RESTART, KeyRestart) - , (E.KEY_RESUME, KeyResume) - , (E.KEY_SAVE, KeySave) - , (E.KEY_SBEG, KeyShiftedBegin) - , (E.KEY_SCANCEL, KeyShiftedCancel) - , (E.KEY_SCOMMAND, KeyShiftedCommand) - , (E.KEY_SCOPY, KeyShiftedCopy) - , (E.KEY_SCREATE, KeyShiftedCreate) - , (E.KEY_SDC, KeyShiftedDeleteCharacter) - , (E.KEY_SDL, KeyShiftedDeleteLine) - , (E.KEY_SELECT, KeySelect) - , (E.KEY_SEND, KeyShiftedEnd) - , (E.KEY_SEOL, KeyShiftedEOL) - , (E.KEY_SEXIT, KeyShiftedExit) - , (E.KEY_SFIND, KeyShiftedFind) - , (E.KEY_SHELP, KeyShiftedHelp) - , (E.KEY_SHOME, KeyShiftedHome) - , (E.KEY_SIC, KeyShiftedInsertCharacter) - , (E.KEY_SLEFT, KeyShiftedLeftArrow) - , (E.KEY_SMESSAGE, KeyShiftedMessage) - , (E.KEY_SMOVE, KeyShiftedMove) - , (E.KEY_SNEXT, KeyShiftedNext) - , (E.KEY_SOPTIONS, KeyShiftedOptions) - , (E.KEY_SPREVIOUS, KeyShiftedPrevious) - , (E.KEY_SPRINT, KeyShiftedPrint) - , (E.KEY_SREDO, KeyShiftedRedo) - , (E.KEY_SREPLACE, KeyShiftedReplace) - , (E.KEY_SRIGHT, KeyShiftedRightArrow) - , (E.KEY_SRSUME, KeyShiftedResume) - , (E.KEY_SSAVE, KeyShiftedSave) - , (E.KEY_SSUSPEND, KeyShiftedSuspend) - , (E.KEY_SUNDO, KeyShiftedUndo) - , (E.KEY_SUSPEND, KeySuspend) - , (E.KEY_UNDO, KeyUndo) - ] - --- }}} - --- Mouse events {{{ - -data ButtonState - = ButtonPressed - | ButtonReleased - | ButtonClicked - | ButtonDoubleClicked - | ButtonTripleClicked - deriving (Show, Eq) - -data MouseState = MouseState - { mouseCoordinates :: (Integer, Integer, Integer) -- ^ (X, Y, Z) - - -- | If the mouse event was caused by a change in button state, - -- the buttons and their new state will be listed here. - , mouseButtons :: [(Integer, ButtonState)] - - , mouseAlt :: Bool - , mouseShift :: Bool - , mouseControl :: Bool - } - deriving (Show, Eq) - -parseMouseState :: MMaskT -> MouseState -parseMouseState mask = MouseState (0, 0, 0) buttons alt shift ctrl where - maskI = toInteger mask - test e = (maskI .&. (E.fromEnum e)) > 0 - - alt = test E.BUTTON_ALT - shift = test E.BUTTON_SHIFT - ctrl = test E.BUTTON_CTRL - - buttons = catMaybes [button1, button2, button3, button4, button5] - - testButton idx r p c dc tc - | test r = Just (idx, ButtonReleased) - | test p = Just (idx, ButtonPressed) - | test c = Just (idx, ButtonClicked) - | test dc = Just (idx, ButtonDoubleClicked) - | test tc = Just (idx, ButtonTripleClicked) - | otherwise = Nothing - - button1 = testButton 1 - E.BUTTON1_RELEASED - E.BUTTON1_PRESSED - E.BUTTON1_CLICKED - E.BUTTON1_DOUBLE_CLICKED - E.BUTTON1_TRIPLE_CLICKED - button2 = testButton 2 - E.BUTTON2_RELEASED - E.BUTTON2_PRESSED - E.BUTTON2_CLICKED - E.BUTTON2_DOUBLE_CLICKED - E.BUTTON2_TRIPLE_CLICKED - button3 = testButton 3 - E.BUTTON3_RELEASED - E.BUTTON3_PRESSED - E.BUTTON3_CLICKED - E.BUTTON3_DOUBLE_CLICKED - E.BUTTON3_TRIPLE_CLICKED - button4 = testButton 4 - E.BUTTON4_RELEASED - E.BUTTON4_PRESSED - E.BUTTON4_CLICKED - E.BUTTON4_DOUBLE_CLICKED - E.BUTTON4_TRIPLE_CLICKED -#ifdef BUTTON5_RELEASED - button5 = testButton 5 - E.BUTTON5_RELEASED - E.BUTTON5_PRESSED - E.BUTTON5_CLICKED - E.BUTTON5_DOUBLE_CLICKED - E.BUTTON5_TRIPLE_CLICKED -#else - button5 = Nothing -#endif - --- }}} - --- }}} - --- misc {{{ - --- | Runs @raw()@ or @noraw()@ -setRaw :: Bool -> Curses () -setRaw set = Curses (io >>= checkRC "setRaw") where - io = if set then {# call raw #} else {# call noraw #} - --- | Runs @cbreak()@ or @nocbreak()@ -setCBreak :: Bool -> Curses () -setCBreak set = Curses (io >>= checkRC "setCBreak") where - io = if set then {# call cbreak #} else {# call nocbreak #} - --- | Runs @echo()@ or @noecho()@ -setEcho :: Bool -> Curses () -setEcho set = Curses (io >>= checkRC "setEcho") where - io = if set then {# call echo #} else {# call noecho #} - --- | Get the output speed of the current terminal, in bits per second. -baudrate :: Curses Integer -baudrate = Curses $ do - rc <- {# call baudrate as c_baudrate #} - checkRC "baudrate" rc - return (toInteger rc) - -beep :: Curses () -beep = Curses ({# call beep as c_beep #} >>= checkRC "beep") - -flash :: Curses () -flash = Curses ({# call flash as c_flash #} >>= checkRC "flash") - --- | Check if the terminal has a mouse -hasMouse :: Curses Bool -hasMouse = Curses (fmap cToBool {# call hsncurses_has_mouse #}) - --- | Check if some position is contained within the given 'Window'. -enclosed :: Window - -> Integer -- ^ Row - -> Integer -- ^ Column - -> Curses Bool -enclosed win y x = Curses . fmap cToBool $ - {# call wenclose #} win (fromInteger y) (fromInteger x) - --- | Return (rows, columns) of current screen -screenSize :: Curses (Integer, Integer) -screenSize = Curses $ do - rows <- peek c_LINES - cols <- peek c_COLS - return (toInteger rows, toInteger cols) - -foreign import ccall "static &LINES" - c_LINES :: Ptr CInt - -foreign import ccall "static &COLS" - c_COLS :: Ptr CInt - --- | Set whether the entire window has been “touched”; --- touched characters are redrawn on the next refresh. -setTouched :: Bool -> Update () -setTouched touched = withWindow_ "setTouched" $ if touched - then {# call touchwin #} - else {# call untouchwin #} - --- | Set whether particular rows in the window have been --- “touched”. -setRowsTouched :: Bool - -> Integer -- ^ Start - -> Integer -- ^ Count - -> Update () -setRowsTouched touched start count = withWindow_ "setRowsTouched" $ \win -> - {# call wtouchln #} win - (fromInteger start) - (fromInteger count) - (cFromBool touched) - --- | Enable/disable support for special keys. -setKeypad :: Window -> Bool -> Curses () -setKeypad win set = Curses (io >>= checkRC "setKeypad") where - io = {# call keypad #} win (cFromBool set) - -getCursor :: Window -> Curses (Integer, Integer) -getCursor win = Curses $ do - row <- {# call getcury #} win - col <- {# call getcurx #} win - return (toInteger row, toInteger col) - --- }}} - --- Utility {{{ - -withWindow :: (Window -> IO a) -> Update a -withWindow io = Update (R.ReaderT (\win -> Curses (io win))) - -withWindow_ :: String -> (Window -> IO CInt) -> Update () -withWindow_ name io = withWindow $ \win -> io win >>= checkRC name - --- }}} diff --git a/UI/NCurses/Enums.chs b/UI/NCurses/Enums.chs deleted file mode 100644 --- a/UI/NCurses/Enums.chs +++ /dev/null @@ -1,215 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright (C) 2010 John Millikin --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program. If not, see . ------------------------------------------------------------------------------ -module UI.NCurses.Enums where - --- this module is a hack to work around c2hs's lack of #define hooks. --- the idea is to create a new class 'Enum' which uses 'Integer' instead --- of 'Int', so integral defines of any size can be retrieved. -import Prelude (Integer, error, show, (++)) - -#define NCURSES_ENABLE_STDBOOL_H 0 -#define _XOPEN_SOURCE_EXTENDED -#define NCURSES_NOMACROS -#include - -class Enum a where - toEnum :: Integer -> a - fromEnum :: a -> Integer - --- misc enums -#c -enum hsncurses_EnumWrapper -{ hsncurses_ALL_MOUSE_EVENTS = ALL_MOUSE_EVENTS -, hsncurses_ERR = ERR -}; -#endc - -{# enum hsncurses_EnumWrapper as EnumWrapper {} with prefix = "hsncurses_" #} - --- attributes -#c -enum hsncurses_Attribute -{ hsncurses_WA_STANDOUT = WA_STANDOUT -, hsncurses_WA_UNDERLINE = WA_UNDERLINE -, hsncurses_WA_REVERSE = WA_REVERSE -, hsncurses_WA_BLINK = WA_BLINK -, hsncurses_WA_DIM = WA_DIM -, hsncurses_WA_BOLD = WA_BOLD -, hsncurses_WA_ALTCHARSET = WA_ALTCHARSET -, hsncurses_WA_INVIS = WA_INVIS -, hsncurses_WA_PROTECT = WA_PROTECT -}; -#endc - -{# enum hsncurses_Attribute as Attribute {} with prefix = "hsncurses_" #} - --- colors -#c -enum hsncurses_Color -{ hsncurses_COLOR_BLACK = COLOR_BLACK -, hsncurses_COLOR_RED = COLOR_RED -, hsncurses_COLOR_GREEN = COLOR_GREEN -, hsncurses_COLOR_YELLOW = COLOR_YELLOW -, hsncurses_COLOR_BLUE = COLOR_BLUE -, hsncurses_COLOR_MAGENTA = COLOR_MAGENTA -, hsncurses_COLOR_CYAN = COLOR_CYAN -, hsncurses_COLOR_WHITE = COLOR_WHITE -}; -#endc - -{# enum hsncurses_Color as Color {} with prefix = "hsncurses_" #} - --- keys -#c -enum hsncurses_Key -{ hsncurses_KEY_CODE_YES = KEY_CODE_YES -, hsncurses_KEY_DOWN = KEY_DOWN -, hsncurses_KEY_UP = KEY_UP -, hsncurses_KEY_LEFT = KEY_LEFT -, hsncurses_KEY_RIGHT = KEY_RIGHT -, hsncurses_KEY_HOME = KEY_HOME -, hsncurses_KEY_BACKSPACE = KEY_BACKSPACE -, hsncurses_KEY_F0 = KEY_F0 -, hsncurses_KEY_DL = KEY_DL -, hsncurses_KEY_IL = KEY_IL -, hsncurses_KEY_DC = KEY_DC -, hsncurses_KEY_IC = KEY_IC -, hsncurses_KEY_EIC = KEY_EIC -, hsncurses_KEY_CLEAR = KEY_CLEAR -, hsncurses_KEY_EOS = KEY_EOS -, hsncurses_KEY_EOL = KEY_EOL -, hsncurses_KEY_SF = KEY_SF -, hsncurses_KEY_SR = KEY_SR -, hsncurses_KEY_NPAGE = KEY_NPAGE -, hsncurses_KEY_PPAGE = KEY_PPAGE -, hsncurses_KEY_STAB = KEY_STAB -, hsncurses_KEY_CTAB = KEY_CTAB -, hsncurses_KEY_CATAB = KEY_CATAB -, hsncurses_KEY_ENTER = KEY_ENTER -, hsncurses_KEY_PRINT = KEY_PRINT -, hsncurses_KEY_LL = KEY_LL -, hsncurses_KEY_A1 = KEY_A1 -, hsncurses_KEY_A3 = KEY_A3 -, hsncurses_KEY_B2 = KEY_B2 -, hsncurses_KEY_C1 = KEY_C1 -, hsncurses_KEY_C3 = KEY_C3 -, hsncurses_KEY_BTAB = KEY_BTAB -, hsncurses_KEY_BEG = KEY_BEG -, hsncurses_KEY_CANCEL = KEY_CANCEL -, hsncurses_KEY_CLOSE = KEY_CLOSE -, hsncurses_KEY_COMMAND = KEY_COMMAND -, hsncurses_KEY_COPY = KEY_COPY -, hsncurses_KEY_CREATE = KEY_CREATE -, hsncurses_KEY_END = KEY_END -, hsncurses_KEY_EXIT = KEY_EXIT -, hsncurses_KEY_FIND = KEY_FIND -, hsncurses_KEY_HELP = KEY_HELP -, hsncurses_KEY_MARK = KEY_MARK -, hsncurses_KEY_MESSAGE = KEY_MESSAGE -, hsncurses_KEY_MOVE = KEY_MOVE -, hsncurses_KEY_NEXT = KEY_NEXT -, hsncurses_KEY_OPEN = KEY_OPEN -, hsncurses_KEY_OPTIONS = KEY_OPTIONS -, hsncurses_KEY_PREVIOUS = KEY_PREVIOUS -, hsncurses_KEY_REDO = KEY_REDO -, hsncurses_KEY_REFERENCE = KEY_REFERENCE -, hsncurses_KEY_REFRESH = KEY_REFRESH -, hsncurses_KEY_REPLACE = KEY_REPLACE -, hsncurses_KEY_RESTART = KEY_RESTART -, hsncurses_KEY_RESUME = KEY_RESUME -, hsncurses_KEY_SAVE = KEY_SAVE -, hsncurses_KEY_SBEG = KEY_SBEG -, hsncurses_KEY_SCANCEL = KEY_SCANCEL -, hsncurses_KEY_SCOMMAND = KEY_SCOMMAND -, hsncurses_KEY_SCOPY = KEY_SCOPY -, hsncurses_KEY_SCREATE = KEY_SCREATE -, hsncurses_KEY_SDC = KEY_SDC -, hsncurses_KEY_SDL = KEY_SDL -, hsncurses_KEY_SELECT = KEY_SELECT -, hsncurses_KEY_SEND = KEY_SEND -, hsncurses_KEY_SEOL = KEY_SEOL -, hsncurses_KEY_SEXIT = KEY_SEXIT -, hsncurses_KEY_SFIND = KEY_SFIND -, hsncurses_KEY_SHELP = KEY_SHELP -, hsncurses_KEY_SHOME = KEY_SHOME -, hsncurses_KEY_SIC = KEY_SIC -, hsncurses_KEY_SLEFT = KEY_SLEFT -, hsncurses_KEY_SMESSAGE = KEY_SMESSAGE -, hsncurses_KEY_SMOVE = KEY_SMOVE -, hsncurses_KEY_SNEXT = KEY_SNEXT -, hsncurses_KEY_SOPTIONS = KEY_SOPTIONS -, hsncurses_KEY_SPREVIOUS = KEY_SPREVIOUS -, hsncurses_KEY_SPRINT = KEY_SPRINT -, hsncurses_KEY_SREDO = KEY_SREDO -, hsncurses_KEY_SREPLACE = KEY_SREPLACE -, hsncurses_KEY_SRIGHT = KEY_SRIGHT -, hsncurses_KEY_SRSUME = KEY_SRSUME -, hsncurses_KEY_SSAVE = KEY_SSAVE -, hsncurses_KEY_SSUSPEND = KEY_SSUSPEND -, hsncurses_KEY_SUNDO = KEY_SUNDO -, hsncurses_KEY_SUSPEND = KEY_SUSPEND -, hsncurses_KEY_UNDO = KEY_UNDO -, hsncurses_KEY_MOUSE = KEY_MOUSE -, hsncurses_KEY_RESIZE = KEY_RESIZE -, hsncurses_KEY_EVENT = KEY_EVENT -}; -#endc - -{# enum hsncurses_Key as Key {} with prefix = "hsncurses_" #} - --- mouse buttons -#c -enum hsncurses_Button -{ hsncurses_BUTTON_CTRL = BUTTON_CTRL -, hsncurses_BUTTON_SHIFT = BUTTON_SHIFT -, hsncurses_BUTTON_ALT = BUTTON_ALT - -, hsncurses_BUTTON1_RELEASED = BUTTON1_RELEASED -, hsncurses_BUTTON1_PRESSED = BUTTON1_PRESSED -, hsncurses_BUTTON1_CLICKED = BUTTON1_CLICKED -, hsncurses_BUTTON1_DOUBLE_CLICKED = BUTTON1_DOUBLE_CLICKED -, hsncurses_BUTTON1_TRIPLE_CLICKED = BUTTON1_TRIPLE_CLICKED - -, hsncurses_BUTTON2_RELEASED = BUTTON2_RELEASED -, hsncurses_BUTTON2_PRESSED = BUTTON2_PRESSED -, hsncurses_BUTTON2_CLICKED = BUTTON2_CLICKED -, hsncurses_BUTTON2_DOUBLE_CLICKED = BUTTON2_DOUBLE_CLICKED -, hsncurses_BUTTON2_TRIPLE_CLICKED = BUTTON2_TRIPLE_CLICKED - -, hsncurses_BUTTON3_RELEASED = BUTTON3_RELEASED -, hsncurses_BUTTON3_PRESSED = BUTTON3_PRESSED -, hsncurses_BUTTON3_CLICKED = BUTTON3_CLICKED -, hsncurses_BUTTON3_DOUBLE_CLICKED = BUTTON3_DOUBLE_CLICKED -, hsncurses_BUTTON3_TRIPLE_CLICKED = BUTTON3_TRIPLE_CLICKED - -, hsncurses_BUTTON4_RELEASED = BUTTON4_RELEASED -, hsncurses_BUTTON4_PRESSED = BUTTON4_PRESSED -, hsncurses_BUTTON4_CLICKED = BUTTON4_CLICKED -, hsncurses_BUTTON4_DOUBLE_CLICKED = BUTTON4_DOUBLE_CLICKED -, hsncurses_BUTTON4_TRIPLE_CLICKED = BUTTON4_TRIPLE_CLICKED - -#ifdef BUTTON5_RELEASED -, hsncurses_BUTTON5_RELEASED = BUTTON5_RELEASED -, hsncurses_BUTTON5_PRESSED = BUTTON5_PRESSED -, hsncurses_BUTTON5_CLICKED = BUTTON5_CLICKED -, hsncurses_BUTTON5_DOUBLE_CLICKED = BUTTON5_DOUBLE_CLICKED -, hsncurses_BUTTON5_TRIPLE_CLICKED = BUTTON5_TRIPLE_CLICKED -#endif -}; -#endc - -{# enum hsncurses_Button as Button {} with prefix = "hsncurses_" #} diff --git a/UI/NCurses/Panel.chs b/UI/NCurses/Panel.chs deleted file mode 100644 --- a/UI/NCurses/Panel.chs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} ------------------------------------------------------------------------------ --- Copyright (C) 2010 John Millikin --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program. If not, see . ------------------------------------------------------------------------------ --- | --- Module: UI.NCurses.Panel --- Copyright: 2010 John Millikin --- License: GPL-3 --- --- Maintainer: jmillikin@gmail.com --- Portability: portable (requires FFI) --- ------------------------------------------------------------------------------ -module UI.NCurses.Panel - ( Panel - , newPanel - , deletePanel - , refreshPanels - , panelAbove - , panelBelow - , panelTop - , panelBottom - , showPanel - , hidePanel - , panelHidden - , movePanel - , raisePanel - , lowerPanel - , getPanelWindow - , replacePanelWindow - ) where -import Foreign -import Foreign.C -import UI.NCurses.Types - --- for haddock -import UI.NCurses (render) - -#include - -{# pointer *PANEL as Panel nocode #} -{# pointer *WINDOW as Window nocode #} -newtype Panel = Panel { panelPtr :: Ptr Panel } - --- | Creates a new 'Panel', on top of the panel stack. -newPanel :: Window -> Curses Panel -newPanel win = Curses $ do - p <- {# call new_panel #} win - if panelPtr p == nullPtr - then error "newPanel: new_panel() returned NULL" - else return p - --- | Permanently removes the given panel from the panel stack. -deletePanel :: Panel -> Curses () -deletePanel p = Curses ({# call del_panel #} p >>= checkRC "deletePanel") - --- | Updates windows to account for the current panel stack order. The user --- must call 'render' before changes are drawn to the screen. -refreshPanels :: Curses () -refreshPanels = Curses {#call update_panels #} - --- | @panelAbove p@ retrieve the panel above /p/. -panelAbove :: Panel -> Curses (Maybe Panel) -panelAbove p = Curses $ do - ptr <- {# call panel_above #} p - return $ if panelPtr ptr == nullPtr - then Nothing - else Just ptr - --- | @panelAbove p@ retrieve the panel below /p/. -panelBelow :: Panel -> Curses (Maybe Panel) -panelBelow p = Curses $ do - ptr <- {# call panel_below #} p - return $ if panelPtr ptr == nullPtr - then Nothing - else Just ptr - --- | Retrieve the top–most panel in the stack. -panelTop :: Curses (Maybe Panel) -panelTop = Curses $ do - ptr <- {# call panel_below #} (Panel nullPtr) - return $ if panelPtr ptr == nullPtr - then Nothing - else Just ptr - --- | Retrieve the bottom–most panel in the stack. -panelBottom :: Curses (Maybe Panel) -panelBottom = Curses $ do - ptr <- {# call panel_above #} (Panel nullPtr) - return $ if panelPtr ptr == nullPtr - then Nothing - else Just ptr - --- | Makes a hidden panel visible, and places it on the top of the stack. -showPanel :: Panel -> Curses () -showPanel p = Curses ({# call show_panel #} p >>= checkRC "showPanel") - --- | Temporarily removes the given panel from the panel stack. Use --- 'showPanel' to restore it. -hidePanel :: Panel -> Curses () -hidePanel p = Curses ({# call hide_panel #} p >>= checkRC "hidePanel") - --- | Checks if the given panel is currently visible. -panelHidden :: Panel -> Curses Bool -panelHidden p = Curses (cToBool `fmap` {# call panel_hidden #} p) - --- | Move the panel so its upper–left corner is at the new --- coordinates. -movePanel :: Panel - -> Integer -- ^ New upper–left row - -> Integer -- ^ New upper–left column - -> Curses () -movePanel p row col = Curses $ - checkRC "movePanel" =<< {# call move_panel #} p - (fromInteger row) - (fromInteger col) - --- | Raise a bottom to the top of the stack. -raisePanel :: Panel -> Curses () -raisePanel p = Curses ({# call top_panel #} p >>= checkRC "raisePanel") - --- | Lower a panel to the bottom of the stack. -lowerPanel :: Panel -> Curses () -lowerPanel p = Curses ({# call bottom_panel #} p >>= checkRC "lowerPanel") - --- | Retrieves which window a panel is drawn to. -getPanelWindow :: Panel -> Curses Window -getPanelWindow p = Curses ({# call panel_window #} p) - --- | Replaces which window a panel is drawn to. -replacePanelWindow :: Panel -> Window -> Curses () -replacePanelWindow p win = Curses $ - {# call replace_panel #} p win >>= checkRC "replacePanelWindow" diff --git a/UI/NCurses/Types.hs b/UI/NCurses/Types.hs deleted file mode 100644 --- a/UI/NCurses/Types.hs +++ /dev/null @@ -1,85 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright (C) 2010 John Millikin --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program. If not, see . ------------------------------------------------------------------------------ -module UI.NCurses.Types where -import qualified Control.Applicative as A -import Control.Monad (liftM, ap) -import Control.Monad.Fix (MonadFix, mfix) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Reader (ReaderT) -import qualified Foreign as F -import qualified Foreign.C as F -import qualified UI.NCurses.Enums as E - --- newtype Curses {{{ - --- | A small wrapper around 'IO', to ensure the @ncurses@ library is --- initialized while running. -newtype Curses a = Curses { unCurses :: IO a } - -instance Monad Curses where - return = Curses . return - m >>= f = Curses (unCurses m >>= unCurses . f) - -instance MonadFix Curses where - mfix f = Curses (mfix (unCurses . f)) - -instance MonadIO Curses where - liftIO = Curses - -instance Functor Curses where - fmap = liftM - -instance A.Applicative Curses where - pure = return - (<*>) = ap - --- }}} - --- newtype Update {{{ - -newtype Update a = Update { unUpdate :: ReaderT Window Curses a } - -instance Monad Update where - return = Update . return - m >>= f = Update (unUpdate m >>= unUpdate . f) - -instance MonadFix Update where - mfix f = Update (mfix (unUpdate . f)) - -instance Functor Update where - fmap = liftM - -instance A.Applicative Update where - pure = return - (<*>) = ap - --- }}} - -newtype Window = Window { windowPtr :: F.Ptr Window } - -checkRC :: String -> F.CInt -> IO () -checkRC name rc = if toInteger rc == E.fromEnum E.ERR - then error $ name ++ ": rc == ERR" - else return () - -cToBool :: Integral a => a -> Bool -cToBool 0 = False -cToBool _ = True - -cFromBool :: Integral a => Bool -> a -cFromBool False = 0 -cFromBool True = 1 diff --git a/cbits/hsncurses-shim.c b/cbits/hsncurses-shim.c new file mode 100644 --- /dev/null +++ b/cbits/hsncurses-shim.c @@ -0,0 +1,18 @@ +#define NCURSES_ENABLE_STDBOOL_H 0 +#define _XOPEN_SOURCE_EXTENDED +#define NCURSES_NOMACROS +#include +#include + +#if NCURSES_VERSION_PATCH < 20081122 +int _nc_has_mouse(); +#endif + +int hsncurses_has_mouse() +{ +#if NCURSES_VERSION_PATCH >= 20081122 + return has_mouse(); +#else + return _nc_has_mouse(); +#endif +} diff --git a/cbits/hsncurses-shim.h b/cbits/hsncurses-shim.h new file mode 100644 --- /dev/null +++ b/cbits/hsncurses-shim.h @@ -0,0 +1,1 @@ +int hsncurses_has_mouse(); diff --git a/hsncurses-shim.c b/hsncurses-shim.c deleted file mode 100644 --- a/hsncurses-shim.c +++ /dev/null @@ -1,18 +0,0 @@ -#define NCURSES_ENABLE_STDBOOL_H 0 -#define _XOPEN_SOURCE_EXTENDED -#define NCURSES_NOMACROS -#include -#include - -#if NCURSES_VERSION_PATCH < 20081122 -int _nc_has_mouse(); -#endif - -int hsncurses_has_mouse() -{ -#if NCURSES_VERSION_PATCH >= 20081122 - return has_mouse(); -#else - return _nc_has_mouse(); -#endif -} diff --git a/hsncurses-shim.h b/hsncurses-shim.h deleted file mode 100644 --- a/hsncurses-shim.h +++ /dev/null @@ -1,1 +0,0 @@ -int hsncurses_has_mouse(); diff --git a/lib/UI/NCurses.chs b/lib/UI/NCurses.chs new file mode 100644 --- /dev/null +++ b/lib/UI/NCurses.chs @@ -0,0 +1,1086 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- Copyright (C) 2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . +----------------------------------------------------------------------------- +-- | +-- Module: UI.NCurses +-- Copyright: 2010 John Millikin +-- License: GPL-3 +-- +-- Maintainer: jmillikin@gmail.com +-- Portability: portable (requires FFI) +-- +----------------------------------------------------------------------------- +module UI.NCurses + ( + -- * Primary types + Curses + , Update + , Window + + -- * Initialization + , runCurses + , defaultWindow + + -- * Window management + , newWindow + , closeWindow + , cloneWindow + + -- * Drawing to the screen + , updateWindow + , render + , moveCursor + , setColor + , drawString + , drawText + , drawBorder + , drawBox + , drawLineH + , drawLineV + , setBackground + + -- * Attributes + , Attribute (..) + , setAttribute + , setAttributes + + -- * Colors + , Color (..) + , ColorID + , supportsColor + , canDefineColor + , defineColor + , queryColor + , defaultColorID + , newColorID + , setColorID + , maxColorID + + -- * Glyphs + , Glyph (..) + + -- ** VT100 drawing glyphs + , glyphCornerUL + , glyphCornerLL + , glyphCornerUR + , glyphCornerLR + , glyphTeeL + , glyphTeeR + , glyphTeeB + , glyphTeeT + , glyphLineH + , glyphLineV + , glyphPlus + , glyphScan1 + , glyphScan9 + , glyphDiamond + , glyphStipple + , glyphDegree + , glyphPlusMinus + , glyphBullet + + -- ** Teletype 5410v1 symbols + , glyphArrowL + , glyphArrowR + , glyphArrowD + , glyphArrowU + , glyphBoard + , glyphLantern + , glyphBlock + + -- ** Other glyphs + , glyphS3 + , glyphS7 + , glyphNE + , glyphLTE + , glyphGTE + , glyphPi + , glyphSterling + + -- * Event handling + , Event (..) + , getEvent + + -- ** Keyboard events + , Key (..) + + -- ** Mouse events + , ButtonState (..) + , MouseState (..) + + -- * misc + , setRaw + , setCBreak + , setEcho + , baudrate + , beep + , flash + , hasMouse + , enclosed + , screenSize + , setTouched + , setRowsTouched + , setKeypad + , getCursor + ) where +-- Imports {{{ +import Control.Exception (bracket_) +import Control.Monad (when, unless) +import qualified Control.Monad.Trans.Reader as R +import Data.Char (chr, ord) +import Data.List (foldl') +import Data.Maybe (catMaybes) +import qualified Data.Map as M +import qualified Data.Text as T +import UI.NCurses.Types +import qualified UI.NCurses.Enums as E +-- }}} + +-- c2hs setup {{{ +#define NCURSES_ENABLE_STDBOOL_H 0 +#define _XOPEN_SOURCE_EXTENDED +#define NCURSES_NOMACROS +#include +#include + +import Foreign hiding (shift) +import Foreign.C + +{# pointer *WINDOW as Window nocode #} +{# pointer *cchar_t as CCharT newtype #} +{# pointer *wchar_t as CWString nocode #} + +type AttrT = {# type attr_t #} +type MMaskT = {# type mmask_t #} +-- }}} + +-- Initialization {{{ + +-- | Put the terminal in graphical mode, including enabling special keys, +-- colors, and mouse events (if supported). +-- +-- After the 'Curses' block has finished running, the terminal is reset +-- to text mode. +runCurses :: Curses a -> IO a +runCurses = bracket_ initCurses {# call endwin #} . unCurses where + allEvents = fromInteger (E.fromEnum E.ALL_MOUSE_EVENTS) + initCurses = do + void {# call initscr #} + void {# call cbreak #} + void $ {# call mousemask #} allEvents nullPtr + hasColor <- {# call has_colors #} + when (hasColor == 1) $ do + void {# call start_color #} + void {# call use_default_colors #} + stdscr <- peek c_stdscr + void $ {# call keypad #} (Window stdscr) 1 + void $ {# call meta #} (Window stdscr) 1 + {# call wtimeout #} (Window stdscr) (- 1) + +-- | The default window created when @ncurses@ is initialized, also known +-- as @stdscr@. +defaultWindow :: Curses Window +defaultWindow = Curses (Window `fmap` peek c_stdscr) + +foreign import ccall "static &stdscr" + c_stdscr :: Ptr (Ptr Window) + +-- }}} + +-- Window management {{{ + +-- | Create a new 'Window', with the given dimensions. To create a +-- fullscreen window, use @'newWindow' 0 0 0 0@. +-- +-- When the window is no longer needed, call 'closeWindow'. Windows are not +-- garbage–collected, because there’s no way to know if +-- they’re still in use (as a background, or event source, etc). +newWindow :: Integer -- ^ Rows + -> Integer -- ^ Columns + -> Integer -- ^ Begin Y + -> Integer -- ^ Begin X + -> Curses Window +newWindow rows cols x y = Curses $ do + win <- {# call newwin #} + (fromInteger rows) + (fromInteger cols) + (fromInteger x) + (fromInteger y) + if windowPtr win == nullPtr + then error "newWindow: newwin() returned NULL" + else do + void $ {# call keypad #} win 1 + void $ {# call meta #} win 1 + {# call wtimeout #} win (- 1) + return win + +-- | Close a window, and free all resources associated with it. Once a +-- window has been closed, it is no longer safe to use. +-- +-- Note: this computation will not automatically clear the window from the +-- screen. +closeWindow :: Window -> Curses () +closeWindow win = Curses ({# call delwin #} win >>= checkRC "closeWindow") + +-- | Create a separate window, initialised with the state of an existing +-- window. +cloneWindow :: Window -> Curses Window +cloneWindow old = Curses $ do + win <- {# call dupwin #} old + if windowPtr win == nullPtr + then error "cloneWindow: dupwin() returned NULL" + else return win + +-- }}} + +-- Drawing to the screen {{{ + +-- | Apply a window update to the window. After all of an +-- application’s windows have been updated, call 'render' to update +-- the terminal’s contents. +updateWindow :: Window -> Update a -> Curses a +updateWindow win (Update reader) = do + a <- R.runReaderT reader win + Curses ({# call wnoutrefresh #} win >>= checkRC "updateWindow") + return a + +-- | Re–draw any portions of the screen which have changed since the +-- last render. +render :: Curses () +render = Curses ({# call doupdate #} >>= checkRC "render") + +-- | Set the current foreground and background colors. See 'newColorID' +-- for how to create color IDs. +setColor :: ColorID -> Update () +setColor (ColorID pair) = withWindow_ "setColor" $ \win -> + {# call wcolor_set #} win pair nullPtr + +-- | Move the window’s cursor position to the given row and column. +moveCursor :: Integer -- ^ Row + -> Integer -- ^ Column + -> Update () +moveCursor y x = withWindow_ "moveCursor" $ \win -> + {# call wmove #} win (fromInteger y) (fromInteger x) + +-- | Add some text to the window, at the current cursor position. +drawString :: String -> Update () +drawString str = withWindow_ "drawString" $ \win -> + withCWString str ({# call waddwstr #} win) + +-- | Add some text to the window, at the current cursor position. +drawText :: T.Text -> Update () +drawText txt = withWindow_ "drawText" $ \win -> + withCWString (T.unpack txt) ({# call waddwstr #} win) + +-- | Draw a border around the edge of the window. For any edge, passing +-- 'Nothing' means to use the default glyph. +drawBorder :: Maybe Glyph -- ^ Left edge + -> Maybe Glyph -- ^ Right edge + -> Maybe Glyph -- ^ Top edge + -> Maybe Glyph -- ^ Bottom edge + -> Maybe Glyph -- ^ Top left corner + -> Maybe Glyph -- ^ Top right corner + -> Maybe Glyph -- ^ Bottom left corner + -> Maybe Glyph -- ^ Bottom right corner + -> Update () +drawBorder le re te be tl tr bl br = + withWindow_ "drawBorder" $ \win -> + withGlyph le $ \pLE -> + withGlyph re $ \pRE -> + withGlyph te $ \pTE -> + withGlyph be $ \pBE -> + withGlyph tl $ \pTL -> + withGlyph tr $ \pTR -> + withGlyph bl $ \pBL -> + withGlyph br $ \pBR -> + {# call wborder_set #} win pLE pRE pTE pBE pTL pTR pBL pBR + +-- | @drawBox v h = drawBorder v v h h Nothing Nothing Nothing Nothing@ +drawBox :: Maybe Glyph -> Maybe Glyph -> Update () +drawBox v h = drawBorder v v h h Nothing Nothing Nothing Nothing + +-- | Draw a horizontal line from left to right, using the given glyph and +-- maximum character count. The cursor position is not changed. +drawLineH :: Maybe Glyph -> Integer -> Update () +drawLineH g n = withWindow_ "drawLineH" $ \win -> + withGlyph g $ \pChar -> + {# call whline_set #} win pChar (fromInteger n) + +-- | Draw a vertical line from top to bottom, using the given glyph and +-- maximum character count. The cursor position is not changed. +drawLineV :: Maybe Glyph -> Integer -> Update () +drawLineV g n = withWindow_ "drawLineV" $ \win -> + withGlyph g $ \pChar -> + {# call wvline_set #} win pChar (fromInteger n) + +-- | Set the window’s background glyph. The glyph will be drawn in +-- place of any blank characters, and the glyph’s attributes will be +-- combined with those of every character. +setBackground :: Glyph -> Update () +setBackground g = withWindow_ "setBackground" $ \win -> + withGlyph (Just g) $ \pChar -> + {# call wbkgrndset #} win pChar >> return 0 + +-- }}} + +-- Attributes {{{ + +data Attribute + = AttributeStandout + | AttributeUnderline + | AttributeReverse + | AttributeBlink + | AttributeDim + | AttributeBold + | AttributeAltCharset + | AttributeInvisible + | AttributeProtect + deriving (Show, Eq) + +attrEnum :: E.Attribute -> AttrT +attrEnum = fromInteger . E.fromEnum + +attrToInt :: Attribute -> AttrT +attrToInt x = case x of + AttributeStandout -> attrEnum E.WA_STANDOUT + AttributeUnderline -> attrEnum E.WA_UNDERLINE + AttributeReverse -> attrEnum E.WA_REVERSE + AttributeBlink -> attrEnum E.WA_BLINK + AttributeDim -> attrEnum E.WA_DIM + AttributeBold -> attrEnum E.WA_BOLD + AttributeAltCharset -> attrEnum E.WA_ALTCHARSET + AttributeInvisible -> attrEnum E.WA_INVIS + AttributeProtect -> attrEnum E.WA_PROTECT + +-- | Set a single 'Attribute' on the current window. No other attributes +-- are modified. +setAttribute :: Attribute -> Bool -> Update () +setAttribute attr on = withWindow_ "setAttribute" $ \win -> + let c = if on then {# call wattr_on #} else {# call wattr_off #} in + c win (attrToInt attr) nullPtr + +-- | Set all 'Attribute's at once on the current window. Any attributes not +-- included in the list will be unset. +setAttributes :: [Attribute] -> Update () +setAttributes attrs = withWindow_ "setAttributes" $ \win -> + let cint = foldl' (\acc a -> acc .|. attrToInt a) 0 attrs in + alloca $ \pPair -> do + {# call wattr_get #} win nullPtr pPair nullPtr >>= checkRC "setAttributes" + colorPair <- peek pPair + {# call wattr_set #} win cint colorPair nullPtr + +-- }}} + +-- Colors {{{ + +data Color + = ColorBlack + | ColorRed + | ColorGreen + | ColorYellow + | ColorBlue + | ColorMagenta + | ColorCyan + | ColorWhite + deriving (Show, Eq) + +-- | A wrapper around 'Integer' to ensure clients don’t use an +-- uninitialized color in an attribute. +newtype ColorID = ColorID CShort + deriving (Show, Eq) + +colorEnum :: E.Color -> CShort +colorEnum = fromInteger . E.fromEnum + +colorToShort :: Color -> CShort +colorToShort x = case x of + ColorBlack -> colorEnum E.COLOR_BLACK + ColorRed -> colorEnum E.COLOR_RED + ColorGreen -> colorEnum E.COLOR_GREEN + ColorYellow -> colorEnum E.COLOR_YELLOW + ColorBlue -> colorEnum E.COLOR_BLUE + ColorMagenta -> colorEnum E.COLOR_MAGENTA + ColorCyan -> colorEnum E.COLOR_CYAN + ColorWhite -> colorEnum E.COLOR_WHITE + +-- | Check if the terminal supports color. If it doesn’t, +-- alternative indicators (such as underlines or bold) should be used. +supportsColor :: Curses Bool +supportsColor = Curses (fmap cToBool {# call has_colors #}) + +-- | Check if the terminal supports changing color defintiions. +canDefineColor :: Curses Bool +canDefineColor = Curses (fmap cToBool {# call can_change_color #}) + +-- | Change the definition of an existing color. Use 'canDefineColor' to +-- determine whether changing color values is possible. +defineColor :: Color + -> Integer -- ^ Red (0 – 1000) + -> Integer -- ^ Green (0 – 1000) + -> Integer -- ^ Blue (0 – 1000) + -> Curses () +defineColor c r g b = Curses $ do + rc <- {# call init_color #} + (colorToShort c) + (fromInteger r) + (fromInteger g) + (fromInteger b) + checkRC "defineColor" rc + +-- | Query the current definition of the given color (see 'defineColor'). +-- The returned tuple is (red, green, blue), with values 0 – 1000. +queryColor :: Color -> Curses (Integer, Integer, Integer) +queryColor c = Curses $ + alloca $ \pRed -> + alloca $ \pGreen -> + alloca $ \pBlue -> do + rc <- {# call color_content #} (colorToShort c) pRed pGreen pBlue + checkRC "queryColor" rc + red <- fmap toInteger (peek pRed) + green <- fmap toInteger (peek pGreen) + blue <- fmap toInteger (peek pBlue) + return (red, green, blue) + +-- | The default color ID +defaultColorID :: ColorID +defaultColorID = ColorID 0 + +-- | Assign a new 'ColorID' to some (foreground, background) color pair. +-- The user may pick which color ID is assigned, but it must be valid. Use +-- 'maxColorID' to determine how many colors the current terminal supports. +newColorID :: Color -- ^ Foreground + -> Color -- ^ Background + -> Integer -- ^ A value /n/, such that + -- (0 < /n/ ≤ 'maxColorID') + -> Curses ColorID +newColorID fg bg n = Curses $ do + unless (n > 0) $ error "newColorID: n must be > 0" + maxColor <- unCurses maxColorID + unless (n <= maxColor) $ error "newColorID: n must be <= maxColorID" + checkRC "newColorID" =<< {# call init_pair #} + (fromInteger n) + (colorToShort fg) + (colorToShort bg) + return (ColorID (fromInteger n)) + +-- Change the definition of an existing 'ColorID' +setColorID :: Color -- ^ Foreground + -> Color -- ^ Background + -> ColorID -- ^ The 'ColorID' to change + -> Curses () +setColorID fg bg (ColorID n) = Curses $ + checkRC "setColorID" =<< {# call init_pair #} n + (colorToShort fg) + (colorToShort bg) + +-- | Get the maximum color ID supported by the current terminal +maxColorID :: Curses Integer +maxColorID = Curses $ do + pairs <- toInteger `fmap` peek c_COLOR_PAIRS + return (pairs - 1) + +foreign import ccall "static &COLOR_PAIRS" + c_COLOR_PAIRS :: Ptr CInt + +-- }}} + +-- Glyphs {{{ + +-- | A glyph is a character, typically spacing, combined with a set of +-- attributes. +data Glyph = Glyph + { glyphCharacter :: Char + , glyphAttributes :: [Attribute] + } + deriving (Show, Eq) + +withGlyph :: Maybe Glyph -> (CCharT -> IO a) -> IO a +withGlyph Nothing io = io (CCharT nullPtr) +withGlyph (Just (Glyph char attrs)) io = + let cAttrs = foldl' (\acc a -> acc .|. attrToInt a) 0 attrs in + + allocaBytes {# sizeof cchar_t #} $ \pBuf -> do + void $ {# call memset #} (castPtr pBuf) 0 {# sizeof cchar_t #} + {# set cchar_t->attr #} pBuf cAttrs + {# set cchar_t->chars #} pBuf (wordPtrToPtr (fromIntegral (ord char))) + io (CCharT pBuf) + +-- VT100 drawing glyphs {{{ + +-- | Upper left corner +glyphCornerUL :: Glyph +glyphCornerUL = Glyph '\x250C' [] + +-- | Lower left corner +glyphCornerLL :: Glyph +glyphCornerLL = Glyph '\x2514' [] + +-- | Upper right corner +glyphCornerUR :: Glyph +glyphCornerUR = Glyph '\x2510' [] + +-- | Lower right corner +glyphCornerLR :: Glyph +glyphCornerLR = Glyph '\x2518' [] + +-- | Tee pointing right +glyphTeeL :: Glyph +glyphTeeL = Glyph '\x251C' [] + +-- | Tee pointing left +glyphTeeR :: Glyph +glyphTeeR = Glyph '\x2524' [] + +-- | Tee pointing up +glyphTeeB :: Glyph +glyphTeeB = Glyph '\x2534' [] + +-- | Tee pointing down +glyphTeeT :: Glyph +glyphTeeT = Glyph '\x252C' [] + +-- | Horizontal line +glyphLineH :: Glyph +glyphLineH = Glyph '\x2500' [] + +-- | Vertical line +glyphLineV :: Glyph +glyphLineV = Glyph '\x2502' [] + +-- | Large plus or crossover +glyphPlus :: Glyph +glyphPlus = Glyph '\x253C' [] + +-- | Scan line 1 +glyphScan1 :: Glyph +glyphScan1 = Glyph '\x23BA' [] + +-- | Scan line 9 +glyphScan9 :: Glyph +glyphScan9 = Glyph '\x23BD' [] + +-- | Diamond +glyphDiamond :: Glyph +glyphDiamond = Glyph '\x25C6' [] + +-- | Stipple, or checker board +glyphStipple :: Glyph +glyphStipple = Glyph '\x2592' [] + +-- | Degree symbol +glyphDegree :: Glyph +glyphDegree = Glyph '\xb0' [] + +-- | Plus/minus +glyphPlusMinus :: Glyph +glyphPlusMinus = Glyph '\xb1' [] + +-- | Bullet +glyphBullet :: Glyph +glyphBullet = Glyph '\xb7' [] + +-- }}} + +-- Teletype 5410v1 symbols {{{ + +-- | Arrow pointing left +glyphArrowL :: Glyph +glyphArrowL = Glyph '\x2190' [] + +-- | Arrow pointing right +glyphArrowR :: Glyph +glyphArrowR = Glyph '\x2192' [] + +-- | Arrow pointing down +glyphArrowD :: Glyph +glyphArrowD = Glyph '\x2193' [] + +-- | Arrow pointing up +glyphArrowU :: Glyph +glyphArrowU = Glyph '\x2191' [] + +-- | Board of squares +glyphBoard :: Glyph +glyphBoard = Glyph '\x2592' [] + +-- | Lantern symbol +glyphLantern :: Glyph +glyphLantern = Glyph '\x2603' [] + +-- | Solid square block +glyphBlock :: Glyph +glyphBlock = Glyph '\x25AE' [] + +-- }}} + +-- Other glyphs {{{ + +-- | Scan line 3 +glyphS3 :: Glyph +glyphS3 = Glyph '\x23BB' [] + +-- | Scan line 7 +glyphS7 :: Glyph +glyphS7 = Glyph '\x23BC' [] + +-- | Not equal +glyphNE :: Glyph +glyphNE = Glyph '\x2260' [] + +-- | Less than or equal +glyphLTE :: Glyph +glyphLTE = Glyph '\x2264' [] + +-- | Greater than or equal +glyphGTE :: Glyph +glyphGTE = Glyph '\x2265' [] + +-- | Pi +glyphPi :: Glyph +glyphPi = Glyph '\x3c0' [] + +-- | UK pounds sterling symbol +glyphSterling :: Glyph +glyphSterling = Glyph '\xa3' [] + +-- }}} + +-- }}} + +-- Event handling {{{ + +data Event + = EventCharacter Char + | EventSpecialKey Key + | EventMouse Integer MouseState + | EventResized + | EventUnknown Integer + deriving (Show, Eq) + +-- | Get the next 'Event' from a given window. +-- +-- If the timeout is specified, and no event is received within the timeout, +-- @getEvent@ returns 'Nothing'. If the timeout is 0 or less, @getEvent@ +-- will not block at all. +getEvent :: Window + -> Maybe Integer -- ^ Timeout, in milliseconds + -> Curses (Maybe Event) +getEvent win timeout = Curses io where + io = alloca $ \ptr -> do + {# call wtimeout #} win $ case timeout of + Nothing -> -1 + Just n | n <= 0 -> 0 + Just n -> fromInteger n + rc <- {# call wget_wch #} win ptr + if toInteger rc == E.fromEnum E.ERR + then return Nothing + else fmap Just (parseCode ptr rc) + + parseCode ptr rc = do + code <- toInteger `fmap` peek ptr + if rc == 0 + then return (charEvent code) + else if code == E.fromEnum E.KEY_MOUSE + then mouseEvent + else if code == E.fromEnum E.KEY_RESIZE + then return EventResized + else keyEvent code + + charEvent = EventCharacter . chr . fromInteger + + mouseEvent = allocaBytes {# sizeof MEVENT #} $ \pEv -> do + {# call getmouse #} pEv >>= checkRC "getEvent" + evID <- fmap toInteger ({# get MEVENT->id #} pEv) + x <- fmap toInteger ({# get MEVENT->x #} pEv) + y <- fmap toInteger ({# get MEVENT->y #} pEv) + z <- fmap toInteger ({# get MEVENT->z #} pEv) + + mask <- {# get MEVENT->bstate #} pEv + let state = parseMouseState mask + + return (EventMouse evID (state { mouseCoordinates = (x, y, z) })) + + codeF0 = E.fromEnum E.KEY_F0 + codeF64 = codeF0 + 64 + keyEvent code = return $ if code >= codeF0 && code <= codeF64 + then EventSpecialKey (KeyFunction (code - codeF0)) + else case M.lookup code keyMap of + Just key -> EventSpecialKey key + Nothing -> EventUnknown code + +-- Keyboard events {{{ + +data Key + = KeyUpArrow + | KeyDownArrow + | KeyLeftArrow + | KeyRightArrow + | KeyHome + | KeyBackspace + | KeyFunction Integer -- ^ Function keys, F0 – F64 + | KeyDeleteLine + | KeyInsertLine + | KeyDeleteCharacter + | KeyInsertCharacter + | KeyEIC -- ^ Sent by rmir or smir in insert mode + | KeyClear -- ^ Clear screen + | KeyEOS -- ^ Clear to end of screen + | KeyEOL -- ^ Clear to end of line + | KeyScrollForward + | KeyScrollBackward + | KeyNextPage + | KeyPreviousPage + | KeySetTab + | KeyClearTab + | KeyClearAllTabs + | KeyEnter + | KeyPrint + | KeyHomeDown + | KeyA1 -- ^ Upper left of keypad + | KeyA3 -- ^ Upper right of keypad + | KeyB2 -- ^ Center of keypad + | KeyC1 -- ^ Lower left of keypad + | KeyC3 -- ^ Lower right of keypad + | KeyBackTab + | KeyBegin + | KeyCancel + | KeyClose + | KeyCommand + | KeyCopy + | KeyCreate + | KeyEnd + | KeyExit + | KeyFind + | KeyHelp + | KeyMark + | KeyMessage + | KeyMove + | KeyNext + | KeyOpen + | KeyOptions + | KeyPrevious + | KeyRedo + | KeyReference + | KeyRefresh + | KeyReplace + | KeyRestart + | KeyResume + | KeySave + | KeyShiftedBegin + | KeyShiftedCancel + | KeyShiftedCommand + | KeyShiftedCopy + | KeyShiftedCreate + | KeyShiftedDeleteCharacter + | KeyShiftedDeleteLine + | KeySelect + | KeyShiftedEnd + | KeyShiftedEOL + | KeyShiftedExit + | KeyShiftedFind + | KeyShiftedHelp + | KeyShiftedHome + | KeyShiftedInsertCharacter + | KeyShiftedLeftArrow + | KeyShiftedMessage + | KeyShiftedMove + | KeyShiftedNext + | KeyShiftedOptions + | KeyShiftedPrevious + | KeyShiftedPrint + | KeyShiftedRedo + | KeyShiftedReplace + | KeyShiftedRightArrow + | KeyShiftedResume + | KeyShiftedSave + | KeyShiftedSuspend + | KeyShiftedUndo + | KeySuspend + | KeyUndo + deriving (Show, Eq) + +keyMap :: M.Map Integer Key +keyMap = M.fromList $ map (\(enum, key) -> (E.fromEnum enum, key)) + [ (E.KEY_DOWN, KeyDownArrow) + , (E.KEY_UP, KeyUpArrow) + , (E.KEY_LEFT, KeyLeftArrow) + , (E.KEY_RIGHT, KeyRightArrow) + , (E.KEY_HOME, KeyHome) + , (E.KEY_BACKSPACE, KeyBackspace) + , (E.KEY_DL, KeyDeleteLine) + , (E.KEY_IL, KeyInsertLine) + , (E.KEY_DC, KeyDeleteCharacter) + , (E.KEY_IC, KeyInsertCharacter) + , (E.KEY_EIC, KeyEIC) + , (E.KEY_CLEAR, KeyClear) + , (E.KEY_EOS, KeyEOS) + , (E.KEY_EOL, KeyEOL) + , (E.KEY_SF, KeyScrollForward) + , (E.KEY_SR, KeyScrollBackward) + , (E.KEY_NPAGE, KeyNextPage) + , (E.KEY_PPAGE, KeyPreviousPage) + , (E.KEY_STAB, KeySetTab) + , (E.KEY_CTAB, KeyClearTab) + , (E.KEY_CATAB, KeyClearAllTabs) + , (E.KEY_ENTER, KeyEnter) + , (E.KEY_PRINT, KeyPrint) + , (E.KEY_LL, KeyHomeDown) + , (E.KEY_A1, KeyA1) + , (E.KEY_A3, KeyA3) + , (E.KEY_B2, KeyB2) + , (E.KEY_C1, KeyC1) + , (E.KEY_C3, KeyC3) + , (E.KEY_BTAB, KeyBackTab) + , (E.KEY_BEG, KeyBegin) + , (E.KEY_CANCEL, KeyCancel) + , (E.KEY_CLOSE, KeyClose) + , (E.KEY_COMMAND, KeyCommand) + , (E.KEY_COPY, KeyCopy) + , (E.KEY_CREATE, KeyCreate) + , (E.KEY_END, KeyEnd) + , (E.KEY_EXIT, KeyExit) + , (E.KEY_FIND, KeyFind) + , (E.KEY_HELP, KeyHelp) + , (E.KEY_MARK, KeyMark) + , (E.KEY_MESSAGE, KeyMessage) + , (E.KEY_MOVE, KeyMove) + , (E.KEY_NEXT, KeyNext) + , (E.KEY_OPEN, KeyOpen) + , (E.KEY_OPTIONS, KeyOptions) + , (E.KEY_PREVIOUS, KeyPrevious) + , (E.KEY_REDO, KeyRedo) + , (E.KEY_REFERENCE, KeyReference) + , (E.KEY_REFRESH, KeyRefresh) + , (E.KEY_REPLACE, KeyReplace) + , (E.KEY_RESTART, KeyRestart) + , (E.KEY_RESUME, KeyResume) + , (E.KEY_SAVE, KeySave) + , (E.KEY_SBEG, KeyShiftedBegin) + , (E.KEY_SCANCEL, KeyShiftedCancel) + , (E.KEY_SCOMMAND, KeyShiftedCommand) + , (E.KEY_SCOPY, KeyShiftedCopy) + , (E.KEY_SCREATE, KeyShiftedCreate) + , (E.KEY_SDC, KeyShiftedDeleteCharacter) + , (E.KEY_SDL, KeyShiftedDeleteLine) + , (E.KEY_SELECT, KeySelect) + , (E.KEY_SEND, KeyShiftedEnd) + , (E.KEY_SEOL, KeyShiftedEOL) + , (E.KEY_SEXIT, KeyShiftedExit) + , (E.KEY_SFIND, KeyShiftedFind) + , (E.KEY_SHELP, KeyShiftedHelp) + , (E.KEY_SHOME, KeyShiftedHome) + , (E.KEY_SIC, KeyShiftedInsertCharacter) + , (E.KEY_SLEFT, KeyShiftedLeftArrow) + , (E.KEY_SMESSAGE, KeyShiftedMessage) + , (E.KEY_SMOVE, KeyShiftedMove) + , (E.KEY_SNEXT, KeyShiftedNext) + , (E.KEY_SOPTIONS, KeyShiftedOptions) + , (E.KEY_SPREVIOUS, KeyShiftedPrevious) + , (E.KEY_SPRINT, KeyShiftedPrint) + , (E.KEY_SREDO, KeyShiftedRedo) + , (E.KEY_SREPLACE, KeyShiftedReplace) + , (E.KEY_SRIGHT, KeyShiftedRightArrow) + , (E.KEY_SRSUME, KeyShiftedResume) + , (E.KEY_SSAVE, KeyShiftedSave) + , (E.KEY_SSUSPEND, KeyShiftedSuspend) + , (E.KEY_SUNDO, KeyShiftedUndo) + , (E.KEY_SUSPEND, KeySuspend) + , (E.KEY_UNDO, KeyUndo) + ] + +-- }}} + +-- Mouse events {{{ + +data ButtonState + = ButtonPressed + | ButtonReleased + | ButtonClicked + | ButtonDoubleClicked + | ButtonTripleClicked + deriving (Show, Eq) + +data MouseState = MouseState + { mouseCoordinates :: (Integer, Integer, Integer) -- ^ (X, Y, Z) + + -- | If the mouse event was caused by a change in button state, + -- the buttons and their new state will be listed here. + , mouseButtons :: [(Integer, ButtonState)] + + , mouseAlt :: Bool + , mouseShift :: Bool + , mouseControl :: Bool + } + deriving (Show, Eq) + +parseMouseState :: MMaskT -> MouseState +parseMouseState mask = MouseState (0, 0, 0) buttons alt shift ctrl where + maskI = toInteger mask + test e = (maskI .&. (E.fromEnum e)) > 0 + + alt = test E.BUTTON_ALT + shift = test E.BUTTON_SHIFT + ctrl = test E.BUTTON_CTRL + + buttons = catMaybes [button1, button2, button3, button4, button5] + + testButton idx r p c dc tc + | test r = Just (idx, ButtonReleased) + | test p = Just (idx, ButtonPressed) + | test c = Just (idx, ButtonClicked) + | test dc = Just (idx, ButtonDoubleClicked) + | test tc = Just (idx, ButtonTripleClicked) + | otherwise = Nothing + + button1 = testButton 1 + E.BUTTON1_RELEASED + E.BUTTON1_PRESSED + E.BUTTON1_CLICKED + E.BUTTON1_DOUBLE_CLICKED + E.BUTTON1_TRIPLE_CLICKED + button2 = testButton 2 + E.BUTTON2_RELEASED + E.BUTTON2_PRESSED + E.BUTTON2_CLICKED + E.BUTTON2_DOUBLE_CLICKED + E.BUTTON2_TRIPLE_CLICKED + button3 = testButton 3 + E.BUTTON3_RELEASED + E.BUTTON3_PRESSED + E.BUTTON3_CLICKED + E.BUTTON3_DOUBLE_CLICKED + E.BUTTON3_TRIPLE_CLICKED + button4 = testButton 4 + E.BUTTON4_RELEASED + E.BUTTON4_PRESSED + E.BUTTON4_CLICKED + E.BUTTON4_DOUBLE_CLICKED + E.BUTTON4_TRIPLE_CLICKED +#ifdef BUTTON5_RELEASED + button5 = testButton 5 + E.BUTTON5_RELEASED + E.BUTTON5_PRESSED + E.BUTTON5_CLICKED + E.BUTTON5_DOUBLE_CLICKED + E.BUTTON5_TRIPLE_CLICKED +#else + button5 = Nothing +#endif + +-- }}} + +-- }}} + +-- misc {{{ + +-- | Runs @raw()@ or @noraw()@ +setRaw :: Bool -> Curses () +setRaw set = Curses (io >>= checkRC "setRaw") where + io = if set then {# call raw #} else {# call noraw #} + +-- | Runs @cbreak()@ or @nocbreak()@ +setCBreak :: Bool -> Curses () +setCBreak set = Curses (io >>= checkRC "setCBreak") where + io = if set then {# call cbreak #} else {# call nocbreak #} + +-- | Runs @echo()@ or @noecho()@ +setEcho :: Bool -> Curses () +setEcho set = Curses (io >>= checkRC "setEcho") where + io = if set then {# call echo #} else {# call noecho #} + +-- | Get the output speed of the current terminal, in bits per second. +baudrate :: Curses Integer +baudrate = Curses $ do + rc <- {# call baudrate as c_baudrate #} + checkRC "baudrate" rc + return (toInteger rc) + +beep :: Curses () +beep = Curses ({# call beep as c_beep #} >>= checkRC "beep") + +flash :: Curses () +flash = Curses ({# call flash as c_flash #} >>= checkRC "flash") + +-- | Check if the terminal has a mouse +hasMouse :: Curses Bool +hasMouse = Curses (fmap cToBool c_hasMouse) + +foreign import ccall unsafe "hsncurses_has_mouse" + c_hasMouse :: IO CInt + +-- | Check if some position is contained within the given 'Window'. +enclosed :: Window + -> Integer -- ^ Row + -> Integer -- ^ Column + -> Curses Bool +enclosed win y x = Curses . fmap cToBool $ + {# call wenclose #} win (fromInteger y) (fromInteger x) + +-- | Return (rows, columns) of current screen +screenSize :: Curses (Integer, Integer) +screenSize = Curses $ do + rows <- peek c_LINES + cols <- peek c_COLS + return (toInteger rows, toInteger cols) + +foreign import ccall "static &LINES" + c_LINES :: Ptr CInt + +foreign import ccall "static &COLS" + c_COLS :: Ptr CInt + +-- | Set whether the entire window has been “touched”; +-- touched characters are redrawn on the next refresh. +setTouched :: Bool -> Update () +setTouched touched = withWindow_ "setTouched" $ if touched + then {# call touchwin #} + else {# call untouchwin #} + +-- | Set whether particular rows in the window have been +-- “touched”. +setRowsTouched :: Bool + -> Integer -- ^ Start + -> Integer -- ^ Count + -> Update () +setRowsTouched touched start count = withWindow_ "setRowsTouched" $ \win -> + {# call wtouchln #} win + (fromInteger start) + (fromInteger count) + (cFromBool touched) + +-- | Enable/disable support for special keys. +setKeypad :: Window -> Bool -> Curses () +setKeypad win set = Curses (io >>= checkRC "setKeypad") where + io = {# call keypad #} win (cFromBool set) + +getCursor :: Window -> Curses (Integer, Integer) +getCursor win = Curses $ do + row <- {# call getcury #} win + col <- {# call getcurx #} win + return (toInteger row, toInteger col) + +-- }}} + +-- Utility {{{ + +withWindow :: (Window -> IO a) -> Update a +withWindow io = Update (R.ReaderT (\win -> Curses (io win))) + +withWindow_ :: String -> (Window -> IO CInt) -> Update () +withWindow_ name io = withWindow $ \win -> io win >>= checkRC name + +-- }}} diff --git a/lib/UI/NCurses/Enums.chs b/lib/UI/NCurses/Enums.chs new file mode 100644 --- /dev/null +++ b/lib/UI/NCurses/Enums.chs @@ -0,0 +1,215 @@ +----------------------------------------------------------------------------- +-- Copyright (C) 2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . +----------------------------------------------------------------------------- +module UI.NCurses.Enums where + +-- this module is a hack to work around c2hs's lack of #define hooks. +-- the idea is to create a new class 'Enum' which uses 'Integer' instead +-- of 'Int', so integral defines of any size can be retrieved. +import Prelude (Integer, error, show, (++)) + +#define NCURSES_ENABLE_STDBOOL_H 0 +#define _XOPEN_SOURCE_EXTENDED +#define NCURSES_NOMACROS +#include + +class Enum a where + toEnum :: Integer -> a + fromEnum :: a -> Integer + +-- misc enums +#c +enum hsncurses_EnumWrapper +{ hsncurses_ALL_MOUSE_EVENTS = ALL_MOUSE_EVENTS +, hsncurses_ERR = ERR +}; +#endc + +{# enum hsncurses_EnumWrapper as EnumWrapper {} with prefix = "hsncurses_" #} + +-- attributes +#c +enum hsncurses_Attribute +{ hsncurses_WA_STANDOUT = WA_STANDOUT +, hsncurses_WA_UNDERLINE = WA_UNDERLINE +, hsncurses_WA_REVERSE = WA_REVERSE +, hsncurses_WA_BLINK = WA_BLINK +, hsncurses_WA_DIM = WA_DIM +, hsncurses_WA_BOLD = WA_BOLD +, hsncurses_WA_ALTCHARSET = WA_ALTCHARSET +, hsncurses_WA_INVIS = WA_INVIS +, hsncurses_WA_PROTECT = WA_PROTECT +}; +#endc + +{# enum hsncurses_Attribute as Attribute {} with prefix = "hsncurses_" #} + +-- colors +#c +enum hsncurses_Color +{ hsncurses_COLOR_BLACK = COLOR_BLACK +, hsncurses_COLOR_RED = COLOR_RED +, hsncurses_COLOR_GREEN = COLOR_GREEN +, hsncurses_COLOR_YELLOW = COLOR_YELLOW +, hsncurses_COLOR_BLUE = COLOR_BLUE +, hsncurses_COLOR_MAGENTA = COLOR_MAGENTA +, hsncurses_COLOR_CYAN = COLOR_CYAN +, hsncurses_COLOR_WHITE = COLOR_WHITE +}; +#endc + +{# enum hsncurses_Color as Color {} with prefix = "hsncurses_" #} + +-- keys +#c +enum hsncurses_Key +{ hsncurses_KEY_CODE_YES = KEY_CODE_YES +, hsncurses_KEY_DOWN = KEY_DOWN +, hsncurses_KEY_UP = KEY_UP +, hsncurses_KEY_LEFT = KEY_LEFT +, hsncurses_KEY_RIGHT = KEY_RIGHT +, hsncurses_KEY_HOME = KEY_HOME +, hsncurses_KEY_BACKSPACE = KEY_BACKSPACE +, hsncurses_KEY_F0 = KEY_F0 +, hsncurses_KEY_DL = KEY_DL +, hsncurses_KEY_IL = KEY_IL +, hsncurses_KEY_DC = KEY_DC +, hsncurses_KEY_IC = KEY_IC +, hsncurses_KEY_EIC = KEY_EIC +, hsncurses_KEY_CLEAR = KEY_CLEAR +, hsncurses_KEY_EOS = KEY_EOS +, hsncurses_KEY_EOL = KEY_EOL +, hsncurses_KEY_SF = KEY_SF +, hsncurses_KEY_SR = KEY_SR +, hsncurses_KEY_NPAGE = KEY_NPAGE +, hsncurses_KEY_PPAGE = KEY_PPAGE +, hsncurses_KEY_STAB = KEY_STAB +, hsncurses_KEY_CTAB = KEY_CTAB +, hsncurses_KEY_CATAB = KEY_CATAB +, hsncurses_KEY_ENTER = KEY_ENTER +, hsncurses_KEY_PRINT = KEY_PRINT +, hsncurses_KEY_LL = KEY_LL +, hsncurses_KEY_A1 = KEY_A1 +, hsncurses_KEY_A3 = KEY_A3 +, hsncurses_KEY_B2 = KEY_B2 +, hsncurses_KEY_C1 = KEY_C1 +, hsncurses_KEY_C3 = KEY_C3 +, hsncurses_KEY_BTAB = KEY_BTAB +, hsncurses_KEY_BEG = KEY_BEG +, hsncurses_KEY_CANCEL = KEY_CANCEL +, hsncurses_KEY_CLOSE = KEY_CLOSE +, hsncurses_KEY_COMMAND = KEY_COMMAND +, hsncurses_KEY_COPY = KEY_COPY +, hsncurses_KEY_CREATE = KEY_CREATE +, hsncurses_KEY_END = KEY_END +, hsncurses_KEY_EXIT = KEY_EXIT +, hsncurses_KEY_FIND = KEY_FIND +, hsncurses_KEY_HELP = KEY_HELP +, hsncurses_KEY_MARK = KEY_MARK +, hsncurses_KEY_MESSAGE = KEY_MESSAGE +, hsncurses_KEY_MOVE = KEY_MOVE +, hsncurses_KEY_NEXT = KEY_NEXT +, hsncurses_KEY_OPEN = KEY_OPEN +, hsncurses_KEY_OPTIONS = KEY_OPTIONS +, hsncurses_KEY_PREVIOUS = KEY_PREVIOUS +, hsncurses_KEY_REDO = KEY_REDO +, hsncurses_KEY_REFERENCE = KEY_REFERENCE +, hsncurses_KEY_REFRESH = KEY_REFRESH +, hsncurses_KEY_REPLACE = KEY_REPLACE +, hsncurses_KEY_RESTART = KEY_RESTART +, hsncurses_KEY_RESUME = KEY_RESUME +, hsncurses_KEY_SAVE = KEY_SAVE +, hsncurses_KEY_SBEG = KEY_SBEG +, hsncurses_KEY_SCANCEL = KEY_SCANCEL +, hsncurses_KEY_SCOMMAND = KEY_SCOMMAND +, hsncurses_KEY_SCOPY = KEY_SCOPY +, hsncurses_KEY_SCREATE = KEY_SCREATE +, hsncurses_KEY_SDC = KEY_SDC +, hsncurses_KEY_SDL = KEY_SDL +, hsncurses_KEY_SELECT = KEY_SELECT +, hsncurses_KEY_SEND = KEY_SEND +, hsncurses_KEY_SEOL = KEY_SEOL +, hsncurses_KEY_SEXIT = KEY_SEXIT +, hsncurses_KEY_SFIND = KEY_SFIND +, hsncurses_KEY_SHELP = KEY_SHELP +, hsncurses_KEY_SHOME = KEY_SHOME +, hsncurses_KEY_SIC = KEY_SIC +, hsncurses_KEY_SLEFT = KEY_SLEFT +, hsncurses_KEY_SMESSAGE = KEY_SMESSAGE +, hsncurses_KEY_SMOVE = KEY_SMOVE +, hsncurses_KEY_SNEXT = KEY_SNEXT +, hsncurses_KEY_SOPTIONS = KEY_SOPTIONS +, hsncurses_KEY_SPREVIOUS = KEY_SPREVIOUS +, hsncurses_KEY_SPRINT = KEY_SPRINT +, hsncurses_KEY_SREDO = KEY_SREDO +, hsncurses_KEY_SREPLACE = KEY_SREPLACE +, hsncurses_KEY_SRIGHT = KEY_SRIGHT +, hsncurses_KEY_SRSUME = KEY_SRSUME +, hsncurses_KEY_SSAVE = KEY_SSAVE +, hsncurses_KEY_SSUSPEND = KEY_SSUSPEND +, hsncurses_KEY_SUNDO = KEY_SUNDO +, hsncurses_KEY_SUSPEND = KEY_SUSPEND +, hsncurses_KEY_UNDO = KEY_UNDO +, hsncurses_KEY_MOUSE = KEY_MOUSE +, hsncurses_KEY_RESIZE = KEY_RESIZE +, hsncurses_KEY_EVENT = KEY_EVENT +}; +#endc + +{# enum hsncurses_Key as Key {} with prefix = "hsncurses_" #} + +-- mouse buttons +#c +enum hsncurses_Button +{ hsncurses_BUTTON_CTRL = BUTTON_CTRL +, hsncurses_BUTTON_SHIFT = BUTTON_SHIFT +, hsncurses_BUTTON_ALT = BUTTON_ALT + +, hsncurses_BUTTON1_RELEASED = BUTTON1_RELEASED +, hsncurses_BUTTON1_PRESSED = BUTTON1_PRESSED +, hsncurses_BUTTON1_CLICKED = BUTTON1_CLICKED +, hsncurses_BUTTON1_DOUBLE_CLICKED = BUTTON1_DOUBLE_CLICKED +, hsncurses_BUTTON1_TRIPLE_CLICKED = BUTTON1_TRIPLE_CLICKED + +, hsncurses_BUTTON2_RELEASED = BUTTON2_RELEASED +, hsncurses_BUTTON2_PRESSED = BUTTON2_PRESSED +, hsncurses_BUTTON2_CLICKED = BUTTON2_CLICKED +, hsncurses_BUTTON2_DOUBLE_CLICKED = BUTTON2_DOUBLE_CLICKED +, hsncurses_BUTTON2_TRIPLE_CLICKED = BUTTON2_TRIPLE_CLICKED + +, hsncurses_BUTTON3_RELEASED = BUTTON3_RELEASED +, hsncurses_BUTTON3_PRESSED = BUTTON3_PRESSED +, hsncurses_BUTTON3_CLICKED = BUTTON3_CLICKED +, hsncurses_BUTTON3_DOUBLE_CLICKED = BUTTON3_DOUBLE_CLICKED +, hsncurses_BUTTON3_TRIPLE_CLICKED = BUTTON3_TRIPLE_CLICKED + +, hsncurses_BUTTON4_RELEASED = BUTTON4_RELEASED +, hsncurses_BUTTON4_PRESSED = BUTTON4_PRESSED +, hsncurses_BUTTON4_CLICKED = BUTTON4_CLICKED +, hsncurses_BUTTON4_DOUBLE_CLICKED = BUTTON4_DOUBLE_CLICKED +, hsncurses_BUTTON4_TRIPLE_CLICKED = BUTTON4_TRIPLE_CLICKED + +#ifdef BUTTON5_RELEASED +, hsncurses_BUTTON5_RELEASED = BUTTON5_RELEASED +, hsncurses_BUTTON5_PRESSED = BUTTON5_PRESSED +, hsncurses_BUTTON5_CLICKED = BUTTON5_CLICKED +, hsncurses_BUTTON5_DOUBLE_CLICKED = BUTTON5_DOUBLE_CLICKED +, hsncurses_BUTTON5_TRIPLE_CLICKED = BUTTON5_TRIPLE_CLICKED +#endif +}; +#endc + +{# enum hsncurses_Button as Button {} with prefix = "hsncurses_" #} diff --git a/lib/UI/NCurses/Panel.chs b/lib/UI/NCurses/Panel.chs new file mode 100644 --- /dev/null +++ b/lib/UI/NCurses/Panel.chs @@ -0,0 +1,146 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- Copyright (C) 2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . +----------------------------------------------------------------------------- +-- | +-- Module: UI.NCurses.Panel +-- Copyright: 2010 John Millikin +-- License: GPL-3 +-- +-- Maintainer: jmillikin@gmail.com +-- Portability: portable (requires FFI) +-- +----------------------------------------------------------------------------- +module UI.NCurses.Panel + ( Panel + , newPanel + , deletePanel + , refreshPanels + , panelAbove + , panelBelow + , panelTop + , panelBottom + , showPanel + , hidePanel + , panelHidden + , movePanel + , raisePanel + , lowerPanel + , getPanelWindow + , replacePanelWindow + ) where +import Foreign +import Foreign.C +import UI.NCurses.Types + +-- for haddock +import UI.NCurses (render) + +#include + +{# pointer *PANEL as Panel nocode #} +{# pointer *WINDOW as Window nocode #} +newtype Panel = Panel { panelPtr :: Ptr Panel } + +-- | Creates a new 'Panel', on top of the panel stack. +newPanel :: Window -> Curses Panel +newPanel win = Curses $ do + p <- {# call new_panel #} win + if panelPtr p == nullPtr + then error "newPanel: new_panel() returned NULL" + else return p + +-- | Permanently removes the given panel from the panel stack. +deletePanel :: Panel -> Curses () +deletePanel p = Curses ({# call del_panel #} p >>= checkRC "deletePanel") + +-- | Updates windows to account for the current panel stack order. The user +-- must call 'render' before changes are drawn to the screen. +refreshPanels :: Curses () +refreshPanels = Curses {#call update_panels #} + +-- | @panelAbove p@ retrieve the panel above /p/. +panelAbove :: Panel -> Curses (Maybe Panel) +panelAbove p = Curses $ do + ptr <- {# call panel_above #} p + return $ if panelPtr ptr == nullPtr + then Nothing + else Just ptr + +-- | @panelAbove p@ retrieve the panel below /p/. +panelBelow :: Panel -> Curses (Maybe Panel) +panelBelow p = Curses $ do + ptr <- {# call panel_below #} p + return $ if panelPtr ptr == nullPtr + then Nothing + else Just ptr + +-- | Retrieve the top–most panel in the stack. +panelTop :: Curses (Maybe Panel) +panelTop = Curses $ do + ptr <- {# call panel_below #} (Panel nullPtr) + return $ if panelPtr ptr == nullPtr + then Nothing + else Just ptr + +-- | Retrieve the bottom–most panel in the stack. +panelBottom :: Curses (Maybe Panel) +panelBottom = Curses $ do + ptr <- {# call panel_above #} (Panel nullPtr) + return $ if panelPtr ptr == nullPtr + then Nothing + else Just ptr + +-- | Makes a hidden panel visible, and places it on the top of the stack. +showPanel :: Panel -> Curses () +showPanel p = Curses ({# call show_panel #} p >>= checkRC "showPanel") + +-- | Temporarily removes the given panel from the panel stack. Use +-- 'showPanel' to restore it. +hidePanel :: Panel -> Curses () +hidePanel p = Curses ({# call hide_panel #} p >>= checkRC "hidePanel") + +-- | Checks if the given panel is currently visible. +panelHidden :: Panel -> Curses Bool +panelHidden p = Curses (cToBool `fmap` {# call panel_hidden #} p) + +-- | Move the panel so its upper–left corner is at the new +-- coordinates. +movePanel :: Panel + -> Integer -- ^ New upper–left row + -> Integer -- ^ New upper–left column + -> Curses () +movePanel p row col = Curses $ + checkRC "movePanel" =<< {# call move_panel #} p + (fromInteger row) + (fromInteger col) + +-- | Raise a bottom to the top of the stack. +raisePanel :: Panel -> Curses () +raisePanel p = Curses ({# call top_panel #} p >>= checkRC "raisePanel") + +-- | Lower a panel to the bottom of the stack. +lowerPanel :: Panel -> Curses () +lowerPanel p = Curses ({# call bottom_panel #} p >>= checkRC "lowerPanel") + +-- | Retrieves which window a panel is drawn to. +getPanelWindow :: Panel -> Curses Window +getPanelWindow p = Curses ({# call panel_window #} p) + +-- | Replaces which window a panel is drawn to. +replacePanelWindow :: Panel -> Window -> Curses () +replacePanelWindow p win = Curses $ + {# call replace_panel #} p win >>= checkRC "replacePanelWindow" diff --git a/lib/UI/NCurses/Types.hs b/lib/UI/NCurses/Types.hs new file mode 100644 --- /dev/null +++ b/lib/UI/NCurses/Types.hs @@ -0,0 +1,85 @@ +----------------------------------------------------------------------------- +-- Copyright (C) 2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . +----------------------------------------------------------------------------- +module UI.NCurses.Types where +import qualified Control.Applicative as A +import Control.Monad (liftM, ap) +import Control.Monad.Fix (MonadFix, mfix) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Reader (ReaderT) +import qualified Foreign as F +import qualified Foreign.C as F +import qualified UI.NCurses.Enums as E + +-- newtype Curses {{{ + +-- | A small wrapper around 'IO', to ensure the @ncurses@ library is +-- initialized while running. +newtype Curses a = Curses { unCurses :: IO a } + +instance Monad Curses where + return = Curses . return + m >>= f = Curses (unCurses m >>= unCurses . f) + +instance MonadFix Curses where + mfix f = Curses (mfix (unCurses . f)) + +instance MonadIO Curses where + liftIO = Curses + +instance Functor Curses where + fmap = liftM + +instance A.Applicative Curses where + pure = return + (<*>) = ap + +-- }}} + +-- newtype Update {{{ + +newtype Update a = Update { unUpdate :: ReaderT Window Curses a } + +instance Monad Update where + return = Update . return + m >>= f = Update (unUpdate m >>= unUpdate . f) + +instance MonadFix Update where + mfix f = Update (mfix (unUpdate . f)) + +instance Functor Update where + fmap = liftM + +instance A.Applicative Update where + pure = return + (<*>) = ap + +-- }}} + +newtype Window = Window { windowPtr :: F.Ptr Window } + +checkRC :: String -> F.CInt -> IO () +checkRC name rc = if toInteger rc == E.fromEnum E.ERR + then error $ name ++ ": rc == ERR" + else return () + +cToBool :: Integral a => a -> Bool +cToBool 0 = False +cToBool _ = True + +cFromBool :: Integral a => Bool -> a +cFromBool False = 0 +cFromBool True = 1 diff --git a/ncurses.cabal b/ncurses.cabal --- a/ncurses.cabal +++ b/ncurses.cabal @@ -1,40 +1,79 @@ name: ncurses -version: 0.2 -synopsis: Modernised bindings to GNU ncurses +version: 0.2.1 license: GPL-3 license-file: license.txt author: John Millikin -maintainer: jmillikin@gmail.com -copyright: Copyright (c) John Millikin 2010 +maintainer: John Millikin build-type: Simple -cabal-version: >=1.6 +cabal-version: >= 1.6 category: User Interfaces, Foreign stability: experimental +homepage: https://john-millikin.com/software/haskell-ncurses/ bug-reports: mailto:jmillikin@gmail.com -homepage: http://john-millikin.com/software/bindings/ncurses/ -tested-with: GHC==6.12.1 -extra-source-files: hsncurses-shim.h +synopsis: Modernised bindings to GNU ncurses +description: + GNU ncurses is a library for creating command-line application with + pseudo-graphical interfaces. This package is a nice, modern binding + to GNU ncurses. + . + The following example is a program that display the message + \"Hello world!\" until the user hits Q: + . + @ + import UI.NCurses + . + main :: IO () + main = runCurses $ do + setEcho False + w <- defaultWindow + updateWindow w $ do + moveCursor 1 10 + drawString \"Hello world!\" + moveCursor 3 10 + drawString \"(press q to quit)\" + moveCursor 0 0 + render + waitFor w (\ev -> ev == EventCharacter \'q\' || ev == EventCharacter \'Q\') + . + waitFor :: Window -> (Event -> Bool) -> Curses () + waitFor w p = loop where + loop = do + ev <- getEvent w Nothing + case ev of + Nothing -> loop + Just ev' -> if p ev' then return () else loop + @ + +extra-source-files: + cbits/hsncurses-shim.c + cbits/hsncurses-shim.h + source-repository head type: bazaar - location: http://john-millikin.com/software/bindings/ncurses/ + location: https://john-millikin.com/branches/haskell-ncurses/0.2/ +source-repository head + type: bazaar + location: https://john-millikin.com/branches/haskell-ncurses/0.2/ + tag: haskell-ncurses_0.2.1 + library - ghc-options: -Wall + hs-source-dirs: lib + ghc-options: -Wall -O2 build-depends: - base >= 4 && < 5 - , containers >= 0.2 && < 0.5 - , text >= 0.7 && < 0.12 - , transformers >= 0.2 && < 0.3 + base >= 4.0 && < 5.0 + , containers >= 0.2 + , text >= 0.7 + , transformers >= 0.2 build-tools: c2hs >= 0.15 extra-libraries: panel ncursesw - c-sources: hsncurses-shim.c - include-dirs: . + c-sources: cbits/hsncurses-shim.c exposed-modules: UI.NCurses