content: {-# 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
  