{-# LANGUAGE ForeignFunctionInterface #-} -- Turn off the unused-binds warning because we can't avoid having an -- unused "WINDOW" constructor. We need a WINDOW type in order to have -- a unique Ptr type for WINDOWptr, but we never actually construct a -- WINDOW in Haskell because that is done by the curses library. #include module Curses ( CursesWindow, init_curses, exit_curses, raw_mode, cooked_mode, get_key, update_screen, clear_screen, -- Does not actually clear the screen until next update screen_size, flash ) where import Foreign import Foreign.C import System.IO import System.IO.Unsafe import Color import Glyph import BoxChar import Keys import Window data WINDOW = WINDOW type WINDOWptr = Ptr WINDOW type CBool = #type bool type ChType = #type chtype cTRUE, cFALSE :: CBool cTRUE = #const TRUE cFALSE = #const FALSE -- Initialize terminal or abort program with error message. -- Returns a pointer to stdscr. foreign import ccall unsafe "curses.h" initscr :: IO WINDOWptr -- Initialize color support foreign import ccall unsafe "curses.h" start_color :: IO CInt -- Allow 8-bit input. Return ERR for failure. Ignores window argument. foreign import ccall unsafe "curses.h" meta :: WINDOWptr -> CBool -> IO CInt -- Disable line buffering and erase/kill character processing -- Disable interrupt, quit, suspend, and flow control characters (read -- them as normal input, instead). Return ERR for failure. foreign import ccall unsafe "curses.h" raw :: IO CInt -- Undo raw mode. Return ERR for failure. foreign import ccall unsafe "curses.h" noraw :: IO CInt -- Don't echo typed characters. Return ERR for failure. foreign import ccall unsafe "curses.h" noecho :: IO CInt -- Echo characters as they are typed. Return ERR for failure. foreign import ccall unsafe "curses.h" echo :: IO CInt -- Don't bother to convert newline to CR LF, either on input or output. -- Always return OK. foreign import ccall unsafe "curses.h" nonl :: IO CInt -- Undo nonl. Always return OK. foreign import ccall unsafe "curses.h" nl :: IO CInt -- Don't discard pending output when an interrupt is received. -- Return ERR for failure. Ignores window argument. foreign import ccall unsafe "curses.h" intrflush :: WINDOWptr -> CBool -> IO CInt -- Interpret function keys, instead of passing through raw escape sequences. -- Return ERR for failure. Window argument should be the same one that -- is used to get keys. foreign import ccall unsafe "curses.h" keypad :: WINDOWptr -> CBool -> IO CInt -- Restore tty mode to what it was before initscr. -- Returns ERR for failure. foreign import ccall unsafe "curses.h" endwin :: IO CInt -- Initialize a color pair. Return ERR for failure. -- Arguments: pair number, foreground, background foreign import ccall unsafe "curses.h" init_pair :: CShort -> CShort -> CShort -> IO CInt -- Create a new text window. -- Arguments: nlines, ncols, begin_y, begin_x -- Returns window pointer, or NULL for failure. foreign import ccall unsafe "curses.h" newwin :: CInt -> CInt -> CInt -> CInt -> IO WINDOWptr -- Destroy a window buffer. Returns ERR for failure. foreign import ccall unsafe "curses.h" delwin :: WINDOWptr -> IO CInt -- Set attribute to use for subsequent addstr and addch calls for this window. -- Return value is unspecified. -- The function name is converted to xwattrset so that the curses wrapper -- can adjust the macro expansion. (wattrset expects a WINDOW *, but FFI -- only supplies a void *). foreign import ccall unsafe "curses_wrapper.h xwattrset" wattrset :: WINDOWptr -> CInt -> IO CInt -- Output a string to a window. Return ERR for failure. foreign import ccall unsafe "curses.h" waddstr :: WINDOWptr -> CString -> IO CInt -- Put a character in a window. Return ERR for failure. foreign import ccall unsafe "curses.h" mvwaddch :: WINDOWptr -> CInt -> CInt -> ChType -> IO CInt -- Move the cursor into a window. Return ERR for failure. foreign import ccall unsafe "curses.h" wmove :: WINDOWptr -> CInt -> CInt -> IO CInt -- Wrappers around getyx, which does not follow normal rules for a C function. foreign import ccall unsafe "curses_wrapper.h" getx :: WINDOWptr -> IO CInt foreign import ccall unsafe "curses_wrapper.h" gety :: WINDOWptr -> IO CInt -- Wrappers around getmaxyx, idem. getmaxyx is misnamed, it returns sizes. foreign import ccall unsafe "curses_wrapper.h" getmax_x :: WINDOWptr -> IO CInt foreign import ccall unsafe "curses_wrapper.h" getmax_y :: WINDOWptr -> IO CInt -- Mark an entire window as "touched" so that it will be refreshed by -- the next wrefresh call. This is needed when exposing overlapped windows. -- Return ERR for failure. foreign import ccall unsafe "curses_wrapper.h xtouchwin" touchwin :: WINDOWptr -> IO CInt -- Clear a window. Always returns OK. foreign import ccall unsafe "curses.h" werase :: WINDOWptr -> IO CInt -- Display a window on the screen. Return ERR for failure. foreign import ccall unsafe "curses.h" wrefresh :: WINDOWptr -> IO CInt -- Copy a window to curscr, in preparation for doupdate. -- Return ERR for failure. foreign import ccall unsafe "curses.h" wnoutrefresh :: WINDOWptr -> IO CInt -- Display the contents of the current screen image on the terminal. -- Return ERR for failure. foreign import ccall unsafe "curses.h" doupdate :: IO CInt -- Read an input character. We use this instead of getChar because -- it respects the raw and keypad modes. foreign import ccall unsafe "curses.h" getch :: IO CInt foreign import ccall unsafe "curses.h flash" c_flash :: IO CInt foreign import ccall unsafe "curses.h & stdscr" stdscrp :: Ptr WINDOWptr -- The next time this window is refreshed, clear the screen first. -- Always returns OK. foreign import ccall unsafe "curses.h" clearok :: WINDOWptr -> CBool -> IO CInt -- == Utility functions == -- color_to_attr :: Color -> CInt color_to_attr Text = #const COLOR_PAIR(0) color_to_attr Black = #const COLOR_PAIR(1) color_to_attr Blue = #const COLOR_PAIR(2) color_to_attr Green = #const COLOR_PAIR(3) color_to_attr Cyan = #const COLOR_PAIR(4) color_to_attr Red = #const COLOR_PAIR(5) color_to_attr Magenta = #const COLOR_PAIR(6) color_to_attr Brown = #const COLOR_PAIR(7) color_to_attr LightGrey = #const COLOR_PAIR(8) -- Adding A_BOLD to a color will brighten it on nearly all terminals. color_to_attr DarkGrey = #const COLOR_PAIR(9) | A_BOLD color_to_attr LightBlue = #const COLOR_PAIR(2) | A_BOLD color_to_attr LightGreen = #const COLOR_PAIR(3) | A_BOLD color_to_attr LightCyan = #const COLOR_PAIR(4) | A_BOLD color_to_attr LightRed = #const COLOR_PAIR(5) | A_BOLD color_to_attr LightMagenta = #const COLOR_PAIR(6) | A_BOLD color_to_attr Yellow = #const COLOR_PAIR(7) | A_BOLD color_to_attr White = #const COLOR_PAIR(8) | A_BOLD init_colors :: IO () init_colors = do init_pair 1 black white init_pair 2 blue black init_pair 3 green black init_pair 4 cyan black init_pair 5 red black init_pair 6 magenta black init_pair 7 yellow black init_pair 8 white black init_pair 9 black black -- Intended for use with A_BOLD return () where black = #const COLOR_BLACK blue = #const COLOR_BLUE green = #const COLOR_GREEN cyan = #const COLOR_CYAN red = #const COLOR_RED magenta = #const COLOR_MAGENTA yellow = #const COLOR_YELLOW white = #const COLOR_WHITE -- == Exported functions start here == -- init_curses :: IO () init_curses = do stdscr <- initscr -- initscr does its own error checking and may abort. -- FIXME: fall back on something if color is not available start_color init_colors -- No error checking from here on. If these calls fail then the best -- action is to simply ignore the feature. meta nullPtr cTRUE keypad stdscr cTRUE -- Get rid of the stored clear-screen for stdscr. We only use separate -- windows, and without this the first refresh will paint the blank -- stdscr over our windows. wrefresh stdscr return () -- FIXME: Figure out whether to check for errors in raw_mode and -- cooked_mode, and if so, what to do about them. raw_mode :: IO () raw_mode = do raw noecho nonl intrflush nullPtr cFALSE return () cooked_mode :: IO () cooked_mode = do noraw echo nl return () exit_curses :: IO () exit_curses = do endwin -- FIXME: Print a warning if endwin failed. return () newtype CursesWindow = CW_ WINDOWptr instance Window CursesWindow where new_window (left, top) (right, bottom) = do let begin_y = fromIntegral top begin_x = fromIntegral left height = fromIntegral (bottom - top + 1) width = fromIntegral (right - left + 1) w <- throwIfNull "Could not allocate new window buffer" (newwin height width begin_y begin_x) return (CW_ w) window_size (CW_ w) = unsafePerformIO $ do x <- getmax_x w y <- getmax_y w return (fromIntegral x, fromIntegral y) refresh_window (CW_ w) = do wnoutrefresh w return () destroy_window (CW_ w) = do delwin w return () touch_window (CW_ w) = do touchwin w return () clear_window (CW_ w) = do werase w return () move_cursor (CW_ w) (x, y) = do wmove w (fromIntegral y) (fromIntegral x) return () get_cursor_position (CW_ w) = do x <- getx w y <- gety w return (fromIntegral x, fromIntegral y) instance TextWindow CursesWindow where write_string (CW_ w) col str = do wattrset w (color_to_attr col) withCString str (waddstr w) return () instance GlyphWindow CursesWindow where write_glyph (CW_ w) (x, y) (Glyph col ch) = do wattrset w (color_to_attr col) c <- ch_to_chtype ch mvwaddch w (fromIntegral y) (fromIntegral x) c return () -- Special line-drawing characters. The Curses definitions are awkward, -- because they look like compile-time constants, but are really expressions. -- Fortunately most of them are also in Unicode, so that we can export -- them as the appropriate Char, and translate to the correct expression here. foreign import ccall unsafe "curses.h & ACS_ULCORNER" acs_ulcorner :: Ptr ChType foreign import ccall unsafe "curses.h & ACS_LLCORNER" acs_llcorner :: Ptr ChType foreign import ccall unsafe "curses.h & ACS_URCORNER" acs_urcorner :: Ptr ChType foreign import ccall unsafe "curses.h & ACS_LRCORNER" acs_lrcorner :: Ptr ChType foreign import ccall unsafe "curses.h & ACS_LTEE" acs_ltee :: Ptr ChType foreign import ccall unsafe "curses.h & ACS_RTEE" acs_rtee :: Ptr ChType foreign import ccall unsafe "curses.h & ACS_BTEE" acs_btee :: Ptr ChType foreign import ccall unsafe "curses.h & ACS_TTEE" acs_ttee :: Ptr ChType foreign import ccall unsafe "curses.h & ACS_HLINE" acs_hline :: Ptr ChType foreign import ccall unsafe "curses.h & ACS_VLINE" acs_vline :: Ptr ChType foreign import ccall unsafe "curses.h & ACS_PLUS" acs_plus :: Ptr ChType foreign import ccall unsafe "curses.h & ACS_DIAMOND" acs_diamond :: Ptr ChType foreign import ccall unsafe "curses.h & ACS_BULLET" acs_bullet :: Ptr ChType foreign import ccall unsafe "curses.h & ACS_LARROW" acs_larrow :: Ptr ChType foreign import ccall unsafe "curses.h & ACS_RARROW" acs_rarrow :: Ptr ChType foreign import ccall unsafe "curses.h & ACS_DARROW" acs_darrow :: Ptr ChType foreign import ccall unsafe "curses.h & ACS_UARROW" acs_uarrow :: Ptr ChType foreign import ccall unsafe "curses.h & ACS_BOARD" acs_board :: Ptr ChType foreign import ccall unsafe "curses.h & ACS_BLOCK" acs_block :: Ptr ChType -- Still missing: -- S1 -- S9 -- CKBOARD -- DEGREE -- PLMINUS -- BOARD -- LANTERN -- BLOCK ch_to_chtype :: Char -> IO ChType ch_to_chtype c | c == ch_ulcorner = peek acs_ulcorner | c == ch_llcorner = peek acs_llcorner | c == ch_urcorner = peek acs_urcorner | c == ch_lrcorner = peek acs_lrcorner | c == ch_ltee = peek acs_ltee | c == ch_rtee = peek acs_rtee | c == ch_btee = peek acs_btee | c == ch_ttee = peek acs_ttee | c == ch_hline = peek acs_hline | c == ch_vline = peek acs_vline | c == ch_plus = peek acs_plus | c == ch_diamond = peek acs_diamond | c == ch_bullet = peek acs_bullet | c == ch_larrow = peek acs_larrow | c == ch_rarrow = peek acs_rarrow | c == ch_darrow = peek acs_darrow | c == ch_uarrow = peek acs_uarrow | c == ch_board = peek acs_board | c == ch_block = peek acs_block ch_to_chtype c = return (fromIntegral (fromEnum c)) get_key :: IO Key get_key = do update_screen ch <- getch return (trans_key (fromIntegral ch)) trans_key :: Int -> Key trans_key #{const KEY_UP} = Key_UP trans_key #{const KEY_DOWN} = Key_DOWN trans_key #{const KEY_LEFT} = Key_LEFT trans_key #{const KEY_RIGHT} = Key_RIGHT trans_key #{const KEY_BACKSPACE} = Key_BACKSPACE trans_key #{const KEY_DC} = Key_DEL trans_key #{const KEY_HOME} = Key_HOME trans_key #{const KEY_END} = Key_END trans_key #{const KEY_NPAGE} = Key_NPAGE trans_key #{const KEY_PPAGE} = Key_PPAGE trans_key #{const KEY_ENTER} = Key_ENTER trans_key #{const KEY_A1} = Key_UPLEFT trans_key #{const KEY_A3} = Key_UPRIGHT trans_key #{const KEY_B2} = Key_CENTER trans_key #{const KEY_C1} = Key_DOWNLEFT trans_key #{const KEY_C3} = Key_DOWNRIGHT trans_key ch | ch >= minChar && ch <= maxChar = Key (toEnum ch) where minChar = fromEnum (minBound :: Char) maxChar = fromEnum (maxBound :: Char) trans_key _ = NoKey update_screen :: IO () update_screen = do doupdate return () -- Clear the screen by refreshing stdscr. Since we don't use stdscr itself, -- it's always blank. clear_screen :: IO () clear_screen = do stdscr <- peek stdscrp clearok stdscr cTRUE wnoutrefresh stdscr return () screen_size :: IO (Int, Int) screen_size = do stdscr <- peek stdscrp x <- getmax_x stdscr y <- getmax_y stdscr return (fromIntegral x, fromIntegral y) flash :: IO () flash = do c_flash return ()