diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,16 @@ +1.4.2.0 (2015-02-12_ + - support for werase and winsch (thanks to Ryan Newton) + - add wnoutrefresh for more efficient updates of multiple windows (Ryan Newton) + - use getmaxyx for scrSize, remove non-recommended approach of reading + LINES and COLS global variables (Ryan Newton) + - fixed findNextActiveCell (Matthew Hague) + - support for GHC 7.8 (Miëtek Bak) + +1.4.1.2 (2012-09-12) + - support for GHC 7.6 + +1.4.1.1 ? + 1.4.1.0 (2011-09-11) - support for GHC 7.2 (thanks to thoughtpolice) - support for windows (thanks to José Romildo Malaquias) diff --git a/UI/HSCurses/Curses.hsc b/UI/HSCurses/Curses.hsc --- a/UI/HSCurses/Curses.hsc +++ b/UI/HSCurses/Curses.hsc @@ -52,7 +52,7 @@ Window, -- data Window deriving Eq Border(..), -- data Border touchWin, - newPad, pRefresh, delWin, newWin, wRefresh, wBorder, defaultBorder, + newPad, pRefresh, delWin, newWin, wRefresh, wnoutRefresh, wBorder, defaultBorder, -- * Refresh Routines @@ -86,10 +86,12 @@ bkgrndSet, -- :: Attr -> Pair -> IO () erase, -- :: IO () wclear, -- :: Window -> IO () + werase, clrToEol, -- :: IO () wClrToEol, beep, waddch, + winsch, waddchnstr, -- :: Window -> CString -> CInt -> IO CInt -- * Output Options @@ -199,7 +201,11 @@ import Control.Monad.Trans import Control.Concurrent +#if !MIN_VERSION_base(4,7,0) import Foreign hiding ( unsafePerformIO, void ) +#else +import Foreign hiding ( void ) +#endif import Foreign.C.String import Foreign.C.Types import Foreign.C.Error @@ -273,7 +279,7 @@ type ChType = #type chtype type NBool = #type bool - +{-# NOINLINE stdScr #-} -- -- | The standard screen -- @@ -452,16 +458,26 @@ ------------------------------------------------------------------------ -- --- | get the dimensions of the screen +-- | get the dimensions of the screen (lines,cols) -- scrSize :: IO (Int, Int) +-- Note, per the documentation: +-- http://invisible-island.net/ncurses/ncurses-intro.html#caution +-- It is not recommended to peek at the LINES and COLS global variables. This code +-- was previously doing exactly that, but now it is fixed to use getmaxyx. +-- -Ryan Newton [2013.03.31] scrSize = do - 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 + yfp <- mallocForeignPtr + xfp <- mallocForeignPtr + withForeignPtr yfp $ \yp -> + withForeignPtr xfp $ \xp -> do + getMaxYX stdScr yp xp + y <- peek yp + x <- peek xp + return (fromIntegral y, fromIntegral x) + +foreign import ccall "HSCurses.h getmaxyx_fun" getMaxYX + :: Window -> Ptr CInt -> Ptr CInt -> IO () -- -- | refresh curses windows and lines. curs_refresh(3) @@ -482,7 +498,16 @@ foreign import ccall unsafe "HSCurses.h wrefresh" wrefresh_c :: Window -> IO CInt +-- | Stage an update to a window, but don't actually do the refresh until update is +-- called. This allows multiple windows to be updated together more smoothly. -- +wnoutRefresh :: Window -> IO () +wnoutRefresh w = throwIfErr_ "wnoutrefresh" $ wnoutrefresh_c w + +foreign import ccall safe "HSCurses.h wnoutrefresh" + wnoutrefresh_c :: Window -> IO CInt + +-- -- | Do an actual update. Used after endWin on linux to restore the terminal -- update :: IO () @@ -774,10 +799,16 @@ ------------------------------------------------------------------------ +-- | Raw NCurses routine. foreign import ccall safe waddch :: Window -> ChType -> IO CInt +-- | Raw NCurses routine. foreign import ccall safe + winsch :: Window -> ChType -> IO CInt + +-- | Raw NCurses routine. +foreign import ccall safe waddchnstr :: Window -> CString -> CInt -> IO CInt foreign import ccall safe "static curses.h mvaddch" mvaddch_c :: CInt -> CInt -> ChType -> IO () @@ -891,10 +922,16 @@ foreign import ccall unsafe bkgdset :: ChType -> IO () +-- | Copy blanks to every position in the screen. erase :: IO () erase = throwIfErr_ "erase" $ werase_c stdScr foreign import ccall unsafe "werase" werase_c :: Window -> IO CInt +-- | Copy blanks to every position in a window. +werase :: Window -> IO () +werase w = throwIfErr_ "werase" $ werase_c w + +-- | Copy blanks to a window and set clearOk for that window. wclear :: Window -> IO () wclear w = throwIfErr_ "wclear" $ wclear_c w foreign import ccall unsafe "wclear" wclear_c :: Window -> IO CInt @@ -1456,11 +1493,6 @@ 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. diff --git a/UI/HSCurses/CursesHelper.hs b/UI/HSCurses/CursesHelper.hs --- a/UI/HSCurses/CursesHelper.hs +++ b/UI/HSCurses/CursesHelper.hs @@ -63,11 +63,16 @@ 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 +#if MIN_VERSION_exceptions(0,6,0) +import Control.Monad.Catch (MonadMask, bracket, bracket_) +#else +import Control.Monad.Catch (MonadCatch, bracket, bracket_) +#define MonadMask MonadCatch +#endif import Control.Monad.Trans #ifndef mingw32_HOST_OS @@ -397,12 +402,12 @@ do (_, p) <- Curses.wAttrGet window Curses.wAttrSet window (a, p) -withStyle :: MonadExcIO m => CursesStyle -> m a -> m a +withStyle :: (MonadIO m, MonadMask m) => CursesStyle -> m a -> m a withStyle = wWithStyle Curses.stdScr -wWithStyle :: MonadExcIO m => Curses.Window -> CursesStyle -> m a -> m a +wWithStyle :: (MonadIO m, MonadMask m) => Curses.Window -> CursesStyle -> m a -> m a wWithStyle window style action = - bracketM + bracket (liftIO $ do old <- Curses.wAttrGet window -- before wSetStyle window style return old) @@ -480,13 +485,13 @@ -- -- | set the cursor, and do action -- -withCursor :: MonadExcIO m => CursorVisibility -> m a -> m a +withCursor :: (MonadIO m, MonadMask m) => CursorVisibility -> m a -> m a withCursor nv action = - bracketM + bracket (liftIO $ Curses.cursSet nv) -- before (\vis -> liftIO $ Curses.cursSet vis) -- after (\_ -> action) -- do this -withProgram :: MonadExcIO m => m a -> m a +withProgram :: (MonadIO m, MonadMask m) => m a -> m a withProgram action = withCursor CursorVisible $ - bracketM_ (liftIO endWin) (liftIO flushinp) action + bracket_ (liftIO endWin) (liftIO flushinp) action diff --git a/UI/HSCurses/IConv.hsc b/UI/HSCurses/IConv.hsc --- a/UI/HSCurses/IConv.hsc +++ b/UI/HSCurses/IConv.hsc @@ -41,7 +41,12 @@ import System.IO.Unsafe ( unsafePerformIO ) +#if !MIN_VERSION_base(4,7,0) import Foreign hiding ( unsafePerformIO ) +#else +import Foreign +#endif + import Foreign.C import Control.Exception ( Exception, try, bracket ) diff --git a/UI/HSCurses/Logging.hs b/UI/HSCurses/Logging.hs --- a/UI/HSCurses/Logging.hs +++ b/UI/HSCurses/Logging.hs @@ -20,8 +20,10 @@ import Control.Monad.Trans -#ifdef __DEBUG__ +#define __DEBUG__ 0 +#if __DEBUG__ + import Data.IORef import System.IO import System.IO.Unsafe (unsafePerformIO) @@ -34,7 +36,7 @@ trace :: String -> a -> a debug :: MonadIO m => String -> m () -#ifdef __DEBUG__ +#if __DEBUG__ logFile :: Handle logFile = unsafePerformIO $ do h <- openFile ".hscurses.log" AppendMode diff --git a/UI/HSCurses/MonadException.hs b/UI/HSCurses/MonadException.hs deleted file mode 100644 --- a/UI/HSCurses/MonadException.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} --- Copyright (c) 2005-2011 Stefan Wehr - http://www.stefanwehr.de --- --- This library is free software; you can redistribute it and/or --- modify it under the terms of the GNU Lesser General Public --- License as published by the Free Software Foundation; either --- version 2.1 of the License, or (at your option) any later version. --- --- This library is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- Lesser General Public License for more details. --- --- You should have received a copy of the GNU Lesser General Public --- License along with this library; if not, write to the Free Software --- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA - -module UI.HSCurses.MonadException where - -#if !MIN_VERSION_base(4,6,0) -import Prelude hiding (catch) -#endif - -import Control.Exception -import Control.Monad.State - -class Monad m => MonadExc m where - catchM :: Exception e => m a -> (e -> 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 :: (Exception e, MonadExc m) => - (e -> 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 :: (Exception e, MonadExc m) => (e -> m a) -> m a -> m a -handleM = flip catchM - -handleJustM :: (Exception e,MonadExc m) => - (e -> Maybe b) -> (b -> m a) -> m a -> m a -handleJustM p = flip (catchJustM p) - -tryM :: (Exception e, MonadExc m) => m a -> m (Either e a) -tryM a = catchM (a >>= \ v -> return (Right v)) (\e -> return (Left e)) - -tryJustM :: (Exception e, MonadExc m) => (e -> 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) - -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::SomeException) -> 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::SomeException) -> 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 :: (Exception e, MonadExc m) - => StateT s m a -> (e -> 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)) diff --git a/UI/HSCurses/Widgets.hs b/UI/HSCurses/Widgets.hs --- a/UI/HSCurses/Widgets.hs +++ b/UI/HSCurses/Widgets.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification #-} --- glasgow-exts needed for existentials and multi-parameter type classes. +{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, CPP #-} -- Copyright (c) 2005-2011 Stefan Wehr - http://www.stefanwehr.de -- @@ -20,13 +19,18 @@ module UI.HSCurses.Widgets where import Control.Exception (assert) +#if MIN_VERSION_exceptions(0,6,0) +import Control.Monad.Catch (MonadMask) +#else +import Control.Monad.Catch (MonadCatch) +#define MonadMask MonadCatch +#endif import Control.Monad.Trans import Data.Char import Data.List import Data.Maybe import UI.HSCurses.Logging -import UI.HSCurses.MonadException import qualified UI.HSCurses.Curses as Curses import qualified UI.HSCurses.CursesHelper as CursesH @@ -68,7 +72,8 @@ minSize :: a -> Size class Widget a => ActiveWidget a where - activate :: MonadExcIO m => m () -> Pos -> Size -> a -> m (a, String) + activate :: (MonadIO m, MonadMask m) => m () -> Pos -> Size -> a -> + m (a, String) type KeyHandler a = Pos -> Size -> a -> IO (Cont a) @@ -307,7 +312,7 @@ CursesH.drawLine width (drop (ew_xoffset ew) $ ew_content ew) Curses.refresh -activateEditWidget :: MonadExcIO m => m () -> Pos -> Size +activateEditWidget :: (MonadIO m, MonadMask m) => m () -> Pos -> Size -> EditWidget -> m (EditWidget, String) activateEditWidget refresh pos@(y, x) sz@(_, width) ew = CursesH.withCursor Curses.CursorVisible $ processKey ew @@ -555,7 +560,7 @@ minSize (TableCell w) = minSize w minSize (ActiveTableCell w) = minSize w -_activateTableCell :: MonadExcIO m => m () -> Pos -> Size +_activateTableCell :: (MonadIO m, MonadMask m) => m () -> Pos -> Size -> TableCell -> m (TableCell, String) _activateTableCell _ _ _ (TableCell _) = error "_activateTableCell: cannot activate non-active cell!" @@ -759,7 +764,7 @@ Just (y,x) -> newTbw { tbw_pos = Just (min newLastVis y, x) } -tableWidgetActivateCurrent :: MonadExcIO m => m () -> Pos -> Size +tableWidgetActivateCurrent :: (MonadIO m, MonadMask m) => m () -> Pos -> Size -> DrawingHint -> TableWidget -> m (TableWidget, Maybe String) tableWidgetActivateCurrent refresh (y, x) sz _ tbw = @@ -799,9 +804,9 @@ tableWidgetGoDown = tableWidgetMove DirDown tableWidgetMove :: Direction - -> (Int, Int) - -> TableWidget - -> TableWidget + -> (Int, Int) + -> TableWidget + -> TableWidget tableWidgetMove dir sz tbw = let pos = tbw_pos tbw opts = tbw_options tbw @@ -814,9 +819,9 @@ tableWidgetMakeVisible (tbw {tbw_pos=newP}) sz y tableWidgetMakeVisible :: TableWidget - -> (Int, Int) - -> Int - -> TableWidget + -> (Int, Int) + -> Int + -> TableWidget tableWidgetMakeVisible tbw sz@(_,_) y = let info = tableWidgetDisplayInfo sz tbw firstVis = tbwdisp_firstVis info @@ -850,7 +855,7 @@ Just z -> Just (y, z) vert f = case f rows y cols x of Nothing -> Nothing - Just z -> Just (y, z) + Just z -> Just (z, x) res = case dir of DirLeft-> horiz goLeft DirRight -> horiz goRight diff --git a/cbits/HSCurses.h b/cbits/HSCurses.h --- a/cbits/HSCurses.h +++ b/cbits/HSCurses.h @@ -55,4 +55,9 @@ #undef wattr_get #endif +// Accessing macros from Haskell is problematic, this is a wrapper: +void getmaxyx_fun(WINDOW* win, int* y, int* x) { + getmaxyx(win,(*y),(*x)); +} + #endif // HSCURSES_H diff --git a/example/ContactManager.hs b/example/ContactManager.hs --- a/example/ContactManager.hs +++ b/example/ContactManager.hs @@ -417,6 +417,7 @@ eventloop w = do k <- CursesH.getKey (resize mkMainWidget) + debug ("Got key " ++ show k) case k of Curses.KeyChar 'q' -> return () Curses.KeyChar 'd' -> process $ delete w diff --git a/hscurses.cabal b/hscurses.cabal --- a/hscurses.cabal +++ b/hscurses.cabal @@ -1,5 +1,5 @@ Name: hscurses -Version: 1.4.1.2 +Version: 1.4.2.0 License: LGPL License-file: LICENSE Author: John Meacham @@ -22,7 +22,7 @@ Homepage: https://github.com/skogsbaer/hscurses Cabal-version: >= 1.6 Build-Type: Configure -Tested-with: GHC==7.0.4, GHC==7.2.1, GHC==7.4.2, GHC==7.6.1 +Tested-with: GHC==7.6.1, GHC==7.8 Data-files: README, TODO, ChangeLog, example/contacts2, example/Setup.hs, example/ContactManager.hs, @@ -35,13 +35,13 @@ Location: git://github.com/skogsbaer/hscurses.git Library - Build-depends: base == 4.*, mtl, + Build-depends: base == 4.*, exceptions, mtl, old-time < 1.2, old-locale == 1.0.* if !os(windows) - Build-depends: unix >= 2.4 && < 2.7 + Build-depends: unix >= 2.4 Exposed-modules: UI.HSCurses.Curses, UI.HSCurses.CursesHelper, UI.HSCurses.Widgets, - UI.HSCurses.MonadException, UI.HSCurses.Logging + UI.HSCurses.Logging Other-modules: UI.HSCurses.CWString, UI.HSCurses.IConv C-sources: