diff --git a/cbits/hsncurses-shim.c b/cbits/hsncurses-shim.c --- a/cbits/hsncurses-shim.c +++ b/cbits/hsncurses-shim.c @@ -37,3 +37,12 @@ pthread_sigmask(SIG_SETMASK, &old_mask, NULL); return rc; } + +void hsncurses_init_cchar_t(cchar_t *wch, attr_t attr, wchar_t *chars, size_t chars_len) { + size_t ii; + memset(wch, 0, sizeof(cchar_t)); + wch->attr = attr; + for (ii = 0; ii < chars_len && ii < CCHARW_MAX; ii++) { + wch->chars[ii] = chars[ii]; + } +} diff --git a/cbits/hsncurses-shim.h b/cbits/hsncurses-shim.h --- a/cbits/hsncurses-shim.h +++ b/cbits/hsncurses-shim.h @@ -17,4 +17,6 @@ int hsncurses_wget_wch(WINDOW *, wint_t *); +void hsncurses_init_cchar_t(cchar_t *wch, attr_t attr, wchar_t *chars, size_t chars_len); + #endif diff --git a/lib/UI/NCurses.chs b/lib/UI/NCurses.chs --- a/lib/UI/NCurses.chs +++ b/lib/UI/NCurses.chs @@ -30,18 +30,35 @@ , newWindow , closeWindow , cloneWindow + , moveWindow + , windowPosition + , resizeWindow + , windowSize + , updateWindow + -- ** Virtual windows (pads) + , Pad + , newPad + , closePad + , updatePad + + -- * The cursor + , moveCursor + , cursorPosition + , getCursor + -- * Drawing to the screen - , updateWindow , render - , moveCursor , setColor , drawString , drawText + , drawGlyph , drawBorder , drawBox , drawLineH , drawLineV + , clear + , clearLine , setBackground -- * Attributes @@ -130,7 +147,7 @@ , setTouched , setRowsTouched , setKeypad - , getCursor + , resizeTerminal ) where import Control.Exception (bracket_) @@ -166,23 +183,6 @@ #include "cbits/hsncurses-shim.h" --- Starting with version 0.18.1, c2hs changed the handling of get/set hooks --- when using newtype'd pointers: . --- --- Version 0.18.2 introduced the C2HS_MIN_VERSION macro to perform --- version detection: . --- --- Detecting version 0.18.1 is impractical, so we depend on a Cabal flag for --- users who need that particular version. -#if !defined(HSNCURSES_NEWTYPE_POINTER_HOOKS) -#if !defined(C2HS_MIN_VERSION) -#define C2HS_MIN_VERSION(mj,mn,rv) (mj<=0&&mn<=18&&rv<=0) -#endif -#if C2HS_MIN_VERSION(0,18,1) -#define HSNCURSES_NEWTYPE_POINTER_HOOKS -#endif -#endif - {# pointer *WINDOW as Window nocode #} {# pointer *cchar_t as CCharT newtype #} {# pointer *wchar_t as CWString nocode #} @@ -270,6 +270,106 @@ Curses ({# call wnoutrefresh #} win >>= checkRC "updateWindow") return a +-- | Moves the window to the given (row,column) coordinate. +moveWindow :: Integer -> Integer -> Update () +moveWindow row col = withWindow_ "moveWindow" $ \win -> + {# call mvwin #} win (fromInteger row) (fromInteger col) + +-- | Returns the current (row, column) coordinates of the window. +windowPosition :: Update (Integer, Integer) +windowPosition = withWindow $ \win -> do + row <- {# call getbegx #} win + col <- {# call getbegy #} win + return (toInteger row, toInteger col) + +-- | Resizes the window to the given row and column dimensions. +resizeWindow :: Integer -> Integer -> Update () +resizeWindow rows cols = withWindow_ "resizeWindow" $ \win -> + {# call wresize #} win (fromInteger rows) (fromInteger cols) + +-- Returns the current (row, column) dimensions of the window. +windowSize :: Update (Integer, Integer) +windowSize = withWindow $ \win -> do + rows <- {# call getmaxx #} win + cols <- {# call getmaxy #} win + return (toInteger rows, toInteger cols) + +-- | A Pad is a 'Window' that is not associated with the screen. +newtype Pad = Pad Window + +-- | Create a new 'Pad' with the given dimensions. +-- +-- When the pad is no longer needed, call 'closePad'. Pads are not +-- garbage–collected, because there’s no way to know if +-- they’re still in use. +newPad :: Integer -- ^ Rows + -> Integer -- ^ Columns + -> Curses Pad +newPad rows cols = Curses $ do + win <- {# call newpad #} + (fromInteger rows) + (fromInteger cols) + if windowPtr win == nullPtr + then error "newPad: newpad() returned NULL" + else do + void $ {# call keypad #} win 1 + void $ {# call meta #} win 1 + {# call wtimeout #} win (- 1) + return (Pad win) + +-- | Close a pad, and free all resources associated with it. Once a +-- pad has been closed, it is no longer safe to use. +closePad :: Pad -> Curses () +closePad (Pad win) = Curses ({# call delwin #} win >>= checkRC "closePad") + +updatePad :: Pad + -> Integer -- Top-most row of the pad's update region (pminrow). + -> Integer -- Left-most column of the pad's update region (pmincol). + -> Integer -- Top-most row of the screen's update region (sminrow). + -> Integer -- Left-most column of the screen's update region (smincol). + -> Integer -- Bottom-most row of the screen's update region (smaxrow). + -> Integer -- Right-most column of the screen's update region (smaxcol). + -> Update a + -> Curses a +updatePad (Pad win) pminrow pmincol sminrow smincol smaxrow smaxcol (Update reader) = do + a <- R.runReaderT reader win + Curses $ + ({# call pnoutrefresh #} win + (fromInteger pminrow) + (fromInteger pmincol) + (fromInteger sminrow) + (fromInteger smincol) + (fromInteger smaxrow) + (fromInteger smaxcol)) + >>= checkRC "updatePad" + return a + +-- | 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) + +-- | Returns the current (row,column) coordinates of the cursor. +-- +-- This is the same as 'getCursor', but is usable within an Update. +cursorPosition :: Update (Integer, Integer) +cursorPosition = withWindow $ \win -> do + row <- {# call getcurx #} win + col <- {# call getcury #} win + return (toInteger row, toInteger col) + +-- | Return current cursor position as (row, column). +-- +-- This is the same as 'cursorPosition', but is usable outside +-- of an Update. +getCursor :: Window -> Curses (Integer, Integer) +getCursor win = Curses $ do + row <- {# call getcury #} win + col <- {# call getcurx #} win + return (toInteger row, toInteger col) + -- | Re–draw any portions of the screen which have changed since the -- last render. render :: Curses () @@ -281,13 +381,6 @@ 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 -> @@ -298,6 +391,11 @@ drawText txt = withWindow_ "drawText" $ \win -> withCWString (T.unpack txt) ({# call waddwstr #} win) +drawGlyph :: Glyph -> Update () +drawGlyph glyph = withWindow_ "drawGlyph" $ \win -> + withGlyph glyph $ \pGlyph -> + {# call wadd_wch #} win pGlyph + -- | 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 @@ -311,14 +409,14 @@ -> 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 -> + withMaybeGlyph le $ \pLE -> + withMaybeGlyph re $ \pRE -> + withMaybeGlyph te $ \pTE -> + withMaybeGlyph be $ \pBE -> + withMaybeGlyph tl $ \pTL -> + withMaybeGlyph tr $ \pTR -> + withMaybeGlyph bl $ \pBL -> + withMaybeGlyph 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@ @@ -329,34 +427,50 @@ -- maximum character count. The cursor position is not changed. drawLineH :: Maybe Glyph -> Integer -> Update () drawLineH g n = withWindow_ "drawLineH" $ \win -> - withGlyph g $ \pChar -> + withMaybeGlyph 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 -> + withMaybeGlyph g $ \pChar -> {# call wvline_set #} win pChar (fromInteger n) +-- | Clear the window content by drawing blanks to every position. +clear :: Update () +clear = withWindow_ "clear" {# call wclear #} + +-- | Clear the current line starting from the current cursor position +-- (inclusive) to the end of the line. +clearLine :: Update () +clearLine = withWindow_ "clear" {# call wclrtoeol #} + -- | 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 -> + withMaybeGlyph (Just g) $ \pChar -> {# call wbkgrndset #} win pChar >> return 0 data Attribute - = AttributeStandout - | AttributeUnderline - | AttributeReverse - | AttributeBlink - | AttributeDim - | AttributeBold - | AttributeAltCharset - | AttributeInvisible - | AttributeProtect + = AttributeColor ColorID -- ^ A_COLOR + | AttributeStandout -- ^ A_STANDOUT + | AttributeUnderline -- ^ A_UNDERLINE + | AttributeReverse -- ^ A_REVERSE + | AttributeBlink -- ^ A_BLINK + | AttributeDim -- ^ A_DIM + | AttributeBold -- ^ A_BOLD + | AttributeAltCharset -- ^ A_ALTCHARSET + | AttributeInvisible -- ^ A_INVISIBLE + | AttributeProtect -- ^ A_PROTECT + | AttributeHorizontal -- ^ A_HORIZONTAL + | AttributeLeft -- ^ A_LEFT + | AttributeLow -- ^ A_LOW + | AttributeRight -- ^ A_RIGHT + | AttributeTop -- ^ A_TOP + | AttributeVertical -- ^ A_VERTICAL deriving (Show, Eq) attrEnum :: E.Attribute -> AttrT @@ -373,7 +487,17 @@ AttributeAltCharset -> attrEnum E.WA_ALTCHARSET AttributeInvisible -> attrEnum E.WA_INVIS AttributeProtect -> attrEnum E.WA_PROTECT + AttributeHorizontal -> attrEnum E.WA_HORIZONTAL + AttributeLeft -> attrEnum E.WA_LEFT + AttributeLow -> attrEnum E.WA_LOW + AttributeRight -> attrEnum E.WA_RIGHT + AttributeTop -> attrEnum E.WA_TOP + AttributeVertical -> attrEnum E.WA_VERTICAL + -- Colors get special handling: the function COLOR_PAIR converts an + -- NCURSES_PAIRS_T to an attr_t. + AttributeColor (ColorID cid) -> fromIntegral ({# call pure unsafe COLOR_PAIR as c_COLOR_PAIR #} (fromIntegral cid)) + -- | Set a single 'Attribute' on the current window. No other attributes -- are modified. setAttribute :: Attribute -> Bool -> Update () @@ -515,20 +639,16 @@ } deriving (Show, Eq) -withGlyph :: Maybe Glyph -> (CCharT -> IO a) -> IO a -withGlyph Nothing io = io (CCharT nullPtr) -withGlyph (Just (Glyph char attrs)) io = +withMaybeGlyph :: Maybe Glyph -> (CCharT -> IO a) -> IO a +withMaybeGlyph Nothing io = io (CCharT nullPtr) +withMaybeGlyph (Just g) io = withGlyph g io + +withGlyph :: Glyph -> (CCharT -> IO a) -> IO a +withGlyph (Glyph char attrs) io = let cAttrs = foldl' (\acc a -> acc .|. attrToInt a) 0 attrs in - + withCWStringLen [char] $ \(cChars, cCharsLen) -> allocaBytes {# sizeof cchar_t #} $ \pBuf -> do - void $ {# call memset #} (castPtr pBuf) 0 {# sizeof cchar_t #} -#ifdef HSNCURSES_NEWTYPE_POINTER_HOOKS - {# set cchar_t->attr #} (CCharT pBuf) cAttrs - {# set cchar_t->chars #} (CCharT pBuf) (wordPtrToPtr (fromIntegral (ord char))) -#else - {# set cchar_t->attr #} pBuf cAttrs - {# set cchar_t->chars #} pBuf (wordPtrToPtr (fromIntegral (ord char))) -#endif + {# call hsncurses_init_cchar_t #} (CCharT pBuf) cAttrs cChars (fromIntegral cCharsLen) io (CCharT pBuf) -- | Upper left corner @@ -669,9 +789,13 @@ -- | 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. +-- If the timeout is 'Nothing', @getEvent@ blocks until an event is received. +-- +-- If the timeout is specified, @getEvent@ blocks for up to that many +-- milliseconds. If no event is received before timing out, @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) @@ -1075,11 +1199,10 @@ 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) +-- | Attempt to resize the terminal to the given number of lines and columns. +resizeTerminal :: Integer -> Integer -> Curses () +resizeTerminal lines cols = Curses (io >>= checkRC "resizeTerminal") where + io = {# call resizeterm #} (fromInteger lines) (fromInteger cols) withWindow :: (Window -> IO a) -> Update a withWindow io = Update (R.ReaderT (\win -> Curses (io win))) diff --git a/lib/UI/NCurses/Enums.chs b/lib/UI/NCurses/Enums.chs --- a/lib/UI/NCurses/Enums.chs +++ b/lib/UI/NCurses/Enums.chs @@ -75,6 +75,12 @@ , hsncurses_WA_ALTCHARSET = WA_ALTCHARSET , hsncurses_WA_INVIS = WA_INVIS , hsncurses_WA_PROTECT = WA_PROTECT +, hsncurses_WA_HORIZONTAL = WA_HORIZONTAL +, hsncurses_WA_LEFT = WA_LEFT +, hsncurses_WA_LOW = WA_LOW +, hsncurses_WA_RIGHT = WA_RIGHT +, hsncurses_WA_TOP = WA_TOP +, hsncurses_WA_VERTICAL = WA_VERTICAL }; #endc diff --git a/ncurses.cabal b/ncurses.cabal --- a/ncurses.cabal +++ b/ncurses.cabal @@ -1,5 +1,5 @@ name: ncurses -version: 0.2.11 +version: 0.2.12 license: GPL-3 license-file: license.txt author: John Millikin @@ -57,7 +57,7 @@ source-repository this type: git location: https://john-millikin.com/code/haskell-ncurses/ - tag: haskell-ncurses_0.2.11 + tag: haskell-ncurses_0.2.12 -- Do not use default to using pkg-config to find ncurses libraries, because -- the .pc files are missing or broken in many installations. @@ -75,14 +75,6 @@ only useful on systems that have the ncursesw package installed incorrectly. On most systems this will cause compile- or run-time errors. -flag force-c2hs-newtype-pointer-hooks - default: False - manual: True - description: - Force using the newtype'd pointer hooks introduced in c2hs 0.18.1. This - is only necessary when building with c2hs==0.18.1, as 0.18.2 and later - can be auto-detected. - library hs-source-dirs: lib ghc-options: -Wall -O2 @@ -115,9 +107,6 @@ extra-libraries: panel ncurses pthread else extra-libraries: panelw ncursesw pthread - - if flag(force-c2hs-newtype-pointer-hooks) - cc-options: -DHSNCURSES_NEWTYPE_POINTER_HOOKS c-sources: cbits/hsncurses-shim.c