module UI.HSCurses.CursesHelper (
start, end, suspend, resizeui,
getKey,
drawLine, drawCursor,
gotoTop,
ForegroundColor(..), BackgroundColor(..),
defaultColor, black, red, green, yellow, blue, magenta, cyan, white,
Attribute(..), convertAttributes,
Style(..), CursesStyle, mkCursesStyle, changeCursesStyle,
setStyle, resetStyle, convertStyles,
defaultStyle, defaultCursesStyle, withStyle,
displayKey,
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
#ifndef mingw32_HOST_OS
import System.Posix.Signals
#endif
start :: IO ()
start = do
Curses.initCurses
Curses.resetParams
Curses.keypad Curses.stdScr True
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
end :: IO ()
end = do Curses.endWin
#if NCURSES_UPDATE_AFTER_END
Curses.update
#endif
suspend :: IO ()
#ifndef mingw32_HOST_OS
suspend = raiseSignal sigTSTP
#else
suspend = return ()
#endif
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 :: Int -> String -> IO ()
drawLine w s = Curses.wAddStr Curses.stdScr $! take w (s ++ repeat ' ')
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 (h1) (o_y + y)) (min (w1) (o_x + x))
gotoTop :: IO ()
gotoTop = Curses.wMove Curses.stdScr 0 0
resizeui :: IO (Int,Int)
resizeui = do
Curses.endWin
Curses.refresh
Curses.scrSize
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"
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
data ForegroundColor
= BlackF
| GreyF
| DarkRedF
| RedF
| DarkGreenF
| GreenF
| BrownF
| YellowF
| DarkBlueF
| BlueF
| PurpleF
| MagentaF
| DarkCyanF
| CyanF
| WhiteF
| BrightWhiteF
| DefaultF
deriving (Eq, Show)
data BackgroundColor
= BlackB
| DarkRedB
| DarkGreenB
| BrownB
| DarkBlueB
| PurpleB
| DarkCyanB
| WhiteB
| DefaultB
deriving (Eq, Show)
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)
data Attribute = Bold
| Underline
| Dim
| Reverse
| Blink
deriving (Eq, Show)
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
data Style = Style ForegroundColor BackgroundColor
| AttributeStyle [Attribute] ForegroundColor BackgroundColor
| ColorlessStyle [Attribute]
deriving (Eq, Show)
defaultStyle :: Style
defaultStyle = Style DefaultF DefaultB
data CursesStyle = CursesStyle Curses.Attr Curses.Pair
| ColorlessCursesStyle Curses.Attr
deriving (Eq, Show)
mkCursesStyle :: [Attribute] -> CursesStyle
mkCursesStyle attrs = ColorlessCursesStyle (convertAttributes attrs)
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)
resetStyle :: IO ()
resetStyle = setStyle defaultCursesStyle
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
setStyle style
return old)
(\old -> liftIO $ Curses.wAttrSet Curses.stdScr old)
(\_ -> action)
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
displayKey :: Key -> String
displayKey (KeyChar ' ') = "<Space>"
displayKey (KeyChar '\t') = "<Tab>"
displayKey (KeyChar '\r') = "<Enter>"
displayKey (KeyChar c)
| isPrint c = [c]
displayKey (KeyChar c)
| 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
withCursor :: MonadExcIO m => CursorVisibility -> m a -> m a
withCursor nv action =
bracketM
(liftIO $ Curses.cursSet nv)
(\vis -> liftIO $ Curses.cursSet vis)
(\_ -> action)
withProgram :: MonadExcIO m => m a -> m a
withProgram action = withCursor CursorVisible $
bracketM_ (liftIO endWin) (liftIO flushinp) action