CursesHelper.hs

{-# 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 = 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) ->
            void $ installHandler sig (Catch $ sigwinch sig key) Nothing
#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
        void $ installHandler sig (Catch $ sigwinch sig key) Nothing
#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 human-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)

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 human-readable strings
displayKey :: Key -> String
displayKey (KeyChar ' ') = "<Space>"
displayKey (KeyChar '\t') = "<Tab>"
displayKey (KeyChar '\r') = "<Enter>"
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 = "<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


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