hscurses 1.2 → 1.3

raw patch · 33 files changed

+3771/−9798 lines, 33 filesdep +old-localedep +old-timedep −haskell98setup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: old-locale, old-time

Dependencies removed: haskell98

API changes (from Hackage documentation)

Files

• HSCurses/CWString.hsc +0/−388
• HSCurses/Curses.hsc +0/−1403
• HSCurses/CursesHelper.hs +0/−473
• HSCurses/IConv.hsc +0/−205
• HSCurses/Logging.hs +0/−70
• HSCurses/MonadException.hs +0/−143
• HSCurses/Widgets.hs +0/−873
• Makefile +0/−48
• README +7/−38
• Setup.hs +1/−1
• UI/HSCurses/CWString.hsc +387/−0
• UI/HSCurses/Curses.hsc +1450/−0
• UI/HSCurses/CursesHelper.hs +474/−0
• UI/HSCurses/IConv.hsc +205/−0
• UI/HSCurses/Logging.hs +75/−0
• UI/HSCurses/MonadException.hs +145/−0
• UI/HSCurses/Widgets.hs +951/−0
• cbits/HSCurses.h +1/−1
• cbits/HSCursesUtils.c +1/−1
• configure +0/−5006
• configure.ac +0/−175
• example/ContactManager.hs +57/−55
• example/Makefile +0/−9
• example/Setup.hs +1/−1
• example/cm.cabal +3/−1
• hscurses.buildinfo.in +0/−1
• hscurses.cabal +13/−14
• hscurses.conf.m4.in.64 +0/−43
• hscurses.conf.m4.in.before64 +0/−23
• install-sh +0/−251
• mk/config.mk.in +0/−55
• mk/paths.mk +0/−228
• mk/rules.mk +0/−292

@@ -1,388 +0,0 @@------ Copyright (c) 2002-2004 John Meacham (john at repetae dot net)--- Copyright (c) 2004      Don Stewart - http://www.cse.unsw.edu.au/~dons--- --- 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 HSCurses.CWString (--    -- * utf8 versions-    withUTF8String,-    withUTF8StringLen,-    newUTF8String,-    newUTF8StringLen,-    peekUTF8String,-    peekUTF8StringLen,--    -- * WChar stuff-#ifdef HAVE_WCHAR_H-    withCWString,-    withCWStringLen,-    newCWString,-    newCWStringLen,-    peekCWString,-    peekCWStringLen,-    wcharIsUnicode,-    CWChar, -    CWString, -    CWStringLen,-#endif-    -- * Locale versions -    withLCString,-    withLCStringLen,-    newLCString,-    newLCStringLen,-    peekLCStringLen,-    peekLCString,---  charIsRepresentable--    ) where--import Data.Char            ( ord, chr )-import Data.Bits            ( Bits((.|.), (.&.), shift) )-import Foreign.C.String--#if __GLASGOW_HASKELL__ < 603-import GHC.Exts-#endif--#ifdef HAVE_WCHAR_H--import Foreign.C.Types--#include <wchar.h>-#include <limits.h>-#include <stdlib.h>--type CWChar = (#type wchar_t)-type CWString = Ptr CWChar-type CWStringLen = (CWString, Int)--fi :: (Integral a, Num b) => a -> b-fi x = fromIntegral x------------------------ CWChar functions----------------------{-# INLINE wcharIsUnicode #-}-wcharIsUnicode :: Bool--#if defined(__STDC_ISO_10646__)--wcharIsUnicode = True---- support functions -wNUL :: CWChar-wNUL = 0-#ifndef __GLASGOW_HASKELL__-pairLength :: String -> CString -> CStringLen-pairLength  = flip (,) . length--cwCharsToChars :: [CWChar] -> [Char]-cwCharsToChars xs  = map castCWCharToChar xs-charsToCWChars :: [Char] -> [CWChar]-charsToCWChars xs  = map castCharToCWChar xs--#endif--- __STDC_ISO_10646__--castCWCharToChar :: CWChar -> Char-castCWCharToChar ch = chr (fromIntegral ch )--castCharToCWChar :: Char -> CWChar-castCharToCWChar ch = fromIntegral (ord ch)---- exported functions-peekCWString    :: CWString -> IO String-#ifndef __GLASGOW_HASKELL__-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)-#endif--peekCWStringLen           :: CWStringLen -> IO String-#ifndef __GLASGOW_HASKELL__-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)-#endif--newCWString :: String -> IO CWString-#ifndef __GLASGOW_HASKELL__-newCWString  = newArray0 wNUL . charsToCWChars-#else-newCWString str = do-  ptr <- mallocArray0 (length str)-  let-        go [] n##   = pokeElemOff ptr (I## n##) wNUL-        go (c:cs) n## = do pokeElemOff ptr (I## n##) (castCharToCWChar c); go cs (n## +## 1##)-  go str 0##-  return ptr-#endif--newCWStringLen     :: String -> IO CWStringLen-#ifndef __GLASGOW_HASKELL__-newCWStringLen str  = do a <- newArray (charsToCWChars str)-                        return (pairLength str a)-#else-newCWStringLen str = do-  ptr <- mallocArray0 len-  let-        go [] _       = return ()-        go (c:cs) n## = do pokeElemOff ptr (I## n##) (castCharToCWChar c); go cs (n## +## 1##)-  go str 0##-  return (ptr, len)-  where-    len = length str-#endif--withCWString :: String -> (CWString -> IO a) -> IO a-#ifndef __GLASGOW_HASKELL__-withCWString  = withArray0 wNUL . charsToCWChars-#else-withCWString str f =-  allocaArray0 (length str) $ \ptr ->-      let-        go [] n##     = pokeElemOff ptr (I## n##) wNUL-        go (c:cs) n## = do pokeElemOff ptr (I## n##) (castCharToCWChar c); go cs (n## +## 1##)-      in do-      go str 0##-      f ptr-#endif--withCWStringLen         :: String -> (CWStringLen -> IO a) -> IO a-#ifndef __GLASGOW_HASKELL__-withCWStringLen str act  = withArray (charsToCWChars str) $ act . pairLength str-#else-withCWStringLen str f =-  allocaArray len $ \ptr ->-      let-        go [] _       = return ()-        go (c:cs) n## = do pokeElemOff ptr (I## n##) (castCharToCWChar c); go cs (n## +## 1##)-      in do-      go str 0##-      f (ptr,len)-  where-    len = length str-#endif---#else--- no __STDC_ISO_10646__-wcharIsUnicode = False-#endif--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)) --clearMBState :: MBState -> IO ()-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--#def inline HsInt hs_get_mb_cur_max () { return MB_CUR_MAX; }-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--foreign import ccall unsafe "string.h memset" -        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--mbstowcs a b s = throwIf (== -1) (const "mbstowcs") $ c_mbstowcs a b s --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-    copyBytes ncp cp len-    pokeElemOff ncp len 0-    peekLCString ncp-    -newLCString :: String -> IO CString-newLCString s = -    withCWString s $ \wcs -> do -        cs <- mallocArray0 alen-        wcsrtombs wcs (cs, fi alen)-        return cs --    where alen = mb_cur_max * length s--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--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--pairLength1 :: String -> CString -> CStringLen-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 = withCStringLen--newLCString :: String -> IO Foreign.C.String.CString-newLCString = newCString--newLCStringLen :: String -> IO Foreign.C.String.CStringLen-newLCStringLen = newCStringLen--peekLCString :: Foreign.C.String.CString -> IO String-peekLCString = peekCString--peekLCStringLen :: Foreign.C.String.CStringLen -> IO String-peekLCStringLen = peekCStringLen--#endif--- no CF_WCHAR_SUPPORT---------------------- UTF8 versions--------------------withUTF8String :: String -> (CString -> IO a) -> IO a-withUTF8String hsStr = withCString (toUTF hsStr)--withUTF8StringLen :: String -> (CStringLen -> IO a) -> IO a-withUTF8StringLen hsStr = withCStringLen (toUTF hsStr)--newUTF8String :: String -> IO CString-newUTF8String = newCString . toUTF--newUTF8StringLen :: String -> IO CStringLen-newUTF8StringLen = newCStringLen . toUTF--peekUTF8String :: CString -> IO String-peekUTF8String strPtr = fmap fromUTF $ peekCString strPtr--peekUTF8StringLen :: CStringLen -> IO String-peekUTF8StringLen strPtr = fmap fromUTF $ peekCStringLen strPtr---- these should read and write directly from/to memory.--- A first pass will be needed to determine the size of the allocated region--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--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-  where-    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 _ = error "fromUTF: illegal three byte sequence" -    -    err = error "fromUTF: illegal UTF-8 character"-

@@ -1,1403 +0,0 @@-{-# OPTIONS -fffi -fglasgow-exts #-}--- 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 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 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-    touchWin,-    newPad, pRefresh, delWin, newWin,--    -- * Refresh Routines-    refresh,            -- :: IO ()-    update,-    resizeTerminal,--    -- * 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, -    addLn,         -- :: IO ()-    mvWAddStr,-    wMove,-    bkgrndSet,      -- :: Attr -> Pair -> IO ()-    erase,          -- :: IO ()-    wclear,         -- :: Window -> IO ()-    clrToEol,       -- :: IO ()-    wClrToEol,-    beep,-    waddch, --    -- * 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(..),--    -- * 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_,-    flushinp,-    recognize-        -  ) where --#include <config.h>-#include <HSCurses.h>--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--import HSCurses.CWString       ( withLCStringLen )-import HSCurses.MonadException-import HSCurses.Logging--import Prelude hiding           ( pi )-import Data.Char-import Data.List-import Data.Ix                  ( Ix )--import Control.Monad-import Control.Monad.Trans-import Control.Concurrent-import Control.Concurrent.Chan--import Foreign-import CForeign-import Foreign.C.Error-import System.Posix.Signals--#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-    defineKey (#const KEY_UP) "\x1b[1;2A"-    defineKey (#const KEY_DOWN) "\x1b[1;2B"-    defineKey (#const KEY_SLEFT) "\x1b[1;2D"-    defineKey (#const KEY_SRIGHT) "\x1b[1;2C"----------------------------------------------------------------------------fi :: (Integral a, Num b) => a -> b-fi = fromIntegral--throwIfErr :: Num a => String -> IO a -> IO a---throwIfErr name act = do---    res <- act---    if res == (#const ERR)---        then ioError (userError ("Curses: "++name++" failed"))---        else return res-throwIfErr s = throwIf (== (#const ERR)) (\a -> "Curses[" ++ show a ++ "]:"  ++ s)--throwIfErr_ :: Num a => String -> IO a -> IO ()-throwIfErr_ name act = void $ throwIfErr name act----------------------------------------------------------------------------type WindowTag = ()-type Window = Ptr WindowTag------- | 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)----------------------------------------------------------------------------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 ()------- | >  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----scrSize :: IO (Int, Int)-scrSize = do-    lnes <- peek linesPtr-    cols <- peek colsPtr-    return (fromIntegral lnes, fromIntegral cols)--foreign import ccall "HSCurses.h &LINES" linesPtr :: Ptr CInt-foreign import ccall "HSCurses.h &COLS"  colsPtr  :: Ptr CInt------- | 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------- | 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----------------------------------------------------------------------------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 -> (#type chtype)-#def inline chtype hs_curses_color_pair (HsInt pair) {return COLOR_PAIR (pair);}------------------ 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-attr0 = Attr (#const WA_NORMAL)--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)----------------------------------------------------------------------------mvWAddStr :: Window -> Int -> Int -> String -> IO ()-mvWAddStr w y x str = wMove w y x >> wAddStr w str --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)----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--foreign import ccall unsafe -    waddch :: Window -> (#type chtype) -> 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 threadsafe-    waddnstr :: Window -> CString -> CInt -> IO CInt--foreign import ccall threadsafe-    waddch :: Window -> (#type chtype) -> IO CInt--foreign import ccall threadsafe -    waddchnstr :: Window -> CString -> CInt -> IO CInt--#endif--foreign import ccall threadsafe-    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 :: (#type chtype) -> IO ()--erase :: IO ()-erase = throwIfErr_ "erase" $ werase_c  stdScr-foreign import ccall unsafe "werase" werase_c :: Window -> IO CInt--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-    -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--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.----foreign import ccall unsafe getch :: IO CInt----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---- ------------------------------------------------------------------------ get char------- ncurses ungetch and Haskell's threadWaitRead do not work together well.--- So I decided to implement my own input queue.--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)-       {- 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.----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)-    cb ButtonControl = (#const BUTTON_CTRL)-    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--{---- haddock doesn't like these commented out with ---   #if defined(__STDC_ISO_10646__)  && defined(HAVE_WADDNWSTR)-   #else --}--recognize :: Char -> IO a -> ((#type 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

@@ -1,473 +0,0 @@-{-# OPTIONS -cpp -#include HSCursesUtils.h -#include <signal.h> #-}---- --- Copyright (C) 2005 Stefan Wehr------ Derived from: yi/Curses/UI.hs---      Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons---      Released under the same license.------ Derived from: riot/UI.hs---      Copyright (c) Tuomo Valkonen 2004.---      Released under the same license.--- --- This program is free software; you can redistribute it and/or--- modify it under the terms of the GNU General Public License as--- published by the Free Software Foundation; either version 2 of--- the License, or (at your option) any later version.--- --- This program 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--- General Public License for more details.--- --- You should have received a copy of the GNU General Public License--- along with this program; if not, write to the Free Software--- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA--- 02111-1307, USA.--- -----module HSCurses.CursesHelper (--        -- * UI initialisation -        start, end, suspend, resizeui,--        -- * Input-        getKey,--        -- * Drawing-        drawLine, drawCursor,--        -- * Navigation-        gotoTop,--        -- * Colors-        ForegroundColor(..), BackgroundColor(..),-        defaultColor, black, red, green, yellow, blue, magenta, cyan, white,--        -- * Attributes-        Attribute(..), convertAttributes,--        -- * Style-        Style(..), CursesStyle, mkCursesStyle, changeCursesStyle,-        setStyle, resetStyle, convertStyles,-        defaultStyle, defaultCursesStyle, withStyle, --        -- * Keys-        displayKey,--        -- * Helpers-        withCursor, withProgram-  )   where--import HSCurses.Curses hiding ( refresh, Window )-import qualified HSCurses.Curses as Curses-import HSCurses.Logging--import Char-import Data.Maybe-import Data.List-import Control.Monad.Trans-import HSCurses.MonadException-import System.Posix.Signals-------------- | @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.resetParams-    Curses.keypad Curses.stdScr True    -- grab the keyboard-    case (Curses.cursesSigWinch, Curses.keyResizeCode) of-      (Just sig, Just key) ->-          do installHandler sig (Catch $ sigwinch sig key) Nothing-             return ()-      _ -> debug ("cannot install SIGWINCH handler: signal=" ++ -                  show Curses.cursesSigWinch ++ ", KEY_RESIZE=" ++ -                  show Curses.keyResizeCode)-    where sigwinch sig key = -              do debug "SIGWINCH signal received"-                 Curses.ungetCh key-                 installHandler sig (Catch $ sigwinch sig key) Nothing-                 return ()--------- | Clean up and go home. ----end :: IO ()-end = do Curses.endWin--- Refresh is needed on linux. grr.-#if NCURSES_UPDATE_AFTER_END-         Curses.update-#endif------- | Suspend the program.----suspend :: IO ()-suspend = raiseSignal sigTSTP------- | @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 refresh = do-    k <- liftIO $ Curses.getCh-    debug ("getKey: " ++ show k)-    case k of-      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-    gotoTop-    (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 = 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"------- | Converts a list of 'Curses.Color' pairs (foreground color and---   background color) into the curses representation 'Curses.Pair'.------   You should call this function exactly once, at application startup.------ (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----------------------------------------------------------------------------- Nicer, user-visible color defs.------ We separate colors into dark and bright colors, to prevent users--- from erroneously constructing bright colors for dark backgrounds,--- which doesn't work.------- | Foreground colors.----data ForegroundColor-    = BlackF-    | GreyF-    | DarkRedF-    | RedF-    | DarkGreenF-    | GreenF-    | BrownF-    | YellowF-    | DarkBlueF-    | BlueF-    | PurpleF-    | MagentaF-    | DarkCyanF-    | CyanF-    | WhiteF-    | BrightWhiteF-    | DefaultF-    deriving (Eq, Show)------- | Background colors.----data BackgroundColor-    = BlackB-    | DarkRedB-    | DarkGreenB-    | BrownB-    | DarkBlueB-    | PurpleB-    | DarkCyanB-    | WhiteB-    | 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)--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)-    BrightWhiteF -> ([Bold], white)-    DefaultF     -> ([], defaultColor)--------------------------------------------------------------------------------- | Abstractions for some commonly used attributes.----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--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-setBlinkA = flip Curses.setBlink True-------------------------------------------------------------------------------- | A humand-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"--}--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-changeCursesStyle _ attrs = ColorlessCursesStyle (convertAttributes attrs)--defaultCursesStyle :: CursesStyle-defaultCursesStyle = CursesStyle Curses.attr0 (Curses.Pair 0)------- | Reset the screen to normal values----resetStyle :: IO ()-resetStyle = setStyle defaultCursesStyle------- | Manipulate the current style of the standard screen----setStyle :: CursesStyle -> IO ()-setStyle (CursesStyle a p) = Curses.wAttrSet Curses.stdScr (a, p)-setStyle (ColorlessCursesStyle a) = -    do (_, p) <- Curses.wAttrGet Curses.stdScr-       Curses.wAttrSet Curses.stdScr (a, p)--withStyle :: MonadExcIO m => CursesStyle -> m a -> m a-withStyle style action = -    bracketM-        (liftIO $ do old <- Curses.wAttrGet Curses.stdScr    -- before-                     setStyle style-                     return old)-        (\old -> liftIO $ Curses.wAttrSet Curses.stdScr old) -- after-        (\_ -> 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-----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) = show c-displayKey KeyDown = "<Down>"-displayKey KeyUp = "<Up>"-displayKey KeyLeft = "<Left>"-displayKey KeyRight = "<Right>"-displayKey KeyHome = "<Home>"-displayKey KeyBackspace = "<BS>"-displayKey (KeyF i) = 'F' : show i-displayKey KeyNPage = "<NPage>"-displayKey KeyPPage = "<PPage>"-displayKey KeyEnter = "<Return>"-displayKey KeyEnd = "<End>"-displayKey KeyIC = "<Insert>"-displayKey KeyDC = "<Delete>"-displayKey k = show k--------------------------------------------------------------------------------- | Other helpers---------- | set the cursor, and do action----withCursor :: MonadExcIO m => CursorVisibility -> m a -> m a-withCursor nv action = -    bracketM-        (liftIO $ Curses.cursSet nv)             -- before-        (\vis -> liftIO $ Curses.cursSet vis)    -- after-        (\_ -> action)                           -- do this--withProgram :: MonadExcIO m => m a -> m a-withProgram action = withCursor CursorVisible $ -    bracketM_ (liftIO endWin) (liftIO flushinp) action

@@ -1,205 +0,0 @@-{-# OPTIONS -fffi #-}------- Copyright (c) 2004 Tuomo Valkonen <tuomov at iki dot fi>--- Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons--- Copyright (c) 2005 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----- | Iconv binding--#if HAVE_ICONV_H-# include <iconv.h>-#endif--module HSCurses.IConv {-(-    IConv,-    iconv,-    iconv_,-    with_iconv,-    to_unicode, -    from_unicode,-    to_unicode_,-    from_unicode_-  )-} where--import HSCurses.CWString          ( peekUTF8StringLen, withUTF8StringLen )--import Foreign-import Foreign.C-import Foreign.C.String-import Control.Exception    ( Exception, try, bracket )--type IConv = Ptr () --(#type iconv_t)--err_ptr :: Ptr b -> Bool-err_ptr p = p == (plusPtr nullPtr (-1))--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-    -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---iconv_close :: IConv -> IO ()-iconv_close ic = -    throwErrnoIfMinus1_ "iconv_close" $ c_iconv_close ic-    -outbuf_size :: Int-outbuf_size = 1024--do_iconv :: ((Ptr a, Int) -> IO String) -> IConv -> (Ptr b, Int) -> IO String-do_iconv get_string_fn ic (inbuf, inbuf_bytes) =-    alloca $ \inbuf_ptr -> -        alloca $ \inbytesleft_ptr -> -            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 []---with_iconv :: String -> String -> (IConv -> IO a) -> IO a-with_iconv to from fn =-    bracket (iconv_open to from) iconv_close fn--iconv_ :: String -> IConv -> IO String-iconv_ str ic =-    withCStringLen str $ do_iconv peekCStringLen ic---- between 8-bit encodings only-iconv :: String -> String -> String -> Either Exception 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"--peek_cuni :: (Ptr (#type wchar_t), Int) -> IO String-peek_cuni (buf, bytes) = do-    let (chars, rembytes) = bytes `divMod` (#size wchar_t)-    if rembytes /= 0 then-        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--cuni_charset :: [Char]-cuni_charset = "UTF-8"--peek_cuni :: CStringLen -> IO String-peek_cuni = peekUTF8StringLen--with_cuni :: [Char] -> (CStringLen -> IO a) -> IO a-with_cuni = withUTF8StringLen--#endif--to_unicode_ :: String -> String -> IO String-to_unicode_ from str =    -     with_iconv cuni_charset from $-      \ic -> withCStringLen str $ do_iconv peek_cuni ic--to_unicode :: String -> String -> Either Exception 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--from_unicode :: String -> String -> Either Exception 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" 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" c_iconv-    :: IConv -> Ptr a -> Ptr CSize -> Ptr b -> Ptr CSize -> IO CSize--#endif

@@ -1,70 +0,0 @@-{-# OPTIONS -cpp -fno-cse #-}---- Copyright (c) 2005 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 HSCurses.Logging (trace,debug) where--import IO-import Time-import Locale-import Data.IORef-import System.IO.Unsafe             ( unsafePerformIO )-import Control.Monad.Trans---trace :: String -> a -> a-debug :: MonadIO m => String -> m ()--#ifdef __DEBUG__--logFile :: Handle-logFile = unsafePerformIO $ do h <- openFile ".hscurses.log" AppendMode-                               debug_ h "logging initialized"-                               return h-{-# 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--debug_ f s =-    do ts <- formatTime-       hPutStrLn f ("[" ++ ts ++ "] " ++ s)-       hFlush f--#else--trace _ x = x--debug s = return ()--#endif

@@ -1,143 +0,0 @@--- Copyright (c) 2005 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 HSCurses.MonadException where--import Prelude hiding (catch)-import Control.Exception-import Control.Monad.State-import Data.Typeable-import Data.Dynamic--class Monad m => MonadExc m where-    catchM      :: m a -> (Exception -> m a) -> m a-    blockM      :: m a -> m a-    unblockM    :: m a -> m a---class (MonadIO m, MonadExc m) => MonadExcIO m------- Operations implemented in term of catchM, blockM and unblockM--- (taken from Control.Exception).-----catchJustM :: MonadExc m =>-       (Exception -> Maybe b) -- ^ Predicate to select exceptions-    -> m a                    -- ^ Computation to run-    -> (b -> m a)             -- ^ Handler-    -> m a-catchJustM p a handler = catchM a handler'-  where handler' e = case p e of -            Nothing -> throw e-            Just b  -> handler b--handleM :: MonadExc m => (Exception -> m a) -> m a -> m a-handleM = flip catchM--handleJustM :: MonadExc m => -              (Exception -> Maybe b) -> (b -> m a) -> m a -> m a-handleJustM p = flip (catchJustM p)--tryM :: MonadExc m => m a -> m (Either Exception a)-tryM a = catchM (a >>= \ v -> return (Right v)) (\e -> return (Left e))--tryJustM :: MonadExc m => (Exception -> Maybe b) -> m a -> m (Either b a)-tryJustM p a = do-  r <- tryM a-  case r of-    Right v -> return (Right v)-    Left  e -> case p e of-            Nothing -> throw e-            Just b  -> return (Left b)--catchDynM :: (MonadExc m, Typeable exc) => -             m a -> (exc -> m a) -> m a-catchDynM m k = catchM m handle-  where handle ex = case ex of-               (DynException dyn) ->-                case fromDynamic dyn of-                    Just exception  -> k exception-                    Nothing -> throw ex-               _ -> throw ex--bracketM :: MonadExc m =>-       m a         -- ^ computation to run first (\"acquire resource\")-    -> (a -> m b)  -- ^ computation to run last (\"release resource\")-    -> (a -> m c)  -- ^ computation to run in-between-    -> m c         -- returns the value from the in-between computation-bracketM before after thing =-  blockM (do-    a <- before -    r <- catchM-       (unblockM (thing a))-       (\e -> do { after a; throw e })-    after a-    return r-  )--bracketM_ :: MonadExc m => m a -> m b -> m c -> m c-bracketM_ before after thing = bracketM before (const after) (const thing)--finally :: IO a -- ^ computation to run first-    -> IO b     -- ^ computation to run afterward (even if an exception -                --   was raised)-    -> IO a     -- returns the value from the first computation-a `finally` sequel =-  blockM (do-    r <- catchM-         (unblockM a)-         (\e -> do { sequel; throw e })-    sequel-    return r-  )-------- Instance declarations-----instance MonadExc IO where-    catchM       = catch-    blockM       = block-    unblockM     = unblock--instance MonadExcIO IO--instance MonadExc m => MonadExc (StateT s m) where-    catchM   = catchState-    blockM   = blockState-    unblockM = unblockState--instance (MonadExc m, MonadIO m) => MonadExcIO (StateT s m)--modifyState :: MonadExc m => (s -> m (a, s)) -> StateT s m a-modifyState f = -    do oldState <- get-       (x, newState) <- lift $ f oldState-       put newState-       return x--catchState run handler =-    modifyState (\oldState -> runStateT run oldState `catchM` -                              (\e -> runStateT (handler e) oldState))--blockState run =-    modifyState (\oldState -> blockM (runStateT run oldState))--unblockState run =-    modifyState (\oldState -> unblockM (runStateT run oldState))-       

@@ -1,873 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}--- glasgow-exts needed for existentials and multi-parameter type classes.---- Copyright (c) 2005 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 HSCurses.Widgets where--import Char-import List-import Maybe-import qualified HSCurses.Curses as Curses-import qualified HSCurses.CursesHelper as CursesH-import HSCurses.Logging--import Control.Monad.Trans-import Control.Exception (assert)-import HSCurses.MonadException--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  :: MonadExcIO 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 = 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 = 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 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 dataLen 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 pos@(y,x) sz@(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 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 = 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 = mkKeyHandler editWidgetGoLeft'-editWidgetGoRight = mkKeyHandler editWidgetGoRight'-editWidgetDeleteLeft = mkKeyHandler editWidgetDeleteLeft'-editWidgetDeleteUnderCursor = mkKeyHandler editWidgetDeleteUnderCursor'-editWidgetDeleteToEnd = mkKeyHandler editWidgetDeleteToEnd'-editWidgetGoHome = mkKeyHandler editWidgetGoHome'-editWidgetGoEnd = mkKeyHandler editWidgetGoEnd'-editWidgetHistoryUp = mkKeyHandler editWidgetHistoryUp'-editWidgetHistoryDown = mkKeyHandler editWidgetHistoryDown'--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 ew = ew_content ew-editWidgetSetContent ew s = -    addToHistory (ew { ew_content = s, ew_xoffset = 0, ew_xcursor = 0 }) s--editWidgetGetOptions ew = ew_options ew-editWidgetSetOptions ew opts = ew { ew_options = opts }--drawEditWidget :: Pos -> Size -> DrawingHint -> EditWidget -> IO ()-drawEditWidget (y, x) (height, 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 :: MonadExcIO m => m () -> Pos -> Size -                   -> EditWidget -> m (EditWidget, String)-activateEditWidget refresh pos@(y, x) sz@(height, width) ew =-    CursesH.withCursor Curses.CursorVisible $ processKey ew-    where -    processKey ew = -        do liftIO $ draw ew-           k <- CursesH.getKey refresh-           case lookup k (ewopt_keyHandlers $ ew_options ew) of-             Nothing -> -                 case k of-                   Curses.KeyChar c | isAscii c && isPrint c -                       -> processKey $ insertChar ew c-                   _   -> processKey ew-             Just f  ->-                 do x <- liftIO $ f pos sz ew-                    case x of-                      Cont ew' -> processKey ew'-                      Done ew' -> do liftIO $ drawEditWidget pos sz DHActive ew'-                                     return (ew', editWidgetGetContent ew')-    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 })-    draw 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' _ _ 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' _ (_, 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' _ _ ew = -    let pos = ew_contentPos ew-        oldContent = ew_content ew-        newContent = take pos oldContent ++ drop (pos+1) oldContent-        in ew { ew_content = newContent }--editWidgetDeleteToEnd' _ _ ew =-    let pos = ew_contentPos ew-        oldContent = ew_content ew-        newContent = take pos oldContent-        in ew { ew_content = newContent }--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 _ _ ew =  return (Done (addToHistory ew (ew_content ew)))--maxHistoryLength = 50--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' _ _ ew = editWidgetHistory (+) ew-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 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 = 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 pos@(y, x) sz@(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 :: MonadExcIO 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 = 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 sz@(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 f [] = []-        applyToFirst f (x:xs) = f x : xs-        applyToLast f [] = []-        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 pos@(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 pos@(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 (y, x) | y == rowIndex && x == 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 :: MonadExcIO m => m () -> Pos -> Size -                           -> DrawingHint -> TableWidget -                           -> m (TableWidget, Maybe String)-tableWidgetActivateCurrent refresh pos@(y, x) sz hint 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 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 tbw sz@(height,_) 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 pos@(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 x -> Just (y, x)-        vert f = case f rows y cols x of-                   Nothing -> Nothing-                   Just y -> Just (y, 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 y | not (y `elem` rows) = Nothing-          goLeft cols x _ _ = -              case reverse (takeWhile (<x) cols) of-                [] -> Nothing-                (x:_) -> Just x-          goRight _ _ rows y | not (y `elem` rows) = Nothing-          goRight cols x _ _ = -              case dropWhile (x>=) cols of-                [] -> Nothing-                (x:_) -> Just x--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 d r l@(h:t) | (d `isPrefixOf` l) = (r, l) -                              | otherwise = nextToken d (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,(y: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)

@@ -1,48 +0,0 @@-TOPDIR = .--# way = p-# HCFLAGS = -D__DEBUG__--include $(TOPDIR)/mk/config.mk--# this rule must remain first-default: boot lib--ALL_DIRS = cbits HSCurses--PKG      = hscurses-LIBRARY  = libhscurses$(_way).a-LIBOBJS  = $(OBJS)--INSTALL_HEADERS = $(wildcard cbits/*.h)--include $(TOPDIR)/mk/rules.mk--.PHONY: srcdist-srcdist:-	@DIST=hscurses-ds-`date +%Y%m%d`; \-	CHANGELOG=CHANGELOG.$$DIST; \-	if [ -e $$DIST ] ; then echo "$$DIST already exists"; exit 1; fi; \-	darcs dist -d $$DIST > /dev/null && \-	gunzip $$DIST.tar.gz && \-	tar --delete --file=$$DIST.tar $$DIST/boring && \-	mkdir $$DIST && \-	darcs changes | sed 's/[[:alnum:].]*@[[:alnum:].]*/(Email address hidden)/g' > $$DIST/$$CHANGELOG && \-	tar --append --file=$$DIST.tar $$DIST/$$CHANGELOG && \-	mv $$DIST/$$CHANGELOG $$CHANGELOG && \-	rm -rf $$DIST && \-	gzip $$DIST.tar && \-	md5sum $$DIST.tar.gz > $$DIST.md5 && \-	echo "created dist as $$DIST.tar.gz"--CLEAN_FILES+=$(wildcard hscurses-ds-*.tar.gz hscurses-ds-*.md5 CHANGELOG.hscurses-ds-*)-# Dependency orders-ifeq ($(MAKECMDGOALS),clean)-#empty-else-ifeq ($(MAKECMDGOALS),distclean)-#empty-else-include $(TOPDIR)/depend-endif-endif

@@ -1,22 +1,21 @@-               hscurses -- A Haskell Binding to NCurses+               hscurses -- A Haskell Binding to ncurses                =+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+ -hscurses is a Haskell binding to the NCurses library, a library of+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 and on-OpenBSD using GHC 6.2, 6.4, 6.6, 6.6.1, 6.8.2.+The hscurses library has been reported to work on Linux x86 using GHC 6.8.2. -Building and installing the hscurses library with GHC 6.6+Building and installing the hscurses library with GHC 6.8 ---------------------------------------------------------  Requirements:  - GNU m4-- GHC >= 6.6+- GHC >= 6.8 - ncurses  Build and installation steps:@@ -30,34 +29,6 @@    runhaskell Setup.hs haddock --Building and installing the hscurses library with GHC 6.2 and 6.4--------------------------------------------------------------------Requirements:--- GNU make-- GNU m4-- GHC >= 6.2-- ncurses--Build and installation steps:--  sh configure-  make-  make doc          # if you want to build the API documentation-  make install      # probably as root--  make register     # probably as root-OR-  make user-register  # don't need to be root--In order to generate the API documentation, you need haddock-(http://www.haskell.org/haddock). The command is then:--  make doc          # result goes to ./html-- Using the hscurses library: --------------------------- @@ -65,15 +36,13 @@ moment, user documentation is only available through Haddock API documentation. - Copyright: ---------- -   John Meacham <john at repetae dot net>, 2002-2004.-   Tuomo Valkonen <tuomov at iki.fi>, 2004.+   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-2005.-  History: --------

@@ -1,2 +1,2 @@ import Distribution.Simple-main = defaultMainWithHooks defaultUserHooks+main = defaultMainWithHooks simpleUserHooks

@@ -0,0 +1,387 @@+-- Copyright (c) 2002-2004 John Meacham (john at repetae dot net)+-- Copyright (c) 2004      Don Stewart - http://www.cse.unsw.edu.au/~dons+--+-- 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.CWString (++    -- * utf8 versions+    withUTF8String,+    withUTF8StringLen,+    newUTF8String,+    newUTF8StringLen,+    peekUTF8String,+    peekUTF8StringLen,++    -- * WChar stuff+#ifdef HAVE_WCHAR_H+    withCWString,+    withCWStringLen,+    newCWString,+    newCWStringLen,+    peekCWString,+    peekCWStringLen,+    wcharIsUnicode,+    CWChar,+    CWString,+    CWStringLen,+#endif+    -- * Locale versions+    withLCString,+    withLCStringLen,+    newLCString,+    newLCStringLen,+    peekLCStringLen,+    peekLCString,+--  charIsRepresentable++    ) where++import Data.Char            ( ord, chr )+import Data.Bits            ( Bits((.|.), (.&.), shift) )+import Foreign.C.String++#if __GLASGOW_HASKELL__ < 603+import GHC.Exts+#endif++#ifdef HAVE_WCHAR_H++import Foreign.C.Types++#include <wchar.h>+#include <limits.h>+#include <stdlib.h>++type CWChar = (#type wchar_t)+type CWString = Ptr CWChar+type CWStringLen = (CWString, Int)++fi :: (Integral a, Num b) => a -> b+fi x = fromIntegral x++-------------------+-- CWChar functions+-------------------++{-# INLINE wcharIsUnicode #-}+wcharIsUnicode :: Bool++#if defined(__STDC_ISO_10646__)++wcharIsUnicode = True++-- support functions+wNUL :: CWChar+wNUL = 0+#ifndef __GLASGOW_HASKELL__+pairLength :: String -> CString -> CStringLen+pairLength  = flip (,) . length++cwCharsToChars :: [CWChar] -> [Char]+cwCharsToChars xs  = map castCWCharToChar xs+charsToCWChars :: [Char] -> [CWChar]+charsToCWChars xs  = map castCharToCWChar xs++#endif+-- __STDC_ISO_10646__++castCWCharToChar :: CWChar -> Char+castCWCharToChar ch = chr (fromIntegral ch )++castCharToCWChar :: Char -> CWChar+castCharToCWChar ch = fromIntegral (ord ch)++-- exported functions+peekCWString    :: CWString -> IO String+#ifndef __GLASGOW_HASKELL__+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)+#endif++peekCWStringLen           :: CWStringLen -> IO String+#ifndef __GLASGOW_HASKELL__+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)+#endif++newCWString :: String -> IO CWString+#ifndef __GLASGOW_HASKELL__+newCWString  = newArray0 wNUL . charsToCWChars+#else+newCWString str = do+  ptr <- mallocArray0 (length str)+  let+        go [] n##   = pokeElemOff ptr (I## n##) wNUL+        go (c:cs) n## = do pokeElemOff ptr (I## n##) (castCharToCWChar c); go cs (n## +## 1##)+  go str 0##+  return ptr+#endif++newCWStringLen     :: String -> IO CWStringLen+#ifndef __GLASGOW_HASKELL__+newCWStringLen str  = do a <- newArray (charsToCWChars str)+                        return (pairLength str a)+#else+newCWStringLen str = do+  ptr <- mallocArray0 len+  let+        go [] _       = return ()+        go (c:cs) n## = do pokeElemOff ptr (I## n##) (castCharToCWChar c); go cs (n## +## 1##)+  go str 0##+  return (ptr, len)+  where+    len = length str+#endif++withCWString :: String -> (CWString -> IO a) -> IO a+#ifndef __GLASGOW_HASKELL__+withCWString  = withArray0 wNUL . charsToCWChars+#else+withCWString str f =+  allocaArray0 (length str) $ \ptr ->+      let+        go [] n##     = pokeElemOff ptr (I## n##) wNUL+        go (c:cs) n## = do pokeElemOff ptr (I## n##) (castCharToCWChar c); go cs (n## +## 1##)+      in do+      go str 0##+      f ptr+#endif++withCWStringLen         :: String -> (CWStringLen -> IO a) -> IO a+#ifndef __GLASGOW_HASKELL__+withCWStringLen str act  = withArray (charsToCWChars str) $ act . pairLength str+#else+withCWStringLen str f =+  allocaArray len $ \ptr ->+      let+        go [] _       = return ()+        go (c:cs) n## = do pokeElemOff ptr (I## n##) (castCharToCWChar c); go cs (n## +## 1##)+      in do+      go str 0##+      f (ptr,len)+  where+    len = length str+#endif+++#else+-- no __STDC_ISO_10646__+wcharIsUnicode = False+#endif++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))++clearMBState :: MBState -> IO ()+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++#def inline HsInt hs_get_mb_cur_max () { return MB_CUR_MAX; }+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++foreign import ccall unsafe "string.h memset"+        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++mbstowcs a b s = throwIf (== -1) (const "mbstowcs") $ c_mbstowcs a b s++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+    copyBytes ncp cp len+    pokeElemOff ncp len 0+    peekLCString ncp++newLCString :: String -> IO CString+newLCString s =+    withCWString s $ \wcs -> do+        cs <- mallocArray0 alen+        wcsrtombs wcs (cs, fi alen)+        return cs++    where alen = mb_cur_max * length s++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++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++pairLength1 :: String -> CString -> CStringLen+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 = withCStringLen++newLCString :: String -> IO Foreign.C.String.CString+newLCString = newCString++newLCStringLen :: String -> IO Foreign.C.String.CStringLen+newLCStringLen = newCStringLen++peekLCString :: Foreign.C.String.CString -> IO String+peekLCString = peekCString++peekLCStringLen :: Foreign.C.String.CStringLen -> IO String+peekLCStringLen = peekCStringLen++#endif+-- no CF_WCHAR_SUPPORT++-----------------+-- UTF8 versions+-----------------++withUTF8String :: String -> (CString -> IO a) -> IO a+withUTF8String hsStr = withCString (toUTF hsStr)++withUTF8StringLen :: String -> (CStringLen -> IO a) -> IO a+withUTF8StringLen hsStr = withCStringLen (toUTF hsStr)++newUTF8String :: String -> IO CString+newUTF8String = newCString . toUTF++newUTF8StringLen :: String -> IO CStringLen+newUTF8StringLen = newCStringLen . toUTF++peekUTF8String :: CString -> IO String+peekUTF8String strPtr = fmap fromUTF $ peekCString strPtr++peekUTF8StringLen :: CStringLen -> IO String+peekUTF8StringLen strPtr = fmap fromUTF $ peekCStringLen strPtr++-- these should read and write directly from/to memory.+-- A first pass will be needed to determine the size of the allocated region++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++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+  where+    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 _ = error "fromUTF: illegal three byte sequence"++    err = error "fromUTF: illegal UTF-8 character"+

@@ -0,0 +1,1450 @@+{-# 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 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+    touchWin,+    newPad, pRefresh, delWin, newWin,++    -- * 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 ()+    clrToEol,      -- :: IO ()+    wClrToEol,+    beep,+    waddch,+    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 <ghcconfig.h>+#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 Control.Monad+import Control.Monad.Trans+import Control.Concurrent+import Control.Concurrent.Chan++import Foreign+import Foreign.C.String+import Foreign.C.Types+import Foreign.C.Error+import System.Posix.Signals++#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+    defineKey (#const KEY_UP) "\x1b[1;2A"+    defineKey (#const KEY_DOWN) "\x1b[1;2B"+    defineKey (#const KEY_SLEFT) "\x1b[1;2D"+    defineKey (#const KEY_SRIGHT) "\x1b[1;2C"++------------------------------------------------------------------------++fi :: (Integral a, Num b) => a -> b+fi = fromIntegral++throwIfErr :: 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_ :: 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)+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)++------------------------------------------------------------------------++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 ()++--+-- | >  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+--+scrSize :: IO (Int, Int)+scrSize = do+    lnes <- peek linesPtr+    cols <- peek colsPtr+    return (fromIntegral lnes, fromIntegral cols)++foreign import ccall "HSCurses.h &LINES" linesPtr :: Ptr CInt+foreign import ccall "HSCurses.h &COLS"  colsPtr  :: Ptr CInt++--+-- | 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++--+-- | 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+#def inline chtype hs_curses_color_pair (HsInt pair) {return COLOR_PAIR (pair);}++-------------+-- 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+attr0 = Attr (#const WA_NORMAL)++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)++------------------------------------------------------------------------++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)++--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++foreign import ccall unsafe+    waddch :: Window -> ChType -> 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 threadsafe+    waddnstr :: Window -> CString -> CInt -> IO CInt++foreign import ccall threadsafe+    waddch :: Window -> ChType -> IO CInt++foreign import ccall threadsafe+    waddchnstr :: Window -> CString -> CInt -> IO CInt++foreign import ccall threadsafe "static curses.h mvaddch" mvaddch_c :: CInt -> CInt -> ChType -> IO ()++#endif++foreign import ccall threadsafe+    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 ()++erase :: IO ()+erase = throwIfErr_ "erase" $ werase_c  stdScr+foreign import ccall unsafe "werase" werase_c :: Window -> IO CInt++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++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++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.+--+foreign import ccall unsafe getch :: IO CInt++--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.+--+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)+    cb ButtonControl = (#const BUTTON_CTRL)+    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++{-+-- haddock doesn't like these commented out with --+   #if defined(__STDC_ISO_10646__)  && defined(HAVE_WADDNWSTR)+   #else+-}++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

@@ -0,0 +1,474 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS -#include HSCursesUtils.h -#include <signal.h> #-}++--+-- Copyright (C) 2005 Stefan Wehr+--+-- Derived from: yi/Curses/UI.hs+--      Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons+--      Released under the same license.+--+-- Derived from: riot/UI.hs+--      Copyright (c) Tuomo Valkonen 2004.+--      Released under the same license.+--+-- This program is free software; you can redistribute it and/or+-- modify it under the terms of the GNU General Public License as+-- published by the Free Software Foundation; either version 2 of+-- the License, or (at your option) any later version.+--+-- This program 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+-- General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA+-- 02111-1307, USA.+--+--++module UI.HSCurses.CursesHelper (++        -- * UI initialisation+        start, end, suspend, resizeui,++        -- * Input+        getKey,++        -- * Drawing+        drawLine, drawCursor,++        -- * Navigation+        gotoTop,++        -- * Colors+        ForegroundColor(..), BackgroundColor(..),+        defaultColor, black, red, green, yellow, blue, magenta, cyan, white,++        -- * Attributes+        Attribute(..), convertAttributes,++        -- * Style+        Style(..), CursesStyle, mkCursesStyle, changeCursesStyle,+        setStyle, resetStyle, convertStyles,+        defaultStyle, defaultCursesStyle, withStyle,++        -- * Keys+        displayKey,++        -- * Helpers+        withCursor, withProgram+  )   where++import UI.HSCurses.Curses hiding ( refresh, Window )+import UI.HSCurses.Logging+import UI.HSCurses.MonadException+import qualified UI.HSCurses.Curses as Curses++import Data.Char+import Data.Maybe+import Data.List+import Control.Monad.Trans+import System.Posix.Signals++--+--++--+-- | @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.resetParams+    Curses.keypad Curses.stdScr True    -- grab the keyboard+    case (Curses.cursesSigWinch, Curses.keyResizeCode) of+      (Just sig, Just key) ->+          do installHandler sig (Catch $ sigwinch sig key) Nothing+             return ()+      _ -> debug ("cannot install SIGWINCH handler: signal=" +++                  show Curses.cursesSigWinch ++ ", KEY_RESIZE=" +++                  show Curses.keyResizeCode)+    where sigwinch sig key =+              do debug "SIGWINCH signal received"+                 Curses.ungetCh key+                 installHandler sig (Catch $ sigwinch sig key) Nothing+                 return ()++++--+-- | Clean up and go home.+--+end :: IO ()+end = do Curses.endWin+-- Refresh is needed on linux. grr.+#if NCURSES_UPDATE_AFTER_END+         Curses.update+#endif++--+-- | Suspend the program.+--+suspend :: IO ()+suspend = raiseSignal sigTSTP++--+-- | @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 refresh = do+    k <- liftIO $ Curses.getCh+    debug ("getKey: " ++ show k)+    case k of+      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+    gotoTop+    (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 = 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"++--+-- | Converts a list of 'Curses.Color' pairs (foreground color and+--   background color) into the curses representation 'Curses.Pair'.+--+--   You should call this function exactly once, at application startup.+--+-- (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++------------------------------------------------------------------------+-- Nicer, user-visible color defs.+--+-- We separate colors into dark and bright colors, to prevent users+-- from erroneously constructing bright colors for dark backgrounds,+-- which doesn't work.++--+-- | Foreground colors.+--+data ForegroundColor+    = BlackF+    | GreyF+    | DarkRedF+    | RedF+    | DarkGreenF+    | GreenF+    | BrownF+    | YellowF+    | DarkBlueF+    | BlueF+    | PurpleF+    | MagentaF+    | DarkCyanF+    | CyanF+    | WhiteF+    | BrightWhiteF+    | DefaultF+    deriving (Eq, Show)++--+-- | Background colors.+--+data BackgroundColor+    = BlackB+    | DarkRedB+    | DarkGreenB+    | BrownB+    | DarkBlueB+    | PurpleB+    | DarkCyanB+    | WhiteB+    | 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)++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)+    BrightWhiteF -> ([Bold], white)+    DefaultF     -> ([], defaultColor)+++------------------------------------------------------------------------+--+-- | Abstractions for some commonly used attributes.+--+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++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+setBlinkA = flip Curses.setBlink True++------------------------------------------------------------------------+--+-- | A humand-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"+-}++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+changeCursesStyle _ attrs = ColorlessCursesStyle (convertAttributes attrs)++defaultCursesStyle :: CursesStyle+defaultCursesStyle = CursesStyle Curses.attr0 (Curses.Pair 0)++--+-- | Reset the screen to normal values+--+resetStyle :: IO ()+resetStyle = setStyle defaultCursesStyle++--+-- | Manipulate the current style of the standard screen+--+setStyle :: CursesStyle -> IO ()+setStyle (CursesStyle a p) = Curses.wAttrSet Curses.stdScr (a, p)+setStyle (ColorlessCursesStyle a) =+    do (_, p) <- Curses.wAttrGet Curses.stdScr+       Curses.wAttrSet Curses.stdScr (a, p)++withStyle :: MonadExcIO m => CursesStyle -> m a -> m a+withStyle style action =+    bracketM+        (liftIO $ do old <- Curses.wAttrGet Curses.stdScr    -- before+                     setStyle style+                     return old)+        (\old -> liftIO $ Curses.wAttrSet Curses.stdScr old) -- after+        (\_ -> 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+--++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) = show c+displayKey KeyDown = "<Down>"+displayKey KeyUp = "<Up>"+displayKey KeyLeft = "<Left>"+displayKey KeyRight = "<Right>"+displayKey KeyHome = "<Home>"+displayKey KeyBackspace = "<BS>"+displayKey (KeyF i) = 'F' : show i+displayKey KeyNPage = "<NPage>"+displayKey KeyPPage = "<PPage>"+displayKey KeyEnter = "<Return>"+displayKey KeyEnd = "<End>"+displayKey KeyIC = "<Insert>"+displayKey KeyDC = "<Delete>"+displayKey k = show k+++------------------------------------------------------------------------+--+-- | Other helpers+--++--+-- | set the cursor, and do action+--+withCursor :: MonadExcIO m => CursorVisibility -> m a -> m a+withCursor nv action =+    bracketM+        (liftIO $ Curses.cursSet nv)             -- before+        (\vis -> liftIO $ Curses.cursSet vis)    -- after+        (\_ -> action)                           -- do this++withProgram :: MonadExcIO m => m a -> m a+withProgram action = withCursor CursorVisible $+    bracketM_ (liftIO endWin) (liftIO flushinp) action

@@ -0,0 +1,205 @@+{-# LANGUAGE ForeignFunctionInterface #-}++--+-- Copyright (c) 2004 Tuomo Valkonen <tuomov at iki dot fi>+-- Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons+-- Copyright (c) 2005 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+++-- | Iconv binding++#if HAVE_ICONV_H+# include <iconv.h>+#endif++module UI.HSCurses.IConv {-(+    IConv,+    iconv,+    iconv_,+    with_iconv,+    to_unicode,+    from_unicode,+    to_unicode_,+    from_unicode_+  )-} where++import UI.HSCurses.CWString          ( peekUTF8StringLen, withUTF8StringLen )++import Foreign+import Foreign.C+import Foreign.C.String+import Control.Exception    ( Exception, try, bracket )++type IConv = Ptr () --(#type iconv_t)++err_ptr :: Ptr b -> Bool+err_ptr p = p == (plusPtr nullPtr (-1))++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++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+++iconv_close :: IConv -> IO ()+iconv_close ic =+    throwErrnoIfMinus1_ "iconv_close" $ c_iconv_close ic++outbuf_size :: Int+outbuf_size = 1024++do_iconv :: ((Ptr a, Int) -> IO String) -> IConv -> (Ptr b, Int) -> IO String+do_iconv get_string_fn ic (inbuf, inbuf_bytes) =+    alloca $ \inbuf_ptr ->+        alloca $ \inbytesleft_ptr ->+            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 []+++with_iconv :: String -> String -> (IConv -> IO a) -> IO a+with_iconv to from fn =+    bracket (iconv_open to from) iconv_close fn++iconv_ :: String -> IConv -> IO String+iconv_ str ic =+    withCStringLen str $ do_iconv peekCStringLen ic++-- between 8-bit encodings only+iconv :: String -> String -> String -> Either Exception 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"++peek_cuni :: (Ptr (#type wchar_t), Int) -> IO String+peek_cuni (buf, bytes) = do+    let (chars, rembytes) = bytes `divMod` (#size wchar_t)+    if rembytes /= 0 then+        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++cuni_charset :: [Char]+cuni_charset = "UTF-8"++peek_cuni :: CStringLen -> IO String+peek_cuni = peekUTF8StringLen++with_cuni :: [Char] -> (CStringLen -> IO a) -> IO a+with_cuni = withUTF8StringLen++#endif++to_unicode_ :: String -> String -> IO String+to_unicode_ from str =+     with_iconv cuni_charset from $+      \ic -> withCStringLen str $ do_iconv peek_cuni ic++to_unicode :: String -> String -> Either Exception 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++from_unicode :: String -> String -> Either Exception 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" 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" c_iconv+    :: IConv -> Ptr a -> Ptr CSize -> Ptr b -> Ptr CSize -> IO CSize++#endif

@@ -0,0 +1,75 @@+{-# LANGUAGE CPP #-}++-- Copyright (c) 2005 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.Logging (trace,debug) where++import Control.Monad.Trans++#ifdef __DEBUG__++import Data.IORef+import System.IO+import System.IO.Unsafe (unsafePerformIO)+import System.Locale+import System.Time++#endif+++trace :: String -> a -> a+debug :: MonadIO m => String -> m ()++#ifdef __DEBUG__++logFile :: Handle+logFile = unsafePerformIO $ do h <- openFile ".hscurses.log" AppendMode+                               debug_ h "logging initialized"+                               return h+{-# 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++debug_ f s =+    do ts <- formatTime+       hPutStrLn f ("[" ++ ts ++ "] " ++ s)+       hFlush f++#else++trace _ x = x++debug _ = return ()++#endif

@@ -0,0 +1,145 @@+-- Copyright (c) 2005 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.MonadException where++import Prelude hiding (catch)+import Control.Exception+import Control.Monad.State+import Data.Dynamic++class Monad m => MonadExc m where+    catchM      :: m a -> (Exception -> m a) -> m a+    blockM      :: m a -> m a+    unblockM    :: m a -> m a+++class (MonadIO m, MonadExc m) => MonadExcIO m++--+-- Operations implemented in term of catchM, blockM and unblockM+-- (taken from Control.Exception).+--++catchJustM :: MonadExc m =>+       (Exception -> Maybe b) -- ^ Predicate to select exceptions+    -> m a                    -- ^ Computation to run+    -> (b -> m a)             -- ^ Handler+    -> m a+catchJustM p a handler = catchM a handler'+  where handler' e = case p e of+            Nothing -> throw e+            Just b  -> handler b++handleM :: MonadExc m => (Exception -> m a) -> m a -> m a+handleM = flip catchM++handleJustM :: MonadExc m =>+              (Exception -> Maybe b) -> (b -> m a) -> m a -> m a+handleJustM p = flip (catchJustM p)++tryM :: MonadExc m => m a -> m (Either Exception a)+tryM a = catchM (a >>= \ v -> return (Right v)) (\e -> return (Left e))++tryJustM :: MonadExc m => (Exception -> Maybe b) -> m a -> m (Either b a)+tryJustM p a = do+  r <- tryM a+  case r of+    Right v -> return (Right v)+    Left  e -> case p e of+            Nothing -> throw e+            Just b  -> return (Left b)++catchDynM :: (MonadExc m, Typeable exc) =>+             m a -> (exc -> m a) -> m a+catchDynM m k = catchM m handl+  where handl ex = case ex of+               (DynException dyn) ->+                case fromDynamic dyn of+                    Just exception  -> k exception+                    Nothing -> throw ex+               _ -> throw ex++bracketM :: MonadExc m =>+       m a         -- ^ computation to run first (\"acquire resource\")+    -> (a -> m b)  -- ^ computation to run last (\"release resource\")+    -> (a -> m c)  -- ^ computation to run in-between+    -> m c         -- returns the value from the in-between computation+bracketM before after thing =+  blockM (do+    a <- before+    r <- catchM+       (unblockM (thing a))+       (\e -> do { after a; throw e })+    after a+    return r+  )++bracketM_ :: MonadExc m => m a -> m b -> m c -> m c+bracketM_ before after thing = bracketM before (const after) (const thing)++finally :: IO a -- ^ computation to run first+    -> IO b     -- ^ computation to run afterward (even if an exception+                --   was raised)+    -> IO a     -- returns the value from the first computation+a `finally` sequel =+  blockM (do+    r <- catchM+         (unblockM a)+         (\e -> do { sequel; throw e })+    sequel+    return r+  )+++--+-- Instance declarations+--++instance MonadExc IO where+    catchM       = catch+    blockM       = block+    unblockM     = unblock++instance MonadExcIO IO++instance MonadExc m => MonadExc (StateT s m) where+    catchM   = catchState+    blockM   = blockState+    unblockM = unblockState++instance (MonadExc m, MonadIO m) => MonadExcIO (StateT s m)++modifyState :: MonadExc m => (s -> m (a, s)) -> StateT s m a+modifyState f =+    do oldState <- get+       (x, newState) <- lift $ f oldState+       put newState+       return x++catchState :: (MonadExc m) => StateT s m a -> (Exception -> StateT s m a)+           -> StateT s m a+catchState run handler =+    modifyState (\oldState -> runStateT run oldState `catchM`+                              (\e -> runStateT (handler e) oldState))++blockState, unblockState :: (MonadExc m) => StateT s m a -> StateT s m a+blockState run =+    modifyState (\oldState -> blockM (runStateT run oldState))++unblockState run =+    modifyState (\oldState -> unblockM (runStateT run oldState))+

@@ -0,0 +1,951 @@+{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification #-}+-- glasgow-exts needed for existentials and multi-parameter type classes.++-- Copyright (c) 2005 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)+import Control.Monad.Trans+import Data.Char+import Data.List+import Data.Maybe++import UI.HSCurses.Logging+import UI.HSCurses.MonadException+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  :: MonadExcIO 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 :: MonadExcIO 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 :: MonadExcIO 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 :: MonadExcIO 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 (y, z)+        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)