diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,12 @@ -1.4.2.0 (2015-02-12_ +1.5.0.0 (2025-01-19) + - Support for mouse events + - Support for 'newterm' and 'delscreen' + - Made debug logging usable for library users by compiling with the 'debug' + flag + - Replaced 'old-time' and 'old-locale' dependencies with just 'time' + - Tested GHC versions >=8.4 + +1.4.2.0 (2015-02-12) - support for werase and winsch (thanks to Ryan Newton) - add wnoutrefresh for more efficient updates of multiple windows (Ryan Newton) - use getmaxyx for scrSize, remove non-recommended approach of reading diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,72 +0,0 @@ - hscurses -- A Haskell Binding to ncurses - =+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+ - -hscurses is a Haskell binding to the ncurses library, a library of -functions that manage an application's display on character-cell -terminals. hscurses also provides some basic widgets implemented on -top of the ncurses binding, such as a text input widget and a table -widget. - -The hscurses library has been reported to work on Linux x86 using GHC -6.12.1, 7.0.3 and 7.2.1. - -Building and installing the hscurses library with GHC ------------------------------------------------------ - -Requirements: - -- GNU m4 -- GHC >= 6.8 -- ncurses - -Build and installation steps: - - runhaskell Setup.hs configure - runhaskell Setup.hs build - runhaskell Setup.hs install - -In order to generate the API documentation, you need haddock -(http://www.haskell.org/haddock). The command is then: - - runhaskell Setup.hs haddock - -Using the hscurses library: ---------------------------- - -Just add the flag `-package hscurses' to the compiler flags. At the -moment, user documentation is only available through Haddock API -documentation. - -Windows support: ----------------- - -Windows support relies on pdcurses (http://pdcurses.sourceforge.net/), -which is already packaged for MinGW -(http://sourceforge.net/projects/mingw/files/MinGW/PDCurses/PDCurses-3.4-1/) -and can be installed with mingw-get. - -Thanks to José Romildo Malaquias (malaquias@gmail.com) for porting -hscurses to the windows platform! - -Copyright: ----------- - - John Meacham , 2002-2004. - Tuomo Valkonen , 2004. - Don Stewart , 2004. - Stefan Wehr , 2004-2011. - -History: --------- - -John Meacham started the binding for his chat client Ginsu -(http://repetae.net/john/computer/ginsu/). - -Tuomo Valkonen integrated to code into Riot -(http://modeemi.fi/~tuomov/riot/), with minor modifications. - -Don Stewart improved the code for the Yi editor -(http://www.cse.unsw.edu.au/~dons/yi.html). - -Stefan Wehr turned the binding into a standalone library. He also -added some basic widgets. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,113 @@ +# hscurses -- A Haskell Binding to ncurses + +`hscurses` is a Haskell binding to the ncurses library, a library of functions +that manage an application's display on character-cell terminals. `hscurses` +also provides some basic widgets implemented on top of the `ncurses` binding, +such as a text input widget and a table widget. + +The `hscurses` library has been reported to work on Linux x86 using GHC 6.12.1, +7.0.3, 7.2.1, and GHC major versions starting from GHC 8.4. See the GitHub +actions for GHC versions that we actively test against. + +## Building the `hscurses` library + +Requirements: + +- `cabal-install` + GHC installation +- `ncurses` with headers + +Build: + + cabal build + +The repository contains a couple of example and testing applications in the +[example](./example) and [tests](./tests) directories. To run them, you have to +enable the `examples` Cabal flag; for instance: + + cabal run -f examples widget-test-edit + +or: + + cabal run -f examples contact-manager -- example/contacts + +In order to generate the API documentation, you need +[haddock](http://www.haskell.org/haddock). The command is then: + + cabal haddock + +## Building and installing the `hscurses` library (old) + +Requirements: + +- GNU `m4` +- GHC >= 6.8 +- `ncurses` with headers + +Build and installation steps: + + runhaskell Setup.hs configure + runhaskell Setup.hs build + runhaskell Setup.hs install + +In order to generate the API documentation, you need haddock +(http://www.haskell.org/haddock). The command is then: + + runhaskell Setup.hs haddock + +## Using the `hscurses` library + +Just add the package `hscurses` to your dependencies and make sure you have an +installation of `ncurses`. At the moment, user documentation is only available +through Haddock API documentation. + +For basic usage check out the code in the [example](./example) and +[./tests](tests) directories. + +### Debug logging + +`hscurses` ships with very basic logging functionality. The default behavior is +not to compile with support for this, but you can use the Cabal flag `debug` to +manually enable this. Logs will be written to `.hscurses.logs` in the directory +you're running the `cabal` command from. Example: + + cabal run -f examples -f debug contact-manager -- example/contacts + +## Windows support + +Windows support relies on [pdcurses](http://pdcurses.sourceforge.net/), which is +already [packaged for MinGW](http://sourceforge.net/projects/mingw/files/MinGW/PDCurses/PDCurses-3.4-1/) +and can be installed with `mingw-get`. + +Thanks to José Romildo Malaquias (malaquias@gmail.com) for porting `hscurses` to +the Windows platform! + +There is also a detailed installation instruction by +[Ilan Godik](https://medium.com/@NightRa): +https://medium.com/@NightRa/installing-hscurses-on-windows-830532d3268a + +## Development notes + +- We used [cabal-fmt](https://github.com/phadej/cabal-fmt) the cabal file(s). +- To consolidate the code style a tiny bit, the Haskell code formatter + [fourmolu](https://fourmolu.github.io/) was used; see + [its configuration](./fourmolu.yaml) for details. + +## Copyright + + John Meacham , 2002-2004. + Tuomo Valkonen , 2004. + Don Stewart , 2004. + Stefan Wehr , 2004-2011. + +## History + +John Meacham started the binding for his chat client +[Ginsu](http://repetae.net/john/computer/ginsu/). + +Tuomo Valkonen integrated to code into [Riot](http://modeemi.fi/~tuomov/riot/), +with minor modifications. + +Don Stewart improved the code for the [Yi editor](http://www.cse.unsw.edu.au/~dons/yi.html). + +Stefan Wehr turned the binding into a standalone library. He also added some +basic widgets. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMainWithHooks autoconfUserHooks diff --git a/UI/HSCurses/CWString.hsc b/UI/HSCurses/CWString.hsc --- a/UI/HSCurses/CWString.hsc +++ b/UI/HSCurses/CWString.hsc @@ -17,8 +17,7 @@ module UI.HSCurses.CWString ( - - -- * utf8 versions + -- utf8 versions withUTF8String, withUTF8StringLen, newUTF8String, @@ -26,7 +25,7 @@ peekUTF8String, peekUTF8StringLen, - -- * WChar stuff + -- WChar stuff #ifdef HAVE_WCHAR_H withCWString, withCWStringLen, @@ -39,19 +38,18 @@ CWString, CWStringLen, #endif - -- * Locale versions + + -- Locale versions withLCString, withLCStringLen, newLCString, newLCStringLen, peekLCStringLen, peekLCString, --- charIsRepresentable - - ) where +) where -import Data.Char ( ord, chr ) -import Data.Bits ( Bits((.|.), (.&.), shift) ) +import Data.Bits (Bits (shift, (.&.), (.|.))) +import Data.Char (chr, ord) import Foreign.C.String #if __GLASGOW_HASKELL__ < 603 @@ -87,54 +85,59 @@ -- support functions wNUL :: CWChar wNUL = 0 + #ifndef __GLASGOW_HASKELL__ + pairLength :: String -> CString -> CStringLen -pairLength = flip (,) . length +pairLength = flip (,) . length cwCharsToChars :: [CWChar] -> [Char] -cwCharsToChars xs = map castCWCharToChar xs +cwCharsToChars xs = map castCWCharToChar xs charsToCWChars :: [Char] -> [CWChar] -charsToCWChars xs = map castCharToCWChar xs +charsToCWChars xs = map castCharToCWChar xs #endif + -- __STDC_ISO_10646__ castCWCharToChar :: CWChar -> Char -castCWCharToChar ch = chr (fromIntegral ch ) +castCWCharToChar ch = chr (fromIntegral ch) castCharToCWChar :: Char -> CWChar castCharToCWChar ch = fromIntegral (ord ch) --- exported functions -peekCWString :: CWString -> IO String +peekCWString :: CWString -> IO String #ifndef __GLASGOW_HASKELL__ -peekCString cp = do cs <- peekArray0 wNUL cp; return (cwCharsToChars cs) +peekCString cp = do cs <- peekArray0 wNUL cp; return (cwCharsToChars cs) #else peekCWString cp = loop 0 where loop i = do val <- peekElemOff cp i - if val == wNUL then return [] else do - rest <- loop (i+1) - return (castCWCharToChar val : rest) + if val == wNUL + then return [] + else do + rest <- loop (i + 1) + return (castCWCharToChar val : rest) #endif -peekCWStringLen :: CWStringLen -> IO String +peekCWStringLen :: CWStringLen -> IO String #ifndef __GLASGOW_HASKELL__ -peekCWStringLen (cp, len) = do cs <- peekArray len cp; return (cwCharsToChars cs) +peekCWStringLen (cp, len) = do cs <- peekArray len cp; return (cwCharsToChars cs) #else peekCWStringLen (cp, len) = loop 0 where - loop i | i == len = return [] - | otherwise = do - val <- peekElemOff cp i - rest <- loop (i+1) - return (castCWCharToChar val : rest) + loop i + | i == len = return [] + | otherwise = do + val <- peekElemOff cp i + rest <- loop (i + 1) + return (castCWCharToChar val : rest) #endif newCWString :: String -> IO CWString #ifndef __GLASGOW_HASKELL__ -newCWString = newArray0 wNUL . charsToCWChars +newCWString = newArray0 wNUL . charsToCWChars #else newCWString str = do ptr <- mallocArray0 (length str) @@ -145,10 +148,12 @@ return ptr #endif -newCWStringLen :: String -> IO CWStringLen +newCWStringLen :: String -> IO CWStringLen #ifndef __GLASGOW_HASKELL__ -newCWStringLen str = do a <- newArray (charsToCWChars str) - return (pairLength str a) +newCWStringLen str = do + a <- newArray (charsToCWChars str) + return + (pairLength str a) #else newCWStringLen str = do ptr <- mallocArray0 len @@ -163,7 +168,7 @@ withCWString :: String -> (CWString -> IO a) -> IO a #ifndef __GLASGOW_HASKELL__ -withCWString = withArray0 wNUL . charsToCWChars +withCWString = withArray0 wNUL . charsToCWChars #else withCWString str f = allocaArray0 (length str) $ \ptr -> @@ -175,9 +180,9 @@ f ptr #endif -withCWStringLen :: String -> (CWStringLen -> IO a) -> IO a +withCWStringLen :: String -> (CWStringLen -> IO a) -> IO a #ifndef __GLASGOW_HASKELL__ -withCWStringLen str act = withArray (charsToCWChars str) $ act . pairLength str +withCWStringLen str act = withArray (charsToCWChars str) $ act . pairLength str #else withCWStringLen str f = allocaArray len $ \ptr -> @@ -197,72 +202,69 @@ wcharIsUnicode = False #endif -newtype MBState = MBState { _mbstate :: (Ptr MBState)} +newtype MBState = MBState {_mbstate :: (Ptr MBState)} withMBState :: (MBState -> IO a) -> IO a -withMBState act = allocaBytes (#const sizeof(mbstate_t)) (\mb -> c_memset mb 0 (#const sizeof(mbstate_t)) >> act (MBState mb)) +withMBState act = allocaBytes (# const sizeof (mbstate_t)) (\mb -> c_memset mb 0 (# const sizeof (mbstate_t)) >> act (MBState mb)) clearMBState :: MBState -> IO () -clearMBState (MBState mb) = c_memset mb 0 (#const sizeof(mbstate_t)) >> return () +clearMBState (MBState mb) = c_memset mb 0 (# const sizeof (mbstate_t)) >> return () wcsrtombs :: CWString -> (CString, CSize) -> IO CSize -wcsrtombs wcs (cs,len) = - alloca (\p -> - poke p wcs >> withMBState (\mb -> - wcsrtombs' p cs len mb)) - where - wcsrtombs' p cs' len' mb = do - x <- c_wcsrtombs cs p len' mb - case x of - -1 -> do - sp <- peek p - poke sp ((fi (ord '?'))::CWChar) - poke p wcs - clearMBState mb - wcsrtombs' p cs' len' mb - e | e >= 0 && e <= len' -> do - let ep = advancePtr cs' (fi e) - poke ep (fi (0::Int)) - return x - e -> error $ "HSCurses.CWString.wcsrtombs: impossible case: "++show e +wcsrtombs wcs (cs, len) = + alloca + ( \p -> + poke p wcs + >> withMBState + ( \mb -> + wcsrtombs' p cs len mb + ) + ) + where + wcsrtombs' p cs' len' mb = do + x <- c_wcsrtombs cs p len' mb + case x of + -1 -> do + sp <- peek p + poke sp ((fi (ord '?')) :: CWChar) + poke p wcs + clearMBState mb + wcsrtombs' p cs' len' mb + e | e >= 0 && e <= len' -> do + let ep = advancePtr cs' (fi e) + poke ep (fi (0 :: Int)) + return x + e -> error $ "HSCurses.CWString.wcsrtombs: impossible case: " ++ show e foreign import ccall unsafe hs_get_mb_cur_max :: IO Int mb_cur_max :: Int mb_cur_max = unsafePerformIO hs_get_mb_cur_max -{- -charIsRepresentable :: Char -> IO Bool -charIsRepresentable ch = fmap (/= -1) $ allocaBytes mb_cur_max (\cs -> c_wctomb cs (fi $ ord ch)) --} - -{- -foreign import ccall unsafe "stdlib.h wctomb" c_wctomb :: CString -> CWChar -> IO CInt --} - foreign import ccall unsafe "stdlib.h wcsrtombs" - c_wcsrtombs :: CString -> (Ptr (Ptr CWChar)) -> CSize -> MBState -> IO CSize + c_wcsrtombs :: CString -> (Ptr (Ptr CWChar)) -> CSize -> MBState -> IO CSize foreign import ccall unsafe "string.h memset" - c_memset :: Ptr a -> CInt -> CSize -> IO (Ptr a) + c_memset :: Ptr a -> CInt -> CSize -> IO (Ptr a) foreign import ccall unsafe "stdlib.h mbstowcs" - c_mbstowcs :: CWString -> CString -> CSize -> IO CSize - -mbstowcs :: CWString - -> Foreign.C.String.CString - -> Foreign.C.Types.CSize -> IO Foreign.C.Types.CSize + c_mbstowcs :: CWString -> CString -> CSize -> IO CSize +mbstowcs :: + CWString -> + Foreign.C.String.CString -> + Foreign.C.Types.CSize -> + IO Foreign.C.Types.CSize mbstowcs a b s = throwIf (== -1) (const "mbstowcs") $ c_mbstowcs a b s -peekLCString :: CString -> IO String -peekLCString cp = do +peekLCString :: CString -> IO String +peekLCString cp = do sz <- mbstowcs nullPtr cp 0 allocaArray (fi $ sz + 1) (\wcp -> mbstowcs wcp cp (sz + 1) >> peekCWString wcp) -- TODO fix for embeded NULs -peekLCStringLen :: CStringLen -> IO String -peekLCStringLen (cp, len) = allocaBytes (len + 1) $ \ncp -> do +peekLCStringLen :: CStringLen -> IO String +peekLCStringLen (cp, len) = allocaBytes (len + 1) $ \ncp -> do copyBytes ncp cp len pokeElemOff ncp len 0 peekLCString ncp @@ -273,45 +275,40 @@ cs <- mallocArray0 alen wcsrtombs wcs (cs, fi alen) return cs - - where alen = mb_cur_max * length s + where + alen = mb_cur_max * length s -newLCStringLen :: String -> IO CStringLen -newLCStringLen str = newLCString str >>= \cs -> return (pairLength1 str cs) +newLCStringLen :: String -> IO CStringLen +newLCStringLen str = newLCString str >>= \cs -> return (pairLength1 str cs) withLCString :: String -> (CString -> IO a) -> IO a withLCString s a = withCWString s $ \wcs -> allocaArray0 alen $ \cs -> - wcsrtombs wcs (cs,fi alen) >> a cs - - where alen = mb_cur_max * length s + wcsrtombs wcs (cs, fi alen) >> a cs + where + alen = mb_cur_max * length s withLCStringLen :: String -> (CStringLen -> IO a) -> IO a withLCStringLen s a = withCWString s $ \wcs -> allocaArray0 alen $ \cs -> do - sz <- wcsrtombs wcs (cs,fi alen) - a (cs,fi sz) - - where alen = mb_cur_max * length s + sz <- wcsrtombs wcs (cs, fi alen) + a (cs, fi sz) + where + alen = mb_cur_max * length s pairLength1 :: String -> CString -> CStringLen -pairLength1 = flip (,) . length +pairLength1 = flip (,) . length #else -- ----------------------------------------------------------- -- no CF_WCHAR_SUPPORT (OpenBSD) -{- -charIsRepresentable :: Char -> IO Bool -charIsRepresentable ch = return $ isLatin1 ch --} - withLCString :: String -> (Foreign.C.String.CString -> IO a) -> IO a withLCString = withCString -withLCStringLen :: String -> (Foreign.C.String.CStringLen -> IO a) -> IO a +withLCStringLen :: String -> (Foreign.C.String.CStringLen -> IO a) -> IO a withLCStringLen = withCStringLen newLCString :: String -> IO Foreign.C.String.CString @@ -356,31 +353,42 @@ toUTF :: String -> String toUTF [] = [] -toUTF (x:xs) | ord x<=0x007F = x:toUTF xs - | ord x<=0x07FF = chr (0xC0 .|. ((ord x `shift` (-6)) .&. 0x1F)): - chr (0x80 .|. (ord x .&. 0x3F)): - toUTF xs - | otherwise = chr (0xE0 .|. ((ord x `shift` (-12)) .&. 0x0F)): - chr (0x80 .|. ((ord x `shift` (-6)) .&. 0x3F)): - chr (0x80 .|. (ord x .&. 0x3F)): - toUTF xs +toUTF (x : xs) + | ord x <= 0x007F = x : toUTF xs + | ord x <= 0x07FF = + chr (0xC0 .|. ((ord x `shift` (-6)) .&. 0x1F)) + : chr (0x80 .|. (ord x .&. 0x3F)) + : toUTF xs + | otherwise = + chr (0xE0 .|. ((ord x `shift` (-12)) .&. 0x0F)) + : chr (0x80 .|. ((ord x `shift` (-6)) .&. 0x3F)) + : chr (0x80 .|. (ord x .&. 0x3F)) + : toUTF xs fromUTF :: String -> String fromUTF [] = [] -fromUTF (al@(x:xs)) | ord x<=0x7F = x:fromUTF xs - | ord x<=0xBF = err - | ord x<=0xDF = twoBytes al - | ord x<=0xEF = threeBytes al - | otherwise = err +fromUTF (al@(x : xs)) + | ord x <= 0x7F = x : fromUTF xs + | ord x <= 0xBF = err + | ord x <= 0xDF = twoBytes al + | ord x <= 0xEF = threeBytes al + | otherwise = err where - twoBytes (x1:x2:xs') = chr (((ord x1 .&. 0x1F) `shift` 6) .|. - (ord x2 .&. 0x3F)):fromUTF xs' + twoBytes (x1 : x2 : xs') = + chr + ( ((ord x1 .&. 0x1F) `shift` 6) + .|. (ord x2 .&. 0x3F) + ) + : fromUTF xs' twoBytes _ = error "fromUTF: illegal two byte sequence" - threeBytes (x1:x2:x3:xs') = chr (((ord x1 .&. 0x0F) `shift` 12) .|. - ((ord x2 .&. 0x3F) `shift` 6) .|. - (ord x3 .&. 0x3F)):fromUTF xs' + threeBytes (x1 : x2 : x3 : xs') = + chr + ( ((ord x1 .&. 0x0F) `shift` 12) + .|. ((ord x2 .&. 0x3F) `shift` 6) + .|. (ord x3 .&. 0x3F) + ) + : fromUTF xs' threeBytes _ = error "fromUTF: illegal three byte sequence" err = error "fromUTF: illegal UTF-8 character" - diff --git a/UI/HSCurses/Curses.hsc b/UI/HSCurses/Curses.hsc --- a/UI/HSCurses/Curses.hsc +++ b/UI/HSCurses/Curses.hsc @@ -1,1552 +1,1722 @@ -{-# LANGUAGE ForeignFunctionInterface, GeneralizedNewtypeDeriving #-} --- glaexts needed for newtype deriving - --- Copyright (c) 2002-2004 John Meacham (john at repetae dot net) --- Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons --- Copyright (c) 2005-2011 Stefan Wehr - http://www.stefanwehr.de --- --- This library is free software; you can redistribute it and/or --- modify it under the terms of the GNU Lesser General Public --- License as published by the Free Software Foundation; either --- version 2.1 of the License, or (at your option) any later version. --- --- This library 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 --- Lesser General Public License for more details. --- --- You should have received a copy of the GNU Lesser General Public --- License along with this library; if not, write to the Free Software --- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA - - - --- --- | 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, --- --- N.B attrs don't work with Irix curses.h. This should be fixed. --- - -module UI.HSCurses.Curses ( - - -- * Basic Functions - stdScr, -- :: Window - initScr, -- :: IO Window - initCurses, -- :: IO () - resetParams, - endWin, -- :: IO () - scrSize, -- :: IO (Int, Int) - - -- * Windows and Pads - Window, -- data Window deriving Eq - Border(..), -- data Border - touchWin, - newPad, pRefresh, delWin, newWin, wRefresh, wnoutRefresh, wBorder, defaultBorder, - - - -- * Refresh Routines - refresh, -- :: IO () - update, - resizeTerminal, - timeout, -- :: Int -> IO () - noqiflush, -- :: IO () - - -- * Navigation - move, -- :: Int -> Int -> IO () - getYX, - - -- * Input - getCh, getch, decodeKey, ungetCh, keyResizeCode, - - -- * Input Options - cBreak, -- :: Bool -> IO () - raw, -- :: Bool -> IO () - echo, -- :: Bool -> IO () - intrFlush, -- :: Bool -> IO () - keypad, -- :: Window -> Bool -> IO () - noDelay, -- :: Window -> Bool -> IO () - - -- * Output - wAddStr, -- :: Window -> String -> IO () - addLn, -- :: IO () - mvWAddStr, - mvAddCh, -- :: Int -> Int -> ChType -> IO () - wMove, - bkgrndSet, -- :: Attr -> Pair -> IO () - erase, -- :: IO () - wclear, -- :: Window -> IO () - werase, - clrToEol, -- :: IO () - wClrToEol, - beep, - waddch, - winsch, - waddchnstr, -- :: Window -> CString -> CInt -> IO CInt - - -- * Output Options - clearOk, - leaveOk, - nl, -- :: Bool -> IO () - - -- * Cursor Routines - CursorVisibility(..), cursSet, - - -- * Color Support - hasColors, -- :: IO Bool - startColor, -- :: IO () - useDefaultColors, -- :: IO () - Pair(..), -- newtype Pair = Pair Int deriving (Eq, Ord, Ix) - colorPairs, -- :: IO Int - Color(..), -- newtype Color = Color Int deriving (Eq, Ord, Ix) - colors, -- :: IO Int - color, -- :: String -> Maybe Color --- black, red, green, yellow, blue, magenta, cyan, white, -- :: Color - initPair, -- :: Pair -> Color -> Color -> IO () - pairContent, -- :: Pair -> IO (Color, Color) - canChangeColor, -- :: IO Bool - initColor, -- :: Color -> (Int, Int, Int) -> IO () - colorContent, -- :: Color -> IO (Int, Int, Int) - defaultBackground, defaultForeground, - - -- * Attributes - attrPlus, - Attr, - attr0, -- :: Attr - - isAltCharset, isBlink, isBold, isDim, isHorizontal, isInvis, - isLeft, isLow, isProtect, isReverse, isRight, isStandout, isTop, - isUnderline, isVertical, - -- :: Attr -> Bool - - setAltCharset, setBlink, setBold, setDim, setHorizontal, setInvis, - setLeft, setLow, setProtect, setReverse, setRight, setStandout, - setTop, setUnderline, setVertical, - -- :: Attr -> Bool -> Attr - - attrSet, -- :: Attr -> Pair -> IO () - attrOn, attrOff, - - standout,standend, - attrDim, attrBold, - attrDimOn, attrDimOff, - attrBoldOn, attrBoldOff, - wAttrOn, - wAttrOff, - wAttrSet, wAttrGet, - - -- * Mouse Routines - withMouseEventMask, - ButtonEvent(..), - MouseEvent(..), - - -- * Keys - Key(..), - cERR, - cKEY_UP, - cKEY_DOWN, - cKEY_LEFT, - cKEY_RIGHT, - cTRUE, --- cACS_BLOCK, - - -- * Lines - vline, - ulCorner, llCorner, urCorner, lrCorner, rTee, lTee, bTee, tTee, hLine, - vLine, plus, s1, s9, diamond, ckBoard, degree, plMinus, bullet, - lArrow, rArrow, dArrow, uArrow, board, lantern, block, - s3, s7, lEqual, gEqual, pi, nEqual, sterling, - - -- * Signals - cursesSigWinch, - - -- * Misc - cursesTest, - throwIfErr, throwIfErr_, - errI, -- :: IO CInt -> IO () - flushinp, - recognize, - ChType, - NBool - - ) where - -#include - -#if HAVE_SIGNAL_H -# include -#endif - -import UI.HSCurses.CWString ( withLCStringLen ) -import UI.HSCurses.Logging - -import Prelude hiding ( pi ) -import Data.Char -import Data.List -import Data.Ix ( Ix ) - -import System.IO.Unsafe ( unsafePerformIO ) - -import Control.Monad ( when, liftM, void ) -import Control.Monad.Trans -import Control.Concurrent - -#if !MIN_VERSION_base(4,7,0) -import Foreign hiding ( unsafePerformIO, void ) -#else -import Foreign hiding ( void ) -#endif -import Foreign.C.String -import Foreign.C.Types -import Foreign.C.Error - -#ifndef mingw32_HOST_OS -import System.Posix.Signals -#endif - -#if __GLASGOW_HASKELL__ < 603 -import Data.Bits -#endif - - ------------------------------------------------------------------------- --- --- | @initCurses fn@ does all initialization necessary for a Curses --- application. --- -initCurses :: IO () -initCurses = do - initScr - b <- hasColors - when b $ startColor >> useDefaultColors - -resetParams :: IO () -resetParams = do - raw True -- raw mode please - echo False - nl False - intrFlush True - leaveOk False - keypad stdScr True -#ifdef NCURSES_EXT_FUNCS - 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" - defineKey (#const KEY_B2) "\x1b[E" -- xterm seems to emit B2, not BEG - defineKey (#const KEY_END) "\x1b[F" - defineKey (#const KEY_END) "\x1b[4~" - defineKey (#const KEY_HOME) "\x1b[H" - defineKey (#const KEY_HOME) "\x1b[1~" -#endif - ------------------------------------------------------------------------- - -fi :: (Integral a, Num b) => a -> b -fi = fromIntegral - -throwIfErr :: (Eq a, Show a, Num a) => String -> IO a -> IO a ---throwIfErr name act = do --- res <- act --- if res == (cERR) --- then ioError (userError ("Curses: "++name++" failed")) --- else return res -throwIfErr s = throwIf (== (#const ERR)) (\a -> "Curses[" ++ show a ++ "]:" ++ s) - -throwIfErr_ :: (Eq a, Show a, Num a) => String -> IO a -> IO () -throwIfErr_ name act = void $ throwIfErr name act - -errI :: IO CInt -> IO () -errI f = do r <- f - if r == cERR then do _ <- endwin - error "curses returned an error" - else return () - ------------------------------------------------------------------------- - -type WindowTag = () -type Window = Ptr WindowTag -type ChType = #type chtype -type NBool = #type bool - -{-# NOINLINE stdScr #-} --- --- | The standard screen --- -stdScr :: Window -stdScr = unsafePerformIO (peek stdscr) -foreign import ccall "static HSCurses.h &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 = throwIfNull "initscr" initscr -foreign import ccall unsafe "HSCurses.h initscr" 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_ "cbreak" cbreak -cBreak False = throwIfErr_ "nocbreak" nocbreak - -foreign import ccall unsafe "HSCurses.h cbreak" cbreak :: IO CInt -foreign import ccall unsafe "HSCurses.h nocbreak" nocbreak :: IO CInt - --- --- |> The raw and noraw routines place the terminal into or out --- > of raw mode. Raw mode is similar to cbreak mode, in that --- > characters typed are immediately passed through to the --- > user program. The differences are that in raw mode, the --- > interrupt, quit, suspend, and flow control characters are --- > all passed through uninterpreted, instead of generating a --- > signal. The behavior of the BREAK key depends on other --- > bits in the tty driver that are not set by curses. --- -raw :: Bool -> IO () -raw False = throwIfErr_ "noraw" noraw -raw True = throwIfErr_ "raw" raw_c - -foreign import ccall unsafe "HSCurses.h noraw" noraw :: IO CInt -foreign import ccall unsafe "HSCurses.h raw" raw_c :: 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_ "noecho" noecho -echo True = throwIfErr_ "echo" echo_c - -foreign import ccall unsafe "HSCurses.h noecho" noecho :: IO CInt -foreign import ccall unsafe "HSCurses.h 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_ "nl" nl_c -nl False = throwIfErr_ "nonl" nonl - -foreign import ccall unsafe "HSCurses.h nl" nl_c :: IO CInt -foreign import ccall unsafe "HSCurses.h nonl" nonl :: IO CInt - --- |> If the intrflush option is enabled, (bf is TRUE), when an --- > interrupt key is pressed on the keyboard (interrupt, --- > break, quit) all output in the tty driver queue will be --- > flushed, giving the effect of faster response to the --- > interrupt, but causing curses to have the wrong idea of --- > what is on the screen. Disabling (bf is FALSE), the --- > option prevents the flush. --- > -intrFlush :: Bool -> IO () -intrFlush bf = - throwIfErr_ "intrflush" $ intrflush stdScr (if bf then 1 else 0) -foreign import ccall unsafe "HSCurses.h intrflush" intrflush :: Window -> (#type bool) -> IO CInt - --- --- | Enable the keypad of the user's terminal. --- -keypad :: Window -> Bool -> IO () -keypad win bf = throwIfErr_ "keypad" $ keypad_c win (if bf then 1 else 0) -foreign import ccall unsafe "HSCurses.h keypad" - keypad_c :: Window -> (#type bool) -> IO CInt - -noDelay :: Window -> Bool -> IO () -noDelay win bf = - throwIfErr_ "nodelay" $ nodelay win (if bf then 1 else 0) - -foreign import ccall unsafe "HSCurses.h nodelay" - 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 True = leaveok_c stdScr 1 -leaveOk False = leaveok_c stdScr 0 - -foreign import ccall unsafe "HSCurses.h leaveok" - leaveok_c :: Window -> (#type bool) -> IO CInt - -clearOk :: Bool -> IO CInt -clearOk True = clearok_c stdScr 1 -clearOk False = clearok_c stdScr 0 - -foreign import ccall unsafe "HSCurses.h clearok" - clearok_c :: Window -> (#type bool) -> IO CInt - ------------------------------------------------------------------------- - -foreign import ccall unsafe "HSCurses.h use_default_colors" - useDefaultColors :: IO () - -defaultBackground, defaultForeground :: Color -defaultBackground = Color (-1) -defaultForeground = Color (-1) - ------------------------------------------------------------------------- - -#ifdef NCURSES_EXT_FUNCS -defineKey :: CInt -> String -> IO () -defineKey k s = withCString s (\s' -> define_key s' k) >> return () - -foreign import ccall unsafe "HSCurses.h define_key" - define_key :: Ptr CChar -> CInt -> IO () -#endif - --- --- | > The program must call endwin for each terminal being used before --- > exiting from curses. --- -endWin :: IO () -endWin = throwIfErr_ "endwin" endwin -foreign import ccall unsafe "HSCurses.h endwin" endwin :: IO CInt - ------------------------------------------------------------------------- - --- --- | get the dimensions of the screen (lines,cols) --- -scrSize :: IO (Int, Int) --- Note, per the documentation: --- http://invisible-island.net/ncurses/ncurses-intro.html#caution --- It is not recommended to peek at the LINES and COLS global variables. This code --- was previously doing exactly that, but now it is fixed to use getmaxyx. --- -Ryan Newton [2013.03.31] -scrSize = do - yfp <- mallocForeignPtr - xfp <- mallocForeignPtr - withForeignPtr yfp $ \yp -> - withForeignPtr xfp $ \xp -> do - getMaxYX stdScr yp xp - y <- peek yp - x <- peek xp - return (fromIntegral y, fromIntegral x) - -foreign import ccall "HSCurses.h getmaxyx_fun" getMaxYX - :: Window -> Ptr CInt -> Ptr CInt -> IO () - --- --- | refresh curses windows and lines. curs_refresh(3) --- -refresh :: IO () -refresh = throwIfErr_ "refresh" refresh_c - -foreign import ccall unsafe "HSCurses.h refresh" - refresh_c :: IO CInt - --- --- | wRefresh refreshes the specified window, copying the data --- | from the virtual screen to the physical screen. --- -wRefresh :: Window -> IO () -wRefresh w = throwIfErr_ "wrefresh" $ wrefresh_c w - -foreign import ccall unsafe "HSCurses.h wrefresh" - wrefresh_c :: Window -> IO CInt - --- | Stage an update to a window, but don't actually do the refresh until update is --- called. This allows multiple windows to be updated together more smoothly. --- -wnoutRefresh :: Window -> IO () -wnoutRefresh w = throwIfErr_ "wnoutrefresh" $ wnoutrefresh_c w - -foreign import ccall safe "HSCurses.h wnoutrefresh" - wnoutrefresh_c :: Window -> IO CInt - --- --- | Do an actual update. Used after endWin on linux to restore the terminal --- -update :: IO () -update = throwIfErr_ "update" update_c - -foreign import ccall unsafe "HSCurses.h doupdate" update_c :: IO CInt - -foreign import ccall unsafe "static curses.h timeout" timeout_c :: CInt -> IO () - --- | Set a delay in milliseconds. -timeout :: Int -> IO () -timeout = timeout_c . fromIntegral - ------------------------------------------------------------------------- - -hasColors :: IO Bool -hasColors = liftM (/= 0) has_colors -foreign import ccall unsafe "HSCurses.h 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_ "start_color" start_color -foreign import ccall unsafe start_color :: IO CInt - -newtype Pair = Pair Int deriving (Eq, Ord, Ix, Show) - --- --- | colorPairs defines the maximum number of color-pairs the terminal --- can support). --- -colorPairs :: IO Int -colorPairs = fmap fromIntegral $ peek colorPairsPtr - -foreign import ccall "HSCurses.h &COLOR_PAIRS" - colorPairsPtr :: Ptr CInt - -newtype Color = Color Int deriving (Eq, Ord, Ix) - -colors :: IO Int -colors = liftM fromIntegral $ peek colorsPtr - -foreign import ccall "HSCurses.h &COLORS" colorsPtr :: Ptr CInt - ---black, red, green, yellow, blue, magenta, cyan, white :: Color - -color :: String -> Maybe Color -color "default" = Just $ Color (-1) -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 _ = Nothing - - --- --- | 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_ "init_pair" $ - init_pair (fromIntegral p) (fromIntegral f) (fromIntegral b) - -foreign import ccall unsafe - init_pair :: CShort -> CShort -> CShort -> IO CInt - - -pairContent :: Pair -> IO (Color, Color) -pairContent (Pair p) = - alloca $ \fPtr -> - alloca $ \bPtr -> do - throwIfErr "pair_content" $ pair_content (fromIntegral p) fPtr bPtr - f <- peek fPtr - b <- peek bPtr - return (Color (fromIntegral f), Color (fromIntegral b)) - -foreign import ccall unsafe pair_content :: CShort -> Ptr CShort -> Ptr CShort -> IO CInt - -canChangeColor :: IO Bool -canChangeColor = liftM (/= 0) can_change_color - -foreign import ccall unsafe can_change_color :: IO (#type bool) - -initColor :: Color -> (Int, Int, Int) -> IO () -initColor (Color c) (r, g, b) = - throwIfErr_ "init_color" $ - init_color (fromIntegral c) (fromIntegral r) (fromIntegral g) (fromIntegral b) -foreign import ccall unsafe init_color :: CShort -> CShort -> CShort -> CShort -> IO CInt - -colorContent :: Color -> IO (Int, Int, Int) -colorContent (Color c) = - alloca $ \rPtr -> - alloca $ \gPtr -> - alloca $ \bPtr -> do - throwIfErr "color_content" $ color_content (fromIntegral c) rPtr gPtr bPtr - r <- peek rPtr - g <- peek gPtr - b <- peek bPtr - return (fromIntegral r, fromIntegral g, fromIntegral b) - -foreign import ccall unsafe - color_content :: CShort -> Ptr CShort -> Ptr CShort -> Ptr CShort -> IO CInt - -foreign import ccall unsafe "HSCurses.h hs_curses_color_pair" colorPair :: Pair -> ChType - -------------- --- Attributes -------------- - -foreign import ccall unsafe "HSCurses.h attr_set" - attr_set :: Attr -> CShort -> Ptr a -> IO Int - --- foreign import ccall unsafe "HSCurses.h attr_get" :: Attr -> CShort -> Ptr a -> IO Int - -foreign import ccall unsafe "HSCurses.h wattr_set" - wattr_set :: Window -> Attr -> CInt -> Ptr a -> IO CInt - -foreign import ccall unsafe "HSCurses.h wattr_get" - wattr_get :: Window -> Ptr Attr -> Ptr CShort -> Ptr a -> IO CInt - -foreign import ccall "HSCurses.h attr_on" attr_on :: (#type attr_t) -> Ptr a -> IO Int -foreign import ccall "HSCurses.h attr_off" attr_off :: (#type attr_t) -> Ptr a -> IO Int -foreign import ccall "HSCurses.h attron" attron :: Int -> IO Int -foreign import ccall "HSCurses.h attroff" attroff :: Int -> IO Int -foreign import ccall unsafe "HSCurses.h wattron" wattron :: Window -> CInt -> IO CInt -foreign import ccall unsafe "HSCurses.h wattroff" wattroff :: Window -> CInt -> IO CInt -foreign import ccall standout :: IO Int -foreign import ccall standend :: IO Int - --- --- | --- -wAttrSet :: Window -> (Attr,Pair) -> IO () -wAttrSet w (a,(Pair p)) = throwIfErr_ "wattr_set" $ - wattr_set w a (fromIntegral p) nullPtr - --- --- | manipulate the current attributes of the named window. see curs_attr(3) --- -wAttrGet :: Window -> IO (Attr,Pair) -wAttrGet w = - alloca $ \pa -> - alloca $ \pp -> do - throwIfErr_ "wattr_get" $ wattr_get w pa pp nullPtr - a <- peek pa - p <- peek pp - return (a,Pair $ fromIntegral p) - - -newtype Attr = Attr (#type attr_t) deriving (Eq,Storable,Bits, Num, Show) - --- --- | Normal display (no highlight) --- -attr0 :: Attr -#ifdef WA_NORMAL -attr0 = Attr (#const WA_NORMAL) -#else -attr0 = Attr (#const A_NORMAL) -#endif - -isAltCharset, isBlink, isBold, isDim, isHorizontal, isInvis, isLeft, - isLow, isProtect, isReverse, isRight, isStandout, isTop, - isUnderline, isVertical :: Attr -> Bool - -isAltCharset = isAttr (#const WA_ALTCHARSET) -isBlink = isAttr (#const WA_BLINK) -isBold = isAttr (#const WA_BOLD) -isDim = isAttr (#const WA_DIM) -isHorizontal = isAttr (#const WA_HORIZONTAL) -isInvis = isAttr (#const WA_INVIS) -isLeft = isAttr (#const WA_LEFT) -isLow = isAttr (#const WA_LOW) -isProtect = isAttr (#const WA_PROTECT) -isReverse = isAttr (#const WA_REVERSE) -isRight = isAttr (#const WA_RIGHT) -isStandout = isAttr (#const WA_STANDOUT) -isTop = isAttr (#const WA_TOP) -isUnderline = isAttr (#const WA_UNDERLINE) -isVertical = isAttr (#const WA_VERTICAL) - -isAttr :: (#type attr_t) -> Attr -> Bool -isAttr b (Attr a) = a .&. b /= 0 - --- --- | Setting attributes --- -setAltCharset, setBlink, setBold, setDim, setHorizontal, setInvis, - setLeft, setLow, setProtect, setReverse, setRight, setStandout, - setTop, setUnderline, setVertical :: Attr -> Bool -> Attr - -setAltCharset = setAttr (#const WA_ALTCHARSET) -setBlink = setAttr (#const WA_BLINK) -setBold = setAttr (#const WA_BOLD) -setDim = setAttr (#const WA_DIM) -setHorizontal = setAttr (#const WA_HORIZONTAL) -setInvis = setAttr (#const WA_INVIS) -setLeft = setAttr (#const WA_LEFT) -setLow = setAttr (#const WA_LOW) -setProtect = setAttr (#const WA_PROTECT) -setReverse = setAttr (#const WA_REVERSE) -setRight = setAttr (#const WA_RIGHT) -setStandout = setAttr (#const WA_STANDOUT) -setTop = setAttr (#const WA_TOP) -setUnderline = setAttr (#const WA_UNDERLINE) -setVertical = setAttr (#const WA_VERTICAL) - -setAttr :: (#type attr_t) -> Attr -> Bool -> Attr -setAttr b (Attr a) False = Attr (a .&. complement b) -setAttr b (Attr a) True = Attr (a .|. b) - -attrPlus :: Attr -> Attr -> Attr -attrPlus (Attr a) (Attr b) = Attr (a .|. b) - -attrSet :: Attr -> Pair -> IO () -attrSet attr (Pair p) = throwIfErr_ "attrset" $ - attr_set attr (fromIntegral p) nullPtr - -attrOn :: Attr -> IO () -attrOn (Attr attr) = throwIfErr_ "attr_on" $ - attr_on attr nullPtr - - -attrOff :: Attr -> IO () -attrOff (Attr attr) = throwIfErr_ "attr_off" $ - attr_off attr nullPtr - - - -wAttrOn :: Window -> Int -> IO () -wAttrOn w x = throwIfErr_ "wattron" $ wattron w (fi x) - -wAttrOff :: Window -> Int -> IO () -wAttrOff w x = throwIfErr_ "wattroff" $ wattroff w (fi x) - -attrDimOn :: IO () -attrDimOn = throwIfErr_ "attron A_DIM" $ - attron (#const A_DIM) - -attrDimOff :: IO () -attrDimOff = throwIfErr_ "attroff A_DIM" $ - attroff (#const A_DIM) - -attrBoldOn :: IO () -attrBoldOn = throwIfErr_ "attron A_BOLD" $ - attron (#const A_BOLD) - -attrBoldOff :: IO () -attrBoldOff = throwIfErr_ "attroff A_BOLD" $ - attroff (#const A_BOLD) - - -attrDim :: Int -attrDim = (#const A_DIM) -attrBold :: Int -attrBold = (#const A_BOLD) - ------------------------------------------------------------------------- - --- | Raw NCurses routine. -foreign import ccall safe - waddch :: Window -> ChType -> IO CInt - --- | Raw NCurses routine. -foreign import ccall safe - winsch :: Window -> ChType -> IO CInt - --- | Raw NCurses routine. -foreign import ccall safe - waddchnstr :: Window -> CString -> CInt -> IO CInt - -foreign import ccall safe "static curses.h mvaddch" mvaddch_c :: CInt -> CInt -> ChType -> IO () - -mvWAddStr :: Window -> Int -> Int -> String -> IO () -mvWAddStr w y x str = wMove w y x >> wAddStr w str - -mvAddCh :: Int -> Int -> ChType -> IO () -mvAddCh l m n = mvaddch_c (fromIntegral l) (fromIntegral m) (fromIntegral n) - -addLn :: IO () -addLn = wAddStr stdScr "\n" - --- --- | normalise the string, stripping \\r and making control chars --- printable. Called over all output(?) - -{- -normalise :: String -> String -normalise [] = [] -normalise ('\r':cs) = normalise cs -normalise (c:cs) | isControl c = '@' : normalise cs - | otherwise = c : normalise cs -{-# INLINE normalise #-} --} - -{- -normalise s = map f . filter (/= '\r') s - where - f c | isPrint c = c - f c = '@' --} - ------------------------------------------------------------------------- - -#if defined(HAVE_WCHAR_H) && (defined(HAVE_LIBNCURSESW) || defined(HAVE_LIBPDCURSESW)) - ---wAddStr :: Window -> String -> IO () ---wAddStr w str = throwIfErr_ ("waddnwstr: " ++ show str) $ withCWStringLen (normalise str) (\(ws,len) -> waddnwstr w ws (fi len)) - -foreign import ccall unsafe - waddnwstr :: Window -> CWString -> CInt -> IO CInt - -wAddStr :: Window -> String -> IO () -wAddStr win str = do - let - convStr f = case f [] of - [] -> return () - s -> throwIfErr_ "waddnstr" $ - withCWStringLen (s) (\(ws,len) -> (waddnwstr win ws (fi len))) - loop [] acc = convStr acc - loop (ch:str') acc = recognize - ch - (loop str' (acc . (ch:))) - (\ch' -> do - convStr acc - throwIfErr "waddch" $ waddch win ch' - loop str' id) - loop str id - -#else - --- --- This is heavily called, and does a lot of allocs. We walk over all --- the string accumulating a list of characters to be drawn. --- --- Got it down to: --- --- wAddStr Yi.Curses 20.0 38.1 --- wAddStr Yi.Curses 10.0 32.5 --- --- TODO make this way less expensive. That accum sucks. --- use difference lists for O(1) append --- -wAddStr :: Window -> [Char] -> IO () -wAddStr _ [] = return () -wAddStr win s = throwIfErr_ ("waddnstr: <" ++ s ++ ">") $ - withLCStringLen (s) (\(ws,len) -> waddnstr win ws (fi len)) - -foreign import ccall safe - waddnstr :: Window -> CString -> CInt -> IO CInt - -#endif - -foreign import ccall safe - vline :: Char -> Int -> IO () - ------------------------------------------------------------------------- - --- --- what ? --- - -#let translate_attr attr = \ - "(if a .&. %lu /= 0 then %lu else 0) .|.", \ - (unsigned long) WA_##attr, (unsigned long) A_##attr - -bkgrndSet :: Attr -> Pair -> IO () -bkgrndSet (Attr a) p = bkgdset $ - fromIntegral (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 bkgdset :: ChType -> IO () - --- | Copy blanks to every position in the screen. -erase :: IO () -erase = throwIfErr_ "erase" $ werase_c stdScr -foreign import ccall unsafe "werase" werase_c :: Window -> IO CInt - --- | Copy blanks to every position in a window. -werase :: Window -> IO () -werase w = throwIfErr_ "werase" $ werase_c w - --- | Copy blanks to a window and set clearOk for that window. -wclear :: Window -> IO () -wclear w = throwIfErr_ "wclear" $ wclear_c w -foreign import ccall unsafe "wclear" wclear_c :: Window -> IO CInt - -clrToEol :: IO () -clrToEol = throwIfErr_ "clrtoeol" clrtoeol -foreign import ccall unsafe 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). --- --- Note that 'move_c' may be a macro. --- -move :: Int -> Int -> IO () -move y x = throwIfErr_ "move" $ move_c (fromIntegral y) (fromIntegral x) - -foreign import ccall unsafe "move" - move_c :: CInt -> CInt -> 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_ "wmove" $ wmove w (fi y) (fi x) - -foreign import ccall unsafe - wmove :: Window -> CInt -> CInt -> IO CInt - ------------------- --- Cursor routines ------------------- - -data CursorVisibility = CursorInvisible | CursorVisible | CursorVeryVisible - -vis_c :: CursorVisibility -> CInt -vis_c vis = case vis of - CursorInvisible -> 0 - CursorVisible -> 1 - CursorVeryVisible -> 2 - -c_vis :: CInt -> CursorVisibility -c_vis 0 = CursorInvisible -c_vis 1 = CursorVisible -c_vis 2 = CursorVeryVisible -c_vis n = error ("Illegal C value for cursor visibility: " ++ show n) - --- --- | 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 :: CursorVisibility -> IO CursorVisibility -cursSet CursorInvisible = - do leaveOk True - old <- curs_set 0 - return $ c_vis old -cursSet v = - do leaveOk False - old <- curs_set (vis_c v) - return $ c_vis old - -foreign import ccall unsafe "HSCurses.h 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 (fromIntegral y, fromIntegral 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 "HSCursesUtils.h hscurses_nomacro_getyx" - nomacro_getyx :: Window -> Ptr CInt -> Ptr CInt -> IO () - ------------------------------------------------------------------------- - - -touchWin :: Window -> IO () -touchWin w = throwIfErr_ "touchwin" $ touchwin w -foreign import ccall touchwin :: Window -> IO CInt - -newPad :: Int -> Int -> IO Window -newPad nlines ncols = throwIfNull "newpad" $ - newpad (fromIntegral nlines) (fromIntegral ncols) - -pRefresh :: Window -> Int -> Int -> Int -> Int -> Int -> Int -> IO () -pRefresh pad pminrow pmincol sminrow smincol smaxrow smaxcol = - throwIfErr_ "prefresh" $ - prefresh pad (fromIntegral pminrow) - (fromIntegral pmincol) - (fromIntegral sminrow) - (fromIntegral smincol) - (fromIntegral smaxrow) - (fromIntegral smaxcol) - -delWin :: Window -> IO () -delWin w = throwIfErr_ "delwin" $ delwin w - -data Border = Border { - ls :: Char - , rs :: Char - , ts :: Char - , bs :: Char - , tl :: Char - , tr :: Char - , bl :: Char - , br :: Char -} - -defaultBorder :: Border -defaultBorder = Border '\0' '\0' '\0' '\0' '\0' '\0' '\0' '\0' - --- --- | > Draw a border around the edges of a window. defaultBorder is --- > a record representing all 0 parameters to wrecord. --- -wBorder :: Window -> Border -> IO () -wBorder w (Border ls rs ts bs tl tr bl br) = throwIfErr_ "wborder" $ - wborder w ls' rs' ts' bs' tl' tr' bl' br' - where ls' = castCharToCChar ls - rs' = castCharToCChar rs - ts' = castCharToCChar ts - bs' = castCharToCChar bs - tl' = castCharToCChar tl - tr' = castCharToCChar tr - bl' = castCharToCChar bl - br' = castCharToCChar br -foreign import ccall unsafe - prefresh :: Window -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt - -foreign import ccall unsafe - newpad :: CInt -> CInt -> IO Window - -foreign import ccall unsafe - delwin :: Window -> IO CInt - -foreign import ccall unsafe - wborder :: Window -> CChar -> CChar -> CChar -> CChar -> CChar -> CChar -> CChar -> CChar -> IO CInt - -newWin :: Int -> Int -> Int -> Int -> IO Window -newWin nlines ncolumn begin_y begin_x = throwIfNull "newwin" $ - newwin (fi nlines) (fi ncolumn) (fi begin_y) (fi begin_x) - -foreign import ccall unsafe - newwin :: CInt -> CInt -> CInt -> CInt -> IO Window - -wClrToEol :: Window -> IO () -wClrToEol w = throwIfErr_ "wclrtoeol" $ wclrtoeol w - -foreign import ccall unsafe wclrtoeol :: Window -> IO CInt - --- --- | > The getch, wgetch, mvgetch and mvwgetch, routines read a --- > character from the window. --- - -#if defined(HAVE_LIBPDCURSES) || defined (HAVE_LIBPDCURSESW) -foreign import ccall unsafe "HSCurses.h hscurses_nomacro_getch" getch :: IO CInt -#else -foreign import ccall unsafe "HSCurses.h getch" getch :: IO CInt -#endif - ---foreign import ccall unsafe def_prog_mode :: IO CInt ---foreign import ccall unsafe reset_prog_mode :: IO CInt -foreign import ccall unsafe flushinp :: IO CInt - -foreign import ccall unsafe "HSCurses.h noqiflush" noqiflush :: IO () - -foreign import ccall unsafe "HSCurses.h beep" c_beep :: IO CInt -foreign import ccall unsafe "HSCurses.h flash" c_flash :: IO CInt - -beep :: IO () -beep = do - br <- c_beep - when (br /= (#const OK)) (c_flash >> return ()) - ------------------------------------------------------------------------- --- --- | Map curses keys to key abstraction --- - -data Key - = KeyChar Char | KeyBreak | KeyDown | KeyUp | KeyLeft | KeyRight - | KeyHome | KeyBackspace | KeyF Int | KeyDL | KeyIL | KeyDC - | KeyIC | KeyEIC | KeyClear | KeyEOS | KeyEOL | KeySF | KeySR - | KeyNPage | KeyPPage | KeySTab | KeyCTab | KeyCATab | KeyEnter - | KeySReset | KeyReset | KeyPrint | KeyLL | KeyA1 | KeyA3 - | KeyB2 | KeyC1 | KeyC3 | KeyBTab | KeyBeg | KeyCancel | KeyClose - | KeyCommand | KeyCopy | KeyCreate | KeyEnd | KeyExit | KeyFind - | KeyHelp | KeyMark | KeyMessage | KeyMove | KeyNext | KeyOpen - | KeyOptions | KeyPrevious | KeyRedo | KeyReference | KeyRefresh - | KeyReplace | KeyRestart | KeyResume | KeySave | KeySBeg - | KeySCancel | KeySCommand | KeySCopy | KeySCreate | KeySDC - | KeySDL | KeySelect | KeySEnd | KeySEOL | KeySExit | KeySFind - | KeySHelp | KeySHome | KeySIC | KeySLeft | KeySMessage | KeySMove - | KeySNext | KeySOptions | KeySPrevious | KeySPrint | KeySRedo - | KeySReplace | KeySRight | KeySRsume | KeySSave | KeySSuspend - | KeySUndo | KeySuspend | KeyUndo | KeyResize | KeyMouse | KeyUnknown Int - deriving (Eq,Show) - -decodeKey :: CInt -> Key -decodeKey key = case key of - _ | key >= 0 && key <= 255 -> KeyChar (chr (fromIntegral key)) - (#const KEY_BREAK) -> KeyBreak - (#const KEY_DOWN) -> KeyDown - (#const KEY_UP) -> KeyUp - (#const KEY_LEFT) -> KeyLeft - (#const KEY_RIGHT) -> KeyRight - (#const KEY_HOME) -> KeyHome - (#const KEY_BACKSPACE) -> KeyBackspace - _ | key >= (#const KEY_F0) && key <= (#const KEY_F(63)) - -> KeyF (fromIntegral (key - #const KEY_F0)) - (#const KEY_DL) -> KeyDL - (#const KEY_IL) -> KeyIL - (#const KEY_DC) -> KeyDC - (#const KEY_IC) -> KeyIC - (#const KEY_EIC) -> KeyEIC - (#const KEY_CLEAR) -> KeyClear - (#const KEY_EOS) -> KeyEOS - (#const KEY_EOL) -> KeyEOL - (#const KEY_SF) -> KeySF - (#const KEY_SR) -> KeySR - (#const KEY_NPAGE) -> KeyNPage - (#const KEY_PPAGE) -> KeyPPage - (#const KEY_STAB) -> KeySTab - (#const KEY_CTAB) -> KeyCTab - (#const KEY_CATAB) -> KeyCATab - (#const KEY_ENTER) -> KeyEnter - (#const KEY_SRESET) -> KeySReset - (#const KEY_RESET) -> KeyReset - (#const KEY_PRINT) -> KeyPrint - (#const KEY_LL) -> KeyLL - (#const KEY_A1) -> KeyA1 - (#const KEY_A3) -> KeyA3 - (#const KEY_B2) -> KeyB2 - (#const KEY_C1) -> KeyC1 - (#const KEY_C3) -> KeyC3 - (#const KEY_BTAB) -> KeyBTab - (#const KEY_BEG) -> KeyBeg - (#const KEY_CANCEL) -> KeyCancel - (#const KEY_CLOSE) -> KeyClose - (#const KEY_COMMAND) -> KeyCommand - (#const KEY_COPY) -> KeyCopy - (#const KEY_CREATE) -> KeyCreate - (#const KEY_END) -> KeyEnd - (#const KEY_EXIT) -> KeyExit - (#const KEY_FIND) -> KeyFind - (#const KEY_HELP) -> KeyHelp - (#const KEY_MARK) -> KeyMark - (#const KEY_MESSAGE) -> KeyMessage - (#const KEY_MOVE) -> KeyMove - (#const KEY_NEXT) -> KeyNext - (#const KEY_OPEN) -> KeyOpen - (#const KEY_OPTIONS) -> KeyOptions - (#const KEY_PREVIOUS) -> KeyPrevious - (#const KEY_REDO) -> KeyRedo - (#const KEY_REFERENCE) -> KeyReference - (#const KEY_REFRESH) -> KeyRefresh - (#const KEY_REPLACE) -> KeyReplace - (#const KEY_RESTART) -> KeyRestart - (#const KEY_RESUME) -> KeyResume - (#const KEY_SAVE) -> KeySave - (#const KEY_SBEG) -> KeySBeg - (#const KEY_SCANCEL) -> KeySCancel - (#const KEY_SCOMMAND) -> KeySCommand - (#const KEY_SCOPY) -> KeySCopy - (#const KEY_SCREATE) -> KeySCreate - (#const KEY_SDC) -> KeySDC - (#const KEY_SDL) -> KeySDL - (#const KEY_SELECT) -> KeySelect - (#const KEY_SEND) -> KeySEnd - (#const KEY_SEOL) -> KeySEOL - (#const KEY_SEXIT) -> KeySExit - (#const KEY_SFIND) -> KeySFind - (#const KEY_SHELP) -> KeySHelp - (#const KEY_SHOME) -> KeySHome - (#const KEY_SIC) -> KeySIC - (#const KEY_SLEFT) -> KeySLeft - (#const KEY_SMESSAGE) -> KeySMessage - (#const KEY_SMOVE) -> KeySMove - (#const KEY_SNEXT) -> KeySNext - (#const KEY_SOPTIONS) -> KeySOptions - (#const KEY_SPREVIOUS) -> KeySPrevious - (#const KEY_SPRINT) -> KeySPrint - (#const KEY_SREDO) -> KeySRedo - (#const KEY_SREPLACE) -> KeySReplace - (#const KEY_SRIGHT) -> KeySRight - (#const KEY_SRSUME) -> KeySRsume - (#const KEY_SSAVE) -> KeySSave - (#const KEY_SSUSPEND) -> KeySSuspend - (#const KEY_SUNDO) -> KeySUndo - (#const KEY_SUSPEND) -> KeySuspend - (#const KEY_UNDO) -> KeyUndo -#ifdef KEY_RESIZE - (#const KEY_RESIZE) -> KeyResize -#endif -#ifdef KEY_MOUSE - (#const KEY_MOUSE) -> KeyMouse -#endif - _ -> KeyUnknown (fromIntegral key) - -keyResizeCode :: Maybe CInt -#ifdef KEY_RESIZE -keyResizeCode = Just (#const KEY_RESIZE) -#else -keyResizeCode = Nothing -#endif - -cERR :: CInt -cERR = #const ERR - -cKEY_UP, cKEY_DOWN, cKEY_LEFT, cKEY_RIGHT :: ChType -cKEY_UP = #const KEY_UP -cKEY_DOWN = #const KEY_DOWN -cKEY_LEFT = #const KEY_LEFT -cKEY_RIGHT = #const KEY_RIGHT - --- cACS_BLOCK :: ChType --- cACS_BLOCK = #const ACS_BLOCK - -cTRUE :: NBool -cTRUE = #const TRUE - - --- --------------------------------------------------------------------- --- get char --- - --- ncurses ungetch and Haskell's threadWaitRead do not work together well. --- So I decided to implement my own input queue. -ungetCh :: (Integral a) => a -> IO () -ungetCh i = - do debug "ungetCh called" - writeChan inputBuf (BufDirect (fi i)) - -data BufData = BufDirect CInt -- data directly available - | DataViaGetch -- data can be obtained by calling getch - -inputBuf :: Chan BufData -inputBuf = unsafePerformIO newChan -{-# NOINLINE inputBuf #-} - -getchToInputBuf :: IO () -getchToInputBuf = - do threadWaitRead (fi (0::Int)) - {- From the (n)curses manpage: - Programmers concerned about portability should be prepared for either - of two cases: (a) signal receipt does not interrupt getch; (b) signal - receipt interrupts getch and causes it to return ERR with errno set to - EINTR. Under the ncurses implementation, handled signals never inter$B!>(B - rupt getch. - -} - -- we only signalize that getch can now called without getting blocked. - -- directly calling `getch' might result in losing the character just - -- read (race condition). - debug "now input available on stdin" - writeChan inputBuf DataViaGetch --- --- | read a character from the window --- -getCh :: IO Key -getCh = - do debug "getCh called" - tid <- forkIO getchToInputBuf - d <- readChan inputBuf - killThread tid -- we can kill the thread savely, because the thread does - -- not read any data via getch - v <- case d of - BufDirect x -> - do debug "getCh: getting data directly from buffer" - return x - DataViaGetch -> - do debug "getCh: getting data via getch" - getch -- won't block! - case v of - (#const ERR) -> -- NO CODE IN THIS LINE - do e <- getErrno - if e `elem` [eAGAIN, eINTR] - then do debug "Curses.getCh returned eAGAIN or eINTR" - getCh - else throwErrno "HSCurses.Curses.getch" - k -> let k' = decodeKey k - in do debug ("getCh: result = " ++ show k') - return k' - - -resizeTerminal :: Int -> Int -> IO () - -#ifdef HAVE_RESIZETERM -resizeTerminal a b = throwIfErr_ "resizeterm" $ resizeterm (fi a) (fi b) - -foreign import ccall unsafe "HSCurses.h resizeterm" - resizeterm :: CInt -> CInt -> IO CInt -#else -resizeTerminal _ _ = return () -#endif - --- --- | The SIGWINCH signal is sent whenever the terminal size changes. --- This signal is not available on all platforms, so it is a |Maybe| value. --- - -#ifdef mingw32_HOST_OS -type Signal = CInt -#endif - -cursesSigWinch :: Maybe Signal -#ifdef SIGWINCH -cursesSigWinch = Just (#const SIGWINCH) -#else -cursesSigWinch = Nothing -#endif - ------------- --- Test case ------------- - -cursesTest :: IO () -cursesTest = do - initScr - hc <- hasColors - when hc startColor - ccc <- canChangeColor - (ys,xs) <- scrSize - cp <- colorPairs - cs <- colors - endWin - putStrLn $ "ScreenSize: " ++ show (xs,ys) - putStrLn $ "hasColors: " ++ show hc - putStrLn $ "canChangeColor: " ++ show ccc - putStrLn $ "colorPairs: " ++ show cp - putStrLn $ "colors: " ++ show cs - - - - ------------------ --- Mouse Routines ------------------ - -data MouseEvent = MouseEvent { - mouseEventId :: Int, - mouseEventX :: Int, - mouseEventY :: Int, - mouseEventZ :: Int, - mouseEventButton :: [ButtonEvent] - } deriving(Show) - -data ButtonEvent = ButtonPressed Int | ButtonReleased Int | ButtonClicked Int | - ButtonDoubleClicked Int | ButtonTripleClicked Int | ButtonShift | ButtonControl | ButtonAlt - deriving(Eq,Show) - -withMouseEventMask :: MonadIO m => [ButtonEvent] -> m a -> m a - -#ifdef KEY_MOUSE - -foreign import ccall unsafe "HSCurses.h mousemask" - mousemask :: (#type mmask_t) -> Ptr (#type mmask_t) -> IO (#type mmask_t) - -withMouseEventMask bes action = do - ov <- liftIO $ alloca (\a -> mousemask (besToMouseMask bes) a >> peek a) - r <- action - liftIO $ mousemask ov nullPtr - return r - -besToMouseMask :: [ButtonEvent] -> (#type mmask_t) -besToMouseMask bes = foldl' (.|.) 0 (map cb bes) where - cb (ButtonPressed 1) = (#const BUTTON1_PRESSED) - cb (ButtonPressed 2) = (#const BUTTON2_PRESSED) - cb (ButtonPressed 3) = (#const BUTTON3_PRESSED) - cb (ButtonPressed 4) = (#const BUTTON4_PRESSED) - cb (ButtonReleased 1) = (#const BUTTON1_RELEASED) - cb (ButtonReleased 2) = (#const BUTTON2_RELEASED) - cb (ButtonReleased 3) = (#const BUTTON3_RELEASED) - cb (ButtonReleased 4) = (#const BUTTON4_RELEASED) - cb (ButtonClicked 1) = (#const BUTTON1_CLICKED) - cb (ButtonClicked 2) = (#const BUTTON2_CLICKED) - cb (ButtonClicked 3) = (#const BUTTON3_CLICKED) - cb (ButtonClicked 4) = (#const BUTTON4_CLICKED) - cb ButtonShift = (#const BUTTON_SHIFT) - cb ButtonAlt = (#const BUTTON_ALT) -#ifdef BUTTON_CTRL - cb ButtonControl = (#const BUTTON_CTRL) -#else - cb ButtonControl = (#const BUTTON_CONTROL) -#endif - cb _ = 0 - - -#else -withMouseEventMask _ a = a - -#endif - - - - -ulCorner, llCorner, urCorner, lrCorner, rTee, lTee, bTee, tTee, hLine, - vLine, plus, s1, s9, diamond, ckBoard, degree, plMinus, bullet, - lArrow, rArrow, dArrow, uArrow, board, lantern, block, - s3, s7, lEqual, gEqual, pi, nEqual, sterling - :: Char - -ulCorner = chr 0x250C -llCorner = chr 0x2514 -urCorner = chr 0x2510 -lrCorner = chr 0x2518 -rTee = chr 0x2524 -lTee = chr 0x251C -bTee = chr 0x2534 -tTee = chr 0x252C -hLine = chr 0x2500 -vLine = chr 0x2502 -plus = chr 0x253C -s1 = chr 0x23BA -- was: 0xF800 -s9 = chr 0x23BD -- was: 0xF804 -diamond = chr 0x25C6 -ckBoard = chr 0x2592 -degree = chr 0x00B0 -plMinus = chr 0x00B1 -bullet = chr 0x00B7 -lArrow = chr 0x2190 -rArrow = chr 0x2192 -dArrow = chr 0x2193 -uArrow = chr 0x2191 -board = chr 0x2591 -lantern = chr 0x256C -block = chr 0x2588 -s3 = chr 0x23BB -- was: 0xF801 -s7 = chr 0x23BC -- was: 0xF803 -lEqual = chr 0x2264 -gEqual = chr 0x2265 -pi = chr 0x03C0 -nEqual = chr 0x2260 -sterling = chr 0x00A3 - - -recognize :: Char -> IO a -> (ChType -> IO a) -> IO a -recognize _ch noConvert _convert = noConvert -- Handle the most common case first. - - - - --- --------------------------------------------------------------------- --- code graveyard --- - -{- - -addStr :: String -> IO () -addStr str = - throwIfErr_ "addstr" $ - withCStringConv (readIORef cursesOutConv) str addstr -foreign import ccall unsafe addstr :: Ptr CChar -> IO CInt - -addStrLn :: String -> IO () -addStrLn str = addStr str >> addLn - --- --- | add a string of characters to a curses window and advance cursor --- curs_addstr(3) --- -wAddStr :: Window -> String -> IO () -wAddStr w str = throwIfErr_ "waddstr" $ - withCStringConv (readIORef cursesOutConv) str (waddstr w) - -foreign import ccall unsafe waddstr :: Window -> Ptr CChar -> IO CInt - - -addGraphStr :: String -> IO () -addGraphStr str = do - conv <- readIORef cursesOutConv - let - convStr f = case f [] of - [] -> return () - s -> throwIfErr_ "addstr" $ - withCStringConv (return conv) s addstr - loop [] acc = convStr acc - loop (ch:str') acc = recognize - ch - (loop str' (acc . (ch:))) - (\ch' -> do - convStr acc - throwIfErr "addch" $ addch ch' - loop str' id) - loop str id - -addGraphStrLn :: String -> IO () -addGraphStrLn str = do addGraphStr str; addLn - --} - --- vim: sw=4 ts=4 +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeApplications #-} + +-- Copyright (c) 2002-2004 John Meacham (john at repetae dot net) +-- Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Copyright (c) 2005-2011 Stefan Wehr - http://www.stefanwehr.de +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + +-- | 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, +-- +-- N.B attrs don't work with Irix curses.h. This should be fixed. +module UI.HSCurses.Curses ( + -- Basic Functions + stdScr, + initScr, + initCurses, + resetParams, + endWin, + scrSize, + newTerm, + delScreen, + + -- Windows, screens and Pads + Screen, + Window, + Border (..), + touchWin, + newPad, + pRefresh, + delWin, + newWin, + wRefresh, + wnoutRefresh, + wBorder, + defaultBorder, + + -- Refresh routines + refresh, + update, + resizeTerminal, + timeout, + noqiflush, + + -- Navigation + move, + getYX, + + -- Input + getCh, + getch, + decodeKey, + ungetCh, + keyResizeCode, + + -- * Input Options + cBreak, -- :: Bool -> IO () + raw, -- :: Bool -> IO () + echo, -- :: Bool -> IO () + intrFlush, -- :: Bool -> IO () + keypad, -- :: Window -> Bool -> IO () + noDelay, -- :: Window -> Bool -> IO () + + -- * Output + wAddStr, -- :: Window -> String -> IO () + addLn, -- :: IO () + mvWAddStr, + mvAddCh, -- :: Int -> Int -> ChType -> IO () + wMove, + bkgrndSet, -- :: Attr -> Pair -> IO () + erase, -- :: IO () + wclear, -- :: Window -> IO () + werase, + clrToEol, -- :: IO () + wClrToEol, + beep, + waddch, + winsch, + waddchnstr, -- :: Window -> CString -> CInt -> IO CInt + + -- * Output Options + clearOk, + leaveOk, + nl, -- :: Bool -> IO () + + -- * Cursor Routines + CursorVisibility (..), + cursSet, + + -- * Color Support + hasColors, -- :: IO Bool + startColor, -- :: IO () + useDefaultColors, -- :: IO () + Pair (..), -- newtype Pair = Pair Int deriving (Eq, Ord, Ix) + colorPairs, -- :: IO Int + Color (..), -- newtype Color = Color Int deriving (Eq, Ord, Ix) + colors, -- :: IO Int + color, -- :: String -> Maybe Color + -- black, red, green, yellow, blue, magenta, cyan, white, -- :: Color + initPair, -- :: Pair -> Color -> Color -> IO () + pairContent, -- :: Pair -> IO (Color, Color) + canChangeColor, -- :: IO Bool + initColor, -- :: Color -> (Int, Int, Int) -> IO () + colorContent, -- :: Color -> IO (Int, Int, Int) + defaultBackground, + defaultForeground, + + -- * Attributes + attrPlus, + Attr, + attr0, -- :: Attr + isAltCharset, + isBlink, + isBold, + isDim, + isHorizontal, + isInvis, + isLeft, + isLow, + isProtect, + isReverse, + isRight, + isStandout, + isTop, + isUnderline, + isVertical, + -- :: Attr -> Bool + + setAltCharset, + setBlink, + setBold, + setDim, + setHorizontal, + setInvis, + setLeft, + setLow, + setProtect, + setReverse, + setRight, + setStandout, + setTop, + setUnderline, + setVertical, + -- :: Attr -> Bool -> Attr + + attrSet, -- :: Attr -> Pair -> IO () + attrOn, + attrOff, + standout, + standend, + attrDim, + attrBold, + attrDimOn, + attrDimOff, + attrBoldOn, + attrBoldOff, + wAttrOn, + wAttrOff, + wAttrSet, + wAttrGet, + + -- * Mouse Routines + getMouse, + withMouseEventMask, + withAllMouseEvents, + ButtonEvent (..), + MouseEvent (..), + + -- * Keys + Key (..), + cERR, + cKEY_UP, + cKEY_DOWN, + cKEY_LEFT, + cKEY_RIGHT, + cTRUE, + -- cACS_BLOCK, + + -- * Lines + vline, + ulCorner, + llCorner, + urCorner, + lrCorner, + rTee, + lTee, + bTee, + tTee, + hLine, + vLine, + plus, + s1, + s9, + diamond, + ckBoard, + degree, + plMinus, + bullet, + lArrow, + rArrow, + dArrow, + uArrow, + board, + lantern, + block, + s3, + s7, + lEqual, + gEqual, + pi, + nEqual, + sterling, + + -- * Signals + cursesSigWinch, + + -- * Misc + cursesTest, + throwIfErr, + throwIfErr_, + errI, -- :: IO CInt -> IO () + flushinp, + recognize, + ChType, + NBool, +) where + +#include + +#if HAVE_SIGNAL_H +#include +#endif + +import UI.HSCurses.Logging + +#if !(defined(HAVE_WCHAR_H) && (defined(HAVE_LIBNCURSESW) || defined(HAVE_LIBPDCURSESW))) +-- FIXME: this is needed for CI builds on macOS; we can probably replace the +-- whole CWString module with just the "new" function in Foreign.C.String +import UI.HSCurses.CWString (withLCStringLen) +#endif + +import Data.Char +import Data.Ix (Ix) +import Prelude hiding (pi) + +-- foldl' was put into Prelude in base 4.20 +#if !MIN_VERSION_base(4,20,0) +import Data.List (foldl') +#endif + +import System.IO.Unsafe (unsafePerformIO) + +import Control.Concurrent +import Control.Monad (liftM, void, when) +import Control.Monad.Trans + +#if !MIN_VERSION_base(4,7,0) +import Foreign hiding (unsafePerformIO, void) +#else +import Foreign hiding (void) +#endif + +import Foreign.C.Error +import Foreign.C.String +import Foreign.C.Types + +import GHC.IO.FD (FD (..)) + +#ifndef mingw32_HOST_OS +import System.Posix.Signals +#endif + +#if __GLASGOW_HASKELL__ < 603 +import Data.Bits +#endif + + +-- | 'initCurses' does all initialization necessary for a Curses application. +initCurses :: IO () +initCurses = do + initScr + b <- hasColors + when b $ startColor >> useDefaultColors + +resetParams :: IO () +resetParams = do + raw True -- raw mode please + echo False + nl False + intrFlush True + leaveOk False + keypad stdScr True +#ifdef NCURSES_EXT_FUNCS + 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" + defineKey (# const KEY_B2) "\x1b[E" -- xterm seems to emit B2, not BEG + defineKey (# const KEY_END) "\x1b[F" + defineKey (# const KEY_END) "\x1b[4~" + defineKey (# const KEY_HOME) "\x1b[H" + defineKey (# const KEY_HOME) "\x1b[1~" +#endif + +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral + +throwIfErr :: (Eq a, Show a, Num a) => String -> IO a -> IO a +throwIfErr s = throwIf (== (# const ERR)) (\a -> "Curses[" ++ show a ++ "]:" ++ s) + +throwIfErr_ :: (Eq a, Show a, Num a) => String -> IO a -> IO () +throwIfErr_ name act = void $ throwIfErr name act + +errI :: IO CInt -> IO () +errI f = do + r <- f + if r == cERR + then do + _ <- endwin + error "curses returned an error" + else return () + +type WindowTag = () +type Window = Ptr WindowTag +type ChType = #type chtype +type NBool = #type bool + + +-- | The standard screen +stdScr :: Window +stdScr = unsafePerformIO (peek stdscr) +{-# NOINLINE stdScr #-} + +foreign import ccall "static HSCurses.h &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 = throwIfNull "initscr" initscr + +foreign import ccall unsafe "HSCurses.h initscr" initscr :: IO Window + +-- This seems like the easiest way to get a FILE (see: man FILE) +-- from an FD +type FILE = Ptr () + +foreign import ccall unsafe "fdopen" + fdopen :: CInt -> CString -> IO FILE + +fdOpen :: FD -> String -> IO FILE +fdOpen fd mode = + withCString mode $ \mode' -> do + fdopen (fdFD fd) mode' + +type Screen = Ptr () + +-- | A program that outputs to more than one terminal should use the 'newTerm' +-- routine for each terminal instead of 'initScr'. A program that needs to +-- inspect capabilities, so it can continue to run in a line-oriented mode if +-- the terminal cannot support a screen-oriented program, would also use +-- 'newTerm'. curs_initscr(3X): +-- +-- > The routine newterm should be called once for each terminal. It returns +-- > a variable of type SCREEN * which should be saved as a reference to that +-- > terminal. newterm's arguments are +-- > +-- > - the type of the terminal to be used in place of $TERM, +-- > +-- > - an output stream connected to the terminal, and +-- > +-- > - an input stream connected to the terminal +-- > +-- > If the type parameter is NULL, $TERM will be used. +newTerm :: String -> FD -> FD -> IO Screen +newTerm typ out in' = + withCString typ $ \typ' -> do + fout <- fdOpen out "rw" + fin <- fdOpen in' "r" + throwIfNull "newterm" $ newterm typ' fout fin + +foreign import ccall unsafe "HSCurses.h newterm" + newterm :: CString -> FILE -> FILE -> IO Screen + +foreign import ccall unsafe "HSCurses.h delscreen" + delScreen :: Screen -> IO () + +-- | > The cbreak routine disables line buffering and erase/kill +-- > character-processing (interrupt and flow control characters are +-- > unaffected), 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_ "cbreak" cbreak +cBreak False = throwIfErr_ "nocbreak" nocbreak + +foreign import ccall unsafe "HSCurses.h cbreak" cbreak :: IO CInt +foreign import ccall unsafe "HSCurses.h nocbreak" nocbreak :: IO CInt + +-- | > The raw and noraw routines place the terminal into or out of raw mode. +-- > Raw mode is similar to cbreak mode, in that characters typed are +-- > immediately passed through to the user program. The differences are that +-- > in raw mode, the interrupt, quit, suspend, and flow control characters +-- > are all passed through uninterpreted, instead of generating a signal. The +-- > behavior of the BREAK key depends on other bits in the tty driver that +-- > are not set by curses. +raw :: Bool -> IO () +raw False = throwIfErr_ "noraw" noraw +raw True = throwIfErr_ "raw" raw_c + +foreign import ccall unsafe "hscurses.h noraw" noraw :: IO CInt +foreign import ccall unsafe "HSCurses.h raw" raw_c :: 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_ "noecho" noecho +echo True = throwIfErr_ "echo" echo_c + +foreign import ccall unsafe "HSCurses.h noecho" noecho :: IO CInt +foreign import ccall unsafe "HSCurses.h 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_ "nl" nl_c +nl False = throwIfErr_ "nonl" nonl + +foreign import ccall unsafe "HSCurses.h nl" nl_c :: IO CInt +foreign import ccall unsafe "HSCurses.h nonl" nonl :: IO CInt + +-- | > If the intrflush option is enabled, (bf is TRUE), when an interrupt key +-- > is pressed on the keyboard (interrupt, break, quit) all output in the tty +-- > driver queue will be flushed, giving the effect of faster response to the +-- > interrupt, but causing curses to have the wrong idea of what is on the +-- > screen. Disabling (bf is FALSE), the option prevents the flush. +intrFlush :: Bool -> IO () +intrFlush bf = + throwIfErr_ "intrflush" $ intrflush stdScr (if bf then 1 else 0) + +foreign import ccall unsafe "HSCurses.h intrflush" + intrflush :: Window -> (#type bool) -> IO CInt + +-- | Enable the keypad of the user's terminal. +keypad :: Window -> Bool -> IO () +keypad win bf = throwIfErr_ "keypad" $ keypad_c win (if bf then 1 else 0) + +foreign import ccall unsafe "HSCurses.h keypad" + keypad_c :: Window -> (#type bool) -> IO CInt + +noDelay :: Window -> Bool -> IO () +noDelay win bf = + throwIfErr_ "nodelay" $ nodelay win (if bf then 1 else 0) + +foreign import ccall unsafe "HSCurses.h nodelay" + 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 cursor 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 True = leaveok_c stdScr 1 +leaveOk False = leaveok_c stdScr 0 + +foreign import ccall unsafe "HSCurses.h leaveok" + leaveok_c :: Window -> (#type bool) -> IO CInt + +clearOk :: Bool -> IO CInt +clearOk True = clearok_c stdScr 1 +clearOk False = clearok_c stdScr 0 + +foreign import ccall unsafe "HSCurses.h clearok" + clearok_c :: Window -> (#type bool) -> IO CInt + +foreign import ccall unsafe "HSCurses.h use_default_colors" + useDefaultColors :: IO () + +defaultBackground, defaultForeground :: Color +defaultBackground = Color (-1) +defaultForeground = Color (-1) + +#ifdef NCURSES_EXT_FUNCS +defineKey :: CInt -> String -> IO () +defineKey k s = withCString s (\s' -> define_key s' k) >> return () + +foreign import ccall unsafe "HSCurses.h define_key" + define_key :: Ptr CChar -> CInt -> IO () +#endif + +-- | > The program must call endwin for each terminal being used before +-- > exiting from curses. +endWin :: IO () +endWin = throwIfErr_ "endwin" endwin + +foreign import ccall unsafe "HSCurses.h endwin" endwin :: IO CInt + +-- | Get the dimensions of the screen (lines, cols). +scrSize :: IO (Int, Int) +-- Note, per the documentation: +-- http://invisible-island.net/ncurses/ncurses-intro.html#caution +-- It is not recommended to peek at the LINES and COLS global variables. This code +-- was previously doing exactly that, but now it is fixed to use getmaxyx. +-- -Ryan Newton [2013.03.31] +scrSize = do + yfp <- mallocForeignPtr + xfp <- mallocForeignPtr + withForeignPtr yfp $ \yp -> + withForeignPtr xfp $ \xp -> do + getMaxYX stdScr yp xp + y <- peek yp + x <- peek xp + return (fromIntegral y, fromIntegral x) + +foreign import ccall "HSCurses.h getmaxyx_fun" + getMaxYX :: + Window -> Ptr CInt -> Ptr CInt -> IO () + +-- | Refresh curses windows and lines. curs_refresh(3) +refresh :: IO () +refresh = throwIfErr_ "refresh" refresh_c + +foreign import ccall unsafe "HSCurses.h refresh" + refresh_c :: IO CInt + +-- | Refresh the specified window, copying the data from the virtual screen to +-- the physical screen. +wRefresh :: Window -> IO () +wRefresh w = throwIfErr_ "wrefresh" $ wrefresh_c w + +foreign import ccall unsafe "HSCurses.h wrefresh" + wrefresh_c :: Window -> IO CInt + +-- | Stage an update to a window, but don't actually do the refresh until update +-- is called. This allows multiple windows to be updated together more smoothly. +wnoutRefresh :: Window -> IO () +wnoutRefresh w = throwIfErr_ "wnoutrefresh" $ wnoutrefresh_c w + +foreign import ccall safe "HSCurses.h wnoutrefresh" + wnoutrefresh_c :: Window -> IO CInt + +-- | Do an actual update. Used after endWin on linux to restore the terminal. +update :: IO () +update = throwIfErr_ "update" update_c + +foreign import ccall unsafe "HSCurses.h doupdate" update_c :: IO CInt + +foreign import ccall unsafe "static curses.h timeout" timeout_c :: CInt -> IO () + +-- | Set a delay in milliseconds. +timeout :: Int -> IO () +timeout = timeout_c . fromIntegral + +hasColors :: IO Bool +hasColors = liftM (/= 0) has_colors + +foreign import ccall unsafe "HSCurses.h 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_ "start_color" start_color + +foreign import ccall unsafe start_color :: IO CInt + +newtype Pair = Pair Int deriving (Eq, Ord, Ix, Show) + +-- | Defines the maximum number of color-pairs the terminal can support). +colorPairs :: IO Int +colorPairs = fmap fromIntegral $ peek colorPairsPtr + +foreign import ccall "HSCurses.h &COLOR_PAIRS" + colorPairsPtr :: Ptr CInt + +newtype Color = Color Int deriving (Eq, Ord, Ix) + +colors :: IO Int +colors = liftM fromIntegral $ peek colorsPtr + +foreign import ccall "HSCurses.h &COLORS" colorsPtr :: Ptr CInt + +color :: String -> Maybe Color +color "default" = Just $ Color (-1) +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 _ = Nothing + +-- | 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_ "init_pair" $ + init_pair (fromIntegral p) (fromIntegral f) (fromIntegral b) + +foreign import ccall unsafe + init_pair :: CShort -> CShort -> CShort -> IO CInt + +pairContent :: Pair -> IO (Color, Color) +pairContent (Pair p) = + alloca $ \fPtr -> + alloca $ \bPtr -> do + throwIfErr "pair_content" $ pair_content (fromIntegral p) fPtr bPtr + f <- peek fPtr + b <- peek bPtr + return (Color (fromIntegral f), Color (fromIntegral b)) + +foreign import ccall unsafe + pair_content :: CShort -> Ptr CShort -> Ptr CShort -> IO CInt + +canChangeColor :: IO Bool +canChangeColor = liftM (/= 0) can_change_color + +foreign import ccall unsafe can_change_color :: IO (#type bool) + +initColor :: Color -> (Int, Int, Int) -> IO () +initColor (Color c) (r, g, b) = + throwIfErr_ "init_color" $ + init_color (fromIntegral c) (fromIntegral r) (fromIntegral g) (fromIntegral b) + +foreign import ccall unsafe + init_color :: CShort -> CShort -> CShort -> CShort -> IO CInt + +colorContent :: Color -> IO (Int, Int, Int) +colorContent (Color c) = + alloca $ \rPtr -> + alloca $ \gPtr -> + alloca $ \bPtr -> do + throwIfErr "color_content" $ color_content (fromIntegral c) rPtr gPtr bPtr + r <- peek rPtr + g <- peek gPtr + b <- peek bPtr + return (fromIntegral r, fromIntegral g, fromIntegral b) + +foreign import ccall unsafe + color_content :: CShort -> Ptr CShort -> Ptr CShort -> Ptr CShort -> IO CInt + +foreign import ccall unsafe "HSCurses.h hs_curses_color_pair" colorPair :: Pair -> ChType + +----------------------------------------------------------------------------- +-- * Attributes +----------------------------------------------------------------------------- + +foreign import ccall unsafe "HSCurses.h attr_set" + attr_set :: Attr -> CShort -> Ptr a -> IO Int + +foreign import ccall unsafe "HSCurses.h wattr_set" + wattr_set :: Window -> Attr -> CInt -> Ptr a -> IO CInt + +foreign import ccall unsafe "HSCurses.h wattr_get" + wattr_get :: Window -> Ptr Attr -> Ptr CShort -> Ptr a -> IO CInt + +foreign import ccall "HSCurses.h attr_on" attr_on :: (#type attr_t) -> Ptr a -> IO Int +foreign import ccall "HSCurses.h attr_off" attr_off :: (#type attr_t) -> Ptr a -> IO Int +foreign import ccall "HSCurses.h attron" attron :: Int -> IO Int +foreign import ccall "HSCurses.h attroff" attroff :: Int -> IO Int +foreign import ccall unsafe "HSCurses.h wattron" wattron :: Window -> CInt -> IO CInt +foreign import ccall unsafe "HSCurses.h wattroff" wattroff :: Window -> CInt -> IO CInt +foreign import ccall standout :: IO Int +foreign import ccall standend :: IO Int + +wAttrSet :: Window -> (Attr, Pair) -> IO () +wAttrSet w (a, (Pair p)) = + throwIfErr_ "wattr_set" $ + wattr_set w a (fromIntegral p) nullPtr + +-- | Manipulate the current attributes of the named window. see curs_attr(3) +wAttrGet :: Window -> IO (Attr, Pair) +wAttrGet w = + alloca $ \pa -> + alloca $ \pp -> do + throwIfErr_ "wattr_get" $ wattr_get w pa pp nullPtr + a <- peek pa + p <- peek pp + return (a, Pair $ fromIntegral p) + +newtype Attr = Attr (#type attr_t) + deriving (Eq, Storable, Bits, Num, Show) + +-- | Normal display (no highlight) +attr0 :: Attr +#ifdef WA_NORMAL +attr0 = Attr (#const WA_NORMAL) +#else +attr0 = Attr (#const A_NORMAL) +#endif + +isAltCharset, isBlink, isBold, isDim, isHorizontal, isInvis, isLeft, + isLow, isProtect, isReverse, isRight, isStandout, isTop, + isUnderline, isVertical :: Attr -> Bool + +isAltCharset = isAttr (#const WA_ALTCHARSET) +isBlink = isAttr (#const WA_BLINK) +isBold = isAttr (#const WA_BOLD) +isDim = isAttr (#const WA_DIM) +isHorizontal = isAttr (#const WA_HORIZONTAL) +isInvis = isAttr (#const WA_INVIS) +isLeft = isAttr (#const WA_LEFT) +isLow = isAttr (#const WA_LOW) +isProtect = isAttr (#const WA_PROTECT) +isReverse = isAttr (#const WA_REVERSE) +isRight = isAttr (#const WA_RIGHT) +isStandout = isAttr (#const WA_STANDOUT) +isTop = isAttr (#const WA_TOP) +isUnderline = isAttr (#const WA_UNDERLINE) +isVertical = isAttr (#const WA_VERTICAL) + +isAttr :: (#type attr_t) -> Attr -> Bool +isAttr b (Attr a) = a .&. b /= 0 + +setAltCharset, setBlink, setBold, setDim, setHorizontal, setInvis, + setLeft, setLow, setProtect, setReverse, setRight, setStandout, + setTop, setUnderline, setVertical :: Attr -> Bool -> Attr + +setAltCharset = setAttr (#const WA_ALTCHARSET) +setBlink = setAttr (#const WA_BLINK) +setBold = setAttr (#const WA_BOLD) +setDim = setAttr (#const WA_DIM) +setHorizontal = setAttr (#const WA_HORIZONTAL) +setInvis = setAttr (#const WA_INVIS) +setLeft = setAttr (#const WA_LEFT) +setLow = setAttr (#const WA_LOW) +setProtect = setAttr (#const WA_PROTECT) +setReverse = setAttr (#const WA_REVERSE) +setRight = setAttr (#const WA_RIGHT) +setStandout = setAttr (#const WA_STANDOUT) +setTop = setAttr (#const WA_TOP) +setUnderline = setAttr (#const WA_UNDERLINE) +setVertical = setAttr (#const WA_VERTICAL) + +setAttr :: (#type attr_t) -> Attr -> Bool -> Attr +setAttr b (Attr a) False = Attr (a .&. complement b) +setAttr b (Attr a) True = Attr (a .|. b) + +attrPlus :: Attr -> Attr -> Attr +attrPlus (Attr a) (Attr b) = Attr (a .|. b) + +attrSet :: Attr -> Pair -> IO () +attrSet attr (Pair p) = throwIfErr_ "attrset" $ + attr_set attr (fromIntegral p) nullPtr + +attrOn :: Attr -> IO () +attrOn (Attr attr) = throwIfErr_ "attr_on" $ + attr_on attr nullPtr + +attrOff :: Attr -> IO () +attrOff (Attr attr) = throwIfErr_ "attr_off" $ + attr_off attr nullPtr + +wAttrOn :: Window -> Int -> IO () +wAttrOn w x = throwIfErr_ "wattron" $ wattron w (fi x) + +wAttrOff :: Window -> Int -> IO () +wAttrOff w x = throwIfErr_ "wattroff" $ wattroff w (fi x) + +attrDimOn :: IO () +attrDimOn = throwIfErr_ "attron A_DIM" $ + attron (#const A_DIM) + +attrDimOff :: IO () +attrDimOff = throwIfErr_ "attroff A_DIM" $ + attroff (#const A_DIM) + +attrBoldOn :: IO () +attrBoldOn = throwIfErr_ "attron A_BOLD" $ + attron (#const A_BOLD) + +attrBoldOff :: IO () +attrBoldOff = throwIfErr_ "attroff A_BOLD" $ + attroff (#const A_BOLD) + +attrDim :: Int +attrDim = (#const A_DIM) +attrBold :: Int +attrBold = (#const A_BOLD) + +-- | Raw NCurses routine. +foreign import ccall safe + waddch :: Window -> ChType -> IO CInt + +-- | Raw NCurses routine. +foreign import ccall safe + winsch :: Window -> ChType -> IO CInt + +-- | Raw NCurses routine. +foreign import ccall safe + waddchnstr :: Window -> CString -> CInt -> IO CInt + +foreign import ccall safe "static curses.h mvaddch" + mvaddch_c :: CInt -> CInt -> ChType -> IO () + +mvWAddStr :: Window -> Int -> Int -> String -> IO () +mvWAddStr w y x str = wMove w y x >> wAddStr w str + +mvAddCh :: Int -> Int -> ChType -> IO () +mvAddCh l m n = mvaddch_c (fromIntegral l) (fromIntegral m) (fromIntegral n) + +addLn :: IO () +addLn = wAddStr stdScr "\n" + +#if defined(HAVE_WCHAR_H) && (defined(HAVE_LIBNCURSESW) || defined(HAVE_LIBPDCURSESW)) + +foreign import ccall unsafe + waddnwstr :: Window -> CWString -> CInt -> IO CInt + +wAddStr :: Window -> String -> IO () +wAddStr win str = do + let convStr f = case f [] of + [] -> return () + s -> + throwIfErr_ "waddnstr" $ + withCWStringLen (s) (\(ws, len) -> (waddnwstr win ws (fi len))) + loop [] acc = convStr acc + loop (ch : str') acc = + recognize + ch + (loop str' (acc . (ch :))) + ( \ch' -> do + convStr acc + throwIfErr "waddch" $ waddch win ch' + loop str' id + ) + loop str id + +#else + +-- This is heavily called, and does a lot of allocs. We walk over all +-- the string accumulating a list of characters to be drawn. +-- +-- Got it down to: +-- +-- wAddStr Yi.Curses 20.0 38.1 +-- wAddStr Yi.Curses 10.0 32.5 +-- +-- TODO make this way less expensive. That accum sucks. +-- use difference lists for O(1) append +wAddStr :: Window -> [Char] -> IO () +wAddStr _ [] = return () +wAddStr win s = + throwIfErr_ ("waddnstr: <" ++ s ++ ">") $ + withLCStringLen (s) (\(ws, len) -> waddnstr win ws (fi len)) + +foreign import ccall safe + waddnstr :: Window -> CString -> CInt -> IO CInt + +#endif + +foreign import ccall safe + vline :: Char -> Int -> IO () + +-- +-- what ? +-- + +#let translate_attr attr = \ + "(if a .&. %lu /= 0 then %lu else 0) .|.", \ + (unsigned long) WA_##attr, (unsigned long) A_##attr + +bkgrndSet :: Attr -> Pair -> IO () +bkgrndSet (Attr a) p = bkgdset $ + fromIntegral (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 bkgdset :: ChType -> IO () + +-- | Copy blanks to every position in the screen. +erase :: IO () +erase = throwIfErr_ "erase" $ werase_c stdScr + +foreign import ccall unsafe "werase" werase_c :: Window -> IO CInt + +-- | Copy blanks to every position in a window. +werase :: Window -> IO () +werase w = throwIfErr_ "werase" $ werase_c w + +-- | Copy blanks to a window and set clearOk for that window. +wclear :: Window -> IO () +wclear w = throwIfErr_ "wclear" $ wclear_c w + +foreign import ccall unsafe "wclear" wclear_c :: Window -> IO CInt + +clrToEol :: IO () +clrToEol = throwIfErr_ "clrtoeol" clrtoeol + +foreign import ccall unsafe 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). +-- +-- Note that 'move_c' may be a macro. +move :: Int -> Int -> IO () +move y x = throwIfErr_ "move" $ move_c (fromIntegral y) (fromIntegral x) + +foreign import ccall unsafe "move" + move_c :: CInt -> CInt -> 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_ "wmove" $ wmove w (fi y) (fi x) + +foreign import ccall unsafe + wmove :: Window -> CInt -> CInt -> IO CInt + +----------------------------------------------------------------------------- +-- * Cursor routines +----------------------------------------------------------------------------- + +data CursorVisibility + = CursorInvisible + | CursorVisible + | CursorVeryVisible + +vis_c :: CursorVisibility -> CInt +vis_c vis = case vis of + CursorInvisible -> 0 + CursorVisible -> 1 + CursorVeryVisible -> 2 + +c_vis :: CInt -> CursorVisibility +c_vis 0 = CursorInvisible +c_vis 1 = CursorVisible +c_vis 2 = CursorVeryVisible +c_vis n = error ("Illegal C value for cursor visibility: " ++ show n) + +-- | 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 :: CursorVisibility -> IO CursorVisibility +cursSet CursorInvisible = do + leaveOk True + old <- curs_set 0 + return $ c_vis old +cursSet v = do + leaveOk False + old <- curs_set (vis_c v) + return $ c_vis old + +foreign import ccall unsafe "HSCurses.h 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 (fromIntegral y, fromIntegral 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. +foreign import ccall unsafe "HSCursesUtils.h hscurses_nomacro_getyx" + nomacro_getyx :: Window -> Ptr CInt -> Ptr CInt -> IO () + +touchWin :: Window -> IO () +touchWin w = throwIfErr_ "touchwin" $ touchwin w + +foreign import ccall touchwin :: Window -> IO CInt + +newPad :: Int -> Int -> IO Window +newPad nlines ncols = + throwIfNull "newpad" $ + newpad (fromIntegral nlines) (fromIntegral ncols) + +pRefresh :: Window -> Int -> Int -> Int -> Int -> Int -> Int -> IO () +pRefresh pad pminrow pmincol sminrow smincol smaxrow smaxcol = + throwIfErr_ "prefresh" $ + prefresh + pad + (fromIntegral pminrow) + (fromIntegral pmincol) + (fromIntegral sminrow) + (fromIntegral smincol) + (fromIntegral smaxrow) + (fromIntegral smaxcol) + +delWin :: Window -> IO () +delWin w = throwIfErr_ "delwin" $ delwin w + +data Border = Border + { ls :: Char + , rs :: Char + , ts :: Char + , bs :: Char + , tl :: Char + , tr :: Char + , bl :: Char + , br :: Char + } + +defaultBorder :: Border +defaultBorder = Border '\0' '\0' '\0' '\0' '\0' '\0' '\0' '\0' + +-- | Draw a border around the edges of a window. 'defaultBorder' is a record +-- representing all 0 parameters to wrecord. +wBorder :: Window -> Border -> IO () +wBorder w (Border ls rs ts bs tl tr bl br) = + throwIfErr_ "wborder" $ + wborder w ls' rs' ts' bs' tl' tr' bl' br' + where + ls' = castCharToCChar ls + rs' = castCharToCChar rs + ts' = castCharToCChar ts + bs' = castCharToCChar bs + tl' = castCharToCChar tl + tr' = castCharToCChar tr + bl' = castCharToCChar bl + br' = castCharToCChar br + +foreign import ccall unsafe + prefresh :: Window -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt + +foreign import ccall unsafe + newpad :: CInt -> CInt -> IO Window + +foreign import ccall unsafe + delwin :: Window -> IO CInt + +foreign import ccall unsafe + wborder :: Window -> CChar -> CChar -> CChar -> CChar -> CChar -> CChar -> CChar -> CChar -> IO CInt + +newWin :: Int -> Int -> Int -> Int -> IO Window +newWin nlines ncolumn begin_y begin_x = + throwIfNull "newwin" $ + newwin (fi nlines) (fi ncolumn) (fi begin_y) (fi begin_x) + +foreign import ccall unsafe + newwin :: CInt -> CInt -> CInt -> CInt -> IO Window + +wClrToEol :: Window -> IO () +wClrToEol w = throwIfErr_ "wclrtoeol" $ wclrtoeol w + +foreign import ccall unsafe wclrtoeol :: Window -> IO CInt + +-- | > The getch, wgetch, mvgetch and mvwgetch, routines read a +-- > character from the window. +#if defined(HAVE_LIBPDCURSES) || defined (HAVE_LIBPDCURSESW) +foreign import ccall unsafe "HSCurses.h hscurses_nomacro_getch" getch :: IO CInt +#else +foreign import ccall unsafe "HSCurses.h getch" getch :: IO CInt +#endif + +foreign import ccall unsafe flushinp :: IO CInt + +foreign import ccall unsafe "HSCurses.h noqiflush" noqiflush :: IO () + +foreign import ccall unsafe "HSCurses.h beep" c_beep :: IO CInt +foreign import ccall unsafe "HSCurses.h flash" c_flash :: IO CInt + +beep :: IO () +beep = do + br <- c_beep + when (br /= (# const OK)) (c_flash >> return ()) + +-- | A mapping of curses keys to Haskell values. +data Key + = KeyChar Char + | KeyBreak + | KeyDown + | KeyUp + | KeyLeft + | KeyRight + | KeyHome + | KeyBackspace + | KeyF Int + | KeyDL + | KeyIL + | KeyDC + | KeyIC + | KeyEIC + | KeyClear + | KeyEOS + | KeyEOL + | KeySF + | KeySR + | KeyNPage + | KeyPPage + | KeySTab + | KeyCTab + | KeyCATab + | KeyEnter + | KeySReset + | KeyReset + | KeyPrint + | KeyLL + | KeyA1 + | KeyA3 + | KeyB2 + | KeyC1 + | KeyC3 + | KeyBTab + | KeyBeg + | KeyCancel + | KeyClose + | KeyCommand + | KeyCopy + | KeyCreate + | KeyEnd + | KeyExit + | KeyFind + | KeyHelp + | KeyMark + | KeyMessage + | KeyMove + | KeyNext + | KeyOpen + | KeyOptions + | KeyPrevious + | KeyRedo + | KeyReference + | KeyRefresh + | KeyReplace + | KeyRestart + | KeyResume + | KeySave + | KeySBeg + | KeySCancel + | KeySCommand + | KeySCopy + | KeySCreate + | KeySDC + | KeySDL + | KeySelect + | KeySEnd + | KeySEOL + | KeySExit + | KeySFind + | KeySHelp + | KeySHome + | KeySIC + | KeySLeft + | KeySMessage + | KeySMove + | KeySNext + | KeySOptions + | KeySPrevious + | KeySPrint + | KeySRedo + | KeySReplace + | KeySRight + | KeySRsume + | KeySSave + | KeySSuspend + | KeySUndo + | KeySuspend + | KeyUndo + | KeyResize + | KeyMouse + | KeyUnknown Int + deriving (Eq, Show) + +decodeKey :: CInt -> Key +decodeKey key = case key of + _ | key >= 0 && key <= 255 -> KeyChar (chr (fromIntegral key)) + (#const KEY_BREAK) -> KeyBreak + (#const KEY_DOWN) -> KeyDown + (#const KEY_UP) -> KeyUp + (#const KEY_LEFT) -> KeyLeft + (#const KEY_RIGHT) -> KeyRight + (#const KEY_HOME) -> KeyHome + (#const KEY_BACKSPACE) -> KeyBackspace + _ | key >= (#const KEY_F0) && key <= (#const KEY_F(63)) + -> KeyF (fromIntegral (key - #const KEY_F0)) + (#const KEY_DL) -> KeyDL + (#const KEY_IL) -> KeyIL + (#const KEY_DC) -> KeyDC + (#const KEY_IC) -> KeyIC + (#const KEY_EIC) -> KeyEIC + (#const KEY_CLEAR) -> KeyClear + (#const KEY_EOS) -> KeyEOS + (#const KEY_EOL) -> KeyEOL + (#const KEY_SF) -> KeySF + (#const KEY_SR) -> KeySR + (#const KEY_NPAGE) -> KeyNPage + (#const KEY_PPAGE) -> KeyPPage + (#const KEY_STAB) -> KeySTab + (#const KEY_CTAB) -> KeyCTab + (#const KEY_CATAB) -> KeyCATab + (#const KEY_ENTER) -> KeyEnter + (#const KEY_SRESET) -> KeySReset + (#const KEY_RESET) -> KeyReset + (#const KEY_PRINT) -> KeyPrint + (#const KEY_LL) -> KeyLL + (#const KEY_A1) -> KeyA1 + (#const KEY_A3) -> KeyA3 + (#const KEY_B2) -> KeyB2 + (#const KEY_C1) -> KeyC1 + (#const KEY_C3) -> KeyC3 + (#const KEY_BTAB) -> KeyBTab + (#const KEY_BEG) -> KeyBeg + (#const KEY_CANCEL) -> KeyCancel + (#const KEY_CLOSE) -> KeyClose + (#const KEY_COMMAND) -> KeyCommand + (#const KEY_COPY) -> KeyCopy + (#const KEY_CREATE) -> KeyCreate + (#const KEY_END) -> KeyEnd + (#const KEY_EXIT) -> KeyExit + (#const KEY_FIND) -> KeyFind + (#const KEY_HELP) -> KeyHelp + (#const KEY_MARK) -> KeyMark + (#const KEY_MESSAGE) -> KeyMessage + (#const KEY_MOVE) -> KeyMove + (#const KEY_NEXT) -> KeyNext + (#const KEY_OPEN) -> KeyOpen + (#const KEY_OPTIONS) -> KeyOptions + (#const KEY_PREVIOUS) -> KeyPrevious + (#const KEY_REDO) -> KeyRedo + (#const KEY_REFERENCE) -> KeyReference + (#const KEY_REFRESH) -> KeyRefresh + (#const KEY_REPLACE) -> KeyReplace + (#const KEY_RESTART) -> KeyRestart + (#const KEY_RESUME) -> KeyResume + (#const KEY_SAVE) -> KeySave + (#const KEY_SBEG) -> KeySBeg + (#const KEY_SCANCEL) -> KeySCancel + (#const KEY_SCOMMAND) -> KeySCommand + (#const KEY_SCOPY) -> KeySCopy + (#const KEY_SCREATE) -> KeySCreate + (#const KEY_SDC) -> KeySDC + (#const KEY_SDL) -> KeySDL + (#const KEY_SELECT) -> KeySelect + (#const KEY_SEND) -> KeySEnd + (#const KEY_SEOL) -> KeySEOL + (#const KEY_SEXIT) -> KeySExit + (#const KEY_SFIND) -> KeySFind + (#const KEY_SHELP) -> KeySHelp + (#const KEY_SHOME) -> KeySHome + (#const KEY_SIC) -> KeySIC + (#const KEY_SLEFT) -> KeySLeft + (#const KEY_SMESSAGE) -> KeySMessage + (#const KEY_SMOVE) -> KeySMove + (#const KEY_SNEXT) -> KeySNext + (#const KEY_SOPTIONS) -> KeySOptions + (#const KEY_SPREVIOUS) -> KeySPrevious + (#const KEY_SPRINT) -> KeySPrint + (#const KEY_SREDO) -> KeySRedo + (#const KEY_SREPLACE) -> KeySReplace + (#const KEY_SRIGHT) -> KeySRight + (#const KEY_SRSUME) -> KeySRsume + (#const KEY_SSAVE) -> KeySSave + (#const KEY_SSUSPEND) -> KeySSuspend + (#const KEY_SUNDO) -> KeySUndo + (#const KEY_SUSPEND) -> KeySuspend + (#const KEY_UNDO) -> KeyUndo +#ifdef KEY_RESIZE + (#const KEY_RESIZE) -> KeyResize +#endif +#ifdef KEY_MOUSE + (#const KEY_MOUSE) -> KeyMouse +#endif + _ -> KeyUnknown (fromIntegral key) + +keyResizeCode :: Maybe CInt +#ifdef KEY_RESIZE +keyResizeCode = Just (#const KEY_RESIZE) +#else +keyResizeCode = Nothing +#endif + +cERR :: CInt +cERR = #const ERR + +cKEY_UP, cKEY_DOWN, cKEY_LEFT, cKEY_RIGHT :: ChType +cKEY_UP = #const KEY_UP +cKEY_DOWN = #const KEY_DOWN +cKEY_LEFT = #const KEY_LEFT +cKEY_RIGHT = #const KEY_RIGHT + +cTRUE :: NBool +cTRUE = #const TRUE + +-- ncurses ungetch and Haskell's threadWaitRead do not work together well. +-- So I decided to implement my own input queue. +ungetCh :: (Integral a) => a -> IO () +ungetCh i = do + debug "ungetCh called" + writeChan inputBuf (BufDirect (fi i)) + +data BufData + = -- | Data directly available + BufDirect CInt + | -- | Data can be obtained by calling getch + DataViaGetch + +inputBuf :: Chan BufData +inputBuf = unsafePerformIO newChan +{-# NOINLINE inputBuf #-} + +getchToInputBuf :: IO () +getchToInputBuf = do + threadWaitRead (fi (0 :: Int)) + {- From the (n)curses manpage: + Programmers concerned about portability should be prepared for either + of two cases: (a) signal receipt does not interrupt getch; (b) signal + receipt interrupts getch and causes it to return ERR with errno set to + EINTR. Under the ncurses implementation, handled signals never inter$B!>(B + rupt getch. + -} + -- we only signalize that getch can now called without getting blocked. + -- directly calling `getch' might result in losing the character just + -- read (race condition). + debug "now input available on stdin" + writeChan inputBuf DataViaGetch + +-- | Read a single character from the window. +getCh :: IO Key +getCh = do + debug "getCh called" + tid <- forkIO getchToInputBuf + d <- readChan inputBuf + -- we can kill the thread safely, because the thread does not read any data + -- via getch + killThread tid + v <- case d of + BufDirect x -> + do debug "getCh: getting data directly from buffer" + return x + DataViaGetch -> + do debug "getCh: getting data via getch" + getch -- won't block! + case v of + (#const ERR) -> -- NO CODE IN THIS LINE + do e <- getErrno + if e `elem` [eAGAIN, eINTR] + then do debug "Curses.getCh returned eAGAIN or eINTR" + getCh + else throwErrno "HSCurses.Curses.getch" + k -> let k' = decodeKey k + in do debug ("getCh: result = " ++ show k') + return k' + +resizeTerminal :: Int -> Int -> IO () + +#ifdef HAVE_RESIZETERM +resizeTerminal a b = throwIfErr_ "resizeterm" $ resizeterm (fi a) (fi b) + +foreign import ccall unsafe "HSCurses.h resizeterm" + resizeterm :: CInt -> CInt -> IO CInt +#else +resizeTerminal _ _ = return () +#endif + +-- | The SIGWINCH signal is sent whenever the terminal size changes. This signal +-- is not available on all platforms, so it is a |Maybe| value. + +#ifdef mingw32_HOST_OS +type Signal = CInt +#endif + +cursesSigWinch :: Maybe Signal +#ifdef SIGWINCH +cursesSigWinch = Just (#const SIGWINCH) +#else +cursesSigWinch = Nothing +#endif + +-- | A test case printing out some common attributes. +cursesTest :: IO () +cursesTest = do + initScr + hc <- hasColors + when hc startColor + ccc <- canChangeColor + (ys,xs) <- scrSize + cp <- colorPairs + cs <- colors + endWin + putStrLn $ "ScreenSize: " ++ show (xs,ys) + putStrLn $ "hasColors: " ++ show hc + putStrLn $ "canChangeColor: " ++ show ccc + putStrLn $ "colorPairs: " ++ show cp + putStrLn $ "colors: " ++ show cs + +----------------------------------------------------------------------------- +-- * Mouse routines +----------------------------------------------------------------------------- + +data MouseEvent = MouseEvent + { mouseEventId :: CInt + , mouseEventX :: CInt + , mouseEventY :: CInt + , mouseEventZ :: CInt + , mouseEventButton :: [ButtonEvent] + } + deriving (Show) + +instance Storable MouseEvent where + sizeOf _ = (#size MEVENT) + alignment _ = (#alignment MEVENT) + peek ptr = do + id' <- (#peek MEVENT, id) ptr + x <- (#peek MEVENT, x) ptr + y <- (#peek MEVENT, y) ptr + z <- (#peek MEVENT, z) ptr + bstate :: (#type mmask_t) <- (#peek MEVENT, bstate) ptr + pure $! MouseEvent id' x y z (besFromMouseMask bstate) + poke ptr (MouseEvent id' x y z bstate) = do + (#poke MEVENT, id) ptr id' + (#poke MEVENT, x) ptr x + (#poke MEVENT, y) ptr y + (#poke MEVENT, z) ptr z + (#poke MEVENT, bstate) ptr (besToMouseMask bstate) + +foreign import ccall unsafe "HSCurses.h getmouse" + getmouse :: Ptr MouseEvent -> IO CInt + +getMouse :: (MonadIO m) => m (Maybe MouseEvent) +getMouse = liftIO $ alloca $ \ptr -> do + res <- getmouse ptr + if res == (# const OK) + then Just <$> peek ptr + else pure Nothing + +data ButtonEvent + = ButtonPressed Int + | ButtonReleased Int + | ButtonClicked Int + | ButtonDoubleClicked Int + | ButtonTripleClicked Int + | ButtonShift + | ButtonControl + | ButtonAlt + deriving (Eq, Show) + +withMouseEventMask :: (MonadIO m) => [ButtonEvent] -> m a -> m a +withAllMouseEvents :: (MonadIO m) => m a -> m a + +#ifdef KEY_MOUSE + +foreign import ccall unsafe "HSCurses.h mousemask" + mousemask :: (#type mmask_t) -> Ptr (#type mmask_t) -> IO (#type mmask_t) + +-- TODO: bracket instead? +withMouseEventMask bes action = do + ov <- liftIO $ alloca (\a -> mousemask (besToMouseMask bes) a >> peek a) + r <- action + liftIO $ mousemask ov nullPtr + return r + +withAllMouseEvents action = do + ov <- liftIO $ alloca (\a -> mousemask (#const ALL_MOUSE_EVENTS) a >> peek a) + r <- action + liftIO $ mousemask ov nullPtr + return r + +besToMouseMask :: [ButtonEvent] -> (#type mmask_t) +besToMouseMask bes = foldl' (.|.) 0 (map cb bes) where + cb (ButtonPressed 1) = (#const BUTTON1_PRESSED) + cb (ButtonPressed 2) = (#const BUTTON2_PRESSED) + cb (ButtonPressed 3) = (#const BUTTON3_PRESSED) + cb (ButtonPressed 4) = (#const BUTTON4_PRESSED) + cb (ButtonReleased 1) = (#const BUTTON1_RELEASED) + cb (ButtonReleased 2) = (#const BUTTON2_RELEASED) + cb (ButtonReleased 3) = (#const BUTTON3_RELEASED) + cb (ButtonReleased 4) = (#const BUTTON4_RELEASED) + cb (ButtonClicked 1) = (#const BUTTON1_CLICKED) + cb (ButtonClicked 2) = (#const BUTTON2_CLICKED) + cb (ButtonClicked 3) = (#const BUTTON3_CLICKED) + cb (ButtonClicked 4) = (#const BUTTON4_CLICKED) + cb (ButtonDoubleClicked 1) = (#const BUTTON1_DOUBLE_CLICKED) + cb (ButtonDoubleClicked 2) = (#const BUTTON2_DOUBLE_CLICKED) + cb (ButtonDoubleClicked 3) = (#const BUTTON3_DOUBLE_CLICKED) + cb (ButtonDoubleClicked 4) = (#const BUTTON4_DOUBLE_CLICKED) + cb (ButtonTripleClicked 1) = (#const BUTTON1_TRIPLE_CLICKED) + cb (ButtonTripleClicked 2) = (#const BUTTON2_TRIPLE_CLICKED) + cb (ButtonTripleClicked 3) = (#const BUTTON3_TRIPLE_CLICKED) + cb (ButtonTripleClicked 4) = (#const BUTTON4_TRIPLE_CLICKED) +#if NCURSES_MOUSE_VERSION > 1 + cb (ButtonPressed 5) = (#const BUTTON5_PRESSED) + cb (ButtonReleased 5) = (#const BUTTON5_RELEASED) + cb (ButtonClicked 5) = (#const BUTTON5_CLICKED) + cb (ButtonDoubleClicked 5) = (#const BUTTON5_DOUBLE_CLICKED) + cb (ButtonTripleClicked 5) = (#const BUTTON5_TRIPLE_CLICKED) +#endif + cb ButtonShift = (#const BUTTON_SHIFT) + cb ButtonAlt = (#const BUTTON_ALT) +#ifdef BUTTON_CTRL + cb ButtonControl = (#const BUTTON_CTRL) +#else + cb ButtonControl = (#const BUTTON_CONTROL) +#endif + cb _ = 0 + +besFromMouseMask :: (#type mmask_t) -> [ButtonEvent] +besFromMouseMask mmask = + foldl' + (\evts (c, evt) -> if mmask .&. c /= 0 then evt : evts else evts) + mempty + mappings + where + mappings = + [ ((#const BUTTON1_PRESSED), ButtonPressed 1) + , ((#const BUTTON2_PRESSED), ButtonPressed 2) + , ((#const BUTTON3_PRESSED), ButtonPressed 3) + , ((#const BUTTON4_PRESSED), ButtonPressed 4) + , ((#const BUTTON1_RELEASED), ButtonReleased 1) + , ((#const BUTTON2_RELEASED), ButtonReleased 2) + , ((#const BUTTON3_RELEASED), ButtonReleased 3) + , ((#const BUTTON4_RELEASED), ButtonReleased 4) + , ((#const BUTTON1_CLICKED), ButtonClicked 1) + , ((#const BUTTON2_CLICKED), ButtonClicked 2) + , ((#const BUTTON3_CLICKED), ButtonClicked 3) + , ((#const BUTTON4_CLICKED), ButtonClicked 4) + , ((#const BUTTON1_DOUBLE_CLICKED), ButtonDoubleClicked 1) + , ((#const BUTTON2_DOUBLE_CLICKED), ButtonDoubleClicked 2) + , ((#const BUTTON3_DOUBLE_CLICKED), ButtonDoubleClicked 3) + , ((#const BUTTON4_DOUBLE_CLICKED), ButtonDoubleClicked 4) + , ((#const BUTTON1_TRIPLE_CLICKED), ButtonTripleClicked 1) + , ((#const BUTTON2_TRIPLE_CLICKED), ButtonTripleClicked 2) + , ((#const BUTTON3_TRIPLE_CLICKED), ButtonTripleClicked 3) + , ((#const BUTTON4_TRIPLE_CLICKED), ButtonTripleClicked 4) +#if NCURSES_MOUSE_VERSION > 1 + , ((#const BUTTON5_PRESSED), ButtonPressed 5) + , ((#const BUTTON5_RELEASED), ButtonReleased 5) + , ((#const BUTTON5_CLICKED), ButtonClicked 5) + , ((#const BUTTON5_DOUBLE_CLICKED), ButtonDoubleClicked 5) + , ((#const BUTTON5_TRIPLE_CLICKED), ButtonTripleClicked 5) +#endif + , ((#const BUTTON_SHIFT), ButtonShift) + , ((#const BUTTON_ALT), ButtonAlt) +#ifdef BUTTON_CTRL + , ((#const BUTTON_CTRL), ButtonControl) +#else + , ((#const BUTTON_CONTROL), ButtonControl) +#endif + ] + +#else + +withMouseEventMask _ a = a +withAllMouseEvents = id + +#endif + +ulCorner :: Char +ulCorner = chr 0x250C + +llCorner :: Char +llCorner = chr 0x2514 + +urCorner :: Char +urCorner = chr 0x2510 + +lrCorner :: Char +lrCorner = chr 0x2518 + +rTee :: Char +rTee = chr 0x2524 + +lTee :: Char +lTee = chr 0x251C + +bTee :: Char +bTee = chr 0x2534 + +tTee :: Char +tTee = chr 0x252C + +hLine :: Char +hLine = chr 0x2500 + +vLine :: Char +vLine = chr 0x2502 + +plus :: Char +plus = chr 0x253C + +s1 :: Char +s1 = chr 0x23BA -- was: 0xF800 + +s9 :: Char +s9 = chr 0x23BD -- was: 0xF804 + +diamond :: Char +diamond = chr 0x25C6 + +ckBoard :: Char +ckBoard = chr 0x2592 + +degree :: Char +degree = chr 0x00B0 + +plMinus :: Char +plMinus = chr 0x00B1 + +bullet :: Char +bullet = chr 0x00B7 + +lArrow :: Char +lArrow = chr 0x2190 + +rArrow :: Char +rArrow = chr 0x2192 + +dArrow :: Char +dArrow = chr 0x2193 + +uArrow :: Char +uArrow = chr 0x2191 + +board :: Char +board = chr 0x2591 + +lantern :: Char +lantern = chr 0x256C + +block :: Char +block = chr 0x2588 + +s3 :: Char +s3 = chr 0x23BB -- was: 0xF801 + +s7 :: Char +s7 = chr 0x23BC -- was: 0xF803 + +lEqual :: Char +lEqual = chr 0x2264 + +gEqual :: Char +gEqual = chr 0x2265 + +pi :: Char +pi = chr 0x03C0 + +nEqual :: Char +nEqual = chr 0x2260 + +sterling :: Char +sterling = chr 0x00A3 + +recognize :: Char -> IO a -> (ChType -> IO a) -> IO a +recognize _ch noConvert _convert = noConvert -- Handle the most common case first. diff --git a/UI/HSCurses/CursesHelper.hs b/UI/HSCurses/CursesHelper.hs --- a/UI/HSCurses/CursesHelper.hs +++ b/UI/HSCurses/CursesHelper.hs @@ -27,43 +27,65 @@ -- License along with this library; if not, write to the Free Software -- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA - module UI.HSCurses.CursesHelper ( - - -- * UI initialisation - start, end, suspend, resizeui, + -- UI initialisation + start, + end, + suspend, + resizeui, - -- * Input - getKey, + -- Input + getKey, - -- * Drawing - drawLine, drawCursor, + -- Drawing + drawLine, + drawCursor, - -- * Navigation - gotoTop, + -- Navigation + gotoTop, - -- * Colors - ForegroundColor(..), BackgroundColor(..), - defaultColor, black, red, green, yellow, blue, magenta, cyan, white, + -- Colors + ForegroundColor (..), + BackgroundColor (..), + defaultColor, + black, + red, + green, + yellow, + blue, + magenta, + cyan, + white, - -- * Attributes - Attribute(..), convertAttributes, + -- Attributes + Attribute (..), + convertAttributes, - -- * Style - Style(..), CursesStyle, mkCursesStyle, changeCursesStyle, - setStyle, wSetStyle, resetStyle, wResetStyle, convertStyles, - defaultStyle, defaultCursesStyle, withStyle, wWithStyle, + -- Style + Style (..), + CursesStyle, + mkCursesStyle, + changeCursesStyle, + setStyle, + wSetStyle, + resetStyle, + wResetStyle, + convertStyles, + defaultStyle, + defaultCursesStyle, + withStyle, + wWithStyle, - -- * Keys - displayKey, + -- Keys + displayKey, - -- * Helpers - withCursor, withProgram - ) where + -- Helpers + withCursor, + withProgram, +) where -import UI.HSCurses.Curses hiding ( refresh, Window ) +import UI.HSCurses.Curses as Curses import UI.HSCurses.Logging -import qualified UI.HSCurses.Curses as Curses import Data.Char import Data.Maybe @@ -73,49 +95,44 @@ import Control.Monad.Catch (MonadCatch, bracket, bracket_) #define MonadMask MonadCatch #endif + +import Control.Monad import Control.Monad.Trans #ifndef mingw32_HOST_OS import System.Posix.Signals #endif --- --- - --- -- | @start@ initializes the UI and grabs the keyboard. -- -- This function installs a handler for the SIGWINCH signal -- which writes the KEY_RESIZE key to the input queue (if KEY_RESIZE and -- and SIGWINCH are both available). --- start :: IO () start = do - Curses.initCurses -- initialise the screen + Curses.initCurses -- initialise the screen Curses.resetParams - Curses.keypad Curses.stdScr True -- grab the keyboard + Curses.keypad Curses.stdScr True -- grab the keyboard case (Curses.cursesSigWinch, Curses.keyResizeCode) of #ifndef mingw32_HOST_OS - (Just sig, Just key) -> - do installHandler sig (Catch $ sigwinch sig key) Nothing - return () + (Just sig, Just key) -> + void $ installHandler sig (Catch $ sigwinch sig key) Nothing #endif - _ -> debug ("cannot install SIGWINCH handler: signal=" ++ - show Curses.cursesSigWinch ++ ", KEY_RESIZE=" ++ - show Curses.keyResizeCode) + _ -> + debug $ + "cannot install SIGWINCH handler: signal=" + ++ show Curses.cursesSigWinch + ++ ", KEY_RESIZE=" + ++ show Curses.keyResizeCode #ifndef mingw32_HOST_OS - where sigwinch sig key = - do debug "SIGWINCH signal received" - Curses.ungetCh key - installHandler sig (Catch $ sigwinch sig key) Nothing - return () + where + sigwinch sig key = do + debug "SIGWINCH signal received" + Curses.ungetCh key + void $ installHandler sig (Catch $ sigwinch sig key) Nothing #endif - - --- -- | Clean up and go home. --- end :: IO () end = do Curses.endWin -- Refresh is needed on linux. grr. @@ -123,9 +140,7 @@ Curses.update #endif --- -- | Suspend the program. --- suspend :: IO () #ifndef mingw32_HOST_OS suspend = raiseSignal sigTSTP @@ -133,78 +148,60 @@ suspend = return () #endif --- -- | @getKey refresh@ reads a key. -- -- The @refresh@ function is used to redraw the screen when the terminal size -- changes (see the documentatio of @start@ for a discussion of the problem). --- -getKey :: MonadIO m => m () -> m Key +getKey :: (MonadIO m) => m () -> m Key getKey refresh = do k <- liftIO $ Curses.getCh debug ("getKey: " ++ show k) case k of - KeyResize -> - do refresh - getKey refresh - _ -> return k - + KeyResize -> + do + refresh + getKey refresh + _ -> return k --- -- | @drawLine n s@ draws @n@ characters of string @s@. --- drawLine :: Int -> String -> IO () -- lazy version is faster than calculating length of s drawLine w s = Curses.wAddStr Curses.stdScr $! take w (s ++ repeat ' ') --- -- | Draw the cursor at the given position. --- -drawCursor :: (Int,Int) -> (Int, Int) -> IO () -drawCursor (o_y,o_x) (y,x) = withCursor Curses.CursorVisible $ do +drawCursor :: (Int, Int) -> (Int, Int) -> IO () +drawCursor (o_y, o_x) (y, x) = withCursor Curses.CursorVisible $ do gotoTop - (h,w) <- scrSize - Curses.wMove Curses.stdScr (min (h-1) (o_y + y)) (min (w-1) (o_x + x)) + (h, w) <- scrSize + Curses.wMove Curses.stdScr (min (h - 1) (o_y + y)) (min (w - 1) (o_x + x)) --- -- | Move cursor to origin of stdScr. --- gotoTop :: IO () gotoTop = Curses.wMove Curses.stdScr 0 0 - --- -- | Resize the window -- From "Writing Programs with NCURSES", by Eric S. Raymond and -- Zeyd M. Ben-Halim --- --- -resizeui :: IO (Int,Int) +resizeui :: IO (Int, Int) resizeui = do Curses.endWin Curses.refresh Curses.scrSize - - ------------------------------------------------------------------------- --- -- | Basic colors. --- defaultColor :: Curses.Color defaultColor = fromJust $ Curses.color "default" black, red, green, yellow, blue, magenta, cyan, white :: Curses.Color -black = fromJust $ Curses.color "black" -red = fromJust $ Curses.color "red" -green = fromJust $ Curses.color "green" -yellow = fromJust $ Curses.color "yellow" -blue = fromJust $ Curses.color "blue" -magenta = fromJust $ Curses.color "magenta" -cyan = fromJust $ Curses.color "cyan" -white = fromJust $ Curses.color "white" +black = fromJust $ Curses.color "black" +red = fromJust $ Curses.color "red" +green = fromJust $ Curses.color "green" +yellow = fromJust $ Curses.color "yellow" +blue = fromJust $ Curses.color "blue" +magenta = fromJust $ Curses.color "magenta" +cyan = fromJust $ Curses.color "cyan" +white = fromJust $ Curses.color "white" --- -- | Converts a list of 'Curses.Color' pairs (foreground color and -- background color) into the curses representation 'Curses.Pair'. -- @@ -212,20 +209,28 @@ -- -- (not visible outside this module) colorsToPairs :: [(Curses.Color, Curses.Color)] -> IO [Curses.Pair] -colorsToPairs cs = - do p <- Curses.colorPairs - let nColors = length cs - blackWhite = p < nColors - if blackWhite - then trace ("Terminal does not support enough colors. Number of " ++ - " colors requested: " ++ show nColors ++ - ". Number of colors supported: " ++ show p) - return $ take nColors (repeat (Curses.Pair 0)) - else mapM toPairs (zip [1..] cs) - where toPairs (n, (fg, bg)) = - let p = Curses.Pair n - in do Curses.initPair p fg bg - return p +colorsToPairs cs = do + p <- Curses.colorPairs + let nColors = length cs + blackWhite = p < nColors + if blackWhite + then + trace + ( "Terminal does not support enough colors. Number of " + ++ " colors requested: " + ++ show nColors + ++ ". Number of colors supported: " + ++ show p + ) + return + $ take nColors (repeat (Curses.Pair 0)) + else mapM toPairs (zip [1 ..] cs) + where + toPairs (n, (fg, bg)) = + let p = Curses.Pair n + in do + Curses.initPair p fg bg + return p ------------------------------------------------------------------------ -- Nicer, user-visible color defs. @@ -234,9 +239,7 @@ -- from erroneously constructing bright colors for dark backgrounds, -- which doesn't work. --- -- | Foreground colors. --- data ForegroundColor = BlackF | GreyF @@ -257,9 +260,7 @@ | DefaultF deriving (Eq, Show) --- -- | Background colors. --- data BackgroundColor = BlackB | DarkRedB @@ -272,107 +273,94 @@ | DefaultB deriving (Eq, Show) --- -- | Mapping abstract colours to ncurses attributes and colours -- -- (not visible outside this module) - convertBg :: BackgroundColor -> ([Attribute], Curses.Color) convertBg c = case c of - BlackB -> ([], black) - DarkRedB -> ([], red) - DarkGreenB -> ([], green) - BrownB -> ([], yellow) - DarkBlueB -> ([], blue) - PurpleB -> ([], magenta) - DarkCyanB -> ([], cyan) - WhiteB -> ([], white) - DefaultB -> ([], defaultColor) + BlackB -> ([], black) + DarkRedB -> ([], red) + DarkGreenB -> ([], green) + BrownB -> ([], yellow) + DarkBlueB -> ([], blue) + PurpleB -> ([], magenta) + DarkCyanB -> ([], cyan) + WhiteB -> ([], white) + DefaultB -> ([], defaultColor) convertFg :: ForegroundColor -> ([Attribute], Curses.Color) convertFg c = case c of - BlackF -> ([], black) - GreyF -> ([Bold], black) - DarkRedF -> ([], red) - RedF -> ([Bold], red) - DarkGreenF -> ([], green) - GreenF -> ([Bold], green) - BrownF -> ([], yellow) - YellowF -> ([Bold], yellow) - DarkBlueF -> ([], blue) - BlueF -> ([Bold], blue) - PurpleF -> ([], magenta) - MagentaF -> ([Bold], magenta) - DarkCyanF -> ([], cyan) - CyanF -> ([Bold], cyan) - WhiteF -> ([], white) + BlackF -> ([], black) + GreyF -> ([Bold], black) + DarkRedF -> ([], red) + RedF -> ([Bold], red) + DarkGreenF -> ([], green) + GreenF -> ([Bold], green) + BrownF -> ([], yellow) + YellowF -> ([Bold], yellow) + DarkBlueF -> ([], blue) + BlueF -> ([Bold], blue) + PurpleF -> ([], magenta) + MagentaF -> ([Bold], magenta) + DarkCyanF -> ([], cyan) + CyanF -> ([Bold], cyan) + WhiteF -> ([], white) BrightWhiteF -> ([Bold], white) - DefaultF -> ([], defaultColor) - + DefaultF -> ([], defaultColor) ------------------------------------------------------------------------- --- -- | Abstractions for some commonly used attributes. --- -data Attribute = Bold - | Underline - | Dim - | Reverse - | Blink - deriving (Eq, Show) +data Attribute + = Bold + | Underline + | Dim + | Reverse + | Blink + deriving (Eq, Show) --- -- | Converts an abstract attribute list into its curses representation. --- convertAttributes :: [Attribute] -> Curses.Attr convertAttributes = foldr setAttrs Curses.attr0 - where setAttrs Bold = setBoldA - setAttrs Underline = setUnderlineA - setAttrs Dim = setDimA - setAttrs Reverse = setReverseA - setAttrs Blink = setBlinkA + where + setAttrs Bold = setBoldA + setAttrs Underline = setUnderlineA + setAttrs Dim = setDimA + setAttrs Reverse = setReverseA + setAttrs Blink = setBlinkA -setBoldA, setUnderlineA, setDimA, - setReverseA, setBlinkA :: Curses.Attr -> Curses.Attr +setBoldA + , setUnderlineA + , setDimA + , setReverseA + , setBlinkA :: + Curses.Attr -> Curses.Attr setBoldA = flip Curses.setBold True setUnderlineA = flip Curses.setUnderline True setDimA = flip Curses.setDim True -setReverseA = flip Curses.setReverse True +setReverseA = flip Curses.setReverse True setBlinkA = flip Curses.setBlink True ------------------------------------------------------------------------- --- --- | A humand-readable style. --- -data Style = Style ForegroundColor BackgroundColor - | AttributeStyle [Attribute] ForegroundColor BackgroundColor - | ColorlessStyle [Attribute] - deriving (Eq, Show) +-- | A human-readable style. +data Style + = Style ForegroundColor BackgroundColor + | AttributeStyle [Attribute] ForegroundColor BackgroundColor + | ColorlessStyle [Attribute] + deriving (Eq, Show) defaultStyle :: Style defaultStyle = Style DefaultF DefaultB --- -- | A style which uses the internal curses representations for -- attributes and colors. --- -data CursesStyle = CursesStyle Curses.Attr Curses.Pair - | ColorlessCursesStyle Curses.Attr - deriving (Eq, Show) - -{- -instance Show CursesStyle where - show (CursesStyle _ _) = "CursesStyle" - show (ColorlessCursesStyle _) = "ColorlessCursesStyle" --} +data CursesStyle + = CursesStyle Curses.Attr Curses.Pair + | ColorlessCursesStyle Curses.Attr + deriving (Eq, Show) mkCursesStyle :: [Attribute] -> CursesStyle mkCursesStyle attrs = ColorlessCursesStyle (convertAttributes attrs) --- -- | Changes the attributes of the given CursesStyle. --- changeCursesStyle :: CursesStyle -> [Attribute] -> CursesStyle changeCursesStyle (CursesStyle _ p) attrs = CursesStyle (convertAttributes attrs) p @@ -381,26 +369,22 @@ defaultCursesStyle :: CursesStyle defaultCursesStyle = CursesStyle Curses.attr0 (Curses.Pair 0) --- -- | Reset the screen to normal values --- resetStyle :: IO () resetStyle = wResetStyle Curses.stdScr wResetStyle :: Curses.Window -> IO () wResetStyle = flip wSetStyle defaultCursesStyle --- -- | Manipulate the current style of the standard screen --- setStyle :: CursesStyle -> IO () setStyle = wSetStyle Curses.stdScr wSetStyle :: Curses.Window -> CursesStyle -> IO () wSetStyle window (CursesStyle a p) = Curses.wAttrSet window (a, p) -wSetStyle window (ColorlessCursesStyle a) = - do (_, p) <- Curses.wAttrGet window - Curses.wAttrSet window (a, p) +wSetStyle window (ColorlessCursesStyle a) = do + (_, p) <- Curses.wAttrGet window + Curses.wAttrSet window (a, p) withStyle :: (MonadIO m, MonadMask m) => CursesStyle -> m a -> m a withStyle = wWithStyle Curses.stdScr @@ -408,58 +392,57 @@ wWithStyle :: (MonadIO m, MonadMask m) => Curses.Window -> CursesStyle -> m a -> m a wWithStyle window style action = bracket - (liftIO $ do old <- Curses.wAttrGet window -- before - wSetStyle window style - return old) + ( liftIO $ do + old <- Curses.wAttrGet window -- before + wSetStyle window style + return old + ) (\old -> liftIO $ Curses.wAttrSet window old) -- after - (\_ -> action) -- do this + (\_ -> action) -- do this --- -- | Converts a list of human-readable styles into the corresponding -- curses representation. -- -- This function should be called exactly once at application startup -- for all styles of the application. convertStyles :: [Style] -> IO [CursesStyle] -convertStyles styleList = - do let (attrs, cs) = unzip $ map convertStyle styleList - cursesAttrs = map convertAttributes attrs - cursesPairs <- colorsToPairs' cs - let res = zipWith toCursesStyle cursesAttrs cursesPairs - trace ("convertStyles: " ++ show (zip styleList res)) (return res) - where convertStyle (Style fg bg) = convertStyle (AttributeStyle [] fg bg) - convertStyle (AttributeStyle attrs fg bg) = - let (afg, cfg) = convertFg fg - (abg, cbg) = convertBg bg - in (afg ++ abg ++ attrs, Just (cfg, cbg)) - convertStyle (ColorlessStyle attrs) = (attrs, Nothing) - colorsToPairs' cs = - do pairs <- colorsToPairs (catMaybes cs) - return $ mergeNothing cs pairs - mergeNothing (Just _:crest) (p:prest) = Just p - : mergeNothing crest prest - mergeNothing (Nothing:crest) ps = Nothing : mergeNothing crest ps - mergeNothing [] [] = [] - toCursesStyle cursesAttrs Nothing = - ColorlessCursesStyle cursesAttrs - toCursesStyle cursesAttrs (Just cursesPair) = - CursesStyle cursesAttrs cursesPair - ------------------------------------------------------------------------- --- --- | Converting keys to humand-readable strings --- +convertStyles styleList = do + let (attrs, cs) = unzip $ map convertStyle styleList + cursesAttrs = map convertAttributes attrs + cursesPairs <- colorsToPairs' cs + let res = zipWith toCursesStyle cursesAttrs cursesPairs + trace ("convertStyles: " ++ show (zip styleList res)) (return res) + where + convertStyle (Style fg bg) = convertStyle (AttributeStyle [] fg bg) + convertStyle (AttributeStyle attrs fg bg) = + let (afg, cfg) = convertFg fg + (abg, cbg) = convertBg bg + in (afg ++ abg ++ attrs, Just (cfg, cbg)) + convertStyle (ColorlessStyle attrs) = (attrs, Nothing) + colorsToPairs' cs = do + pairs <- colorsToPairs (catMaybes cs) + return $ mergeNothing cs pairs + mergeNothing (Just _ : crest) (p : prest) = + Just p + : mergeNothing crest prest + mergeNothing (Nothing : crest) ps = Nothing : mergeNothing crest ps + mergeNothing _ _ = [] + toCursesStyle cursesAttrs Nothing = + ColorlessCursesStyle cursesAttrs + toCursesStyle cursesAttrs (Just cursesPair) = + CursesStyle cursesAttrs cursesPair +-- | Converting keys to human-readable strings displayKey :: Key -> String displayKey (KeyChar ' ') = "" displayKey (KeyChar '\t') = "" displayKey (KeyChar '\r') = "" displayKey (KeyChar c) | isPrint c = [c] -displayKey (KeyChar c) -- Control - | ord '\^A' <= ord c && ord c <= ord '\^Z' - = let c' = chr $ ord c - ord '\^A' + ord 'a' - in '^':[toUpper c'] +displayKey (KeyChar c) -- Control + | ord '\^A' <= ord c && ord c <= ord '\^Z' = + let c' = chr $ ord c - ord '\^A' + ord 'a' + in '^' : [toUpper c'] displayKey (KeyChar c) = show c displayKey KeyDown = "" displayKey KeyUp = "" @@ -479,19 +462,18 @@ ------------------------------------------------------------------------ -- --- | Other helpers +-- Other helpers -- --- --- | set the cursor, and do action --- +-- | Set the cursor, and do action withCursor :: (MonadIO m, MonadMask m) => CursorVisibility -> m a -> m a withCursor nv action = bracket - (liftIO $ Curses.cursSet nv) -- before - (\vis -> liftIO $ Curses.cursSet vis) -- after - (\_ -> action) -- do this + (liftIO $ Curses.cursSet nv) -- before + (\vis -> liftIO $ Curses.cursSet vis) -- after + (\_ -> action) -- do this withProgram :: (MonadIO m, MonadMask m) => m a -> m a -withProgram action = withCursor CursorVisible $ - bracket_ (liftIO endWin) (liftIO flushinp) action +withProgram action = + withCursor CursorVisible $ + bracket_ (liftIO endWin) (liftIO flushinp) action diff --git a/UI/HSCurses/IConv.hsc b/UI/HSCurses/IConv.hsc --- a/UI/HSCurses/IConv.hsc +++ b/UI/HSCurses/IConv.hsc @@ -23,34 +23,25 @@ -- | Iconv binding #if HAVE_ICONV_H -# include +#include #endif -module UI.HSCurses.IConv {-( - IConv, - iconv, - iconv_, - with_iconv, - to_unicode, - from_unicode, - to_unicode_, - from_unicode_ - )-} where +module UI.HSCurses.IConv where -import UI.HSCurses.CWString ( peekUTF8StringLen, withUTF8StringLen ) +import UI.HSCurses.CWString (peekUTF8StringLen, withUTF8StringLen) -import System.IO.Unsafe ( unsafePerformIO ) +import System.IO.Unsafe (unsafePerformIO) #if !MIN_VERSION_base(4,7,0) -import Foreign hiding ( unsafePerformIO ) +import Foreign hiding (unsafePerformIO) #else import Foreign #endif +import Control.Exception (Exception, bracket, try) import Foreign.C -import Control.Exception ( Exception, try, bracket ) -type IConv = Ptr () --(#type iconv_t) +type IConv = Ptr () -- (#type iconv_t) err_ptr :: Ptr b -> Bool err_ptr p = p == (plusPtr nullPtr (-1)) @@ -58,23 +49,25 @@ throw_if_not_2_big :: String -> IO CSize -> IO CSize throw_if_not_2_big s r_ = do r <- r_ - if r == fromIntegral (-1 :: Int) then do - errno <- getErrno - if errno /= e2BIG then - throwErrno s - else - return r - else - return r + if r == fromIntegral (-1 :: Int) + then do + errno <- getErrno + if errno /= e2BIG + then + throwErrno s + else + return r + else + return r iconv_open :: String -> String -> IO IConv iconv_open to from = withCString to $ \cto -> withCString from $ - \cfrom -> do - throwErrnoIf err_ptr "iconv_open" - $ c_iconv_open cto cfrom - + \cfrom -> + do + throwErrnoIf err_ptr "iconv_open" + $ c_iconv_open cto cfrom iconv_close :: IConv -> IO () iconv_close ic = @@ -90,22 +83,27 @@ alloca $ \outbuf_ptr -> alloca $ \outbytesleft_ptr -> allocaBytes outbuf_size $ \outbuf -> do - poke (inbytesleft_ptr :: Ptr CSize) (fromIntegral inbuf_bytes) - poke inbuf_ptr inbuf - let loop acc = do - poke (outbytesleft_ptr :: Ptr CSize) (fromIntegral outbuf_size) - poke outbuf_ptr outbuf - ret <- throw_if_not_2_big "c_iconv" $ - c_iconv ic inbuf_ptr inbytesleft_ptr - outbuf_ptr outbytesleft_ptr - left <- peek outbytesleft_ptr - res <- get_string_fn (castPtr outbuf, outbuf_size - fromIntegral left) - if ret == fromIntegral (-1 :: Int) then - loop (acc++res) - else - return (acc++res) - loop [] - + poke (inbytesleft_ptr :: Ptr CSize) (fromIntegral inbuf_bytes) + poke inbuf_ptr inbuf + let loop acc = do + poke (outbytesleft_ptr :: Ptr CSize) (fromIntegral outbuf_size) + poke outbuf_ptr outbuf + ret <- + throw_if_not_2_big "c_iconv" $ + c_iconv + ic + inbuf_ptr + inbytesleft_ptr + outbuf_ptr + outbytesleft_ptr + left <- peek outbytesleft_ptr + res <- get_string_fn (castPtr outbuf, outbuf_size - fromIntegral left) + if ret == fromIntegral (-1 :: Int) + then + loop (acc ++ res) + else + return (acc ++ res) + loop [] with_iconv :: String -> String -> (IConv -> IO a) -> IO a with_iconv to from fn = @@ -116,24 +114,12 @@ withCStringLen str $ do_iconv peekCStringLen ic -- between 8-bit encodings only -iconv :: Exception e => String -> String -> String -> Either e String +iconv :: (Exception e) => String -> String -> String -> Either e String iconv to from str = unsafePerformIO $ try $ with_iconv to from (iconv_ str) - #ifdef HAVE_WCHAR_H -{- -type CUni = (#type wchar_t) -cuni_size = (#size wchar_t) -unicode_charset = "WCHAR_T" -chartocuni :: Char -> CUni -chartocuni = fromIntegral . ord - -cunitochar :: CUni -> Char -cunitochar = chr . fromIntegral --} - cuni_charset :: [Char] cuni_charset = "WCHAR_T" @@ -144,14 +130,13 @@ error "Conversion result contains remainder bytes." else peekCWStringLen (buf, chars) - --liftM (map cunitochar) $ peekArray chars buf with_cuni :: String -> ((Ptr (#type wchar_t), Int) -> IO String) -> IO String with_cuni str f = withCWStringLen str $ \(s, l) -> f (s, l*(#size wchar_t)) - --withArray (map chartocuni str) $ \s -> f (s, l*cuni_size) #else + -- no CF_WCHAR_SUPPORT -- Due to endianness problems, it is easiest to do this through UTF-8 @@ -169,43 +154,46 @@ to_unicode_ :: String -> String -> IO String to_unicode_ from str = - with_iconv cuni_charset from $ - \ic -> withCStringLen str $ do_iconv peek_cuni ic + with_iconv cuni_charset from $ + \ic -> withCStringLen str $ do_iconv peek_cuni ic -to_unicode :: Exception e => String -> String -> Either e String +to_unicode :: (Exception e) => String -> String -> Either e String to_unicode from str = unsafePerformIO $ try $ to_unicode_ from str from_unicode_ :: String -> String -> IO String from_unicode_ to str = - with_iconv to cuni_charset $ - \ic -> with_cuni str $ do_iconv peekCStringLen ic + with_iconv to cuni_charset $ + \ic -> with_cuni str $ do_iconv peekCStringLen ic -from_unicode :: Exception e => String -> String -> Either e String +from_unicode :: (Exception e) => String -> String -> Either e String from_unicode from str = unsafePerformIO $ try $ from_unicode_ from str - #ifndef ICONV_LIB_PREFIX -foreign import ccall unsafe "iconv.h iconv_open" c_iconv_open - :: CString -> CString -> IO IConv - -foreign import ccall unsafe "iconv.h iconv_close" c_iconv_close - :: IConv -> IO CInt +foreign import ccall unsafe "iconv.h iconv_open" + c_iconv_open :: + CString -> CString -> IO IConv -foreign import ccall unsafe "iconv.h iconv" c_iconv - :: IConv -> Ptr a -> Ptr CSize -> Ptr b -> Ptr CSize -> IO CSize +foreign import ccall unsafe "iconv.h iconv_close" + c_iconv_close :: + IConv -> IO CInt +foreign import ccall unsafe "iconv.h iconv" + c_iconv :: + IConv -> Ptr a -> Ptr CSize -> Ptr b -> Ptr CSize -> IO CSize #else -foreign import ccall unsafe "iconv.h libiconv_open" c_iconv_open - :: CString -> CString -> IO IConv - -foreign import ccall unsafe "iconv.h libiconv_close" c_iconv_close - :: IConv -> IO CInt +foreign import ccall unsafe "iconv.h libiconv_open" + c_iconv_open :: + CString -> CString -> IO IConv -foreign import ccall unsafe "iconv.h libiconv" c_iconv - :: IConv -> Ptr a -> Ptr CSize -> Ptr b -> Ptr CSize -> IO CSize +foreign import ccall unsafe "iconv.h libiconv_close" + c_iconv_close :: + IConv -> IO CInt +foreign import ccall unsafe "iconv.h libiconv" + c_iconv :: + IConv -> Ptr a -> Ptr CSize -> Ptr b -> Ptr CSize -> IO CSize #endif diff --git a/UI/HSCurses/Logging.hs b/UI/HSCurses/Logging.hs --- a/UI/HSCurses/Logging.hs +++ b/UI/HSCurses/Logging.hs @@ -16,27 +16,22 @@ -- License along with this library; if not, write to the Free Software -- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -module UI.HSCurses.Logging (trace,debug) where +module UI.HSCurses.Logging (trace, debug) where import Control.Monad.Trans -#define __DEBUG__ 0 - -#if __DEBUG__ +#if DEBUG -import Data.IORef import System.IO import System.IO.Unsafe (unsafePerformIO) -import System.Locale -import System.Time +import qualified Data.Time as Time #endif - trace :: String -> a -> a -debug :: MonadIO m => String -> m () +debug :: (MonadIO m) => String -> m () -#if __DEBUG__ +#if DEBUG logFile :: Handle logFile = unsafePerformIO $ do h <- openFile ".hscurses.log" AppendMode @@ -45,33 +40,25 @@ {-# NOINLINE logFile #-} formatTime :: IO String -formatTime = - do let fmt = "%Y-%m-%d %H:%M:%S" - clockT <- getClockTime - calTime <- toCalendarTime clockT - let maxSdecLen = 5 - sdec' = show $ ctPicosec calTime - sdec = if length sdec' > maxSdecLen - then take maxSdecLen sdec' - else sdec' - return (formatCalendarTime defaultTimeLocale fmt calTime - ++ ":" ++ sdec) - -trace s x = - unsafePerformIO $ do debug s - return x - -debug s = liftIO $ debug_ logFile s +formatTime = do + let fmt = "%Y-%m-%d %H:%M:%S%03Q" + now <- Time.getZonedTime + return $ Time.formatTime Time.defaultTimeLocale fmt now +debug_ :: Handle -> String -> IO () debug_ f s = do ts <- formatTime hPutStrLn f ("[" ++ ts ++ "] " ++ s) hFlush f +trace s x = + unsafePerformIO $ do debug s + return x +debug s = liftIO $ debug_ logFile s + #else trace _ x = x - debug _ = return () #endif diff --git a/UI/HSCurses/Widgets.hs b/UI/HSCurses/Widgets.hs --- a/UI/HSCurses/Widgets.hs +++ b/UI/HSCurses/Widgets.hs @@ -1,956 +1,1133 @@ -{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, CPP #-} - --- Copyright (c) 2005-2011 Stefan Wehr - http://www.stefanwehr.de --- --- This library is free software; you can redistribute it and/or --- modify it under the terms of the GNU Lesser General Public --- License as published by the Free Software Foundation; either --- version 2.1 of the License, or (at your option) any later version. --- --- This library 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 --- Lesser General Public License for more details. --- --- You should have received a copy of the GNU Lesser General Public --- License along with this library; if not, write to the Free Software --- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA - -module UI.HSCurses.Widgets where - -import Control.Exception (assert) -#if MIN_VERSION_exceptions(0,6,0) -import Control.Monad.Catch (MonadMask) -#else -import Control.Monad.Catch (MonadCatch) -#define MonadMask MonadCatch -#endif -import Control.Monad.Trans -import Data.Char -import Data.List -import Data.Maybe - -import UI.HSCurses.Logging -import qualified UI.HSCurses.Curses as Curses -import qualified UI.HSCurses.CursesHelper as CursesH - -type Pos = (Int, Int) -type Offset = (Int, Int) - -type Size = (Int, -- height - Int -- width - ) - -getHeight :: Size -> Int -getHeight = fst - -getWidth :: Size -> Int -getWidth = snd - -getYOffset :: Offset -> Int -getYOffset = fst - -getXOffset :: Offset -> Int -getXOffset = snd - -getYPos :: Pos -> Int -getYPos = fst - -getXPos :: Pos -> Int -getXPos = snd - -data Direction = DirLeft | DirRight | DirUp | DirDown - deriving (Eq, Show, Ord) - -data HAlignment = AlignLeft | AlignCenter | AlignRight - deriving (Eq, Show) - -data Cont a = Cont a | Done a - -class Widget a where - draw :: Pos -> Size -> DrawingHint -> a -> IO () - minSize :: a -> Size - -class Widget a => ActiveWidget a where - activate :: (MonadIO m, MonadMask m) => m () -> Pos -> Size -> a -> - m (a, String) - -type KeyHandler a = Pos -> Size -> a -> IO (Cont a) - -mkKeyHandler :: (Pos -> Size -> a -> a) - -> KeyHandler a -mkKeyHandler f pos sz w = return (Cont (f pos sz w)) - --- --- Drawing --- - -data DrawingHint = DHNormal - | DHFocus - | DHActive - deriving (Eq, Show, Ord) - -data DrawingStyle = DStyle - { dstyle_normal :: CursesH.CursesStyle - , dstyle_focus :: CursesH.CursesStyle - , dstyle_active :: CursesH.CursesStyle - } deriving (Eq, Show) - - -mkDrawingStyle :: CursesH.CursesStyle -> DrawingStyle -mkDrawingStyle defStyle = - let revStyle = CursesH.changeCursesStyle defStyle [CursesH.Reverse] - in DStyle { dstyle_normal = defStyle - , dstyle_focus = revStyle - , dstyle_active = revStyle - } - -defaultDrawingStyle :: DrawingStyle -defaultDrawingStyle = mkDrawingStyle CursesH.defaultCursesStyle -_draw :: DrawingHint -> DrawingStyle -> IO a -> IO a -_draw DHActive sty io = CursesH.withStyle (dstyle_active sty) io -_draw DHNormal sty io = CursesH.withStyle (dstyle_normal sty) io -_draw DHFocus sty io = CursesH.withStyle (dstyle_focus sty) io - --- --- Helper functions for scrolling --- - -scrollFactor :: Double -scrollFactor = 0.8 - -scrollBy :: Int -> Int -scrollBy displayLen = - let amount = floor ((fromInteger . toInteger) displayLen * scrollFactor) - in max (displayLen - 1) (min 1 amount) - --- returns the new offset for scrolling in forward direction --- dataLen: total number of data items --- offset: the index of the first data item shown on the current page --- displayLen: the number of data items that is shown in one page -scrollForward :: Int -> Int -> Int -> Int -scrollForward dataLen offset displayLen = - if offset + displayLen >= dataLen - then offset - else min (offset + scrollBy displayLen) (dataLen - displayLen) - --- returns the new offset for scrolling in backward direction. --- parameters as for scrollForward -scrollBackward :: t -> Int -> Int -> Int -scrollBackward _ offset displayLen = - if offset == 0 - then offset - else max (offset - scrollBy displayLen) 0 - - --- --- EmptyWidget --- - -data EmptyWidget = EmptyWidget Size - -instance Widget EmptyWidget where - draw _ _ _ _ = return () - minSize (EmptyWidget sz) = sz - - --- --- An opaque widget --- - -data OpaqueWidget = OpaqueWidget Size - -instance Widget OpaqueWidget where - draw (y,x) (h,w) _ _ = - let draw' n = - do Curses.wMove Curses.stdScr (y+n) x - CursesH.drawLine w "" - in do mapM draw' (take h [0..]) - Curses.refresh - minSize (OpaqueWidget sz) = sz - --- --- Widget for text input --- - -data EditWidget = EditWidget - { ew_content :: String, - ew_xoffset :: Int, -- content!!xoffset is the 1st char shown - ew_xcursor :: Int, -- cursor position - ew_history :: [String], - ew_historyIndex :: Int, - ew_historySavedContent :: Maybe String, - ew_options :: EditWidgetOptions - } - -ew_contentPos :: EditWidget -> Int -ew_contentPos ew = ew_xcursor ew + ew_xoffset ew - -instance Widget EditWidget where - draw = drawEditWidget - minSize ew = (1, ewopt_minWidth $ ew_options ew) - -instance ActiveWidget EditWidget where - activate = activateEditWidget - -data EditWidgetOptions = EWOptions - { ewopt_keyHandlers :: [(Curses.Key, KeyHandler EditWidget)], - ewopt_minWidth :: Int, - ewopt_style :: DrawingStyle - } - -defaultEWOptions :: EditWidgetOptions -defaultEWOptions = EWOptions - { ewopt_keyHandlers = editWidgetKeyHandlers, - ewopt_minWidth = 8, - ewopt_style = defaultDrawingStyle - } - -newEditWidget :: EditWidgetOptions -> String -> EditWidget -newEditWidget opts = - editWidgetSetContent - (EditWidget - { ew_content = "", - ew_xoffset = 0, - ew_xcursor = 0, - ew_history = [], - ew_historyIndex = -1, - ew_historySavedContent = Nothing, - ew_options = opts - }) - - - -editWidgetGoLeft :: Pos - -> Size - -> EditWidget - -> IO (Cont EditWidget) -editWidgetGoLeft = mkKeyHandler editWidgetGoLeft' -editWidgetGoRight :: Pos - -> Size - -> EditWidget - -> IO (Cont EditWidget) -editWidgetGoRight = mkKeyHandler editWidgetGoRight' -editWidgetDeleteLeft :: Pos - -> Size - -> EditWidget - -> IO (Cont EditWidget) -editWidgetDeleteLeft = mkKeyHandler editWidgetDeleteLeft' -editWidgetDeleteUnderCursor :: Pos - -> Size - -> EditWidget - -> IO (Cont EditWidget) -editWidgetDeleteUnderCursor = mkKeyHandler editWidgetDeleteUnderCursor' -editWidgetDeleteToEnd :: Pos - -> Size - -> EditWidget - -> IO (Cont EditWidget) -editWidgetDeleteToEnd = mkKeyHandler editWidgetDeleteToEnd' -editWidgetGoHome :: Pos - -> Size - -> EditWidget - -> IO (Cont EditWidget) -editWidgetGoHome = mkKeyHandler editWidgetGoHome' -editWidgetGoEnd :: Pos - -> Size - -> EditWidget - -> IO (Cont EditWidget) -editWidgetGoEnd = mkKeyHandler editWidgetGoEnd' -editWidgetHistoryUp :: Pos - -> Size - -> EditWidget - -> IO (Cont EditWidget) -editWidgetHistoryUp = mkKeyHandler editWidgetHistoryUp' -editWidgetHistoryDown :: Pos - -> Size - -> EditWidget - -> IO (Cont EditWidget) -editWidgetHistoryDown = mkKeyHandler editWidgetHistoryDown' - -editWidgetKeyHandlers :: [(Curses.Key, - Pos - -> Size - -> EditWidget - -> IO (Cont EditWidget))] -editWidgetKeyHandlers = - [(Curses.KeyLeft, editWidgetGoLeft), - (Curses.KeyRight, editWidgetGoRight), - (Curses.KeyBackspace, editWidgetDeleteLeft), - (Curses.KeyChar '\^D', editWidgetDeleteUnderCursor), - (Curses.KeyDC, editWidgetDeleteUnderCursor), - (Curses.KeyChar '\^K', editWidgetDeleteToEnd), - (Curses.KeyHome, editWidgetGoHome), - (Curses.KeyChar '\^A', editWidgetGoHome), - (Curses.KeyEnd, editWidgetGoEnd), - (Curses.KeyChar '\^E', editWidgetGoEnd), - (Curses.KeyChar '\r', editWidgetFinish), - (Curses.KeyChar '\t', editWidgetFinish), - (Curses.KeyUp, editWidgetHistoryUp), - (Curses.KeyDown, editWidgetHistoryDown) - ] - -editWidgetGetContent :: EditWidget -> String -editWidgetGetContent ew = ew_content ew -editWidgetSetContent :: EditWidget - -> String - -> EditWidget -editWidgetSetContent ew s = - addToHistory (ew { ew_content = s, ew_xoffset = 0, ew_xcursor = 0 }) s - -editWidgetGetOptions :: EditWidget - -> EditWidgetOptions -editWidgetGetOptions ew = ew_options ew -editWidgetSetOptions :: EditWidget - -> EditWidgetOptions - -> EditWidget -editWidgetSetOptions ew opts = ew { ew_options = opts } - -drawEditWidget :: Pos -> Size -> DrawingHint -> EditWidget -> IO () -drawEditWidget (y, x) (_, width) hint ew = - _draw hint (ewopt_style . ew_options $ ew) $ - do Curses.wMove Curses.stdScr y x - CursesH.drawLine width (drop (ew_xoffset ew) $ ew_content ew) - Curses.refresh - -activateEditWidget :: (MonadIO m, MonadMask m) => m () -> Pos -> Size - -> EditWidget -> m (EditWidget, String) -activateEditWidget refresh pos@(y, x) sz@(_, width) ew = - CursesH.withCursor Curses.CursorVisible $ processKey ew - where - processKey ex = - do liftIO $ drawLocal ex - k <- CursesH.getKey refresh - case lookup k (ewopt_keyHandlers $ ew_options ex) of - Nothing -> - case k of - Curses.KeyChar c | isAscii c && isPrint c - -> processKey $ insertChar ex c - _ -> processKey ex - Just f -> - do x' <- liftIO $ f pos sz ex - case x' of - Cont ex' -> processKey ex' - Done ex' -> do liftIO $ drawEditWidget pos sz DHActive ex' - return (ex', editWidgetGetContent ex') - insertChar ew' c = - let pos' = ew_contentPos ew' - oldContent = ew_content ew' - newContent = take pos' oldContent ++ (c : drop pos' oldContent) - in editWidgetGoRight' pos' sz (ew' { ew_content = newContent }) - drawLocal ew' = _draw DHActive (ewopt_style . ew_options $ ew') $ - do Curses.wMove Curses.stdScr y x - CursesH.drawLine width (drop (ew_xoffset ew') $ ew_content ew') - Curses.wMove Curses.stdScr y (x + ew_xcursor ew') - Curses.refresh - -editWidgetGoLeft' :: t -> t1 -> EditWidget -> EditWidget -editWidgetGoLeft' _ _ ew = - let newXcursor = max (ew_xcursor ew - 1) 0 - newXoffset = if ew_xcursor ew == 0 - then max (ew_xoffset ew - 1) 0 - else ew_xoffset ew - in ew { ew_xoffset = newXoffset, - ew_xcursor = newXcursor } - -editWidgetGoRight' :: t -> (t1, Int) -> EditWidget -> EditWidget -editWidgetGoRight' _ (_, width) ew = - let len = length (ew_content ew) - lastChar = len - ew_xoffset ew - 1 - newXcursor = minimum [ew_xcursor ew + 1, lastChar + 1, width - 1] - newXoffset = if ew_xcursor ew == width - 1 - then min (ew_xoffset ew + 1) (len - width + 1) - else ew_xoffset ew - in ew { ew_xoffset = newXoffset, - ew_xcursor = newXcursor } - -editWidgetDeleteLeft' :: Pos -> Size -> EditWidget -> EditWidget -editWidgetDeleteLeft' pos sz ew = - let cpos = ew_contentPos ew - 1 - oldContent = ew_content ew - newContent = take cpos oldContent ++ drop (cpos+1) oldContent - ew' = editWidgetGoLeft' pos sz (ew { ew_content = newContent }) - in if ew_xcursor ew == 0 && ew_xoffset ew /= 0 - then editWidgetGoRight' pos sz (editWidgetGoLeft' pos sz ew') - else ew' - -editWidgetDeleteUnderCursor' :: t -> t1 -> EditWidget -> EditWidget -editWidgetDeleteUnderCursor' _ _ ew = - let pos = ew_contentPos ew - oldContent = ew_content ew - newContent = take pos oldContent ++ drop (pos+1) oldContent - in ew { ew_content = newContent } - -editWidgetDeleteToEnd' :: t -> t1 -> EditWidget -> EditWidget -editWidgetDeleteToEnd' _ _ ew = - let pos = ew_contentPos ew - oldContent = ew_content ew - newContent = take pos oldContent - in ew { ew_content = newContent } - -editWidgetGoHome' :: t -> t1 -> EditWidget -> EditWidget -editWidgetGoHome' _ _ ew = - ew { ew_xcursor = 0, - ew_xoffset = 0 } - -editWidgetGoEnd' :: Pos -> Size -> EditWidget -> EditWidget -editWidgetGoEnd' pos sz ew = - let cpos = ew_contentPos ew - len = length (ew_content ew) - in if cpos == len - then ew - else editWidgetGoEnd' pos sz (editWidgetGoRight' pos sz ew) - -editWidgetFinish :: (Monad m) => t -> t1 -> EditWidget -> m (Cont EditWidget) -editWidgetFinish _ _ ew = return (Done (addToHistory ew (ew_content ew))) - -maxHistoryLength :: Int -maxHistoryLength = 50 - -addToHistory :: EditWidget -> [Char] -> EditWidget -addToHistory ew s = - let newHist = if not (null s) - then take maxHistoryLength (s : ew_history ew) - else ew_history ew - in ew { ew_history = newHist, ew_historyIndex = -1, - ew_historySavedContent = Nothing } - -editWidgetHistoryUp' :: t -> t1 -> EditWidget -> EditWidget -editWidgetHistoryUp' _ _ ew = editWidgetHistory (+) ew - -editWidgetHistoryDown' :: t -> t1 -> EditWidget -> EditWidget -editWidgetHistoryDown' _ _ ew = editWidgetHistory (-) ew - --- ew_historyList: list of history items, i.e. non-null strings which were --- entered into the widget and confirmed with ENTER or which were added --- via editWidgetSetContent. --- ew_historyIndex: the index of the history item shown in the widget. The --- value -1 means that the value saved in ew_historySavedContent should --- be shown. -editWidgetHistory :: (Num t) => (Int -> t -> Int) -> EditWidget -> EditWidget -editWidgetHistory op ew = - let i = ew_historyIndex ew - l = ew_history ew - j = i `op` 1 - in if j >= 0 && j < length l - then let savedContent = - case ew_historySavedContent ew of - Nothing -> Just (ew_content ew) - x -> x - in ew { ew_historyIndex = j, ew_content = l!!j, - ew_historySavedContent = savedContent, - ew_xcursor = 0, ew_xoffset = 0 } - else if j == -1 - then case ew_historySavedContent ew of - Nothing -> ew - Just x -> ew { ew_content = x, - ew_historyIndex = j, - ew_xcursor = 0, - ew_xoffset = 0 } - else ew - - - --- --- Text widget --- - -data TextWidget = TextWidget - { tw_text :: String, - tw_yoffset :: Int, - tw_xoffset :: Int, - tw_options :: TextWidgetOptions - } - deriving (Eq, Show) - -instance Widget TextWidget where - draw = drawTextWidget - minSize tw = - case twopt_size $ tw_options tw of - TWSizeDefault -> let l = lines (tw_text tw) - in (length l, if null l then 0 else maximum (map length l)) - TWSizeFixed sz -> sz - -data TextWidgetSize = TWSizeDefault -- minimal size determined by content - | TWSizeFixed Size -- minimal size is fixed, content is - -- possibly cut off - deriving (Eq, Show) - {- - | Autowrap -- minimal width determined by content, - -- but lines are wrapped if necessary - -} - -data TextWidgetOptions = TWOptions - { twopt_size :: TextWidgetSize, - twopt_style :: DrawingStyle, - twopt_halign :: HAlignment } - deriving (Eq, Show) - -defaultTWOptions :: TextWidgetOptions -defaultTWOptions = TWOptions - { twopt_size = TWSizeDefault, - twopt_style = defaultDrawingStyle, - twopt_halign = AlignLeft } - -newTextWidget :: TextWidgetOptions -> String -> TextWidget -newTextWidget opts s = TextWidget - { tw_text = s, - tw_yoffset = 0, - tw_xoffset = 0, - tw_options = opts - } - -drawTextWidget :: Pos -> Size -> DrawingHint -> TextWidget -> IO () -drawTextWidget (y, x) (height, width) hint tw = - let ly = take height $ drop (tw_yoffset tw) (lines (tw_text tw)) - l = take height $ (map (drop (tw_xoffset tw)) ly ++ repeat []) - l' = map (align (twopt_halign $ tw_options tw) width ' ') l - in --trace ("drawing text widget at " ++ show pos ++ " with size " ++ show sz) $ - do _draw hint (twopt_style . tw_options $ tw) - (mapM drawLine $ zip l' [0..]) - Curses.refresh - where drawLine (s, i) = - do Curses.wMove Curses.stdScr (y + i) x - CursesH.drawLine width s - -textWidgetGetText :: TextWidget -> String -textWidgetGetText = tw_text - -textWidgetSetText :: TextWidget -> String -> TextWidget -textWidgetSetText tw s = tw { tw_text = s } - -textWidgetScrollDown :: Size -> TextWidget -> TextWidget -textWidgetScrollDown (h, _) tw = - let dataLen = length $ lines (tw_text tw) - offset = tw_yoffset tw - in tw { tw_yoffset = scrollForward dataLen offset h } - -textWidgetScrollUp :: Size -> TextWidget -> TextWidget -textWidgetScrollUp (h, _) tw = - let dataLen = length $ lines (tw_text tw) - offset = tw_yoffset tw - in tw { tw_yoffset = scrollBackward dataLen offset h } - -textWidgetScrollLeft :: Size -> TextWidget -> TextWidget -textWidgetScrollLeft (_, w) tw = - let dataLen = length $ lines (tw_text tw) - offset = tw_xoffset tw - in tw { tw_xoffset = scrollBackward dataLen offset w } - -textWidgetScrollRight :: Size -> TextWidget -> TextWidget -textWidgetScrollRight (_, w) tw = - let dataLen = length $ lines (tw_text tw) - offset = tw_xoffset tw - in tw { tw_xoffset = scrollForward dataLen offset w } - - --- --- Table widget --- - -data TableCell = forall w. Widget w => TableCell w - | forall w. ActiveWidget w => ActiveTableCell w - -isActive :: TableCell -> Bool -isActive (TableCell _) = False -isActive (ActiveTableCell _) = True - -instance Widget TableCell where - draw pos sz hint (TableCell w) = draw pos sz hint w - draw pos sz hint (ActiveTableCell w) = draw pos sz hint w - minSize (TableCell w) = minSize w - minSize (ActiveTableCell w) = minSize w - -_activateTableCell :: (MonadIO m, MonadMask m) => m () -> Pos -> Size - -> TableCell -> m (TableCell, String) -_activateTableCell _ _ _ (TableCell _) = - error "_activateTableCell: cannot activate non-active cell!" -_activateTableCell refresh pos sz (ActiveTableCell w) = - do (new, res) <- activate refresh pos sz w - return (ActiveTableCell new, res) - -type Row = [TableCell] - -singletonRow :: TableCell -> Row -singletonRow tc = [tc] - -getCellWidget :: TableWidget -> (Int, Int) -> TableCell -getCellWidget tbw (row, col) = (tbw_rows tbw) !! row !! col - -setCellWidget :: TableWidget -> (Int, Int) -> TableCell -> TableWidget -setCellWidget tbw (rowIndex, colIndex) w = - let rows = tbw_rows tbw - row = rows !! rowIndex - newRow = listReplace row w colIndex - newRows = listReplace rows newRow rowIndex - in tbw { tbw_rows = newRows } - -data TableWidget = TableWidget - { tbw_rows :: [Row], - tbw_colOffset :: Int, - tbw_pos :: Maybe Pos, - tbw_options :: TableWidgetOptions } - -data FillRow = First | Last | None deriving (Eq,Show) - -data TableWidgetOptions = TBWOptions - { tbwopt_fillCol :: Maybe Int, - tbwopt_fillRow :: FillRow, - tbwopt_activeCols :: [Int], - tbwopt_minSize :: Size } - deriving (Eq, Show) - -defaultTBWOptions :: TableWidgetOptions -defaultTBWOptions = TBWOptions - { tbwopt_fillCol = Nothing, - tbwopt_fillRow = None, - tbwopt_activeCols = [], - tbwopt_minSize = (4, 10) } - -instance Widget TableWidget where - draw = drawTableWidget - minSize = tbwopt_minSize . tbw_options - -newTableWidget :: TableWidgetOptions -> [Row] -> TableWidget -newTableWidget opts rows = TableWidget - { tbw_rows = rows, - tbw_colOffset = 0, - tbw_pos = findFirstActiveCell rows opts, - tbw_options = opts } - -data TableWidgetDisplayInfo = - TBWDisplayInfo - { tbwdisp_height :: Int -- height of the display area - , tbwdisp_width :: Int -- width of the display area - , tbwdisp_firstVis :: Int -- index of the first row visible - , tbwdisp_lastVis :: Int -- index of the last row visible - , tbwdisp_rows :: [Row] -- the rows which are visible - , tbwdisp_nrows :: Int -- the number of rows visible - , tbwdisp_heights :: [Int] -- the heights of the visible rows - , tbwdisp_widths :: [Int] -- the widths of the visible rows - -- free space at the right side (xoffset, size) - , tbwdisp_rightMargin :: Maybe (Int, Size) - } - -tableWidgetDisplayInfo :: Size -> TableWidget -> TableWidgetDisplayInfo -tableWidgetDisplayInfo (height, width) tbw = - assert (isQuadratic (tbw_rows tbw)) $ - let allRows = tbw_rows tbw - ncols = length (allRows!!0) - colOffset = tbw_colOffset tbw - allHeights = minSpaces getHeight allRows - heights' = drop colOffset allHeights - nrows = getNRows heights' 0 0 - rows = take nrows $ drop colOffset allRows - (heights, heightDummy) = - let hs = take nrows heights' - s = sum hs - d = height - s - in case tbwopt_fillRow $ tbw_options tbw of - First -> (applyToFirst (+d) hs, 0) - Last -> (applyToLast (+d) hs, 0) - None -> (hs, d) - widths' = minSpaces getWidth (transpose $ tbw_rows tbw) - (widths, rightMargin) = - if sum widths' > width - then error ("table to wide: width=" ++ show (sum widths') ++ - ", available width=" ++ show width) - else case tbwopt_fillCol $ tbw_options tbw of - Just i | i >= 0 && i < ncols - -> (take i widths' ++ - let rest = drop i widths' - in (head rest + width - sum widths') : tail rest - , Nothing) - _ -> let diff = width - sum widths' - msz = (height, diff) - m = if diff > 0 then Just (sum widths', msz) - else Nothing - in (widths', m) - dummyHeights = if heightDummy == 0 then [] else [heightDummy] - dummyRows = if heightDummy == 0 then [] - else [map (\w -> TableCell (OpaqueWidget (heightDummy, w))) - widths] - in TBWDisplayInfo - { tbwdisp_height = height - , tbwdisp_width = width - , tbwdisp_firstVis = colOffset - , tbwdisp_lastVis = colOffset + nrows - 1 - , tbwdisp_rows = rows ++ dummyRows - , tbwdisp_nrows = nrows + length dummyRows - , tbwdisp_heights = heights ++ dummyHeights - , tbwdisp_widths = widths - , tbwdisp_rightMargin = rightMargin - } - where - minSpaces f ls = - snd $ mapAccumL - (\acc ws -> - (acc, acc + maximum (map (f . minSize) ws))) - 0 ls - getNRows (h:hs) n acc | h + n <= height = getNRows hs (h+n) (acc+1) - getNRows _ _ acc = acc - isQuadratic [] = True - isQuadratic (x:xs) = isQuadratic' xs (length x) - isQuadratic' (x:xs) n = length x == n && isQuadratic' xs n - isQuadratic' [] _ = True - applyToFirst _ [] = [] - applyToFirst f (x:xs) = f x : xs - applyToLast _ [] = [] - applyToLast f l = - let (h, t) = (head $ reverse l, tail $ reverse l) - in reverse $ f h : t - -getCellInfo :: Pos -> Size -> TableWidget -> (Int,Int) -> (Pos, Size) -getCellInfo (y,x) sz tbw (row, col) = - let info = tableWidgetDisplayInfo sz tbw - heights = tbwdisp_heights info - widths = tbwdisp_widths info - h = heights !! row - w = widths !! col - yoff = sum $ take row heights - xoff = sum $ take col widths - in ((y+yoff, x+xoff), (h, w)) - -drawTableWidget :: Pos -> Size -> DrawingHint -> TableWidget -> IO () -drawTableWidget (y, x) sz hint tbw = - let info = tableWidgetDisplayInfo sz tbw - heights = tbwdisp_heights info - widths = tbwdisp_widths info - firstVis = tbwdisp_firstVis info - rows = tbwdisp_rows info - rightMargin = tbwdisp_rightMargin info - in do drawRows rows heights widths 0 firstVis hint - case rightMargin of - Nothing -> return () - Just (xoff,s) -> draw (y,x+xoff) s hint (OpaqueWidget s) - Curses.refresh - where drawRows :: [Row] -> [Int] -> [Int] -> Int -> Int - -> DrawingHint -> IO () - drawRows [] _ _ _ _ _ = return () - drawRows (r:rs) (h:hs) widths yoffset rowIndex hint' = - do drawCols r h widths yoffset 0 (rowIndex, 0) hint' - drawRows rs hs widths (yoffset + h) (rowIndex + 1) hint' - drawCols :: Row -> Int -> [Int] -> Int -> Int -> (Int, Int) - -> DrawingHint -> IO () - drawCols [] _ _ _ _ _ _ = return () - drawCols (c:cs) h (w:ws) yoffset xoffset (rowIndex, colIndex) hint' = - let hint'' = case tbw_pos tbw of - Just (z, a) | z == rowIndex && a == colIndex - -> DHFocus - _ -> hint' - in do draw (y+yoffset, x+xoffset) (h,w) hint'' c - drawCols cs h ws yoffset (xoffset + w) - (rowIndex, colIndex+1) hint' - - -tableWidgetScrollDown :: Size -> TableWidget -> TableWidget -tableWidgetScrollDown (h, _) tbw = - let dataLen = length $ tbw_rows tbw - offset = tbw_colOffset tbw - newOffset = scrollForward dataLen offset h - newTbw = tbw { tbw_colOffset = newOffset } - in case tbw_pos newTbw of - Nothing -> newTbw - Just (y,x) -> newTbw { tbw_pos = Just (max newOffset y, x) } - -tableWidgetScrollUp :: Size -> TableWidget -> TableWidget -tableWidgetScrollUp sz@(h,_) tbw = - let dataLen = length $ tbw_rows tbw - offset = tbw_colOffset tbw - newOffset = scrollBackward dataLen offset h - newTbw = tbw { tbw_colOffset = newOffset } - newLastVis = tbwdisp_lastVis (tableWidgetDisplayInfo sz newTbw) - in case tbw_pos newTbw of - Nothing -> newTbw - Just (y,x) -> - newTbw { tbw_pos = Just (min newLastVis y, x) } - -tableWidgetActivateCurrent :: (MonadIO m, MonadMask m) => m () -> Pos -> Size - -> DrawingHint -> TableWidget - -> m (TableWidget, Maybe String) -tableWidgetActivateCurrent refresh (y, x) sz _ tbw = - case tbw_pos tbw of - Nothing -> do debug "tableWidgetActivateCurrent: pos=Nothing" - return (tbw, Nothing) - Just p -> let w = getCellWidget tbw p - in if not $ isActive w - then do debug "tableWidgetActivateCurrent: not active" - return (tbw, Nothing) - else activate' w p - where - activate' widget colyx@(coly, colx) = - let info = tableWidgetDisplayInfo sz tbw - vcol = colx - vrow = coly - tbwdisp_firstVis info - heights = tbwdisp_heights info - widths = tbwdisp_widths info - h = heights !! vrow - w = widths !! vcol - yoffset = sum (take vrow heights) - xoffset = sum (take vcol widths) - in do (new, res) <- _activateTableCell refresh (y+yoffset, x+xoffset) - (h, w) widget - return (setCellWidget tbw colyx new, Just res) - -tableWidgetGoLeft :: Size -> TableWidget -> TableWidget -tableWidgetGoLeft = tableWidgetMove DirLeft - -tableWidgetGoRight :: Size -> TableWidget -> TableWidget -tableWidgetGoRight = tableWidgetMove DirRight - -tableWidgetGoUp :: Size -> TableWidget -> TableWidget -tableWidgetGoUp = tableWidgetMove DirUp - -tableWidgetGoDown :: Size -> TableWidget -> TableWidget -tableWidgetGoDown = tableWidgetMove DirDown - -tableWidgetMove :: Direction - -> (Int, Int) - -> TableWidget - -> TableWidget -tableWidgetMove dir sz tbw = - let pos = tbw_pos tbw - opts = tbw_options tbw - nrows = length (tbw_rows tbw) - in case pos of - Nothing -> tbw - Just p -> case findNextActiveCell opts nrows p dir of - Nothing -> tbw - newP@(Just (y, _)) -> - tableWidgetMakeVisible (tbw {tbw_pos=newP}) sz y - -tableWidgetMakeVisible :: TableWidget - -> (Int, Int) - -> Int - -> TableWidget -tableWidgetMakeVisible tbw sz@(_,_) y = - let info = tableWidgetDisplayInfo sz tbw - firstVis = tbwdisp_firstVis info - lastVis = tbwdisp_lastVis info - in if y < firstVis - then tableWidgetMakeVisible (tableWidgetScrollUp sz tbw) sz y - else if y > lastVis - then tableWidgetMakeVisible - (tableWidgetScrollDown sz tbw) sz y - else tbw - -findFirstActiveCell :: [Row] -> TableWidgetOptions -> Maybe Pos -findFirstActiveCell rows opts = - let nrows = length rows - firstActiveCells = map (\y -> findNextActiveCell opts nrows - (y, -1) DirRight) - [0..nrows-1] - in case catMaybes firstActiveCells of - [] -> Nothing - (x:_) -> Just x - -findNextActiveCell :: TableWidgetOptions -> Int -> Pos -> Direction - -> Maybe Pos -findNextActiveCell opts nrows (y,x) dir = --- trace ("findNextActiveCell (opts=" ++ show opts ++ ", nrows=" ++ show nrows --- ++ ", pos=" ++ show pos ++ ", dir=" ++ show dir) $ - let rows = [0..(nrows - 1)] - cols = sort (tbwopt_activeCols opts) - horiz f = case f cols x rows y of - Nothing -> Nothing - Just z -> Just (y, z) - vert f = case f rows y cols x of - Nothing -> Nothing - Just z -> Just (z, x) - res = case dir of - DirLeft-> horiz goLeft - DirRight -> horiz goRight - DirUp -> vert goLeft - DirDown -> vert goRight - in --trace ("result of findNextActiveCell: " ++ show res) - res - where goLeft _ _ rows a | not (a `elem` rows) = Nothing - goLeft cols b _ _ = - case reverse (takeWhile ( Nothing - (c:_) -> Just c - goRight _ _ rows a | not (a `elem` rows) = Nothing - goRight cols a _ _ = - case dropWhile (a>=) cols of - [] -> Nothing - (b:_) -> Just b - -tableWidgetDeleteRow :: Int -> TableWidget -> TableWidget -tableWidgetDeleteRow n tbw = - let rows = tbw_rows tbw - rows' = deleteAt n rows - pos' = - case tbw_pos tbw of - Nothing -> Nothing - Just (row,col) -> - let row' = min row (length rows' - 1) - in if row' >= 0 then Just (row', col) - else Nothing - in tbw { tbw_rows = rows', tbw_pos = pos' } - --- --- BorderWidget --- - - --- --- Selection Widget --- - --- --- Utility functions --- - --- | Join a list by some delimiter -joinLists :: [[a]] -> [a] -> [a] -joinLists l s = if (null l) then [] else foldr1 (\x -> \y -> x ++ s ++ y) l - --- | Split a list by some delimiter -splitList :: Eq a => [a] -> [a] -> [[a]] -splitList d l = - unfoldr (\x -> if (null x) - then Nothing - else Just $ nextToken d [] (snd $ splitAt (length d) x)) - (d++l) - where nextToken _ r [] = (r, []) - nextToken e r m@(h:t) | (e `isPrefixOf` m) = (r, m) - | otherwise = nextToken e (r++[h]) t - -listReplace :: [a] -> a -> Int -> [a] -listReplace l a i = - case splitAt i l of - (_, []) -> error ("listReplace: index to large. index="++show i++ - ", length="++show (length l)) - ([], _) | i < 0 -> error ("listReplace: negative index. index="++ - show i) - (xs,(_:ys)) -> xs ++ (a:ys) - ---alignRows :: [[String]] -> Char -> String -> [String] -alignRows :: [[[a]]] -> a -> [a] -> [[a]] -alignRows rows fill delim = - let widths = foldr maxWidths (repeat 0) rows - in map (alignRow widths) rows - where - maxWidths :: [[a]] -> [Int] -> [Int] - maxWidths row acc = map (uncurry max) (zip acc (map length row)) - alignRow widths row = concatMap (uncurry alignCell) (zip widths row) - alignCell width cell = - let diff = width - length cell - in cell ++ (take diff $ repeat fill) ++ delim - - -align :: HAlignment -> Int -> a -> [a] -> [a] -align a w f l = - let space = w - length l - in case a of - AlignLeft -> l ++ (fill space) - AlignRight -> (fill space) ++ l - AlignCenter -> - let left = space `div` 2 - right = left + (space `mod` 2) - in fill left ++ l ++ fill right - where fill n = take n (repeat f) - -deleteAt :: Int -> [a] -> [a] -deleteAt n l = if n >= 0 && n < length l - then let (a,b) = splitAt n l in a ++ (tail b) - else error ("deleteAt: illegal index: " ++ show n) +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- Copyright (c) 2005-2011 Stefan Wehr - http://www.stefanwehr.de +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + +module UI.HSCurses.Widgets where + +import Control.Exception (assert) +#if MIN_VERSION_exceptions(0,6,0) +import Control.Monad.Catch (MonadMask) +#else +import Control.Monad.Catch (MonadCatch) +#define MonadMask MonadCatch +#endif +import Control.Monad.Trans +import Data.Char +import Data.List +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe + +import qualified UI.HSCurses.Curses as Curses +import qualified UI.HSCurses.CursesHelper as CursesH +import UI.HSCurses.Logging + +type Pos = (Int, Int) +type Offset = (Int, Int) + +type Size = + ( Int -- height + , Int -- width + ) + +getHeight :: Size -> Int +getHeight = fst + +getWidth :: Size -> Int +getWidth = snd + +getYOffset :: Offset -> Int +getYOffset = fst + +getXOffset :: Offset -> Int +getXOffset = snd + +getYPos :: Pos -> Int +getYPos = fst + +getXPos :: Pos -> Int +getXPos = snd + +data Direction = DirLeft | DirRight | DirUp | DirDown + deriving (Eq, Show, Ord) + +data HAlignment = AlignLeft | AlignCenter | AlignRight + deriving (Eq, Show) + +data Cont a = Cont a | Done a + +class Widget a where + draw :: Pos -> Size -> DrawingHint -> a -> IO () + minSize :: a -> Size + +class (Widget a) => ActiveWidget a where + activate :: + (MonadIO m, MonadMask m) => + m () -> + Pos -> + Size -> + a -> + m (a, String) + +type KeyHandler a = Pos -> Size -> a -> IO (Cont a) + +mkKeyHandler :: + (Pos -> Size -> a -> a) -> + KeyHandler a +mkKeyHandler f pos sz w = return (Cont (f pos sz w)) + +-- +-- Drawing +-- + +data DrawingHint + = DHNormal + | DHFocus + | DHActive + deriving (Eq, Show, Ord) + +data DrawingStyle = DStyle + { dstyle_normal :: CursesH.CursesStyle + , dstyle_focus :: CursesH.CursesStyle + , dstyle_active :: CursesH.CursesStyle + } + deriving (Eq, Show) + +mkDrawingStyle :: CursesH.CursesStyle -> DrawingStyle +mkDrawingStyle defStyle = + let revStyle = CursesH.changeCursesStyle defStyle [CursesH.Reverse] + in DStyle + { dstyle_normal = defStyle + , dstyle_focus = revStyle + , dstyle_active = revStyle + } + +defaultDrawingStyle :: DrawingStyle +defaultDrawingStyle = mkDrawingStyle CursesH.defaultCursesStyle +_draw :: DrawingHint -> DrawingStyle -> IO a -> IO a +_draw DHActive sty io = CursesH.withStyle (dstyle_active sty) io +_draw DHNormal sty io = CursesH.withStyle (dstyle_normal sty) io +_draw DHFocus sty io = CursesH.withStyle (dstyle_focus sty) io + +-- +-- Helper functions for scrolling +-- + +scrollFactor :: Double +scrollFactor = 0.8 + +scrollBy :: Int -> Int +scrollBy displayLen = + let amount = floor ((fromInteger . toInteger) displayLen * scrollFactor) + in max (displayLen - 1) (min 1 amount) + +-- returns the new offset for scrolling in forward direction +-- dataLen: total number of data items +-- offset: the index of the first data item shown on the current page +-- displayLen: the number of data items that is shown in one page +scrollForward :: Int -> Int -> Int -> Int +scrollForward dataLen offset displayLen = + if offset + displayLen >= dataLen + then offset + else min (offset + scrollBy displayLen) (dataLen - displayLen) + +-- returns the new offset for scrolling in backward direction. +-- parameters as for scrollForward +scrollBackward :: t -> Int -> Int -> Int +scrollBackward _ offset displayLen = + if offset == 0 + then offset + else max (offset - scrollBy displayLen) 0 + +-- +-- EmptyWidget +-- + +data EmptyWidget = EmptyWidget Size + +instance Widget EmptyWidget where + draw _ _ _ _ = return () + minSize (EmptyWidget sz) = sz + +-- +-- An opaque widget +-- + +data OpaqueWidget = OpaqueWidget Size + +instance Widget OpaqueWidget where + draw (y, x) (h, w) _ _ = + let draw' n = + do + Curses.wMove Curses.stdScr (y + n) x + CursesH.drawLine w "" + in do + mapM draw' (take h [0 ..]) + Curses.refresh + minSize (OpaqueWidget sz) = sz + +-- +-- Widget for text input +-- + +data EditWidget = EditWidget + { ew_content :: String + , ew_xoffset :: Int -- content!!xoffset is the 1st char shown + , ew_xcursor :: Int -- cursor position + , ew_history :: [String] + , ew_historyIndex :: Int + , ew_historySavedContent :: Maybe String + , ew_options :: EditWidgetOptions + } + +ew_contentPos :: EditWidget -> Int +ew_contentPos ew = ew_xcursor ew + ew_xoffset ew + +instance Widget EditWidget where + draw = drawEditWidget + minSize ew = (1, ewopt_minWidth $ ew_options ew) + +instance ActiveWidget EditWidget where + activate = activateEditWidget + +data EditWidgetOptions = EWOptions + { ewopt_keyHandlers :: [(Curses.Key, KeyHandler EditWidget)] + , ewopt_minWidth :: Int + , ewopt_style :: DrawingStyle + } + +defaultEWOptions :: EditWidgetOptions +defaultEWOptions = + EWOptions + { ewopt_keyHandlers = editWidgetKeyHandlers + , ewopt_minWidth = 8 + , ewopt_style = defaultDrawingStyle + } + +newEditWidget :: EditWidgetOptions -> String -> EditWidget +newEditWidget opts = + editWidgetSetContent + ( EditWidget + { ew_content = "" + , ew_xoffset = 0 + , ew_xcursor = 0 + , ew_history = [] + , ew_historyIndex = -1 + , ew_historySavedContent = Nothing + , ew_options = opts + } + ) + +editWidgetGoLeft :: + Pos -> + Size -> + EditWidget -> + IO (Cont EditWidget) +editWidgetGoLeft = mkKeyHandler editWidgetGoLeft' +editWidgetGoRight :: + Pos -> + Size -> + EditWidget -> + IO (Cont EditWidget) +editWidgetGoRight = mkKeyHandler editWidgetGoRight' +editWidgetDeleteLeft :: + Pos -> + Size -> + EditWidget -> + IO (Cont EditWidget) +editWidgetDeleteLeft = mkKeyHandler editWidgetDeleteLeft' +editWidgetDeleteUnderCursor :: + Pos -> + Size -> + EditWidget -> + IO (Cont EditWidget) +editWidgetDeleteUnderCursor = mkKeyHandler editWidgetDeleteUnderCursor' +editWidgetDeleteToEnd :: + Pos -> + Size -> + EditWidget -> + IO (Cont EditWidget) +editWidgetDeleteToEnd = mkKeyHandler editWidgetDeleteToEnd' +editWidgetGoHome :: + Pos -> + Size -> + EditWidget -> + IO (Cont EditWidget) +editWidgetGoHome = mkKeyHandler editWidgetGoHome' +editWidgetGoEnd :: + Pos -> + Size -> + EditWidget -> + IO (Cont EditWidget) +editWidgetGoEnd = mkKeyHandler editWidgetGoEnd' +editWidgetHistoryUp :: + Pos -> + Size -> + EditWidget -> + IO (Cont EditWidget) +editWidgetHistoryUp = mkKeyHandler editWidgetHistoryUp' +editWidgetHistoryDown :: + Pos -> + Size -> + EditWidget -> + IO (Cont EditWidget) +editWidgetHistoryDown = mkKeyHandler editWidgetHistoryDown' + +editWidgetKeyHandlers :: + [ ( Curses.Key + , Pos -> + Size -> + EditWidget -> + IO (Cont EditWidget) + ) + ] +editWidgetKeyHandlers = + [ (Curses.KeyLeft, editWidgetGoLeft) + , (Curses.KeyRight, editWidgetGoRight) + , (Curses.KeyBackspace, editWidgetDeleteLeft) + , (Curses.KeyChar '\^D', editWidgetDeleteUnderCursor) + , (Curses.KeyDC, editWidgetDeleteUnderCursor) + , (Curses.KeyChar '\^K', editWidgetDeleteToEnd) + , (Curses.KeyHome, editWidgetGoHome) + , (Curses.KeyChar '\^A', editWidgetGoHome) + , (Curses.KeyEnd, editWidgetGoEnd) + , (Curses.KeyChar '\^E', editWidgetGoEnd) + , (Curses.KeyChar '\r', editWidgetFinish) + , (Curses.KeyChar '\t', editWidgetFinish) + , (Curses.KeyUp, editWidgetHistoryUp) + , (Curses.KeyDown, editWidgetHistoryDown) + ] + +editWidgetGetContent :: EditWidget -> String +editWidgetGetContent ew = ew_content ew +editWidgetSetContent :: + EditWidget -> + String -> + EditWidget +editWidgetSetContent ew s = + addToHistory (ew {ew_content = s, ew_xoffset = 0, ew_xcursor = 0}) s + +editWidgetGetOptions :: + EditWidget -> + EditWidgetOptions +editWidgetGetOptions ew = ew_options ew +editWidgetSetOptions :: + EditWidget -> + EditWidgetOptions -> + EditWidget +editWidgetSetOptions ew opts = ew {ew_options = opts} + +drawEditWidget :: Pos -> Size -> DrawingHint -> EditWidget -> IO () +drawEditWidget (y, x) (_, width) hint ew = + _draw hint (ewopt_style . ew_options $ ew) $ + do + Curses.wMove Curses.stdScr y x + CursesH.drawLine width (drop (ew_xoffset ew) $ ew_content ew) + Curses.refresh + +activateEditWidget :: + (MonadIO m, MonadMask m) => + m () -> + Pos -> + Size -> + EditWidget -> + m (EditWidget, String) +activateEditWidget refresh pos@(y, x) sz@(_, width) ew = + CursesH.withCursor Curses.CursorVisible $ processKey ew + where + processKey ex = + do + liftIO $ drawLocal ex + k <- CursesH.getKey refresh + case lookup k (ewopt_keyHandlers $ ew_options ex) of + Nothing -> + case k of + Curses.KeyChar c + | isAscii c && isPrint c -> + processKey $ insertChar ex c + _ -> processKey ex + Just f -> + do + x' <- liftIO $ f pos sz ex + case x' of + Cont ex' -> processKey ex' + Done ex' -> do + liftIO $ drawEditWidget pos sz DHActive ex' + return (ex', editWidgetGetContent ex') + insertChar ew' c = + let pos' = ew_contentPos ew' + oldContent = ew_content ew' + newContent = take pos' oldContent ++ (c : drop pos' oldContent) + in editWidgetGoRight' pos' sz (ew' {ew_content = newContent}) + drawLocal ew' = _draw DHActive (ewopt_style . ew_options $ ew') $ + do + Curses.wMove Curses.stdScr y x + CursesH.drawLine width (drop (ew_xoffset ew') $ ew_content ew') + Curses.wMove Curses.stdScr y (x + ew_xcursor ew') + Curses.refresh + +editWidgetGoLeft' :: t -> t1 -> EditWidget -> EditWidget +editWidgetGoLeft' _ _ ew = + let newXcursor = max (ew_xcursor ew - 1) 0 + newXoffset = + if ew_xcursor ew == 0 + then max (ew_xoffset ew - 1) 0 + else ew_xoffset ew + in ew + { ew_xoffset = newXoffset + , ew_xcursor = newXcursor + } + +editWidgetGoRight' :: t -> (t1, Int) -> EditWidget -> EditWidget +editWidgetGoRight' _ (_, width) ew = + let len = length (ew_content ew) + lastChar = len - ew_xoffset ew - 1 + newXcursor = minimum [ew_xcursor ew + 1, lastChar + 1, width - 1] + newXoffset = + if ew_xcursor ew == width - 1 + then min (ew_xoffset ew + 1) (len - width + 1) + else ew_xoffset ew + in ew + { ew_xoffset = newXoffset + , ew_xcursor = newXcursor + } + +editWidgetDeleteLeft' :: Pos -> Size -> EditWidget -> EditWidget +editWidgetDeleteLeft' pos sz ew = + let cpos = ew_contentPos ew - 1 + oldContent = ew_content ew + newContent = take cpos oldContent ++ drop (cpos + 1) oldContent + ew' = editWidgetGoLeft' pos sz (ew {ew_content = newContent}) + in if ew_xcursor ew == 0 && ew_xoffset ew /= 0 + then editWidgetGoRight' pos sz (editWidgetGoLeft' pos sz ew') + else ew' + +editWidgetDeleteUnderCursor' :: t -> t1 -> EditWidget -> EditWidget +editWidgetDeleteUnderCursor' _ _ ew = + let pos = ew_contentPos ew + oldContent = ew_content ew + newContent = take pos oldContent ++ drop (pos + 1) oldContent + in ew {ew_content = newContent} + +editWidgetDeleteToEnd' :: t -> t1 -> EditWidget -> EditWidget +editWidgetDeleteToEnd' _ _ ew = + let pos = ew_contentPos ew + oldContent = ew_content ew + newContent = take pos oldContent + in ew {ew_content = newContent} + +editWidgetGoHome' :: t -> t1 -> EditWidget -> EditWidget +editWidgetGoHome' _ _ ew = + ew + { ew_xcursor = 0 + , ew_xoffset = 0 + } + +editWidgetGoEnd' :: Pos -> Size -> EditWidget -> EditWidget +editWidgetGoEnd' pos sz ew = + let cpos = ew_contentPos ew + len = length (ew_content ew) + in if cpos == len + then ew + else editWidgetGoEnd' pos sz (editWidgetGoRight' pos sz ew) + +editWidgetFinish :: (Monad m) => t -> t1 -> EditWidget -> m (Cont EditWidget) +editWidgetFinish _ _ ew = return (Done (addToHistory ew (ew_content ew))) + +maxHistoryLength :: Int +maxHistoryLength = 50 + +addToHistory :: EditWidget -> [Char] -> EditWidget +addToHistory ew s = + let newHist = + if not (null s) + then take maxHistoryLength (s : ew_history ew) + else ew_history ew + in ew + { ew_history = newHist + , ew_historyIndex = -1 + , ew_historySavedContent = Nothing + } + +editWidgetHistoryUp' :: t -> t1 -> EditWidget -> EditWidget +editWidgetHistoryUp' _ _ ew = editWidgetHistory (+) ew + +editWidgetHistoryDown' :: t -> t1 -> EditWidget -> EditWidget +editWidgetHistoryDown' _ _ ew = editWidgetHistory (-) ew + +-- ew_historyList: list of history items, i.e. non-null strings which were +-- entered into the widget and confirmed with ENTER or which were added +-- via editWidgetSetContent. +-- ew_historyIndex: the index of the history item shown in the widget. The +-- value -1 means that the value saved in ew_historySavedContent should +-- be shown. +editWidgetHistory :: (Num t) => (Int -> t -> Int) -> EditWidget -> EditWidget +editWidgetHistory op ew = + let i = ew_historyIndex ew + l = ew_history ew + j = i `op` 1 + in if j >= 0 && j < length l + then + let savedContent = + case ew_historySavedContent ew of + Nothing -> Just (ew_content ew) + x -> x + in ew + { ew_historyIndex = j + , ew_content = l !! j + , ew_historySavedContent = savedContent + , ew_xcursor = 0 + , ew_xoffset = 0 + } + else + if j == -1 + then case ew_historySavedContent ew of + Nothing -> ew + Just x -> + ew + { ew_content = x + , ew_historyIndex = j + , ew_xcursor = 0 + , ew_xoffset = 0 + } + else ew + +-- +-- Text widget +-- + +data TextWidget = TextWidget + { tw_text :: String + , tw_yoffset :: Int + , tw_xoffset :: Int + , tw_options :: TextWidgetOptions + } + deriving (Eq, Show) + +instance Widget TextWidget where + draw = drawTextWidget + minSize tw = + case twopt_size $ tw_options tw of + TWSizeDefault -> + let l = lines (tw_text tw) + in (length l, if null l then 0 else maximum (map length l)) + TWSizeFixed sz -> sz + +data TextWidgetSize + = TWSizeDefault -- minimal size determined by content + | TWSizeFixed Size -- minimal size is fixed, content is + -- possibly cut off + deriving (Eq, Show) + +{- +\| Autowrap -- minimal width determined by content, + -- but lines are wrapped if necessary + -} + +data TextWidgetOptions = TWOptions + { twopt_size :: TextWidgetSize + , twopt_style :: DrawingStyle + , twopt_halign :: HAlignment + } + deriving (Eq, Show) + +defaultTWOptions :: TextWidgetOptions +defaultTWOptions = + TWOptions + { twopt_size = TWSizeDefault + , twopt_style = defaultDrawingStyle + , twopt_halign = AlignLeft + } + +newTextWidget :: TextWidgetOptions -> String -> TextWidget +newTextWidget opts s = + TextWidget + { tw_text = s + , tw_yoffset = 0 + , tw_xoffset = 0 + , tw_options = opts + } + +drawTextWidget :: Pos -> Size -> DrawingHint -> TextWidget -> IO () +drawTextWidget (y, x) (height, width) hint tw = + let ly = take height $ drop (tw_yoffset tw) (lines (tw_text tw)) + l = take height $ (map (drop (tw_xoffset tw)) ly ++ repeat []) + l' = map (align (twopt_halign $ tw_options tw) width ' ') l + in -- trace ("drawing text widget at " ++ show pos ++ " with size " ++ show sz) $ + do + _draw + hint + (twopt_style . tw_options $ tw) + (mapM drawLine $ zip l' [0 ..]) + Curses.refresh + where + drawLine (s, i) = + do + Curses.wMove Curses.stdScr (y + i) x + CursesH.drawLine width s + +textWidgetGetText :: TextWidget -> String +textWidgetGetText = tw_text + +textWidgetSetText :: TextWidget -> String -> TextWidget +textWidgetSetText tw s = tw {tw_text = s} + +textWidgetScrollDown :: Size -> TextWidget -> TextWidget +textWidgetScrollDown (h, _) tw = + let dataLen = length $ lines (tw_text tw) + offset = tw_yoffset tw + in tw {tw_yoffset = scrollForward dataLen offset h} + +textWidgetScrollUp :: Size -> TextWidget -> TextWidget +textWidgetScrollUp (h, _) tw = + let dataLen = length $ lines (tw_text tw) + offset = tw_yoffset tw + in tw {tw_yoffset = scrollBackward dataLen offset h} + +textWidgetScrollLeft :: Size -> TextWidget -> TextWidget +textWidgetScrollLeft (_, w) tw = + let dataLen = length $ lines (tw_text tw) + offset = tw_xoffset tw + in tw {tw_xoffset = scrollBackward dataLen offset w} + +textWidgetScrollRight :: Size -> TextWidget -> TextWidget +textWidgetScrollRight (_, w) tw = + let dataLen = length $ lines (tw_text tw) + offset = tw_xoffset tw + in tw {tw_xoffset = scrollForward dataLen offset w} + +-- +-- Table widget +-- + +data TableCell + = forall w. (Widget w) => TableCell w + | forall w. (ActiveWidget w) => ActiveTableCell w + +isActive :: TableCell -> Bool +isActive (TableCell _) = False +isActive (ActiveTableCell _) = True + +instance Widget TableCell where + draw pos sz hint (TableCell w) = draw pos sz hint w + draw pos sz hint (ActiveTableCell w) = draw pos sz hint w + minSize (TableCell w) = minSize w + minSize (ActiveTableCell w) = minSize w + +_activateTableCell :: + (MonadIO m, MonadMask m) => + m () -> + Pos -> + Size -> + TableCell -> + m (TableCell, String) +_activateTableCell _ _ _ (TableCell _) = + error "_activateTableCell: cannot activate non-active cell!" +_activateTableCell refresh pos sz (ActiveTableCell w) = + do + (new, res) <- activate refresh pos sz w + return (ActiveTableCell new, res) + +type Row = [TableCell] + +singletonRow :: TableCell -> Row +singletonRow tc = [tc] + +getCellWidget :: TableWidget -> (Int, Int) -> TableCell +getCellWidget tbw (row, col) = (tbw_rows tbw) !! row !! col + +setCellWidget :: TableWidget -> (Int, Int) -> TableCell -> TableWidget +setCellWidget tbw (rowIndex, colIndex) w = + let rows = tbw_rows tbw + row = rows !! rowIndex + newRow = listReplace row w colIndex + newRows = listReplace rows newRow rowIndex + in tbw {tbw_rows = newRows} + +data TableWidget = TableWidget + { tbw_rows :: [Row] + , tbw_colOffset :: Int + , tbw_pos :: Maybe Pos + , tbw_options :: TableWidgetOptions + } + +data FillRow = First | Last | None deriving (Eq, Show) + +data TableWidgetOptions = TBWOptions + { tbwopt_fillCol :: Maybe Int + , tbwopt_fillRow :: FillRow + , tbwopt_activeCols :: [Int] + , tbwopt_minSize :: Size + } + deriving (Eq, Show) + +defaultTBWOptions :: TableWidgetOptions +defaultTBWOptions = + TBWOptions + { tbwopt_fillCol = Nothing + , tbwopt_fillRow = None + , tbwopt_activeCols = [] + , tbwopt_minSize = (4, 10) + } + +instance Widget TableWidget where + draw = drawTableWidget + minSize = tbwopt_minSize . tbw_options + +newTableWidget :: TableWidgetOptions -> [Row] -> TableWidget +newTableWidget opts rows = + TableWidget + { tbw_rows = rows + , tbw_colOffset = 0 + , tbw_pos = findFirstActiveCell rows opts + , tbw_options = opts + } + +data TableWidgetDisplayInfo + = TBWDisplayInfo + { tbwdisp_height :: Int -- height of the display area + , tbwdisp_width :: Int -- width of the display area + , tbwdisp_firstVis :: Int -- index of the first row visible + , tbwdisp_lastVis :: Int -- index of the last row visible + , tbwdisp_rows :: [Row] -- the rows which are visible + , tbwdisp_nrows :: Int -- the number of rows visible + , tbwdisp_heights :: [Int] -- the heights of the visible rows + , tbwdisp_widths :: [Int] -- the widths of the visible rows + -- free space at the right side (xoffset, size) + , tbwdisp_rightMargin :: Maybe (Int, Size) + } + +tableWidgetDisplayInfo :: Size -> TableWidget -> TableWidgetDisplayInfo +tableWidgetDisplayInfo (height, width) tbw = + assert (isQuadratic (tbw_rows tbw)) $ + let allRows = tbw_rows tbw + ncols = length (allRows !! 0) + colOffset = tbw_colOffset tbw + allHeights = minSpaces getHeight allRows + heights' = drop colOffset allHeights + nrows = getNRows heights' 0 0 + rows = take nrows $ drop colOffset allRows + (heights, heightDummy) = + let hs = take nrows heights' + s = sum hs + d = height - s + in case tbwopt_fillRow $ tbw_options tbw of + First -> (applyToFirst (+ d) hs, 0) + Last -> (applyToLast (+ d) hs, 0) + None -> (hs, d) + widths' = minSpaces getWidth (transpose $ tbw_rows tbw) + (widths, rightMargin) = + if sum widths' > width + then + error + ( "table too wide: width=" + ++ show (sum widths') + ++ ", available width=" + ++ show width + ) + else case tbwopt_fillCol $ tbw_options tbw of + Just i + | i >= 0 && i < ncols -> + ( take i widths' + ++ case drop i widths' of + [] -> error "rest unexpectedly empty" + (w : ws) -> (w + width - sum widths') : ws + , Nothing + ) + _ -> + let diff = width - sum widths' + msz = (height, diff) + m = + if diff > 0 + then Just (sum widths', msz) + else Nothing + in (widths', m) + dummyHeights = if heightDummy == 0 then [] else [heightDummy] + dummyRows = + if heightDummy == 0 + then [] + else + [ map + (\w -> TableCell (OpaqueWidget (heightDummy, w))) + widths + ] + in TBWDisplayInfo + { tbwdisp_height = height + , tbwdisp_width = width + , tbwdisp_firstVis = colOffset + , tbwdisp_lastVis = colOffset + nrows - 1 + , tbwdisp_rows = rows ++ dummyRows + , tbwdisp_nrows = nrows + length dummyRows + , tbwdisp_heights = heights ++ dummyHeights + , tbwdisp_widths = widths + , tbwdisp_rightMargin = rightMargin + } + where + minSpaces f ls = + snd $ + mapAccumL + ( \acc ws -> + (acc, acc + maximum (map (f . minSize) ws)) + ) + 0 + ls + getNRows (h : hs) n acc | h + n <= height = getNRows hs (h + n) (acc + 1) + getNRows _ _ acc = acc + isQuadratic [] = True + isQuadratic (x : xs) = isQuadratic' xs (length x) + isQuadratic' (x : xs) n = length x == n && isQuadratic' xs n + isQuadratic' [] _ = True + applyToFirst _ [] = [] + applyToFirst f (x : xs) = f x : xs + applyToLast _ [] = [] + applyToLast f (x : xs) = + let rev = NonEmpty.reverse $ x :| xs + (h, t) = (NonEmpty.head rev, NonEmpty.tail rev) + in reverse $ f h : t + +getCellInfo :: Pos -> Size -> TableWidget -> (Int, Int) -> (Pos, Size) +getCellInfo (y, x) sz tbw (row, col) = + let info = tableWidgetDisplayInfo sz tbw + heights = tbwdisp_heights info + widths = tbwdisp_widths info + h = heights !! row + w = widths !! col + yoff = sum $ take row heights + xoff = sum $ take col widths + in ((y + yoff, x + xoff), (h, w)) + +drawTableWidget :: Pos -> Size -> DrawingHint -> TableWidget -> IO () +drawTableWidget (y, x) sz hint tbw = + let info = tableWidgetDisplayInfo sz tbw + heights = tbwdisp_heights info + widths = tbwdisp_widths info + firstVis = tbwdisp_firstVis info + rows = tbwdisp_rows info + rightMargin = tbwdisp_rightMargin info + in do + drawRows rows heights widths 0 firstVis hint + case rightMargin of + Nothing -> return () + Just (xoff, s) -> draw (y, x + xoff) s hint (OpaqueWidget s) + Curses.refresh + where + drawRows :: + [Row] -> + [Int] -> + [Int] -> + Int -> + Int -> + DrawingHint -> + IO () + drawRows [] _ _ _ _ _ = return () + drawRows (r : rs) (h : hs) widths yoffset rowIndex hint' = + do + drawCols r h widths yoffset 0 (rowIndex, 0) hint' + drawRows rs hs widths (yoffset + h) (rowIndex + 1) hint' + drawRows _ _ _ _ _ _ = return () + drawCols :: + Row -> + Int -> + [Int] -> + Int -> + Int -> + (Int, Int) -> + DrawingHint -> + IO () + drawCols [] _ _ _ _ _ _ = return () + drawCols (c : cs) h (w : ws) yoffset xoffset (rowIndex, colIndex) hint' = + let hint'' = case tbw_pos tbw of + Just (z, a) + | z == rowIndex && a == colIndex -> + DHFocus + _ -> hint' + in do + draw (y + yoffset, x + xoffset) (h, w) hint'' c + drawCols + cs + h + ws + yoffset + (xoffset + w) + (rowIndex, colIndex + 1) + hint' + drawCols _ _ _ _ _ _ _ = return () + +tableWidgetScrollDown :: Size -> TableWidget -> TableWidget +tableWidgetScrollDown (h, _) tbw = + let dataLen = length $ tbw_rows tbw + offset = tbw_colOffset tbw + newOffset = scrollForward dataLen offset h + newTbw = tbw {tbw_colOffset = newOffset} + in case tbw_pos newTbw of + Nothing -> newTbw + Just (y, x) -> newTbw {tbw_pos = Just (max newOffset y, x)} + +tableWidgetScrollUp :: Size -> TableWidget -> TableWidget +tableWidgetScrollUp sz@(h, _) tbw = + let dataLen = length $ tbw_rows tbw + offset = tbw_colOffset tbw + newOffset = scrollBackward dataLen offset h + newTbw = tbw {tbw_colOffset = newOffset} + newLastVis = tbwdisp_lastVis (tableWidgetDisplayInfo sz newTbw) + in case tbw_pos newTbw of + Nothing -> newTbw + Just (y, x) -> + newTbw {tbw_pos = Just (min newLastVis y, x)} + +tableWidgetActivateCurrent :: + (MonadIO m, MonadMask m) => + m () -> + Pos -> + Size -> + DrawingHint -> + TableWidget -> + m (TableWidget, Maybe String) +tableWidgetActivateCurrent refresh (y, x) sz _ tbw = + case tbw_pos tbw of + Nothing -> do + debug "tableWidgetActivateCurrent: pos=Nothing" + return (tbw, Nothing) + Just p -> + let w = getCellWidget tbw p + in if not $ isActive w + then do + debug "tableWidgetActivateCurrent: not active" + return (tbw, Nothing) + else activate' w p + where + activate' widget colyx@(coly, colx) = + let info = tableWidgetDisplayInfo sz tbw + vcol = colx + vrow = coly - tbwdisp_firstVis info + heights = tbwdisp_heights info + widths = tbwdisp_widths info + h = heights !! vrow + w = widths !! vcol + yoffset = sum (take vrow heights) + xoffset = sum (take vcol widths) + in do + (new, res) <- + _activateTableCell + refresh + (y + yoffset, x + xoffset) + (h, w) + widget + return (setCellWidget tbw colyx new, Just res) + +tableWidgetGoLeft :: Size -> TableWidget -> TableWidget +tableWidgetGoLeft = tableWidgetMove DirLeft + +tableWidgetGoRight :: Size -> TableWidget -> TableWidget +tableWidgetGoRight = tableWidgetMove DirRight + +tableWidgetGoUp :: Size -> TableWidget -> TableWidget +tableWidgetGoUp = tableWidgetMove DirUp + +tableWidgetGoDown :: Size -> TableWidget -> TableWidget +tableWidgetGoDown = tableWidgetMove DirDown + +tableWidgetMove :: + Direction -> + (Int, Int) -> + TableWidget -> + TableWidget +tableWidgetMove dir sz tbw = + let pos = tbw_pos tbw + opts = tbw_options tbw + nrows = length (tbw_rows tbw) + in case pos of + Nothing -> tbw + Just p -> case findNextActiveCell opts nrows p dir of + Nothing -> tbw + newP@(Just (y, _)) -> + tableWidgetMakeVisible (tbw {tbw_pos = newP}) sz y + +tableWidgetMakeVisible :: + TableWidget -> + (Int, Int) -> + Int -> + TableWidget +tableWidgetMakeVisible tbw sz@(_, _) y = + let info = tableWidgetDisplayInfo sz tbw + firstVis = tbwdisp_firstVis info + lastVis = tbwdisp_lastVis info + in if y < firstVis + then tableWidgetMakeVisible (tableWidgetScrollUp sz tbw) sz y + else + if y > lastVis + then + tableWidgetMakeVisible + (tableWidgetScrollDown sz tbw) + sz + y + else tbw + +findFirstActiveCell :: [Row] -> TableWidgetOptions -> Maybe Pos +findFirstActiveCell rows opts = + let nrows = length rows + firstActiveCells = + map + ( \y -> + findNextActiveCell + opts + nrows + (y, -1) + DirRight + ) + [0 .. nrows - 1] + in case catMaybes firstActiveCells of + [] -> Nothing + (x : _) -> Just x + +findNextActiveCell :: + TableWidgetOptions -> + Int -> + Pos -> + Direction -> + Maybe Pos +findNextActiveCell opts nrows (y, x) dir = + -- trace ("findNextActiveCell (opts=" ++ show opts ++ ", nrows=" ++ show nrows + -- ++ ", pos=" ++ show pos ++ ", dir=" ++ show dir) $ + let rows = [0 .. (nrows - 1)] + cols = sort (tbwopt_activeCols opts) + horiz f = case f cols x rows y of + Nothing -> Nothing + Just z -> Just (y, z) + vert f = case f rows y cols x of + Nothing -> Nothing + Just z -> Just (z, x) + res = case dir of + DirLeft -> horiz goLeft + DirRight -> horiz goRight + DirUp -> vert goLeft + DirDown -> vert goRight + in -- trace ("result of findNextActiveCell: " ++ show res) + res + where + goLeft _ _ rows a | not (a `elem` rows) = Nothing + goLeft cols b _ _ = + case reverse (takeWhile (< b) cols) of + [] -> Nothing + (c : _) -> Just c + goRight _ _ rows a | not (a `elem` rows) = Nothing + goRight cols a _ _ = + case dropWhile (a >=) cols of + [] -> Nothing + (b : _) -> Just b + +tableWidgetDeleteRow :: Int -> TableWidget -> TableWidget +tableWidgetDeleteRow n tbw = + let rows = tbw_rows tbw + rows' = deleteAt n rows + pos' = + case tbw_pos tbw of + Nothing -> Nothing + Just (row, col) -> + let row' = min row (length rows' - 1) + in if row' >= 0 + then Just (row', col) + else Nothing + in tbw {tbw_rows = rows', tbw_pos = pos'} + +-- +-- BorderWidget +-- + +-- +-- Selection Widget +-- + +-- +-- Utility functions +-- + +-- | Join a list by some delimiter +joinLists :: [[a]] -> [a] -> [a] +joinLists l s = if (null l) then [] else foldr1 (\x -> \y -> x ++ s ++ y) l + +-- | Split a list by some delimiter +splitList :: (Eq a) => [a] -> [a] -> [[a]] +splitList d l = + unfoldr + ( \x -> + if (null x) + then Nothing + else Just $ nextToken d [] (snd $ splitAt (length d) x) + ) + (d ++ l) + where + nextToken _ r [] = (r, []) + nextToken e r m@(h : t) + | (e `isPrefixOf` m) = (r, m) + | otherwise = nextToken e (r ++ [h]) t + +listReplace :: [a] -> a -> Int -> [a] +listReplace l a i = + case splitAt i l of + (_, []) -> + error + ( "listReplace: index to large. index=" + ++ show i + ++ ", length=" + ++ show (length l) + ) + ([], _) + | i < 0 -> + error + ( "listReplace: negative index. index=" + ++ show i + ) + (xs, (_ : ys)) -> xs ++ (a : ys) + +-- alignRows :: [[String]] -> Char -> String -> [String] +alignRows :: [[[a]]] -> a -> [a] -> [[a]] +alignRows rows fill delim = + let widths = foldr maxWidths (repeat 0) rows + in map (alignRow widths) rows + where + maxWidths :: [[a]] -> [Int] -> [Int] + maxWidths row acc = map (uncurry max) (zip acc (map length row)) + alignRow widths row = concatMap (uncurry alignCell) (zip widths row) + alignCell width cell = + let diff = width - length cell + in cell ++ (take diff $ repeat fill) ++ delim + +align :: HAlignment -> Int -> a -> [a] -> [a] +align a w f l = + let space = w - length l + in case a of + AlignLeft -> l ++ (fill space) + AlignRight -> (fill space) ++ l + AlignCenter -> + let left = space `div` 2 + right = left + (space `mod` 2) + in fill left ++ l ++ fill right + where + fill n = take n (repeat f) + +deleteAt :: Int -> [a] -> [a] +deleteAt n l = + if n >= 0 && n < length l + then + let (a, b) = splitAt n l + in case b of + [] -> error "deleteAt: impossible" + (_ : rest) -> a ++ rest + else error ("deleteAt: illegal index: " ++ show n) diff --git a/example/ContactManager.hs b/example/ContactManager.hs --- a/example/ContactManager.hs +++ b/example/ContactManager.hs @@ -27,21 +27,23 @@ {- TODO: -* save -* add +\* save +\* add -} +import Prelude hiding ((<>)) + import Control.Exception import Control.Monad.State -import Data.List ( sort ) +import Data.List (sort) import System.Environment (getArgs, getProgName) import System.Exit (exitFailure) import Text.PrettyPrint.HughesPJ -import UI.HSCurses.Logging -import UI.HSCurses.Widgets import qualified UI.HSCurses.Curses as Curses import qualified UI.HSCurses.CursesHelper as CursesH +import UI.HSCurses.Logging +import UI.HSCurses.Widgets type Name = String type Email = String @@ -53,40 +55,41 @@ type PhoneNumber = String data Contact = Contact - { lastName :: Name - , firstName :: Name - , emailAddress :: Email - , address :: Address - , zipCode :: ZIPCode - , city :: City - , province :: Province - , country :: Country - , phoneNumber :: PhoneNumber + { lastName :: Name + , firstName :: Name + , emailAddress :: Email + , address :: Address + , zipCode :: ZIPCode + , city :: City + , province :: Province + , country :: Country + , phoneNumber :: PhoneNumber } - deriving (Show,Read,Eq,Ord) + deriving (Show, Read, Eq, Ord) -emptyContact = Contact - { lastName = "" - , firstName = "" - , emailAddress = "" - , address = "" - , zipCode = "" - , city = "" - , province = "" - , country = "" - , phoneNumber = "" - } +emptyContact = + Contact + { lastName = "" + , firstName = "" + , emailAddress = "" + , address = "" + , zipCode = "" + , city = "" + , province = "" + , country = "" + , phoneNumber = "" + } pprContact c = pprLine (combine (lastName c) ", " (firstName c)) $ - pprLine (address c) $ - pprLine (combine (zipCode c) " " (city c)) $ - pprLine (province c) $ - pprLine (country c) $ - pprLine (phoneNumber c) $ - pprLine (emailAddress c) $ - empty - where + pprLine (address c) $ + pprLine (combine (zipCode c) " " (city c)) $ + pprLine (province c) $ + pprLine (country c) $ + pprLine (phoneNumber c) $ + pprLine (emailAddress c) $ + empty + where pprLine :: String -> Doc -> Doc pprLine [] = (<>) empty pprLine s = ($$) (text s) @@ -104,82 +107,104 @@ , ("City", city c) , ("State/Province", province c) , ("Country", country c) - , ("Phone", phoneNumber c) ] + , ("Phone", phoneNumber c) + ] readContacts :: FilePath -> IO [Contact] readContacts f = - do s <- readFile f - case reads s of - [(contacts, [])] -> return (sort contacts) - _ -> error ("corrupt contact file: " ++ f) + do + s <- readFile f + case reads s of + [(contacts, [])] -> return (sort contacts) + _ -> error ("corrupt contact file: " ++ f) writeContacts :: FilePath -> [Contact] -> IO () writeContacts f contacts = writeFile f (show contacts) sampleContacts = - [ emptyContact { lastName = "Wehr" - , firstName = "Stefan" - , emailAddress = "mail AT stefanwehr DOT de" - , address = "28 Loch Maree St" - , zipCode = "2032" - , city = "Kingsford" - , province = "NSW" - , country = "Australia" } - , emptyContact { lastName = "Thorpe" - , firstName = "Ian" - , emailAddress = "ian@aol7.com.au" - , city = "Perth" - , country = "Australia" } - , emptyContact { lastName = "Gates" - , firstName = "Bill" - , emailAddress = "billy@microsoft.com" } - , emptyContact { lastName = "Stewart" - , firstName = "Don" - , address = "CSE, UNSW, 501-16, k17 building" - , city = "Sydney" - , country = "Australia" } ] - + [ emptyContact + { lastName = "Wehr" + , firstName = "Stefan" + , emailAddress = "mail AT stefanwehr DOT de" + , address = "28 Loch Maree St" + , zipCode = "2032" + , city = "Kingsford" + , province = "NSW" + , country = "Australia" + } + , emptyContact + { lastName = "Thorpe" + , firstName = "Ian" + , emailAddress = "ian@aol7.com.au" + , city = "Perth" + , country = "Australia" + } + , emptyContact + { lastName = "Gates" + , firstName = "Bill" + , emailAddress = "billy@microsoft.com" + } + , emptyContact + { lastName = "Stewart" + , firstName = "Don" + , address = "CSE, UNSW, 501-16, k17 building" + , city = "Sydney" + , country = "Australia" + } + ] title = "contact-manager" help = "q:quit, d:delete, a:add" data CMState = CMState - { cm_styles :: [CursesH.CursesStyle] + { cm_styles :: [CursesH.CursesStyle] , cm_contacts :: [Contact] } type CM = StateT CMState IO runCM :: [CursesH.CursesStyle] -> [Contact] -> CM a -> IO a -runCM stys contacts cm = evalStateT cm (CMState { cm_styles = stys - , cm_contacts = contacts }) +runCM stys contacts cm = + evalStateT + cm + ( CMState + { cm_styles = stys + , cm_contacts = contacts + } + ) nthStyle :: Int -> CM CursesH.CursesStyle nthStyle n = - do cs <- gets cm_styles - return $ cs !! n + do + cs <- gets cm_styles + return $ cs !! n getSize = liftIO $ Curses.scrSize -styles = [ CursesH.defaultStyle - , CursesH.AttributeStyle [CursesH.Bold] CursesH.GreenF CursesH.DarkBlueB - ] - +styles = + [ CursesH.defaultStyle + , CursesH.AttributeStyle [CursesH.Bold] CursesH.GreenF CursesH.DarkBlueB + ] defStyle = nthStyle 0 lineStyle = nthStyle 1 lineDrawingStyle = - do sty <- lineStyle - return $ mkDrawingStyle sty + do + sty <- lineStyle + return $ mkDrawingStyle sty lineOptions = - do sz <- getSize - ds <- lineDrawingStyle - return $ TWOptions { twopt_size = TWSizeFixed (1, getWidth sz), - twopt_style = ds, - twopt_halign = AlignLeft } + do + sz <- getSize + ds <- lineDrawingStyle + return $ + TWOptions + { twopt_size = TWSizeFixed (1, getWidth sz) + , twopt_style = ds + , twopt_halign = AlignLeft + } type ToplineWidget = TextWidget type MidlineWidget = TextWidget @@ -190,37 +215,46 @@ type ContactEditWidget = TableWidget mkToplineWidget = - do opts <- lineOptions - return $ newTextWidget (opts { twopt_halign = AlignCenter }) - title + do + opts <- lineOptions + return $ + newTextWidget + (opts {twopt_halign = AlignCenter}) + title mkMidlineWidget :: ContactListWidget -> CM MidlineWidget mkMidlineWidget listWidget = - do opts <- lineOptions - contacts <- gets cm_contacts - let s = case tbw_pos listWidget of - Nothing -> show (length contacts) - Just (row, _) -> show (1+row) ++ "/" ++ show (length contacts) - return $ newTextWidget (opts { twopt_halign = AlignRight }) s + do + opts <- lineOptions + contacts <- gets cm_contacts + let s = case tbw_pos listWidget of + Nothing -> show (length contacts) + Just (row, _) -> show (1 + row) ++ "/" ++ show (length contacts) + return $ newTextWidget (opts {twopt_halign = AlignRight}) s mkBotlineWidget = - do opts <- lineOptions - return $ newTextWidget opts help + do + opts <- lineOptions + return $ newTextWidget opts help -- We need to insert a dummy widget at the lower-right corner of the window, -- i.e. at the lower-right corner of the message line. Otherwise, an -- error occurs because drawing a character to this position moves the -- cursor to the next line, which doesn't exist. mkMsglineWidget = - do sz <- getSize - let width = getWidth sz - opts = TWOptions { twopt_size = TWSizeFixed (1, width - 1), - twopt_style = defaultDrawingStyle, - twopt_halign = AlignLeft } - tw = newTextWidget opts "msgline" - row = [TableCell tw, TableCell $ EmptyWidget (1,1)] - tabOpts = defaultTBWOptions { tbwopt_minSize = (1, width) } - return $ newTableWidget tabOpts [row] + do + sz <- getSize + let width = getWidth sz + opts = + TWOptions + { twopt_size = TWSizeFixed (1, width - 1) + , twopt_style = defaultDrawingStyle + , twopt_halign = AlignLeft + } + tw = newTextWidget opts "msgline" + row = [TableCell tw, TableCell $ EmptyWidget (1, 1)] + tabOpts = defaultTBWOptions {tbwopt_minSize = (1, width)} + return $ newTableWidget tabOpts [row] nlines = 4 @@ -228,84 +262,108 @@ contactDetailsHeight (h, _) = let n = h - nlines - in n `div` 2 + (n `mod` 2) + in n `div` 2 + (n `mod` 2) contactListOptions = - do sz <- getSize - return $ TBWOptions - { tbwopt_fillCol = Nothing, - tbwopt_fillRow = None, - tbwopt_activeCols = [0], - tbwopt_minSize = (contactListHeight sz, getWidth sz) } + do + sz <- getSize + return $ + TBWOptions + { tbwopt_fillCol = Nothing + , tbwopt_fillRow = None + , tbwopt_activeCols = [0] + , tbwopt_minSize = (contactListHeight sz, getWidth sz) + } contactDetailsOptions = - do sz <- getSize - return $ TWOptions { twopt_size = TWSizeFixed (contactDetailsHeight sz, - getWidth sz), - twopt_style = defaultDrawingStyle, - twopt_halign = AlignLeft } + do + sz <- getSize + return $ + TWOptions + { twopt_size = + TWSizeFixed + ( contactDetailsHeight sz + , getWidth sz + ) + , twopt_style = defaultDrawingStyle + , twopt_halign = AlignLeft + } mkContactListWidget :: CM ContactListWidget mkContactListWidget = - do contacts <- gets cm_contacts - sz <- getSize - let lines = alignRows (map contactLine contacts) ' ' " " - rows = map (contactRow $ getWidth sz) lines - opts <- contactListOptions - return $ newTableWidget opts rows - where contactLine c = [lastName c, firstName c, emailAddress c] - contactRow w s = [TableCell $ newTextWidget - (defaultTWOptions { twopt_size = TWSizeFixed (1, w) }) s] - lastRow = [TableCell (EmptyWidget (0,0))] + do + contacts <- gets cm_contacts + sz <- getSize + let lines = alignRows (map contactLine contacts) ' ' " " + rows = map (contactRow $ getWidth sz) lines + opts <- contactListOptions + return $ newTableWidget opts rows + where + contactLine c = [lastName c, firstName c, emailAddress c] + contactRow w s = + [ TableCell $ + newTextWidget + (defaultTWOptions {twopt_size = TWSizeFixed (1, w)}) + s + ] + lastRow = [TableCell (EmptyWidget (0, 0))] mkContactDetailsWidget :: ContactListWidget -> CM ContactDetailsWidget mkContactDetailsWidget listWidget = - do contacts <- gets cm_contacts - let contact = case tbw_pos listWidget of - Nothing -> "" - Just (row, _) -> - let c = contacts !! row - in show $ pprContact c - opts <- contactDetailsOptions - return $ newTextWidget opts contact + do + contacts <- gets cm_contacts + let contact = case tbw_pos listWidget of + Nothing -> "" + Just (row, _) -> + let c = contacts !! row + in show $ pprContact c + opts <- contactDetailsOptions + return $ newTextWidget opts contact mkContactEditWidget :: Contact -> CM ContactEditWidget mkContactEditWidget contact = let l = contactToLabelValueList contact rows = map mkRow l - in do sz <- getSize - let opts = TBWOptions - { tbwopt_fillCol = Just 1, - tbwopt_fillRow = None, - tbwopt_activeCols = [1], - tbwopt_minSize = (getHeight sz - 3, getWidth sz) } - return $ newTableWidget opts rows - where mkRow (label, value) = - let labelW = newTextWidget defaultTWOptions label - valueW = newEditWidget defaultEWOptions value - in [TableCell labelW, ActiveTableCell valueW] + in do + sz <- getSize + let opts = + TBWOptions + { tbwopt_fillCol = Just 1 + , tbwopt_fillRow = None + , tbwopt_activeCols = [1] + , tbwopt_minSize = (getHeight sz - 3, getWidth sz) + } + return $ newTableWidget opts rows + where + mkRow (label, value) = + let labelW = newTextWidget defaultTWOptions label + valueW = newEditWidget defaultEWOptions value + in [TableCell labelW, ActiveTableCell valueW] mkMainEditWidget contact = - do tlw <- mkToplineWidget - blw <- mkBotlineWidget - msglw <- mkMsglineWidget - ew <- mkContactEditWidget contact - return $ MainEditWidget tlw blw msglw ew + do + tlw <- mkToplineWidget + blw <- mkBotlineWidget + msglw <- mkMsglineWidget + ew <- mkContactEditWidget contact + return $ MainEditWidget tlw blw msglw ew data MainEditWidget = MainEditWidget { toplineEditWidget :: ToplineWidget , botlineEditWidget :: BotlineWidget , msglineEditWidget :: MsglineWidget - , contactEditWidget :: ContactEditWidget } + , contactEditWidget :: ContactEditWidget + } mkMainWidget = - do tlw <- mkToplineWidget - clw <- mkContactListWidget - mlw <- mkMidlineWidget clw - cdw <- mkContactDetailsWidget clw - blw <- mkBotlineWidget - msglw <- mkMsglineWidget - return $ MainWidget tlw mlw blw msglw clw cdw + do + tlw <- mkToplineWidget + clw <- mkContactListWidget + mlw <- mkMidlineWidget clw + cdw <- mkContactDetailsWidget clw + blw <- mkBotlineWidget + msglw <- mkMsglineWidget + return $ MainWidget tlw mlw blw msglw clw cdw instance Widget MainEditWidget where draw pos sz hint w = draw pos sz hint (mkRealMainEditWidget (Just sz) w) @@ -313,15 +371,17 @@ mkRealMainEditWidget :: (Maybe Size) -> MainEditWidget -> TableWidget mkRealMainEditWidget msz w = - let cells = [ TableCell $ toplineEditWidget w - , TableCell $ contactEditWidget w - , TableCell $ botlineEditWidget w - , TableCell $ msglineEditWidget w ] + let cells = + [ TableCell $ toplineEditWidget w + , TableCell $ contactEditWidget w + , TableCell $ botlineEditWidget w + , TableCell $ msglineEditWidget w + ] rows = map singletonRow cells opts = case msz of - Nothing -> defaultTBWOptions - Just sz -> defaultTBWOptions { tbwopt_minSize = sz } - in newTableWidget opts rows + Nothing -> defaultTBWOptions + Just sz -> defaultTBWOptions {tbwopt_minSize = sz} + in newTableWidget opts rows data MainWidget = MainWidget { toplineWidget :: ToplineWidget @@ -329,48 +389,63 @@ , botlineWidget :: BotlineWidget , msglineWidget :: MsglineWidget , contactListWidget :: ContactListWidget - , contactDetailsWidget :: ContactDetailsWidget } + , contactDetailsWidget :: ContactDetailsWidget + } instance Widget MainWidget where draw pos sz hint w = draw pos sz hint (mkRealMainWidget (Just sz) w) minSize w = minSize (mkRealMainWidget Nothing w) mkRealMainWidget msz w = - let cells = [ TableCell $ toplineWidget w - , TableCell $ contactListWidget w - , TableCell $ midlineWidget w - , TableCell $ contactDetailsWidget w - , TableCell $ botlineWidget w - , TableCell $ msglineWidget w ] + let cells = + [ TableCell $ toplineWidget w + , TableCell $ contactListWidget w + , TableCell $ midlineWidget w + , TableCell $ contactDetailsWidget w + , TableCell $ botlineWidget w + , TableCell $ msglineWidget w + ] rows = map singletonRow cells opts = case msz of - Nothing -> defaultTBWOptions - Just sz -> defaultTBWOptions { tbwopt_minSize = sz } - in newTableWidget opts rows + Nothing -> defaultTBWOptions + Just sz -> defaultTBWOptions {tbwopt_minSize = sz} + in newTableWidget opts rows updateStateDependentWidgets :: MainWidget -> ContactListWidget -> CM MainWidget updateStateDependentWidgets w listWidget = - do detailsWidget <- mkContactDetailsWidget listWidget - midlineWidget <- mkMidlineWidget listWidget - return $ w { contactListWidget = listWidget - , contactDetailsWidget = detailsWidget - , midlineWidget = midlineWidget } + do + detailsWidget <- mkContactDetailsWidget listWidget + midlineWidget <- mkMidlineWidget listWidget + return $ + w + { contactListWidget = listWidget + , contactDetailsWidget = detailsWidget + , midlineWidget = midlineWidget + } move :: Direction -> MainWidget -> CM MainWidget move dir w = - do sz <- getSize - let listWidget = tableWidgetMove dir sz (contactListWidget w) - updateStateDependentWidgets w listWidget + do + sz <- getSize + let listWidget = tableWidgetMove dir sz (contactListWidget w) + updateStateDependentWidgets w listWidget delete w = let lw = contactListWidget w - in case tbw_pos lw of - Nothing -> return w - Just (row,_) -> - let lw' = tableWidgetDeleteRow row lw - in do modify (\s -> s { cm_contacts = - deleteAt row (cm_contacts s) }) - updateStateDependentWidgets w lw' + in case tbw_pos lw of + Nothing -> return w + Just (row, _) -> + let lw' = tableWidgetDeleteRow row lw + in do + modify + ( \s -> + s + { cm_contacts = + deleteAt row (cm_contacts s) + } + ) + updateStateDependentWidgets w lw' + {- editEventloop w ewm = do k <- CursesH.getKey (resize mkMainEditWidget) @@ -390,64 +465,76 @@ edit w = let lw = contactListWidget w - in case tbw_pos lw of - Nothing -> return w - Just (row,_) -> - do contacts <- gets cm_contacts + in case tbw_pos lw of + Nothing -> return w + Just (row, _) -> + do + contacts <- gets cm_contacts let c = contacts !! row ew <- mkMainEditWidget c redraw ew return w - --editEventloop w ew -resize :: Widget w => CM w -> CM () +-- editEventloop w ew + +resize :: (Widget w) => CM w -> CM () resize f = - do liftIO $ do Curses.endWin - Curses.resetParams - Curses.cursSet Curses.CursorInvisible - Curses.refresh - w <- f - redraw w + do + liftIO $ do + Curses.endWin + Curses.resetParams + Curses.cursSet Curses.CursorInvisible + Curses.refresh + w <- f + redraw w -redraw :: Widget w => w -> CM () +redraw :: (Widget w) => w -> CM () redraw w = - do sz <- getSize - liftIO $ draw (0, 0) sz DHNormal w - liftIO $ Curses.refresh + do + sz <- getSize + liftIO $ draw (0, 0) sz DHNormal w + liftIO $ Curses.refresh eventloop w = - do k <- CursesH.getKey (resize mkMainWidget) - debug ("Got key " ++ show k) - case k of - Curses.KeyChar 'q' -> return () - Curses.KeyChar 'd' -> process $ delete w - Curses.KeyChar 'e' -> process $ edit w - Curses.KeyUp -> process $ move DirUp w - Curses.KeyDown -> process $ move DirDown w - _ -> eventloop w - where process f = - do w' <- f - redraw w' - eventloop w' + do + k <- CursesH.getKey (resize mkMainWidget) + debug ("Got key " ++ show k) + case k of + Curses.KeyChar 'q' -> return () + Curses.KeyChar 'd' -> process $ delete w + Curses.KeyChar 'e' -> process $ edit w + Curses.KeyUp -> process $ move DirUp w + Curses.KeyDown -> process $ move DirDown w + _ -> eventloop w + where + process f = + do + w' <- f + redraw w' + eventloop w' cmMain :: CM () cmMain = - do w <- mkMainWidget - redraw w - eventloop w - + do + w <- mkMainWidget + redraw w + eventloop w main :: IO () main = - do args <- getArgs - contacts <- - if length args /= 1 - then do p <- getProgName - putStrLn ("Usage: " ++ p ++ " contact-file") - exitFailure - else readContacts (args!!0) - runCurses contacts `finally` CursesH.end - where runCurses contacts = - do CursesH.start - cstyles <- CursesH.convertStyles styles - Curses.cursSet Curses.CursorInvisible - runCM cstyles contacts cmMain + do + args <- getArgs + contacts <- + if length args /= 1 + then do + p <- getProgName + putStrLn ("Usage: " ++ p ++ " contact-file") + exitFailure + else readContacts (args !! 0) + runCurses contacts `finally` CursesH.end + where + runCurses contacts = + do + CursesH.start + cstyles <- CursesH.convertStyles styles + Curses.cursSet Curses.CursorInvisible + runCM cstyles contacts cmMain diff --git a/example/Setup.hs b/example/Setup.hs deleted file mode 100644 --- a/example/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env runhaskell -import Distribution.Simple -main = defaultMainWithHooks simpleUserHooks diff --git a/example/cm.cabal b/example/cm.cabal deleted file mode 100644 --- a/example/cm.cabal +++ /dev/null @@ -1,14 +0,0 @@ -Name: contact-manager -Synopsis: Primitive addressbook -Version: 0.1 -License: GPL -License-file: ../LICENSE -Author: Stefan Wehr - -Build-Depends: base>3, hscurses >= 1.2, mtl, pretty -Build-Type: Simple - -Executable: cm -Main-Is: ContactManager.hs -ghc-options: -funbox-strict-fields -threaded - diff --git a/example/contacts b/example/contacts deleted file mode 100644 --- a/example/contacts +++ /dev/null @@ -1,1 +0,0 @@ -[Contact {lastName = "Wehr", firstName = "Stefan", emailAddress = "mail AT stefanwehr DOT de", address = "28 Loch Maree St", zipCode = "2032", city = "Kingsford", province = "NSW", country = "Australia", phoneNumber = ""},Contact {lastName = "Thorpe", firstName = "Ian", emailAddress = "ian@aol7.com.au", address = "", zipCode = "", city = "Perth", province = "", country = "Australia", phoneNumber = ""},Contact {lastName = "Gates", firstName = "Bill", emailAddress = "billy@microsoft.com", address = "", zipCode = "", city = "", province = "", country = "", phoneNumber = ""},Contact {lastName = "Stewart", firstName = "Don", emailAddress = "", address = "CSE, UNSW, 501-16, k17 building", zipCode = "", city = "Sydney", province = "", country = "Australia", phoneNumber = ""}] diff --git a/example/contacts2 b/example/contacts2 deleted file mode 100644 --- a/example/contacts2 +++ /dev/null @@ -1,1 +0,0 @@ -[Contact {lastName = "Wehr", firstName = "Stefan", emailAddress = "mail AT stefanwehr DOT de", address = "28 Loch Maree St", zipCode = "2032", city = "Kingsford", province = "NSW", country = "Australia", phoneNumber = ""},Contact {lastName = "Thorpe", firstName = "Ian", emailAddress = "ian@aol7.com.au", address = "", zipCode = "", city = "Perth", province = "", country = "Australia", phoneNumber = ""},Contact {lastName = "Gates", firstName = "Bill", emailAddress = "billy@microsoft.com", address = "", zipCode = "", city = "", province = "", country = "", phoneNumber = ""},Contact {lastName = "Stewart", firstName = "Don", emailAddress = "", address = "CSE, UNSW, 501-16, k17 building", zipCode = "", city = "Sydney", province = "", country = "Australia", phoneNumber = ""}] diff --git a/hscurses.cabal b/hscurses.cabal --- a/hscurses.cabal +++ b/hscurses.cabal @@ -1,55 +1,177 @@ -Name: hscurses -Version: 1.4.2.0 -License: LGPL -License-file: LICENSE -Author: John Meacham - Tuomo Valkonen - Don Stewart - Stefan Wehr -Copyright: Stefan Wehr 2004 - 2011 - Don Stewart 2004 - Tuomo Valkonen 2004 - John Meacham 2002-2004 -Maintainer: Stefan Wehr -Stability: Stable -Category: User-interface -Synopsis: NCurses bindings for Haskell -Description: - Binding to NCurses, a library of functions that manage an - application's display on character-cell terminals. Additionally, - it contains some basic widgets such as a text input widget and - a table widget. -Homepage: https://github.com/skogsbaer/hscurses -Cabal-version: >= 1.6 -Build-Type: Configure -Tested-with: GHC==7.6.1, GHC==7.8 -Data-files: - README, TODO, ChangeLog, - example/contacts2, example/Setup.hs, example/ContactManager.hs, - example/cm.cabal, example/contacts, cbits/config.h.in - configure, configure.ac, hscurses.buildinfo.in, - cbits/HSCurses.h, cbits/HSCursesUtils.h +name: hscurses +version: 1.5.0.0 +license: LGPL +license-file: LICENSE +author: + John Meacham + Tuomo Valkonen + Don Stewart + Stefan Wehr -Source-Repository head - Type: git - Location: git://github.com/skogsbaer/hscurses.git +extra-source-files: ChangeLog +copyright: + Stefan Wehr 2004 - 2011 + Don Stewart 2004 + Tuomo Valkonen 2004 + John Meacham 2002-2004 -Library - Build-depends: base == 4.*, exceptions, mtl, - old-time < 1.2, old-locale == 1.0.* +maintainer: Stefan Wehr +stability: Stable +category: User-interface +synopsis: NCurses bindings for Haskell +description: + Binding to NCurses, a library of functions that manage an + application's display on character-cell terminals. Additionally, + it contains some basic widgets such as a text input widget and + a table widget. + +homepage: https://github.com/skogsbaer/hscurses +cabal-version: >=1.10 +build-type: Configure +tested-with: + GHC ==7.6.1 + || ==7.8 + || ==8.4.4 + || ==8.6.5 + || ==8.8.4 + || ==8.10.7 + || ==9.4.8 + || ==9.6.6 + || ==9.8.4 + || ==9.10.1 + || ==9.12.1 + +data-files: + cbits/config.h.in + cbits/HSCurses.h + cbits/HSCursesUtils.h + configure + configure.ac + hscurses.buildinfo.in + README.md + TODO + +source-repository head + type: git + location: https://github.com/skogsbaer/hscurses + +flag examples + description: Build test and example binaries + default: False + manual: True + +flag debug + description: Compile with logging/tracing functions + default: False + manual: True + +library + build-depends: + base >=4 && <5 + , exceptions <0.11 + , mtl <2.4 + , time <1.13 + + extra-libraries: ncurses + if !os(windows) - Build-depends: unix >= 2.4 - Exposed-modules: - UI.HSCurses.Curses, UI.HSCurses.CursesHelper, UI.HSCurses.Widgets, - UI.HSCurses.Logging - Other-modules: - UI.HSCurses.CWString, UI.HSCurses.IConv - C-sources: - cbits/HSCursesUtils.c - Includes: - HSCurses.h, HSCursesUtils.h - Extensions: - CPP, ForeignFunctionInterface, GeneralizedNewtypeDeriving, - ScopedTypeVariables, ExistentialQuantification - Include-dirs: cbits . - Ghc-options: -funbox-strict-fields -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing + build-depends: unix <2.9 + + if flag(debug) + cpp-options: -DDEBUG=1 + + exposed-modules: + UI.HSCurses.Curses + UI.HSCurses.CursesHelper + UI.HSCurses.Logging + UI.HSCurses.Widgets + + other-modules: + UI.HSCurses.CWString + UI.HSCurses.IConv + + c-sources: cbits/HSCursesUtils.c + includes: + HSCurses.h + HSCursesUtils.h + + default-extensions: + CPP + ExistentialQuantification + ForeignFunctionInterface + GeneralizedNewtypeDeriving + ScopedTypeVariables + + include-dirs: cbits + ghc-options: + -funbox-strict-fields -Wall -fno-warn-unused-do-bind + -fno-warn-name-shadowing + + default-language: Haskell2010 + +executable contact-manager + if flag(examples) + build-depends: + base >=4.0 && <5 + , hscurses + , mtl >=2.0 && <2.4 + , pretty >=1.0 && <1.2 + + else + buildable: False + + hs-source-dirs: example + default-language: Haskell2010 + main-is: ContactManager.hs + +executable key-test + if flag(examples) + build-depends: + base >=4.0 && <5 + , hscurses + + else + buildable: False + + hs-source-dirs: tests/key-test + default-language: Haskell2010 + main-is: KeyTest.hs + +executable widget-test-text + if flag(examples) + build-depends: + base >=4.0 && <5 + , hscurses + + else + buildable: False + + hs-source-dirs: tests/widget-test + default-language: Haskell2010 + main-is: TextTest.hs + +executable widget-test-table + if flag(examples) + build-depends: + base >=4.0 && <5 + , hscurses + + else + buildable: False + + hs-source-dirs: tests/widget-test + default-language: Haskell2010 + main-is: TableTest.hs + +executable widget-test-edit + if flag(examples) + build-depends: + base >=4.0 + , hscurses + + else + buildable: False + + hs-source-dirs: tests/widget-test + default-language: Haskell2010 + main-is: EditTest.hs diff --git a/tests/key-test/KeyTest.hs b/tests/key-test/KeyTest.hs new file mode 100644 --- /dev/null +++ b/tests/key-test/KeyTest.hs @@ -0,0 +1,34 @@ +import UI.HSCurses.Curses +import qualified UI.HSCurses.CursesHelper as CursesH + +import Control.Exception +import Control.Monad (forever) +import Data.Char +import System.Exit + +draw s = do + (h, w) <- scrSize + CursesH.gotoTop + CursesH.drawLine w s + refresh + +done = return () + +main :: IO () +main = + finally + ( do + CursesH.start + draw "Press any key, click the mouse, or use the mouse wheel" + withAllMouseEvents $ do + forever $ do + c <- CursesH.getKey done + case c of + KeyChar 'q' -> exitWith ExitSuccess + KeyMouse -> do + draw "mouse\n" + me <- getMouse + draw (show me) + x -> draw ("Last key: " ++ CursesH.displayKey x ++ " (" ++ show x ++ ")") + ) + CursesH.end diff --git a/tests/widget-test/EditTest.hs b/tests/widget-test/EditTest.hs new file mode 100644 --- /dev/null +++ b/tests/widget-test/EditTest.hs @@ -0,0 +1,59 @@ +import qualified UI.HSCurses.Curses as Curses +import qualified UI.HSCurses.CursesHelper as CursesH +import UI.HSCurses.Widgets + +import Control.Exception +import System.Exit + +draw s = do + (h, w) <- Curses.scrSize + CursesH.gotoTop + CursesH.drawLine w s + Curses.refresh + +done = return () + +forever :: (Monad m) => m t -> m t +forever x = x >> forever x + +exit ew _ _ = return (Done ew) + +options stys = + let dsty = (mkDrawingStyle (stys !! 1)) {dstyle_active = stys !! 1} + in defaultEWOptions {ewopt_style = dsty} + +editWidget stys = newEditWidget (options stys) "" + +edit ew = do + (ew', s) <- activateEditWidget done (1, 10) (1, 10) ew + Curses.wMove Curses.stdScr 5 0 + CursesH.drawLine 60 ("saved: " ++ s) + Curses.refresh + return ew' + +loop ew = do + c <- CursesH.getKey done + ew' <- case c of + Curses.KeyChar 'q' -> exitWith ExitSuccess + Curses.KeyChar 'e' -> edit ew + _ -> return ew + loop ew' + +styles = + [ CursesH.defaultStyle + , CursesH.Style CursesH.CyanF CursesH.PurpleB + ] + +main :: IO () +main = + do + CursesH.start + cstyles <- CursesH.convertStyles styles + Curses.cursSet Curses.CursorInvisible + CursesH.gotoTop + CursesH.drawLine 20 "Hit 'e'!" + Curses.wMove Curses.stdScr 1 0 + CursesH.drawLine 9 "Input: " + Curses.refresh + loop (editWidget cstyles) + `finally` CursesH.end diff --git a/tests/widget-test/TableTest.hs b/tests/widget-test/TableTest.hs new file mode 100644 --- /dev/null +++ b/tests/widget-test/TableTest.hs @@ -0,0 +1,116 @@ +import Control.Exception +import System.Exit +import qualified UI.HSCurses.Curses as Curses +import qualified UI.HSCurses.CursesHelper as CursesH +import UI.HSCurses.Widgets + +row1 sty = map (TableCell . newTextWidget defaultTWOptions) ["1", "eins", "one"] +row2 sty = + TableCell + ( newTextWidget + ( defaultTWOptions + { twopt_size = + TWSizeFixed (2, 10) + , twopt_style = + mkDrawingStyle (sty !! 2) + } + ) + "2" + ) + : map (TableCell . newTextWidget defaultTWOptions) ["zwei", "two"] +row3 sty = + map (TableCell . newTextWidget defaultTWOptions) ["3", "drei"] + ++ [ ActiveTableCell $ + newEditWidget + ( defaultEWOptions + { ewopt_style = + mkDrawingStyle (sty !! 1) + } + ) + "" + ] +row4 sty = + map + (TableCell . newTextWidget defaultTWOptions) + ["4", "vier", "four"] +row5 sty = + map (TableCell . newTextWidget defaultTWOptions) ["5", "fuenf"] + ++ [ TableCell + ( newTextWidget + ( defaultTWOptions + { twopt_size = + TWSizeFixed (1, 6) + , twopt_style = + mkDrawingStyle (sty !! 3) + } + ) + "five56XXXXX" + ) + ] + +rows sty = [row1 sty, row2 sty, row3 sty, row4 sty, row5 sty] + +tableWidget sty = newTableWidget (TBWOptions (Just 1) None [0, 2] (10, 10)) (rows sty) + +tableSize = (2, 50) +tablePos = (1, 0) + +msgSize = (1, 40) +msgPos = (10, 0) + +text = "0 1 2 3 4 5" + +done = return () + +loop tbw msg = do + drawTableWidget tablePos tableSize DHNormal tbw + drawTextWidget msgPos msgSize DHNormal msg + c <- CursesH.getKey done + case c of + Curses.KeyChar 'q' -> exitWith ExitSuccess + Curses.KeyChar ' ' -> loop (tableWidgetScrollDown tableSize tbw) msg + Curses.KeyChar '-' -> loop (tableWidgetScrollUp tableSize tbw) msg + Curses.KeyRight -> loop (tableWidgetGoRight tableSize tbw) msg + Curses.KeyLeft -> loop (tableWidgetGoLeft tableSize tbw) msg + Curses.KeyUp -> loop (tableWidgetGoUp tableSize tbw) msg + Curses.KeyDown -> loop (tableWidgetGoDown tableSize tbw) msg + Curses.KeyChar '\r' -> do + (new, res) <- + tableWidgetActivateCurrent + done + tablePos + tableSize + DHNormal + tbw + let msg' = case res of + Nothing -> + textWidgetSetText + msg + "could not activate current cell" + Just s -> + textWidgetSetText + msg + ("new content: <" ++ s ++ ">") + loop new msg' + _ -> loop tbw msg + +styles = + [ CursesH.defaultStyle + , CursesH.Style CursesH.WhiteF CursesH.PurpleB + , CursesH.AttributeStyle [CursesH.Dim] CursesH.CyanF CursesH.WhiteB + , CursesH.ColorlessStyle [CursesH.Bold] + ] + +main :: IO () +main = + do + CursesH.start + cstyles <- CursesH.convertStyles styles + Curses.cursSet Curses.CursorInvisible + drawTextWidget + (0, 0) + (1, 60) + DHFocus + (newTextWidget defaultTWOptions text) + loop (tableWidget cstyles) (newTextWidget defaultTWOptions "") + `finally` CursesH.end diff --git a/tests/widget-test/TextTest.hs b/tests/widget-test/TextTest.hs new file mode 100644 --- /dev/null +++ b/tests/widget-test/TextTest.hs @@ -0,0 +1,37 @@ +import Control.Exception +import System.Exit +import qualified UI.HSCurses.Curses as Curses +import qualified UI.HSCurses.CursesHelper as CursesH +import UI.HSCurses.Widgets + +twOptions sty = defaultTWOptions {twopt_style = mkDrawingStyle sty} + +text sty = newTextWidget (twOptions sty) (reverse "1\n12\n123\n1234\n12345\n123456\n1234567\n12345678\n123456789\n1234567890") + +textSize = (4, 4) + +loop tw = do + drawTextWidget (0, 0) textSize DHNormal tw + c <- CursesH.getKey done + case c of + Curses.KeyChar 'q' -> exitWith ExitSuccess + Curses.KeyChar ' ' -> loop $ textWidgetScrollDown textSize tw + Curses.KeyChar '-' -> loop $ textWidgetScrollUp textSize tw + Curses.KeyChar ',' -> loop $ textWidgetScrollLeft textSize tw + Curses.KeyChar '.' -> loop $ textWidgetScrollRight textSize tw + _ -> loop tw + +done :: IO () +done = return () + +styles = [CursesH.defaultStyle, CursesH.Style CursesH.WhiteF CursesH.PurpleB] + +main :: IO () +main = + do + CursesH.start + cstyles <- CursesH.convertStyles styles + Curses.cursSet Curses.CursorInvisible + CursesH.gotoTop + loop (text (cstyles !! 1)) + `finally` CursesH.end