diff --git a/lib/UI/NCurses.chs b/lib/UI/NCurses.chs --- a/lib/UI/NCurses.chs +++ b/lib/UI/NCurses.chs @@ -21,6 +21,7 @@ Curses , Update , Window + , CursesException -- * Initialization , runCurses @@ -68,6 +69,7 @@ -- * Colors , Color (..) + , maxColor , ColorID , supportsColor , canDefineColor @@ -134,6 +136,11 @@ , CursorMode(CursorInvisible, CursorVisible, CursorVeryVisible) , setCursorMode + -- * Error handling + , tryCurses + , catchCurses + , throwCurses + -- * misc , setRaw , setCBreak @@ -150,7 +157,7 @@ , resizeTerminal ) where -import Control.Exception (bracket_) +import Control.Exception (bracket_, catch, throwIO, try) import Control.Monad (when, unless) import qualified Control.Monad.Trans.Reader as R import Data.Char (chr, ord) @@ -237,7 +244,7 @@ (fromInteger x) (fromInteger y) if windowPtr win == nullPtr - then error "newWindow: newwin() returned NULL" + then throwIO (CursesException "newWindow: newwin() returned NULL") else do void $ {# call keypad #} win 1 void $ {# call meta #} win 1 @@ -258,7 +265,7 @@ cloneWindow old = Curses $ do win <- {# call dupwin #} old if windowPtr win == nullPtr - then error "cloneWindow: dupwin() returned NULL" + then throwIO (CursesException "cloneWindow: dupwin() returned NULL") else return win -- | Apply a window update to the window. After all of an @@ -310,7 +317,7 @@ (fromInteger rows) (fromInteger cols) if windowPtr win == nullPtr - then error "newPad: newpad() returned NULL" + then throwIO (CursesException "newPad: newpad() returned NULL") else do void $ {# call keypad #} win 1 void $ {# call meta #} win 1 @@ -530,8 +537,26 @@ -- -- This is most useful for terminals with translucent backgrounds. | ColorDefault + + -- | A color outside of the standard COLOR_* enum space, for terminals + -- that support more than eight colors. + -- + -- Color-related functions may fail if a Color is provided that cannot + -- be supported by the current terminal. Users are responsible for + -- checking 'maxColor' when using extended colors. + | Color Int16 deriving (Show, Eq) +-- Get the maximum 'Color' supported by the current terminal. +maxColor :: Curses Integer +maxColor = Curses $ do + count <- toInteger `fmap` peek c_COLORS + return (count - 1) + +foreign import ccall "static &COLORS" + c_COLORS :: Ptr CInt + + -- | A wrapper around 'Integer' to ensure clients don’t use an -- uninitialized color in an attribute. newtype ColorID = ColorID CShort @@ -542,6 +567,7 @@ colorToShort :: Color -> CShort colorToShort x = case x of + Color n -> CShort n ColorBlack -> colorEnum E.COLOR_BLACK ColorRed -> colorEnum E.COLOR_RED ColorGreen -> colorEnum E.COLOR_GREEN @@ -603,9 +629,9 @@ -- (0 < /n/ ≤ 'maxColorID') -> Curses ColorID newColorID fg bg n = Curses $ do - unless (n > 0) $ error "newColorID: n must be > 0" + unless (n > 0) $ throwIO (CursesException "newColorID: n must be > 0") maxColor <- unCurses maxColorID - unless (n <= maxColor) $ error "newColorID: n must be <= maxColorID" + unless (n <= maxColor) $ throwIO (CursesException "newColorID: n must be <= maxColorID") checkRC "newColorID" =<< {# call init_pair #} (fromInteger n) (colorToShort fg) @@ -1118,6 +1144,25 @@ 1 -> CursorVisible 2 -> CursorVeryVisible _ -> CursorModeUnknown rc + +-- | Returns Left if a Curses exception occured in the given computation. +-- +-- See 'try' for more details. +tryCurses :: Curses a -> Curses (Either CursesException a) +tryCurses (Curses io) = Curses (try io) + +-- | Handles errors in the given computation by passing them to a callback. +-- +-- See 'catch' for more details. +catchCurses :: Curses a -> (CursesException -> Curses a) -> Curses a +catchCurses (Curses io) fn = Curses (catch io (unCurses . fn)) + +-- | Throws an exception from within Curses handling code. This is useful +-- for re-throwing errors from within a 'catchCurses' callback. +-- +-- See 'throwIO' for more details. +throwCurses :: CursesException -> Curses a +throwCurses = Curses . throwIO -- | Runs @raw()@ or @noraw()@ setRaw :: Bool -> Curses () diff --git a/lib/UI/NCurses/Panel.chs b/lib/UI/NCurses/Panel.chs --- a/lib/UI/NCurses/Panel.chs +++ b/lib/UI/NCurses/Panel.chs @@ -34,6 +34,7 @@ , replacePanelWindow ) where +import Control.Exception (throwIO) import Foreign import Foreign.C @@ -57,7 +58,7 @@ newPanel win = Curses $ do p <- {# call new_panel #} win if panelPtr p == nullPtr - then error "newPanel: new_panel() returned NULL" + then throwIO (CursesException "newPanel: new_panel() returned NULL") else return p -- | Permanently removes the given panel from the panel stack. diff --git a/lib/UI/NCurses/Types.hs b/lib/UI/NCurses/Types.hs --- a/lib/UI/NCurses/Types.hs +++ b/lib/UI/NCurses/Types.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveDataTypeable #-} + -- Copyright (C) 2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -16,10 +18,12 @@ module UI.NCurses.Types where import qualified Control.Applicative as A +import Control.Exception (Exception, throwIO) import Control.Monad (liftM, ap) import Control.Monad.Fix (MonadFix, mfix) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Reader (ReaderT) +import Data.Typeable import qualified Foreign as F import qualified Foreign.C as F @@ -64,9 +68,14 @@ newtype Window = Window { windowPtr :: F.Ptr Window } +newtype CursesException = CursesException String + deriving (Show, Typeable) + +instance Exception CursesException + checkRC :: String -> F.CInt -> IO () checkRC name rc = if toInteger rc == E.fromEnum E.ERR - then error $ name ++ ": rc == ERR" + then throwIO (CursesException (name ++ ": rc == ERR")) else return () cToBool :: Integral a => a -> Bool diff --git a/ncurses.cabal b/ncurses.cabal --- a/ncurses.cabal +++ b/ncurses.cabal @@ -1,5 +1,5 @@ name: ncurses -version: 0.2.12 +version: 0.2.13 license: GPL-3 license-file: license.txt author: John Millikin @@ -57,7 +57,7 @@ source-repository this type: git location: https://john-millikin.com/code/haskell-ncurses/ - tag: haskell-ncurses_0.2.12 + tag: haskell-ncurses_0.2.13 -- Do not use default to using pkg-config to find ncurses libraries, because -- the .pc files are missing or broken in many installations.