{-# LANGUAGE CPP #-}
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,
wSetStyle,
resetStyle,
wResetStyle,
convertStyles,
defaultStyle,
defaultCursesStyle,
withStyle,
wWithStyle,
displayKey,
withCursor,
withProgram,
) where
import UI.HSCurses.Curses as Curses
import UI.HSCurses.Logging
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
import Control.Monad.Trans
#ifndef mingw32_HOST_OS
import System.Posix.Signals
#endif
start :: IO ()
start :: IO ()
start = do
IO ()
Curses.initCurses
IO ()
Curses.resetParams
Window -> Bool -> IO ()
Curses.keypad Window
Curses.stdScr Bool
True
case (Maybe CInt
Curses.cursesSigWinch, Maybe CInt
Curses.keyResizeCode) of
#ifndef mingw32_HOST_OS
(Just CInt
sig, Just CInt
key) ->
IO Handler -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Handler -> IO ()) -> IO Handler -> IO ()
forall a b. (a -> b) -> a -> b
$ CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
sig (IO () -> Handler
Catch (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ CInt -> CInt -> IO ()
forall {t}. Integral t => CInt -> t -> IO ()
sigwinch CInt
sig CInt
key) Maybe SignalSet
forall a. Maybe a
Nothing
#endif
(Maybe CInt, Maybe CInt)
_ ->
String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"cannot install SIGWINCH handler: signal="
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe CInt -> String
forall a. Show a => a -> String
show Maybe CInt
Curses.cursesSigWinch
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", KEY_RESIZE="
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe CInt -> String
forall a. Show a => a -> String
show Maybe CInt
Curses.keyResizeCode
#ifndef mingw32_HOST_OS
where
sigwinch :: CInt -> t -> IO ()
sigwinch CInt
sig t
key = do
String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug String
"SIGWINCH signal received"
t -> IO ()
forall a. Integral a => a -> IO ()
Curses.ungetCh t
key
IO Handler -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Handler -> IO ()) -> IO Handler -> IO ()
forall a b. (a -> b) -> a -> b
$ CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
sig (IO () -> Handler
Catch (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ CInt -> t -> IO ()
sigwinch CInt
sig t
key) Maybe SignalSet
forall a. Maybe a
Nothing
#endif
end :: IO ()
end :: IO ()
end = do Curses.endWin
#if NCURSES_UPDATE_AFTER_END
Curses.update
#endif
suspend :: IO ()
#ifndef mingw32_HOST_OS
suspend :: IO ()
suspend = CInt -> IO ()
raiseSignal CInt
sigTSTP
#else
suspend = return ()
#endif
getKey :: (MonadIO m) => m () -> m Key
getKey :: forall (m :: * -> *). MonadIO m => m () -> m Key
getKey m ()
refresh = do
k <- IO Key -> m Key
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Key -> m Key) -> IO Key -> m Key
forall a b. (a -> b) -> a -> b
$ IO Key
Curses.getCh
debug ("getKey: " ++ show k)
case k of
Key
KeyResize ->
do
m ()
refresh
m () -> m Key
forall (m :: * -> *). MonadIO m => m () -> m Key
getKey m ()
refresh
Key
_ -> Key -> m Key
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Key
k
drawLine :: Int -> String -> IO ()
drawLine :: Int -> String -> IO ()
drawLine Int
w String
s = Window -> String -> IO ()
Curses.wAddStr Window
Curses.stdScr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$! Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
w (String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. a -> [a]
repeat Char
' ')
drawCursor :: (Int, Int) -> (Int, Int) -> IO ()
drawCursor :: (Int, Int) -> (Int, Int) -> IO ()
drawCursor (Int
o_y, Int
o_x) (Int
y, Int
x) = CursorVisibility -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
CursorVisibility -> m a -> m a
withCursor CursorVisibility
Curses.CursorVisible (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
IO ()
gotoTop
(h, w) <- IO (Int, Int)
scrSize
Curses.wMove Curses.stdScr (min (h - 1) (o_y + y)) (min (w - 1) (o_x + x))
gotoTop :: IO ()
gotoTop :: IO ()
gotoTop = Window -> Int -> Int -> IO ()
Curses.wMove Window
Curses.stdScr Int
0 Int
0
resizeui :: IO (Int, Int)
resizeui :: IO (Int, Int)
resizeui = do
IO ()
Curses.endWin
IO ()
Curses.refresh
IO (Int, Int)
Curses.scrSize
defaultColor :: Curses.Color
defaultColor :: Color
defaultColor = Maybe Color -> Color
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Color -> Color) -> Maybe Color -> Color
forall a b. (a -> b) -> a -> b
$ String -> Maybe Color
Curses.color String
"default"
black, red, green, yellow, blue, magenta, cyan, white :: Curses.Color
black :: Color
black = Maybe Color -> Color
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Color -> Color) -> Maybe Color -> Color
forall a b. (a -> b) -> a -> b
$ String -> Maybe Color
Curses.color String
"black"
red :: Color
red = Maybe Color -> Color
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Color -> Color) -> Maybe Color -> Color
forall a b. (a -> b) -> a -> b
$ String -> Maybe Color
Curses.color String
"red"
green :: Color
green = Maybe Color -> Color
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Color -> Color) -> Maybe Color -> Color
forall a b. (a -> b) -> a -> b
$ String -> Maybe Color
Curses.color String
"green"
yellow :: Color
yellow = Maybe Color -> Color
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Color -> Color) -> Maybe Color -> Color
forall a b. (a -> b) -> a -> b
$ String -> Maybe Color
Curses.color String
"yellow"
blue :: Color
blue = Maybe Color -> Color
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Color -> Color) -> Maybe Color -> Color
forall a b. (a -> b) -> a -> b
$ String -> Maybe Color
Curses.color String
"blue"
magenta :: Color
magenta = Maybe Color -> Color
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Color -> Color) -> Maybe Color -> Color
forall a b. (a -> b) -> a -> b
$ String -> Maybe Color
Curses.color String
"magenta"
cyan :: Color
cyan = Maybe Color -> Color
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Color -> Color) -> Maybe Color -> Color
forall a b. (a -> b) -> a -> b
$ String -> Maybe Color
Curses.color String
"cyan"
white :: Color
white = Maybe Color -> Color
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Color -> Color) -> Maybe Color -> Color
forall a b. (a -> b) -> a -> b
$ String -> Maybe Color
Curses.color String
"white"
colorsToPairs :: [(Curses.Color, Curses.Color)] -> IO [Curses.Pair]
colorsToPairs :: [(Color, Color)] -> IO [Pair]
colorsToPairs [(Color, Color)]
cs = do
p <- IO Int
Curses.colorPairs
let nColors = [(Color, Color)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Color, Color)]
cs
blackWhite = Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
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 :: (Int, (Color, Color)) -> IO Pair
toPairs (Int
n, (Color
fg, Color
bg)) =
let p :: Pair
p = Int -> Pair
Curses.Pair Int
n
in do
Pair -> Color -> Color -> IO ()
Curses.initPair Pair
p Color
fg Color
bg
Pair -> IO Pair
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Pair
p
data ForegroundColor
= BlackF
| GreyF
| DarkRedF
| RedF
| DarkGreenF
| GreenF
| BrownF
| YellowF
| DarkBlueF
| BlueF
| PurpleF
| MagentaF
| DarkCyanF
| CyanF
| WhiteF
| BrightWhiteF
| DefaultF
deriving (ForegroundColor -> ForegroundColor -> Bool
(ForegroundColor -> ForegroundColor -> Bool)
-> (ForegroundColor -> ForegroundColor -> Bool)
-> Eq ForegroundColor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ForegroundColor -> ForegroundColor -> Bool
== :: ForegroundColor -> ForegroundColor -> Bool
$c/= :: ForegroundColor -> ForegroundColor -> Bool
/= :: ForegroundColor -> ForegroundColor -> Bool
Eq, Int -> ForegroundColor -> String -> String
[ForegroundColor] -> String -> String
ForegroundColor -> String
(Int -> ForegroundColor -> String -> String)
-> (ForegroundColor -> String)
-> ([ForegroundColor] -> String -> String)
-> Show ForegroundColor
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ForegroundColor -> String -> String
showsPrec :: Int -> ForegroundColor -> String -> String
$cshow :: ForegroundColor -> String
show :: ForegroundColor -> String
$cshowList :: [ForegroundColor] -> String -> String
showList :: [ForegroundColor] -> String -> String
Show)
data BackgroundColor
= BlackB
| DarkRedB
| DarkGreenB
| BrownB
| DarkBlueB
| PurpleB
| DarkCyanB
| WhiteB
| DefaultB
deriving (BackgroundColor -> BackgroundColor -> Bool
(BackgroundColor -> BackgroundColor -> Bool)
-> (BackgroundColor -> BackgroundColor -> Bool)
-> Eq BackgroundColor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BackgroundColor -> BackgroundColor -> Bool
== :: BackgroundColor -> BackgroundColor -> Bool
$c/= :: BackgroundColor -> BackgroundColor -> Bool
/= :: BackgroundColor -> BackgroundColor -> Bool
Eq, Int -> BackgroundColor -> String -> String
[BackgroundColor] -> String -> String
BackgroundColor -> String
(Int -> BackgroundColor -> String -> String)
-> (BackgroundColor -> String)
-> ([BackgroundColor] -> String -> String)
-> Show BackgroundColor
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> BackgroundColor -> String -> String
showsPrec :: Int -> BackgroundColor -> String -> String
$cshow :: BackgroundColor -> String
show :: BackgroundColor -> String
$cshowList :: [BackgroundColor] -> String -> String
showList :: [BackgroundColor] -> String -> String
Show)
convertBg :: BackgroundColor -> ([Attribute], Curses.Color)
convertBg :: BackgroundColor -> ([Attribute], Color)
convertBg BackgroundColor
c = case BackgroundColor
c of
BackgroundColor
BlackB -> ([], Color
black)
BackgroundColor
DarkRedB -> ([], Color
red)
BackgroundColor
DarkGreenB -> ([], Color
green)
BackgroundColor
BrownB -> ([], Color
yellow)
BackgroundColor
DarkBlueB -> ([], Color
blue)
BackgroundColor
PurpleB -> ([], Color
magenta)
BackgroundColor
DarkCyanB -> ([], Color
cyan)
BackgroundColor
WhiteB -> ([], Color
white)
BackgroundColor
DefaultB -> ([], Color
defaultColor)
convertFg :: ForegroundColor -> ([Attribute], Curses.Color)
convertFg :: ForegroundColor -> ([Attribute], Color)
convertFg ForegroundColor
c = case ForegroundColor
c of
ForegroundColor
BlackF -> ([], Color
black)
ForegroundColor
GreyF -> ([Attribute
Bold], Color
black)
ForegroundColor
DarkRedF -> ([], Color
red)
ForegroundColor
RedF -> ([Attribute
Bold], Color
red)
ForegroundColor
DarkGreenF -> ([], Color
green)
ForegroundColor
GreenF -> ([Attribute
Bold], Color
green)
ForegroundColor
BrownF -> ([], Color
yellow)
ForegroundColor
YellowF -> ([Attribute
Bold], Color
yellow)
ForegroundColor
DarkBlueF -> ([], Color
blue)
ForegroundColor
BlueF -> ([Attribute
Bold], Color
blue)
ForegroundColor
PurpleF -> ([], Color
magenta)
ForegroundColor
MagentaF -> ([Attribute
Bold], Color
magenta)
ForegroundColor
DarkCyanF -> ([], Color
cyan)
ForegroundColor
CyanF -> ([Attribute
Bold], Color
cyan)
ForegroundColor
WhiteF -> ([], Color
white)
ForegroundColor
BrightWhiteF -> ([Attribute
Bold], Color
white)
ForegroundColor
DefaultF -> ([], Color
defaultColor)
data Attribute
= Bold
| Underline
| Dim
| Reverse
| Blink
deriving (Attribute -> Attribute -> Bool
(Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool) -> Eq Attribute
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Attribute -> Attribute -> Bool
== :: Attribute -> Attribute -> Bool
$c/= :: Attribute -> Attribute -> Bool
/= :: Attribute -> Attribute -> Bool
Eq, Int -> Attribute -> String -> String
[Attribute] -> String -> String
Attribute -> String
(Int -> Attribute -> String -> String)
-> (Attribute -> String)
-> ([Attribute] -> String -> String)
-> Show Attribute
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Attribute -> String -> String
showsPrec :: Int -> Attribute -> String -> String
$cshow :: Attribute -> String
show :: Attribute -> String
$cshowList :: [Attribute] -> String -> String
showList :: [Attribute] -> String -> String
Show)
convertAttributes :: [Attribute] -> Curses.Attr
convertAttributes :: [Attribute] -> Attr
convertAttributes =
(Attribute -> Attr -> Attr) -> Attr -> [Attribute] -> Attr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Attribute -> Attr -> Attr
setAttrs Attr
Curses.attr0
where
setAttrs :: Attribute -> Attr -> Attr
setAttrs Attribute
Bold = Attr -> Attr
setBoldA
setAttrs Attribute
Underline = Attr -> Attr
setUnderlineA
setAttrs Attribute
Dim = Attr -> Attr
setDimA
setAttrs Attribute
Reverse = Attr -> Attr
setReverseA
setAttrs Attribute
Blink = Attr -> Attr
setBlinkA
setBoldA
, setUnderlineA
, setDimA
, setReverseA
, setBlinkA ::
Curses.Attr -> Curses.Attr
setBoldA :: Attr -> Attr
setBoldA = (Attr -> Bool -> Attr) -> Bool -> Attr -> Attr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Attr -> Bool -> Attr
Curses.setBold Bool
True
setUnderlineA :: Attr -> Attr
setUnderlineA = (Attr -> Bool -> Attr) -> Bool -> Attr -> Attr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Attr -> Bool -> Attr
Curses.setUnderline Bool
True
setDimA :: Attr -> Attr
setDimA = (Attr -> Bool -> Attr) -> Bool -> Attr -> Attr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Attr -> Bool -> Attr
Curses.setDim Bool
True
setReverseA :: Attr -> Attr
setReverseA = (Attr -> Bool -> Attr) -> Bool -> Attr -> Attr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Attr -> Bool -> Attr
Curses.setReverse Bool
True
setBlinkA :: Attr -> Attr
setBlinkA = (Attr -> Bool -> Attr) -> Bool -> Attr -> Attr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Attr -> Bool -> Attr
Curses.setBlink Bool
True
data Style
= Style ForegroundColor BackgroundColor
| AttributeStyle [Attribute] ForegroundColor BackgroundColor
| ColorlessStyle [Attribute]
deriving (Style -> Style -> Bool
(Style -> Style -> Bool) -> (Style -> Style -> Bool) -> Eq Style
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Style -> Style -> Bool
== :: Style -> Style -> Bool
$c/= :: Style -> Style -> Bool
/= :: Style -> Style -> Bool
Eq, Int -> Style -> String -> String
[Style] -> String -> String
Style -> String
(Int -> Style -> String -> String)
-> (Style -> String) -> ([Style] -> String -> String) -> Show Style
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Style -> String -> String
showsPrec :: Int -> Style -> String -> String
$cshow :: Style -> String
show :: Style -> String
$cshowList :: [Style] -> String -> String
showList :: [Style] -> String -> String
Show)
defaultStyle :: Style
defaultStyle :: Style
defaultStyle = ForegroundColor -> BackgroundColor -> Style
Style ForegroundColor
DefaultF BackgroundColor
DefaultB
data CursesStyle
= CursesStyle Curses.Attr Curses.Pair
| ColorlessCursesStyle Curses.Attr
deriving (CursesStyle -> CursesStyle -> Bool
(CursesStyle -> CursesStyle -> Bool)
-> (CursesStyle -> CursesStyle -> Bool) -> Eq CursesStyle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CursesStyle -> CursesStyle -> Bool
== :: CursesStyle -> CursesStyle -> Bool
$c/= :: CursesStyle -> CursesStyle -> Bool
/= :: CursesStyle -> CursesStyle -> Bool
Eq, Int -> CursesStyle -> String -> String
[CursesStyle] -> String -> String
CursesStyle -> String
(Int -> CursesStyle -> String -> String)
-> (CursesStyle -> String)
-> ([CursesStyle] -> String -> String)
-> Show CursesStyle
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> CursesStyle -> String -> String
showsPrec :: Int -> CursesStyle -> String -> String
$cshow :: CursesStyle -> String
show :: CursesStyle -> String
$cshowList :: [CursesStyle] -> String -> String
showList :: [CursesStyle] -> String -> String
Show)
mkCursesStyle :: [Attribute] -> CursesStyle
mkCursesStyle :: [Attribute] -> CursesStyle
mkCursesStyle [Attribute]
attrs = Attr -> CursesStyle
ColorlessCursesStyle ([Attribute] -> Attr
convertAttributes [Attribute]
attrs)
changeCursesStyle :: CursesStyle -> [Attribute] -> CursesStyle
changeCursesStyle :: CursesStyle -> [Attribute] -> CursesStyle
changeCursesStyle (CursesStyle Attr
_ Pair
p) [Attribute]
attrs =
Attr -> Pair -> CursesStyle
CursesStyle ([Attribute] -> Attr
convertAttributes [Attribute]
attrs) Pair
p
changeCursesStyle CursesStyle
_ [Attribute]
attrs = Attr -> CursesStyle
ColorlessCursesStyle ([Attribute] -> Attr
convertAttributes [Attribute]
attrs)
defaultCursesStyle :: CursesStyle
defaultCursesStyle :: CursesStyle
defaultCursesStyle = Attr -> Pair -> CursesStyle
CursesStyle Attr
Curses.attr0 (Int -> Pair
Curses.Pair Int
0)
resetStyle :: IO ()
resetStyle :: IO ()
resetStyle = Window -> IO ()
wResetStyle Window
Curses.stdScr
wResetStyle :: Curses.Window -> IO ()
wResetStyle :: Window -> IO ()
wResetStyle = (Window -> CursesStyle -> IO ()) -> CursesStyle -> Window -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Window -> CursesStyle -> IO ()
wSetStyle CursesStyle
defaultCursesStyle
setStyle :: CursesStyle -> IO ()
setStyle :: CursesStyle -> IO ()
setStyle = Window -> CursesStyle -> IO ()
wSetStyle Window
Curses.stdScr
wSetStyle :: Curses.Window -> CursesStyle -> IO ()
wSetStyle :: Window -> CursesStyle -> IO ()
wSetStyle Window
window (CursesStyle Attr
a Pair
p) = Window -> (Attr, Pair) -> IO ()
Curses.wAttrSet Window
window (Attr
a, Pair
p)
wSetStyle Window
window (ColorlessCursesStyle Attr
a) = do
(_, p) <- Window -> IO (Attr, Pair)
Curses.wAttrGet Window
window
Curses.wAttrSet window (a, p)
withStyle :: (MonadIO m, MonadMask m) => CursesStyle -> m a -> m a
withStyle :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
CursesStyle -> m a -> m a
withStyle = Window -> CursesStyle -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Window -> CursesStyle -> m a -> m a
wWithStyle Window
Curses.stdScr
wWithStyle :: (MonadIO m, MonadMask m) => Curses.Window -> CursesStyle -> m a -> m a
wWithStyle :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Window -> CursesStyle -> m a -> m a
wWithStyle Window
window CursesStyle
style m a
action =
m (Attr, Pair)
-> ((Attr, Pair) -> m ()) -> ((Attr, Pair) -> m a) -> m a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket
( IO (Attr, Pair) -> m (Attr, Pair)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Attr, Pair) -> m (Attr, Pair))
-> IO (Attr, Pair) -> m (Attr, Pair)
forall a b. (a -> b) -> a -> b
$ do
old <- Window -> IO (Attr, Pair)
Curses.wAttrGet Window
window
wSetStyle window style
return old
)
(\(Attr, Pair)
old -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Window -> (Attr, Pair) -> IO ()
Curses.wAttrSet Window
window (Attr, Pair)
old)
(\(Attr, Pair)
_ -> m a
action)
convertStyles :: [Style] -> IO [CursesStyle]
convertStyles :: [Style] -> IO [CursesStyle]
convertStyles [Style]
styleList = do
let ([[Attribute]]
attrs, [Maybe (Color, Color)]
cs) = [([Attribute], Maybe (Color, Color))]
-> ([[Attribute]], [Maybe (Color, Color)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([Attribute], Maybe (Color, Color))]
-> ([[Attribute]], [Maybe (Color, Color)]))
-> [([Attribute], Maybe (Color, Color))]
-> ([[Attribute]], [Maybe (Color, Color)])
forall a b. (a -> b) -> a -> b
$ (Style -> ([Attribute], Maybe (Color, Color)))
-> [Style] -> [([Attribute], Maybe (Color, Color))]
forall a b. (a -> b) -> [a] -> [b]
map Style -> ([Attribute], Maybe (Color, Color))
convertStyle [Style]
styleList
cursesAttrs :: [Attr]
cursesAttrs = ([Attribute] -> Attr) -> [[Attribute]] -> [Attr]
forall a b. (a -> b) -> [a] -> [b]
map [Attribute] -> Attr
convertAttributes [[Attribute]]
attrs
cursesPairs <- [Maybe (Color, Color)] -> IO [Maybe Pair]
colorsToPairs' [Maybe (Color, Color)]
cs
let res = (Attr -> Maybe Pair -> CursesStyle)
-> [Attr] -> [Maybe Pair] -> [CursesStyle]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Attr -> Maybe Pair -> CursesStyle
toCursesStyle [Attr]
cursesAttrs [Maybe Pair]
cursesPairs
trace ("convertStyles: " ++ show (zip styleList res)) (return res)
where
convertStyle :: Style -> ([Attribute], Maybe (Color, Color))
convertStyle (Style ForegroundColor
fg BackgroundColor
bg) = Style -> ([Attribute], Maybe (Color, Color))
convertStyle ([Attribute] -> ForegroundColor -> BackgroundColor -> Style
AttributeStyle [] ForegroundColor
fg BackgroundColor
bg)
convertStyle (AttributeStyle [Attribute]
attrs ForegroundColor
fg BackgroundColor
bg) =
let ([Attribute]
afg, Color
cfg) = ForegroundColor -> ([Attribute], Color)
convertFg ForegroundColor
fg
([Attribute]
abg, Color
cbg) = BackgroundColor -> ([Attribute], Color)
convertBg BackgroundColor
bg
in ([Attribute]
afg [Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++ [Attribute]
abg [Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++ [Attribute]
attrs, (Color, Color) -> Maybe (Color, Color)
forall a. a -> Maybe a
Just (Color
cfg, Color
cbg))
convertStyle (ColorlessStyle [Attribute]
attrs) = ([Attribute]
attrs, Maybe (Color, Color)
forall a. Maybe a
Nothing)
colorsToPairs' :: [Maybe (Color, Color)] -> IO [Maybe Pair]
colorsToPairs' [Maybe (Color, Color)]
cs = do
pairs <- [(Color, Color)] -> IO [Pair]
colorsToPairs ([Maybe (Color, Color)] -> [(Color, Color)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Color, Color)]
cs)
return $ mergeNothing cs pairs
mergeNothing :: [Maybe a] -> [a] -> [Maybe a]
mergeNothing (Just a
_ : [Maybe a]
crest) (a
p : [a]
prest) =
a -> Maybe a
forall a. a -> Maybe a
Just a
p
Maybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
: [Maybe a] -> [a] -> [Maybe a]
mergeNothing [Maybe a]
crest [a]
prest
mergeNothing (Maybe a
Nothing : [Maybe a]
crest) [a]
ps = Maybe a
forall a. Maybe a
Nothing Maybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
: [Maybe a] -> [a] -> [Maybe a]
mergeNothing [Maybe a]
crest [a]
ps
mergeNothing [Maybe a]
_ [a]
_ = []
toCursesStyle :: Attr -> Maybe Pair -> CursesStyle
toCursesStyle Attr
cursesAttrs Maybe Pair
Nothing =
Attr -> CursesStyle
ColorlessCursesStyle Attr
cursesAttrs
toCursesStyle Attr
cursesAttrs (Just Pair
cursesPair) =
Attr -> Pair -> CursesStyle
CursesStyle Attr
cursesAttrs Pair
cursesPair
displayKey :: Key -> String
displayKey :: Key -> String
displayKey (KeyChar Char
' ') = String
"<Space>"
displayKey (KeyChar Char
'\t') = String
"<Tab>"
displayKey (KeyChar Char
'\r') = String
"<Enter>"
displayKey (KeyChar Char
c)
| Char -> Bool
isPrint Char
c = [Char
c]
displayKey (KeyChar Char
c)
| Char -> Int
ord Char
'\^A' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> Int
ord Char
c Bool -> Bool -> Bool
&& Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> Int
ord Char
'\^Z' =
let c' :: Char
c' = Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'\^A' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
'a'
in Char
'^' Char -> String -> String
forall a. a -> [a] -> [a]
: [Char -> Char
toUpper Char
c']
displayKey (KeyChar Char
c) = Char -> String
forall a. Show a => a -> String
show Char
c
displayKey Key
KeyDown = String
"<Down>"
displayKey Key
KeyUp = String
"<Up>"
displayKey Key
KeyLeft = String
"<Left>"
displayKey Key
KeyRight = String
"<Right>"
displayKey Key
KeyHome = String
"<Home>"
displayKey Key
KeyBackspace = String
"<BS>"
displayKey (KeyF Int
i) = Char
'F' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
i
displayKey Key
KeyNPage = String
"<NPage>"
displayKey Key
KeyPPage = String
"<PPage>"
displayKey Key
KeyEnter = String
"<Return>"
displayKey Key
KeyEnd = String
"<End>"
displayKey Key
KeyIC = String
"<Insert>"
displayKey Key
KeyDC = String
"<Delete>"
displayKey Key
k = Key -> String
forall a. Show a => a -> String
show Key
k
withCursor :: (MonadIO m, MonadMask m) => CursorVisibility -> m a -> m a
withCursor :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
CursorVisibility -> m a -> m a
withCursor CursorVisibility
nv m a
action =
m CursorVisibility
-> (CursorVisibility -> m CursorVisibility)
-> (CursorVisibility -> m a)
-> m a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket
(IO CursorVisibility -> m CursorVisibility
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CursorVisibility -> m CursorVisibility)
-> IO CursorVisibility -> m CursorVisibility
forall a b. (a -> b) -> a -> b
$ CursorVisibility -> IO CursorVisibility
Curses.cursSet CursorVisibility
nv)
(\CursorVisibility
vis -> IO CursorVisibility -> m CursorVisibility
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CursorVisibility -> m CursorVisibility)
-> IO CursorVisibility -> m CursorVisibility
forall a b. (a -> b) -> a -> b
$ CursorVisibility -> IO CursorVisibility
Curses.cursSet CursorVisibility
vis)
(\CursorVisibility
_ -> m a
action)
withProgram :: (MonadIO m, MonadMask m) => m a -> m a
withProgram :: forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
withProgram m a
action =
CursorVisibility -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
CursorVisibility -> m a -> m a
withCursor CursorVisibility
CursorVisible (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$
m () -> m CInt -> m a -> m a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> m c -> m b -> m b
bracket_ (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
endWin) (IO CInt -> m CInt
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO CInt
flushinp) m a
action