{-# LANGUAGE CPP #-}
{-# OPTIONS -#include HSCursesUtils.h -#include <signal.h> #-}

--
-- 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, resetStyle, convertStyles,
        defaultStyle, defaultCursesStyle, withStyle,

        -- * Keys
        displayKey,

        -- * Helpers
        withCursor, withProgram
  )   where

import UI.HSCurses.Curses hiding ( refresh, Window )
import UI.HSCurses.Logging
import UI.HSCurses.MonadException
import qualified UI.HSCurses.Curses as Curses

import Data.Char
import Data.Maybe
import Data.List
import Control.Monad.Trans

#ifndef mingw32_HOST_OS
import System.Posix.Signals
#endif

--
--

--
-- | @start@ 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) ->
          do installHandler sig (Catch $ sigwinch sig key) Nothing
             return ()
#endif
      _ -> debug ("cannot install SIGWINCH handler: signal=" ++
                  show Curses.cursesSigWinch ++ ", KEY_RESIZE=" ++
                  show Curses.keyResizeCode)
#ifndef mingw32_HOST_OS
    where sigwinch sig key =
              do debug "SIGWINCH signal received"
                 Curses.ungetCh key
                 installHandler sig (Catch $ sigwinch sig key) Nothing
                 return ()
#endif



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

{-
instance Show CursesStyle where
    show (CursesStyle _ _) = "CursesStyle"
    show (ColorlessCursesStyle _) = "ColorlessCursesStyle"
-}

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 = setStyle defaultCursesStyle

--
-- | Manipulate the current style of the standard screen
--
setStyle :: CursesStyle -> IO ()
setStyle (CursesStyle a p) = Curses.wAttrSet Curses.stdScr (a, p)
setStyle (ColorlessCursesStyle a) =
    do (_, p) <- Curses.wAttrGet Curses.stdScr
       Curses.wAttrSet Curses.stdScr (a, p)

withStyle :: MonadExcIO m => CursesStyle -> m a -> m a
withStyle style action =
    bracketM
        (liftIO $ do old <- Curses.wAttrGet Curses.stdScr    -- before
                     setStyle style
                     return old)
        (\old -> liftIO $ Curses.wAttrSet Curses.stdScr 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 humand-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 :: MonadExcIO m => CursorVisibility -> m a -> m a
withCursor nv action =
    bracketM
        (liftIO $ Curses.cursSet nv)             -- before
        (\vis -> liftIO $ Curses.cursSet vis)    -- after
        (\_ -> action)                           -- do this

withProgram :: MonadExcIO m => m a -> m a
withProgram action = withCursor CursorVisible $
    bracketM_ (liftIO endWin) (liftIO flushinp) action