{-# LANGUAGE CPP #-} -- -- Copyright (C) 2005-2011 Stefan Wehr -- -- Derived from: yi/Curses/UI.hs -- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons -- Released under the GPL, granted permission to release this module -- under the LGPL. -- -- Derived from: riot/UI.hs -- Copyright (c) Tuomo Valkonen 2004. -- Released under the GPL, granted permission to release this module -- under the LGPL. -- 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.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, wSetStyle, resetStyle, wResetStyle, convertStyles, defaultStyle, defaultCursesStyle, withStyle, wWithStyle, -- * Keys displayKey, -- * Helpers withCursor, withProgram ) where import UI.HSCurses.Curses hiding ( refresh, Window ) import UI.HSCurses.Logging 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 import System.Posix.Signals #endif -- -- -- -- | @start@ initializes the UI and grabs the keyboard. -- -- This function installs a handler for the SIGWINCH signal -- which writes the KEY_RESIZE key to the input queue (if KEY_RESIZE and -- and SIGWINCH are both available). -- start :: IO () start = do Curses.initCurses -- initialise the screen Curses.resetParams Curses.keypad Curses.stdScr True -- grab the keyboard case (Curses.cursesSigWinch, Curses.keyResizeCode) of #ifndef mingw32_HOST_OS (Just sig, Just key) -> do installHandler sig (Catch $ sigwinch sig key) Nothing return () #endif _ -> debug ("cannot install SIGWINCH handler: signal=" ++ show Curses.cursesSigWinch ++ ", KEY_RESIZE=" ++ show Curses.keyResizeCode) #ifndef mingw32_HOST_OS where sigwinch sig key = do debug "SIGWINCH signal received" Curses.ungetCh key installHandler sig (Catch $ sigwinch sig key) Nothing return () #endif -- -- | 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 () #ifndef mingw32_HOST_OS suspend = raiseSignal sigTSTP #else suspend = return () #endif -- -- | @getKey refresh@ reads a key. -- -- The @refresh@ function is used to redraw the screen when the terminal size -- changes (see the documentatio of @start@ for a discussion of the problem). -- getKey :: MonadIO m => m () -> m Key getKey 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 = wResetStyle Curses.stdScr wResetStyle :: Curses.Window -> IO () wResetStyle = flip wSetStyle defaultCursesStyle -- -- | Manipulate the current style of the standard screen -- setStyle :: CursesStyle -> IO () setStyle = wSetStyle Curses.stdScr wSetStyle :: Curses.Window -> CursesStyle -> IO () wSetStyle window (CursesStyle a p) = Curses.wAttrSet window (a, p) wSetStyle window (ColorlessCursesStyle a) = do (_, p) <- Curses.wAttrGet window Curses.wAttrSet window (a, p) withStyle :: (MonadIO m, MonadMask m) => CursesStyle -> m a -> m a withStyle = wWithStyle Curses.stdScr wWithStyle :: (MonadIO m, MonadMask m) => Curses.Window -> CursesStyle -> m a -> m a wWithStyle window style action = bracket (liftIO $ do old <- Curses.wAttrGet window -- before wSetStyle window style return old) (\old -> liftIO $ Curses.wAttrSet window 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 ' ') = "" displayKey (KeyChar '\t') = "" displayKey (KeyChar '\r') = "" displayKey (KeyChar c) | isPrint c = [c] displayKey (KeyChar c) -- Control | ord '\^A' <= ord c && ord c <= ord '\^Z' = let c' = chr $ ord c - ord '\^A' + ord 'a' in '^':[toUpper c'] displayKey (KeyChar c) = show c displayKey KeyDown = "" displayKey KeyUp = "" displayKey KeyLeft = "" displayKey KeyRight = "" displayKey KeyHome = "" displayKey KeyBackspace = "" displayKey (KeyF i) = 'F' : show i displayKey KeyNPage = "" displayKey KeyPPage = "" displayKey KeyEnter = "" displayKey KeyEnd = "" displayKey KeyIC = "" displayKey KeyDC = "" displayKey k = show k ------------------------------------------------------------------------ -- -- | Other helpers -- -- -- | set the cursor, and do action -- withCursor :: (MonadIO m, MonadMask m) => CursorVisibility -> m a -> m a withCursor nv action = bracket (liftIO $ Curses.cursSet nv) -- before (\vis -> liftIO $ Curses.cursSet vis) -- after (\_ -> action) -- do this withProgram :: (MonadIO m, MonadMask m) => m a -> m a withProgram action = withCursor CursorVisible $ bracket_ (liftIO endWin) (liftIO flushinp) action