{-# 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 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@ 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 :: IO ()
start = do
    IO ()
Curses.initCurses -- initialise the screen
    IO ()
Curses.resetParams
    Window -> Bool -> IO ()
Curses.keypad Window
Curses.stdScr Bool
True -- grab the keyboard
    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

-- | Clean up and go home.
end :: IO ()
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 :: IO ()
suspend = CInt -> IO ()
raiseSignal CInt
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 :: 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 n s@ draws @n@ characters of string @s@.
drawLine :: Int -> String -> IO ()
-- lazy version is faster than calculating length of s
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
' ')

-- | Draw the cursor at the given position.
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))

-- | Move cursor to origin of stdScr.
gotoTop :: IO ()
gotoTop :: IO ()
gotoTop = Window -> Int -> Int -> IO ()
Curses.wMove Window
Curses.stdScr Int
0 Int
0

-- | Resize the window
-- From "Writing Programs with NCURSES", by Eric S. Raymond and
-- Zeyd M. Ben-Halim
resizeui :: IO (Int, Int)
resizeui :: IO (Int, Int)
resizeui = do
    IO ()
Curses.endWin
    IO ()
Curses.refresh
    IO (Int, Int)
Curses.scrSize

-- | Basic colors.
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"

-- | 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 :: [(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

------------------------------------------------------------------------
-- 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 (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)

-- | Background colors.
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)

-- | Mapping abstract colours to ncurses attributes and colours
--
-- (not visible outside this module)
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)

-- | Abstractions for some commonly used attributes.
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)

-- | Converts an abstract attribute list into its curses representation.
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

-- | A human-readable style.
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

-- | A style which uses the internal curses representations for
--   attributes and colors.
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)

-- | Changes the attributes of the given CursesStyle.
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)

-- | Reset the screen to normal values
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

-- | Manipulate the current style of the standard screen
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 -- before
            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) -- after
        (\(Attr, Pair)
_ -> m a
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 :: [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

-- | Converting keys to human-readable strings
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) -- Control
    | 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


------------------------------------------------------------------------
--
-- Other helpers
--

-- | Set the cursor, and do action
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) -- before
        (\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) -- after
        (\CursorVisibility
_ -> m a
action) -- do this

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