hscurses 1.4.2.0 → 1.5.0.0

raw patch · 20 files changed

+4125/−3327 lines, 20 filesdep +hscursesdep +prettydep +timedep −old-localedep −old-timedep ~basedep ~exceptionsdep ~mtlsetup-changednew-component:exe:contact-managernew-component:exe:key-testnew-component:exe:widget-test-editnew-component:exe:widget-test-tablenew-component:exe:widget-test-textnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: hscurses, pretty, time

Dependencies removed: old-locale, old-time

Dependency ranges changed: base, exceptions, mtl, unix

API changes (from Hackage documentation)

Files

• ChangeLog +9/−1
• README +0/−72
• README.md +113/−0
• Setup.hs +1/−0
• UI/HSCurses/CWString.hsc +120/−112
• UI/HSCurses/Curses.hsc +1722/−1552
• UI/HSCurses/CursesHelper.hs +208/−226
• UI/HSCurses/IConv.hsc +68/−80
• UI/HSCurses/Logging.hs +15/−28
• UI/HSCurses/Widgets.hs +1133/−956
• example/ContactManager.hs +316/−229
• example/Setup.hs +0/−3
• example/cm.cabal +0/−14
• example/contacts +0/−1
• example/contacts2 +0/−1
• hscurses.cabal +174/−52
• tests/key-test/KeyTest.hs +34/−0
• tests/widget-test/EditTest.hs +59/−0
• tests/widget-test/TableTest.hs +116/−0
• tests/widget-test/TextTest.hs +37/−0

@@ -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

@@ -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 <john @ repetae . net>, 2002-2004.-   Tuomo Valkonen <tuomov @ iki.fi>, 2004.-   Don Stewart <http://www.cse.unsw.edu.au/~dons>, 2004.-   Stefan Wehr <http://www.stefanwehr.de>, 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.

@@ -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 <john @ repetae . net>, 2002-2004.+    Tuomo Valkonen <tuomov @ iki.fi>, 2004.+    Don Stewart <http://www.cse.unsw.edu.au/~dons>, 2004.+    Stefan Wehr <http://www.stefanwehr.de>, 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.

@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMainWithHooks autoconfUserHooks

@@ -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"-

@@ -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, <http://dickey.his.com/ncurses/>------ 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 <HSCurses.h>--#if HAVE_SIGNAL_H-# include <signal.h>-#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  <curses.h>,---     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, <http://dickey.his.com/ncurses/>+--+-- 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 <HSCurses.h>++#if HAVE_SIGNAL_H+#include <signal.h>+#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 <curses.h>, 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.

@@ -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 ' ') = "<Space>" displayKey (KeyChar '\t') = "<Tab>" displayKey (KeyChar '\r') = "<Enter>" 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 = "<Down>" displayKey KeyUp = "<Up>"@@ -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

@@ -23,34 +23,25 @@ -- | Iconv binding  #if HAVE_ICONV_H-# include <iconv.h>+#include <iconv.h> #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

@@ -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

@@ -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 (<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 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)

@@ -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

@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell-import Distribution.Simple-main = defaultMainWithHooks simpleUserHooks

@@ -1,14 +0,0 @@-Name:          contact-manager-Synopsis:      Primitive addressbook-Version:       0.1-License:       GPL-License-file:  ../LICENSE-Author:   Stefan Wehr <http://www.informatik.uni-freiburg.de/~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-