module HSCurses.Curses (
stdScr,
initScr,
initCurses,
resetParams,
endWin,
scrSize,
Window,
touchWin,
newPad, pRefresh, delWin, newWin,
refresh,
update,
resizeTerminal,
move,
getYX,
getCh, getch, decodeKey, ungetCh, keyResizeCode,
cBreak,
raw,
echo,
intrFlush,
keypad,
noDelay,
wAddStr,
addLn,
mvWAddStr,
wMove,
bkgrndSet,
erase,
wclear,
clrToEol,
wClrToEol,
beep,
waddch,
clearOk,
leaveOk,
nl,
CursorVisibility(..), cursSet,
hasColors,
startColor,
useDefaultColors,
Pair(..),
colorPairs,
Color(..),
colors,
color,
initPair,
pairContent,
canChangeColor,
initColor,
colorContent,
defaultBackground, defaultForeground,
attrPlus,
Attr,
attr0,
isAltCharset, isBlink, isBold, isDim, isHorizontal, isInvis,
isLeft, isLow, isProtect, isReverse, isRight, isStandout, isTop,
isUnderline, isVertical,
setAltCharset, setBlink, setBold, setDim, setHorizontal, setInvis,
setLeft, setLow, setProtect, setReverse, setRight, setStandout,
setTop, setUnderline, setVertical,
attrSet,
attrOn, attrOff,
standout,standend,
attrDim, attrBold,
attrDimOn, attrDimOff,
attrBoldOn, attrBoldOff,
wAttrOn,
wAttrOff,
wAttrSet, wAttrGet,
withMouseEventMask,
ButtonEvent(..),
MouseEvent(..),
Key(..),
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,
cursesSigWinch,
cursesTest,
throwIfErr, throwIfErr_,
flushinp,
recognize
) where
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
initCurses :: IO ()
initCurses = do
initScr
b <- hasColors
when b $ startColor >> useDefaultColors
resetParams :: IO ()
resetParams = do
raw True
echo False
nl False
intrFlush True
leaveOk False
keypad stdScr True
defineKey (259) "\x1b[1;2A"
defineKey (258) "\x1b[1;2B"
defineKey (393) "\x1b[1;2D"
defineKey (402) "\x1b[1;2C"
fi :: (Integral a, Num b) => a -> b
fi = fromIntegral
throwIfErr :: Num a => String -> IO a -> IO a
throwIfErr s = throwIf (== (1)) (\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
stdScr :: Window
stdScr = unsafePerformIO (peek stdscr)
foreign import ccall "static HSCurses.h &stdscr"
stdscr :: Ptr Window
initScr :: IO Window
initScr = throwIfNull "initscr" initscr
foreign import ccall unsafe "HSCurses.h initscr" initscr :: IO Window
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
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
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
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
intrFlush :: Bool -> IO ()
intrFlush bf =
throwIfErr_ "intrflush" $ intrflush stdScr (if bf then 1 else 0)
foreign import ccall unsafe "HSCurses.h intrflush" intrflush :: Window -> (Word8) -> IO CInt
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 -> (Word8) -> 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 -> (Word8) -> IO CInt
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 -> (Word8) -> 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 -> (Word8) -> 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 ()
endWin :: IO ()
endWin = throwIfErr_ "endwin" endwin
foreign import ccall unsafe "HSCurses.h endwin" endwin :: IO CInt
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 :: IO ()
refresh = throwIfErr_ "refresh" refresh_c
foreign import ccall unsafe "HSCurses.h refresh"
refresh_c :: IO CInt
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 (Word8)
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 :: 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
color :: String -> Maybe Color
color "default" = Just $ Color (1)
color "black" = Just $ Color (0)
color "red" = Just $ Color (1)
color "green" = Just $ Color (2)
color "yellow" = Just $ Color (3)
color "blue" = Just $ Color (4)
color "magenta" = Just $ Color (5)
color "cyan" = Just $ Color (6)
color "white" = Just $ Color (7)
color _ = Nothing
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 (Word8)
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 -> (Word32)
foreign import ccall unsafe "HSCurses.h attr_set"
attr_set :: 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 :: (Word32) -> Ptr a -> IO Int
foreign import ccall "HSCurses.h attr_off" attr_off :: (Word32) -> 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
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 (Word32) deriving (Eq,Storable,Bits, Num, Show)
attr0 :: Attr
attr0 = Attr (0)
isAltCharset, isBlink, isBold, isDim, isHorizontal, isInvis, isLeft,
isLow, isProtect, isReverse, isRight, isStandout, isTop,
isUnderline, isVertical :: Attr -> Bool
isAltCharset = isAttr (4194304)
isBlink = isAttr (524288)
isBold = isAttr (2097152)
isDim = isAttr (1048576)
isHorizontal = isAttr (33554432)
isInvis = isAttr (8388608)
isLeft = isAttr (67108864)
isLow = isAttr (134217728)
isProtect = isAttr (16777216)
isReverse = isAttr (262144)
isRight = isAttr (268435456)
isStandout = isAttr (65536)
isTop = isAttr (536870912)
isUnderline = isAttr (131072)
isVertical = isAttr (1073741824)
isAttr :: (Word32) -> Attr -> Bool
isAttr b (Attr a) = a .&. b /= 0
setAltCharset, setBlink, setBold, setDim, setHorizontal, setInvis,
setLeft, setLow, setProtect, setReverse, setRight, setStandout,
setTop, setUnderline, setVertical :: Attr -> Bool -> Attr
setAltCharset = setAttr (4194304)
setBlink = setAttr (524288)
setBold = setAttr (2097152)
setDim = setAttr (1048576)
setHorizontal = setAttr (33554432)
setInvis = setAttr (8388608)
setLeft = setAttr (67108864)
setLow = setAttr (134217728)
setProtect = setAttr (16777216)
setReverse = setAttr (262144)
setRight = setAttr (268435456)
setStandout = setAttr (65536)
setTop = setAttr (536870912)
setUnderline = setAttr (131072)
setVertical = setAttr (1073741824)
setAttr :: (Word32) -> 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 (1048576)
attrDimOff :: IO ()
attrDimOff = throwIfErr_ "attroff A_DIM" $
attroff (1048576)
attrBoldOn :: IO ()
attrBoldOn = throwIfErr_ "attron A_BOLD" $
attron (2097152)
attrBoldOff :: IO ()
attrBoldOff = throwIfErr_ "attroff A_BOLD" $
attroff (2097152)
attrDim :: Int
attrDim = (1048576)
attrBold :: Int
attrBold = (2097152)
mvWAddStr :: Window -> Int -> Int -> String -> IO ()
mvWAddStr w y x str = wMove w y x >> wAddStr w str
addLn :: IO ()
addLn = wAddStr stdScr "\n"
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 -> (Word32) -> IO CInt
foreign import ccall threadsafe
waddchnstr :: Window -> CString -> CInt -> IO CInt
foreign import ccall threadsafe
vline :: Char -> Int -> IO ()
bkgrndSet :: Attr -> Pair -> IO ()
bkgrndSet (Attr a) p = bkgdset $
fromIntegral (ord ' ') .|.
(if a .&. 4194304 /= 0 then 4194304 else 0) .|.
(if a .&. 524288 /= 0 then 524288 else 0) .|.
(if a .&. 2097152 /= 0 then 2097152 else 0) .|.
(if a .&. 1048576 /= 0 then 1048576 else 0) .|.
(if a .&. 8388608 /= 0 then 8388608 else 0) .|.
(if a .&. 16777216 /= 0 then 16777216 else 0) .|.
(if a .&. 262144 /= 0 then 262144 else 0) .|.
(if a .&. 65536 /= 0 then 65536 else 0) .|.
(if a .&. 131072 /= 0 then 131072 else 0) .|.
colorPair p
foreign import ccall unsafe bkgdset :: (Word32) -> 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 :: 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
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
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)
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
getYX :: Window -> IO (Int, Int)
getYX w =
alloca $ \py ->
alloca $ \px -> do
nomacro_getyx w py px
y <- peek py
x <- peek px
return (fromIntegral y, fromIntegral 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
foreign import ccall unsafe getch :: 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 /= (0)) (c_flash >> return ())
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))
(257) -> KeyBreak
(258) -> KeyDown
(259) -> KeyUp
(260) -> KeyLeft
(261) -> KeyRight
(262) -> KeyHome
(263) -> KeyBackspace
_ | key >= (264) && key <= (327)
-> KeyF (fromIntegral (key 264))
(328) -> KeyDL
(329) -> KeyIL
(330) -> KeyDC
(331) -> KeyIC
(332) -> KeyEIC
(333) -> KeyClear
(334) -> KeyEOS
(335) -> KeyEOL
(336) -> KeySF
(337) -> KeySR
(338) -> KeyNPage
(339) -> KeyPPage
(340) -> KeySTab
(341) -> KeyCTab
(342) -> KeyCATab
(343) -> KeyEnter
(344) -> KeySReset
(345) -> KeyReset
(346) -> KeyPrint
(347) -> KeyLL
(348) -> KeyA1
(349) -> KeyA3
(350) -> KeyB2
(351) -> KeyC1
(352) -> KeyC3
(353) -> KeyBTab
(354) -> KeyBeg
(355) -> KeyCancel
(356) -> KeyClose
(357) -> KeyCommand
(358) -> KeyCopy
(359) -> KeyCreate
(360) -> KeyEnd
(361) -> KeyExit
(362) -> KeyFind
(363) -> KeyHelp
(364) -> KeyMark
(365) -> KeyMessage
(366) -> KeyMove
(367) -> KeyNext
(368) -> KeyOpen
(369) -> KeyOptions
(370) -> KeyPrevious
(371) -> KeyRedo
(372) -> KeyReference
(373) -> KeyRefresh
(374) -> KeyReplace
(375) -> KeyRestart
(376) -> KeyResume
(377) -> KeySave
(378) -> KeySBeg
(379) -> KeySCancel
(380) -> KeySCommand
(381) -> KeySCopy
(382) -> KeySCreate
(383) -> KeySDC
(384) -> KeySDL
(385) -> KeySelect
(386) -> KeySEnd
(387) -> KeySEOL
(388) -> KeySExit
(389) -> KeySFind
(390) -> KeySHelp
(391) -> KeySHome
(392) -> KeySIC
(393) -> KeySLeft
(394) -> KeySMessage
(395) -> KeySMove
(396) -> KeySNext
(397) -> KeySOptions
(398) -> KeySPrevious
(399) -> KeySPrint
(400) -> KeySRedo
(401) -> KeySReplace
(402) -> KeySRight
(403) -> KeySRsume
(404) -> KeySSave
(405) -> KeySSuspend
(406) -> KeySUndo
(407) -> KeySuspend
(408) -> KeyUndo
(410) -> KeyResize
(409) -> KeyMouse
_ -> KeyUnknown (fromIntegral key)
keyResizeCode :: Maybe CInt
keyResizeCode = Just (410)
ungetCh i =
do debug "ungetCh called"
writeChan inputBuf (BufDirect (fi i))
data BufData = BufDirect CInt
| DataViaGetch
inputBuf :: Chan BufData
inputBuf = unsafePerformIO newChan
getchToInputBuf :: IO ()
getchToInputBuf =
do threadWaitRead (fi 0)
debug "now input available on stdin"
writeChan inputBuf DataViaGetch
getCh :: IO Key
getCh =
do debug "getCh called"
tid <- forkIO getchToInputBuf
d <- readChan inputBuf
killThread tid
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
case v of
(1) ->
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 ()
resizeTerminal _ _ = return ()
cursesSigWinch :: Maybe Signal
cursesSigWinch = Just (28)
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
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
foreign import ccall unsafe "HSCurses.h mousemask"
mousemask :: (Word32) -> Ptr (Word32) -> IO (Word32)
withMouseEventMask bes action = do
ov <- liftIO $ alloca (\a -> mousemask (besToMouseMask bes) a >> peek a)
r <- action
liftIO $ mousemask ov nullPtr
return r
besToMouseMask :: [ButtonEvent] -> (Word32)
besToMouseMask bes = foldl' (.|.) 0 (map cb bes) where
cb (ButtonPressed 1) = (2)
cb (ButtonPressed 2) = (128)
cb (ButtonPressed 3) = (8192)
cb (ButtonPressed 4) = (524288)
cb (ButtonReleased 1) = (1)
cb (ButtonReleased 2) = (64)
cb (ButtonReleased 3) = (4096)
cb (ButtonReleased 4) = (262144)
cb (ButtonClicked 1) = (4)
cb (ButtonClicked 2) = (256)
cb (ButtonClicked 3) = (16384)
cb (ButtonClicked 4) = (1048576)
cb ButtonShift = (33554432)
cb ButtonAlt = (67108864)
cb ButtonControl = (16777216)
cb _ = 0
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
s9 = chr 0x23BD
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
s7 = chr 0x23BC
lEqual = chr 0x2264
gEqual = chr 0x2265
pi = chr 0x03C0
nEqual = chr 0x2260
sterling = chr 0x00A3
recognize :: Char -> IO a -> ((Word32) -> IO a) -> IO a
recognize _ch noConvert _convert = noConvert