--
-- 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,
--
-- attrs dont work with Irix curses.h. This should be fixed.
--
#include "utils.h"
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,
#ifdef KEY_RESIZE
keyResize,
#endif
-- * 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
#if HAVE_SIGNAL_H
# include
#endif
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
#ifdef SIGWINCH
import System.Posix.Signals (installHandler, Signal, Handler(Catch))
#endif
--
-- 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
#ifdef SIGWINCH
-- does this still work?
installHandler cursesSigWinch (Catch fn) Nothing >> return ()
#endif
-- | 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 (== (#const ERR))
{-# 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 -> (#type bool) -> IO CInt
-- |> 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 -> (#type bool) -> IO CInt
--
-- |> 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 -> (#type bool) -> IO CInt
------------------------------------------------------------------------
-- | 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.
--
#if defined(HAVE_USE_DEFAULT_COLORS)
foreign import ccall unsafe "use_default_colors"
useDefaultColors :: IO ()
#else
useDefaultColors :: IO ()
useDefaultColors = return ()
#endif
------------------------------------------------------------------------
--
-- |> 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 (#type bool)
--
-- | 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
#if defined(HAVE_USE_DEFAULT_COLORS)
color "default" = Just $ Color (-1)
#endif
color "black" = Just $ Color (#const COLOR_BLACK)
color "red" = Just $ Color (#const COLOR_RED)
color "green" = Just $ Color (#const COLOR_GREEN)
color "yellow" = Just $ Color (#const COLOR_YELLOW)
color "blue" = Just $ Color (#const COLOR_BLUE)
color "magenta" = Just $ Color (#const COLOR_MAGENTA)
color "cyan" = Just $ Color (#const COLOR_CYAN)
color "white" = Just $ Color (#const COLOR_WHITE)
color _ = Just $ Color (#const COLOR_BLACK) -- NB
--
-- |> 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 ,
-- > 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 (#const A_NORMAL)
setBold :: Attr -> Bool -> Attr
setBold = setAttr (Attr #const A_BOLD)
setReverse :: Attr -> Bool -> Attr
setReverse = setAttr (Attr #const A_REVERSE)
-- | 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)
------------------------------------------------------------------------
#let translate_attr attr = \
"(if a .&. %lu /= 0 then %lu else 0) .|.", \
(unsigned long) A_##attr, (unsigned long) A_##attr
bkgrndSet :: Attr -> Pair -> IO ()
bkgrndSet (Attr a) (Pair p) = bkgdset $
fi (ord ' ') .|.
#translate_attr ALTCHARSET
#translate_attr BLINK
#translate_attr BOLD
#translate_attr DIM
#translate_attr INVIS
#translate_attr PROTECT
#translate_attr REVERSE
#translate_attr STANDOUT
#translate_attr UNDERLINE
colorPair p
foreign import ccall unsafe "get_color_pair"
colorPair :: Int -> (#type chtype)
foreign import ccall unsafe bkgdset :: (#type chtype) -> IO ()
------------------------------------------------------------------------
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 (#const KEY_DOWN)
keyUp :: Char
keyUp = chr (#const KEY_UP)
keyLeft :: Char
keyLeft = chr (#const KEY_LEFT)
keyRight :: Char
keyRight = chr (#const KEY_RIGHT)
keyHome :: Char
keyHome = chr (#const KEY_HOME)
keyBackspace :: Char
keyBackspace = chr (#const KEY_BACKSPACE)
keyNPage :: Char
keyNPage = chr (#const KEY_NPAGE)
keyPPage :: Char
keyPPage = chr (#const KEY_PPAGE)
keyEnd :: Char
keyEnd = chr (#const KEY_END)
#ifdef KEY_RESIZE
-- ncurses sends this
keyResize :: Char
keyResize = chr (#const KEY_RESIZE)
#endif
-- ---------------------------------------------------------------------
-- 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
(#const ERR) -> yield >> getCh
x -> return $ decodeKey x
------------------------------------------------------------------------
#ifdef SIGWINCH
cursesSigWinch :: Signal
cursesSigWinch = #const SIGWINCH
#endif