content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE ExistentialQuantification #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  
  -- Copyright (c) 2005-2011 Stefan Wehr - http://www.stefanwehr.de
  --
  -- 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.Widgets where
  
  import Control.Exception (assert)
  #if MIN_VERSION_exceptions(0,6,0)
  import Control.Monad.Catch (MonadMask)
  #else
  import Control.Monad.Catch (MonadCatch)
  #define MonadMask MonadCatch
  #endif
  import Control.Monad.Trans
  import Data.Char
  import Data.List
  import Data.List.NonEmpty (NonEmpty ((:|)))
  import qualified Data.List.NonEmpty as NonEmpty
  import Data.Maybe
  
  import qualified UI.HSCurses.Curses as Curses
  import qualified UI.HSCurses.CursesHelper as CursesH
  import UI.HSCurses.Logging
  
  type Pos = (Int, Int)
  type Offset = (Int, Int)
  
  type Size =
      ( Int -- height
      , Int -- width
      )
  
  getHeight :: Size -> Int
  getHeight = fst
  
  getWidth :: Size -> Int
  getWidth = snd
  
  getYOffset :: Offset -> Int
  getYOffset = fst
  
  getXOffset :: Offset -> Int
  getXOffset = snd
  
  getYPos :: Pos -> Int
  getYPos = fst
  
  getXPos :: Pos -> Int
  getXPos = snd
  
  data Direction = DirLeft | DirRight | DirUp | DirDown
      deriving (Eq, Show, Ord)
  
  data HAlignment = AlignLeft | AlignCenter | AlignRight
      deriving (Eq, Show)
  
  data Cont a = Cont a | Done a
  
  class Widget a where
      draw :: Pos -> Size -> DrawingHint -> a -> IO ()
      minSize :: a -> Size
  
  class (Widget a) => ActiveWidget a where
      activate ::
          (MonadIO m, MonadMask m) =>
          m () ->
          Pos ->
          Size ->
          a ->
          m (a, String)
  
  type KeyHandler a = Pos -> Size -> a -> IO (Cont a)
  
  mkKeyHandler ::
      (Pos -> Size -> a -> a) ->
      KeyHandler a
  mkKeyHandler f pos sz w = return (Cont (f pos sz w))
  
  --
  -- Drawing
  --
  
  data DrawingHint
      = DHNormal
      | DHFocus
      | DHActive
      deriving (Eq, Show, Ord)
  
  data DrawingStyle = DStyle
      { dstyle_normal :: CursesH.CursesStyle
      , dstyle_focus :: CursesH.CursesStyle
      , dstyle_active :: CursesH.CursesStyle
      }
      deriving (Eq, Show)
  
  mkDrawingStyle :: CursesH.CursesStyle -> DrawingStyle
  mkDrawingStyle defStyle =
      let revStyle = CursesH.changeCursesStyle defStyle [CursesH.Reverse]
       in DStyle
              { dstyle_normal = defStyle
              , dstyle_focus = revStyle
              , dstyle_active = revStyle
              }
  
  defaultDrawingStyle :: DrawingStyle
  defaultDrawingStyle = mkDrawingStyle CursesH.defaultCursesStyle
  _draw :: DrawingHint -> DrawingStyle -> IO a -> IO a
  _draw DHActive sty io = CursesH.withStyle (dstyle_active sty) io
  _draw DHNormal sty io = CursesH.withStyle (dstyle_normal sty) io
  _draw DHFocus sty io = CursesH.withStyle (dstyle_focus sty) io
  
  --
  -- Helper functions for scrolling
  --
  
  scrollFactor :: Double
  scrollFactor = 0.8
  
  scrollBy :: Int -> Int
  scrollBy displayLen =
      let amount = floor ((fromInteger . toInteger) displayLen * scrollFactor)
       in max (displayLen - 1) (min 1 amount)
  
  -- returns the new offset for scrolling in forward direction
  -- dataLen: total number of data items
  -- offset: the index of the first data item shown on the current page
  -- displayLen: the number of data items that is shown in one page
  scrollForward :: Int -> Int -> Int -> Int
  scrollForward dataLen offset displayLen =
      if offset + displayLen >= dataLen
          then offset
          else min (offset + scrollBy displayLen) (dataLen - displayLen)
  
  -- returns the new offset for scrolling in backward direction.
  -- parameters as for scrollForward
  scrollBackward :: t -> Int -> Int -> Int
  scrollBackward _ offset displayLen =
      if offset == 0
          then offset
          else max (offset - scrollBy displayLen) 0
  
  --
  -- EmptyWidget
  --
  
  data EmptyWidget = EmptyWidget Size
  
  instance Widget EmptyWidget where
      draw _ _ _ _ = return ()
      minSize (EmptyWidget sz) = sz
  
  --
  -- An opaque widget
  --
  
  data OpaqueWidget = OpaqueWidget Size
  
  instance Widget OpaqueWidget where
      draw (y, x) (h, w) _ _ =
          let draw' n =
                  do
                      Curses.wMove Curses.stdScr (y + n) x
                      CursesH.drawLine w ""
           in do
                  mapM draw' (take h [0 ..])
                  Curses.refresh
      minSize (OpaqueWidget sz) = sz
  
  --
  -- Widget for text input
  --
  
  data EditWidget = EditWidget
      { ew_content :: String
      , ew_xoffset :: Int -- content!!xoffset is the 1st char shown
      , ew_xcursor :: Int -- cursor position
      , ew_history :: [String]
      , ew_historyIndex :: Int
      , ew_historySavedContent :: Maybe String
      , ew_options :: EditWidgetOptions
      }
  
  ew_contentPos :: EditWidget -> Int
  ew_contentPos ew = ew_xcursor ew + ew_xoffset ew
  
  instance Widget EditWidget where
      draw = drawEditWidget
      minSize ew = (1, ewopt_minWidth $ ew_options ew)
  
  instance ActiveWidget EditWidget where
      activate = activateEditWidget
  
  data EditWidgetOptions = EWOptions
      { ewopt_keyHandlers :: [(Curses.Key, KeyHandler EditWidget)]
      , ewopt_minWidth :: Int
      , ewopt_style :: DrawingStyle
      }
  
  defaultEWOptions :: EditWidgetOptions
  defaultEWOptions =
      EWOptions
          { ewopt_keyHandlers = editWidgetKeyHandlers
          , ewopt_minWidth = 8
          , ewopt_style = defaultDrawingStyle
          }
  
  newEditWidget :: EditWidgetOptions -> String -> EditWidget
  newEditWidget opts =
      editWidgetSetContent
          ( EditWidget
              { ew_content = ""
              , ew_xoffset = 0
              , ew_xcursor = 0
              , ew_history = []
              , ew_historyIndex = -1
              , ew_historySavedContent = Nothing
              , ew_options = opts
              }
          )
  
  editWidgetGoLeft ::
      Pos ->
      Size ->
      EditWidget ->
      IO (Cont EditWidget)
  editWidgetGoLeft = mkKeyHandler editWidgetGoLeft'
  editWidgetGoRight ::
      Pos ->
      Size ->
      EditWidget ->
      IO (Cont EditWidget)
  editWidgetGoRight = mkKeyHandler editWidgetGoRight'
  editWidgetDeleteLeft ::
      Pos ->
      Size ->
      EditWidget ->
      IO (Cont EditWidget)
  editWidgetDeleteLeft = mkKeyHandler editWidgetDeleteLeft'
  editWidgetDeleteUnderCursor ::
      Pos ->
      Size ->
      EditWidget ->
      IO (Cont EditWidget)
  editWidgetDeleteUnderCursor = mkKeyHandler editWidgetDeleteUnderCursor'
  editWidgetDeleteToEnd ::
      Pos ->
      Size ->
      EditWidget ->
      IO (Cont EditWidget)
  editWidgetDeleteToEnd = mkKeyHandler editWidgetDeleteToEnd'
  editWidgetGoHome ::
      Pos ->
      Size ->
      EditWidget ->
      IO (Cont EditWidget)
  editWidgetGoHome = mkKeyHandler editWidgetGoHome'
  editWidgetGoEnd ::
      Pos ->
      Size ->
      EditWidget ->
      IO (Cont EditWidget)
  editWidgetGoEnd = mkKeyHandler editWidgetGoEnd'
  editWidgetHistoryUp ::
      Pos ->
      Size ->
      EditWidget ->
      IO (Cont EditWidget)
  editWidgetHistoryUp = mkKeyHandler editWidgetHistoryUp'
  editWidgetHistoryDown ::
      Pos ->
      Size ->
      EditWidget ->
      IO (Cont EditWidget)
  editWidgetHistoryDown = mkKeyHandler editWidgetHistoryDown'
  
  editWidgetKeyHandlers ::
      [ ( Curses.Key
        , Pos ->
          Size ->
          EditWidget ->
          IO (Cont EditWidget)
        )
      ]
  editWidgetKeyHandlers =
      [ (Curses.KeyLeft, editWidgetGoLeft)
      , (Curses.KeyRight, editWidgetGoRight)
      , (Curses.KeyBackspace, editWidgetDeleteLeft)
      , (Curses.KeyChar '\^D', editWidgetDeleteUnderCursor)
      , (Curses.KeyDC, editWidgetDeleteUnderCursor)
      , (Curses.KeyChar '\^K', editWidgetDeleteToEnd)
      , (Curses.KeyHome, editWidgetGoHome)
      , (Curses.KeyChar '\^A', editWidgetGoHome)
      , (Curses.KeyEnd, editWidgetGoEnd)
      , (Curses.KeyChar '\^E', editWidgetGoEnd)
      , (Curses.KeyChar '\r', editWidgetFinish)
      , (Curses.KeyChar '\t', editWidgetFinish)
      , (Curses.KeyUp, editWidgetHistoryUp)
      , (Curses.KeyDown, editWidgetHistoryDown)
      ]
  
  editWidgetGetContent :: EditWidget -> String
  editWidgetGetContent ew = ew_content ew
  editWidgetSetContent ::
      EditWidget ->
      String ->
      EditWidget
  editWidgetSetContent ew s =
      addToHistory (ew {ew_content = s, ew_xoffset = 0, ew_xcursor = 0}) s
  
  editWidgetGetOptions ::
      EditWidget ->
      EditWidgetOptions
  editWidgetGetOptions ew = ew_options ew
  editWidgetSetOptions ::
      EditWidget ->
      EditWidgetOptions ->
      EditWidget
  editWidgetSetOptions ew opts = ew {ew_options = opts}
  
  drawEditWidget :: Pos -> Size -> DrawingHint -> EditWidget -> IO ()
  drawEditWidget (y, x) (_, width) hint ew =
      _draw hint (ewopt_style . ew_options $ ew) $
          do
              Curses.wMove Curses.stdScr y x
              CursesH.drawLine width (drop (ew_xoffset ew) $ ew_content ew)
              Curses.refresh
  
  activateEditWidget ::
      (MonadIO m, MonadMask m) =>
      m () ->
      Pos ->
      Size ->
      EditWidget ->
      m (EditWidget, String)
  activateEditWidget refresh pos@(y, x) sz@(_, width) ew =
      CursesH.withCursor Curses.CursorVisible $ processKey ew
    where
      processKey ex =
          do
              liftIO $ drawLocal ex
              k <- CursesH.getKey refresh
              case lookup k (ewopt_keyHandlers $ ew_options ex) of
                  Nothing ->
                      case k of
                          Curses.KeyChar c
                              | isAscii c && isPrint c ->
                                  processKey $ insertChar ex c
                          _ -> processKey ex
                  Just f ->
                      do
                          x' <- liftIO $ f pos sz ex
                          case x' of
                              Cont ex' -> processKey ex'
                              Done ex' -> do
                                  liftIO $ drawEditWidget pos sz DHActive ex'
                                  return (ex', editWidgetGetContent ex')
      insertChar ew' c =
          let pos' = ew_contentPos ew'
              oldContent = ew_content ew'
              newContent = take pos' oldContent ++ (c : drop pos' oldContent)
           in editWidgetGoRight' pos' sz (ew' {ew_content = newContent})
      drawLocal ew' = _draw DHActive (ewopt_style . ew_options $ ew') $
          do
              Curses.wMove Curses.stdScr y x
              CursesH.drawLine width (drop (ew_xoffset ew') $ ew_content ew')
              Curses.wMove Curses.stdScr y (x + ew_xcursor ew')
              Curses.refresh
  
  editWidgetGoLeft' :: t -> t1 -> EditWidget -> EditWidget
  editWidgetGoLeft' _ _ ew =
      let newXcursor = max (ew_xcursor ew - 1) 0
          newXoffset =
              if ew_xcursor ew == 0
                  then max (ew_xoffset ew - 1) 0
                  else ew_xoffset ew
       in ew
              { ew_xoffset = newXoffset
              , ew_xcursor = newXcursor
              }
  
  editWidgetGoRight' :: t -> (t1, Int) -> EditWidget -> EditWidget
  editWidgetGoRight' _ (_, width) ew =
      let len = length (ew_content ew)
          lastChar = len - ew_xoffset ew - 1
          newXcursor = minimum [ew_xcursor ew + 1, lastChar + 1, width - 1]
          newXoffset =
              if ew_xcursor ew == width - 1
                  then min (ew_xoffset ew + 1) (len - width + 1)
                  else ew_xoffset ew
       in ew
              { ew_xoffset = newXoffset
              , ew_xcursor = newXcursor
              }
  
  editWidgetDeleteLeft' :: Pos -> Size -> EditWidget -> EditWidget
  editWidgetDeleteLeft' pos sz ew =
      let cpos = ew_contentPos ew - 1
          oldContent = ew_content ew
          newContent = take cpos oldContent ++ drop (cpos + 1) oldContent
          ew' = editWidgetGoLeft' pos sz (ew {ew_content = newContent})
       in if ew_xcursor ew == 0 && ew_xoffset ew /= 0
              then editWidgetGoRight' pos sz (editWidgetGoLeft' pos sz ew')
              else ew'
  
  editWidgetDeleteUnderCursor' :: t -> t1 -> EditWidget -> EditWidget
  editWidgetDeleteUnderCursor' _ _ ew =
      let pos = ew_contentPos ew
          oldContent = ew_content ew
          newContent = take pos oldContent ++ drop (pos + 1) oldContent
       in ew {ew_content = newContent}
  
  editWidgetDeleteToEnd' :: t -> t1 -> EditWidget -> EditWidget
  editWidgetDeleteToEnd' _ _ ew =
      let pos = ew_contentPos ew
          oldContent = ew_content ew
          newContent = take pos oldContent
       in ew {ew_content = newContent}
  
  editWidgetGoHome' :: t -> t1 -> EditWidget -> EditWidget
  editWidgetGoHome' _ _ ew =
      ew
          { ew_xcursor = 0
          , ew_xoffset = 0
          }
  
  editWidgetGoEnd' :: Pos -> Size -> EditWidget -> EditWidget
  editWidgetGoEnd' pos sz ew =
      let cpos = ew_contentPos ew
          len = length (ew_content ew)
       in if cpos == len
              then ew
              else editWidgetGoEnd' pos sz (editWidgetGoRight' pos sz ew)
  
  editWidgetFinish :: (Monad m) => t -> t1 -> EditWidget -> m (Cont EditWidget)
  editWidgetFinish _ _ ew = return (Done (addToHistory ew (ew_content ew)))
  
  maxHistoryLength :: Int
  maxHistoryLength = 50
  
  addToHistory :: EditWidget -> [Char] -> EditWidget
  addToHistory ew s =
      let newHist =
              if not (null s)
                  then take maxHistoryLength (s : ew_history ew)
                  else ew_history ew
       in ew
              { ew_history = newHist
              , ew_historyIndex = -1
              , ew_historySavedContent = Nothing
              }
  
  editWidgetHistoryUp' :: t -> t1 -> EditWidget -> EditWidget
  editWidgetHistoryUp' _ _ ew = editWidgetHistory (+) ew
  
  editWidgetHistoryDown' :: t -> t1 -> EditWidget -> EditWidget
  editWidgetHistoryDown' _ _ ew = editWidgetHistory (-) ew
  
  -- ew_historyList: list of history items, i.e. non-null strings which were
  --   entered into the widget and confirmed with ENTER or which were added
  --   via editWidgetSetContent.
  -- ew_historyIndex: the index of the history item shown in the widget. The
  --   value -1 means that the value saved in ew_historySavedContent should
  --   be shown.
  editWidgetHistory :: (Num t) => (Int -> t -> Int) -> EditWidget -> EditWidget
  editWidgetHistory op ew =
      let i = ew_historyIndex ew
          l = ew_history ew
          j = i `op` 1
       in if j >= 0 && j < length l
              then
                  let savedContent =
                          case ew_historySavedContent ew of
                              Nothing -> Just (ew_content ew)
                              x -> x
                   in ew
                          { ew_historyIndex = j
                          , ew_content = l !! j
                          , ew_historySavedContent = savedContent
                          , ew_xcursor = 0
                          , ew_xoffset = 0
                          }
              else
                  if j == -1
                      then case ew_historySavedContent ew of
                          Nothing -> ew
                          Just x ->
                              ew
                                  { ew_content = x
                                  , ew_historyIndex = j
                                  , ew_xcursor = 0
                                  , ew_xoffset = 0
                                  }
                      else ew
  
  --
  -- Text widget
  --
  
  data TextWidget = TextWidget
      { tw_text :: String
      , tw_yoffset :: Int
      , tw_xoffset :: Int
      , tw_options :: TextWidgetOptions
      }
      deriving (Eq, Show)
  
  instance Widget TextWidget where
      draw = drawTextWidget
      minSize tw =
          case twopt_size $ tw_options tw of
              TWSizeDefault ->
                  let l = lines (tw_text tw)
                   in (length l, if null l then 0 else maximum (map length l))
              TWSizeFixed sz -> sz
  
  data TextWidgetSize
      = TWSizeDefault -- minimal size determined by content
      | TWSizeFixed Size -- minimal size is fixed, content is
      -- possibly cut off
      deriving (Eq, Show)
  
  {-
  \| Autowrap   -- minimal width determined by content,
               -- but lines are wrapped if necessary
               -}
  
  data TextWidgetOptions = TWOptions
      { twopt_size :: TextWidgetSize
      , twopt_style :: DrawingStyle
      , twopt_halign :: HAlignment
      }
      deriving (Eq, Show)
  
  defaultTWOptions :: TextWidgetOptions
  defaultTWOptions =
      TWOptions
          { twopt_size = TWSizeDefault
          , twopt_style = defaultDrawingStyle
          , twopt_halign = AlignLeft
          }
  
  newTextWidget :: TextWidgetOptions -> String -> TextWidget
  newTextWidget opts s =
      TextWidget
          { tw_text = s
          , tw_yoffset = 0
          , tw_xoffset = 0
          , tw_options = opts
          }
  
  drawTextWidget :: Pos -> Size -> DrawingHint -> TextWidget -> IO ()
  drawTextWidget (y, x) (height, width) hint tw =
      let ly = take height $ drop (tw_yoffset tw) (lines (tw_text tw))
          l = take height $ (map (drop (tw_xoffset tw)) ly ++ repeat [])
          l' = map (align (twopt_halign $ tw_options tw) width ' ') l
       in -- trace ("drawing text widget at " ++ show pos ++ " with size " ++ show sz) $
          do
              _draw
                  hint
                  (twopt_style . tw_options $ tw)
                  (mapM drawLine $ zip l' [0 ..])
              Curses.refresh
    where
      drawLine (s, i) =
          do
              Curses.wMove Curses.stdScr (y + i) x
              CursesH.drawLine width s
  
  textWidgetGetText :: TextWidget -> String
  textWidgetGetText = tw_text
  
  textWidgetSetText :: TextWidget -> String -> TextWidget
  textWidgetSetText tw s = tw {tw_text = s}
  
  textWidgetScrollDown :: Size -> TextWidget -> TextWidget
  textWidgetScrollDown (h, _) tw =
      let dataLen = length $ lines (tw_text tw)
          offset = tw_yoffset tw
       in tw {tw_yoffset = scrollForward dataLen offset h}
  
  textWidgetScrollUp :: Size -> TextWidget -> TextWidget
  textWidgetScrollUp (h, _) tw =
      let dataLen = length $ lines (tw_text tw)
          offset = tw_yoffset tw
       in tw {tw_yoffset = scrollBackward dataLen offset h}
  
  textWidgetScrollLeft :: Size -> TextWidget -> TextWidget
  textWidgetScrollLeft (_, w) tw =
      let dataLen = length $ lines (tw_text tw)
          offset = tw_xoffset tw
       in tw {tw_xoffset = scrollBackward dataLen offset w}
  
  textWidgetScrollRight :: Size -> TextWidget -> TextWidget
  textWidgetScrollRight (_, w) tw =
      let dataLen = length $ lines (tw_text tw)
          offset = tw_xoffset tw
       in tw {tw_xoffset = scrollForward dataLen offset w}
  
  --
  -- Table widget
  --
  
  data TableCell
      = forall w. (Widget w) => TableCell w
      | forall w. (ActiveWidget w) => ActiveTableCell w
  
  isActive :: TableCell -> Bool
  isActive (TableCell _) = False
  isActive (ActiveTableCell _) = True
  
  instance Widget TableCell where
      draw pos sz hint (TableCell w) = draw pos sz hint w
      draw pos sz hint (ActiveTableCell w) = draw pos sz hint w
      minSize (TableCell w) = minSize w
      minSize (ActiveTableCell w) = minSize w
  
  _activateTableCell ::
      (MonadIO m, MonadMask m) =>
      m () ->
      Pos ->
      Size ->
      TableCell ->
      m (TableCell, String)
  _activateTableCell _ _ _ (TableCell _) =
      error "_activateTableCell: cannot activate non-active cell!"
  _activateTableCell refresh pos sz (ActiveTableCell w) =
      do
          (new, res) <- activate refresh pos sz w
          return (ActiveTableCell new, res)
  
  type Row = [TableCell]
  
  singletonRow :: TableCell -> Row
  singletonRow tc = [tc]
  
  getCellWidget :: TableWidget -> (Int, Int) -> TableCell
  getCellWidget tbw (row, col) = (tbw_rows tbw) !! row !! col
  
  setCellWidget :: TableWidget -> (Int, Int) -> TableCell -> TableWidget
  setCellWidget tbw (rowIndex, colIndex) w =
      let rows = tbw_rows tbw
          row = rows !! rowIndex
          newRow = listReplace row w colIndex
          newRows = listReplace rows newRow rowIndex
       in tbw {tbw_rows = newRows}
  
  data TableWidget = TableWidget
      { tbw_rows :: [Row]
      , tbw_colOffset :: Int
      , tbw_pos :: Maybe Pos
      , tbw_options :: TableWidgetOptions
      }
  
  data FillRow = First | Last | None deriving (Eq, Show)
  
  data TableWidgetOptions = TBWOptions
      { tbwopt_fillCol :: Maybe Int
      , tbwopt_fillRow :: FillRow
      , tbwopt_activeCols :: [Int]
      , tbwopt_minSize :: Size
      }
      deriving (Eq, Show)
  
  defaultTBWOptions :: TableWidgetOptions
  defaultTBWOptions =
      TBWOptions
          { tbwopt_fillCol = Nothing
          , tbwopt_fillRow = None
          , tbwopt_activeCols = []
          , tbwopt_minSize = (4, 10)
          }
  
  instance Widget TableWidget where
      draw = drawTableWidget
      minSize = tbwopt_minSize . tbw_options
  
  newTableWidget :: TableWidgetOptions -> [Row] -> TableWidget
  newTableWidget opts rows =
      TableWidget
          { tbw_rows = rows
          , tbw_colOffset = 0
          , tbw_pos = findFirstActiveCell rows opts
          , tbw_options = opts
          }
  
  data TableWidgetDisplayInfo
      = TBWDisplayInfo
      { tbwdisp_height :: Int -- height of the display area
      , tbwdisp_width :: Int -- width of the display area
      , tbwdisp_firstVis :: Int -- index of the first row visible
      , tbwdisp_lastVis :: Int -- index of the last row visible
      , tbwdisp_rows :: [Row] -- the rows which are visible
      , tbwdisp_nrows :: Int -- the number of rows visible
      , tbwdisp_heights :: [Int] -- the heights of the visible rows
      , tbwdisp_widths :: [Int] -- the widths of the visible rows
      -- free space at the right side (xoffset, size)
      , tbwdisp_rightMargin :: Maybe (Int, Size)
      }
  
  tableWidgetDisplayInfo :: Size -> TableWidget -> TableWidgetDisplayInfo
  tableWidgetDisplayInfo (height, width) tbw =
      assert (isQuadratic (tbw_rows tbw)) $
          let allRows = tbw_rows tbw
              ncols = length (allRows !! 0)
              colOffset = tbw_colOffset tbw
              allHeights = minSpaces getHeight allRows
              heights' = drop colOffset allHeights
              nrows = getNRows heights' 0 0
              rows = take nrows $ drop colOffset allRows
              (heights, heightDummy) =
                  let hs = take nrows heights'
                      s = sum hs
                      d = height - s
                   in case tbwopt_fillRow $ tbw_options tbw of
                          First -> (applyToFirst (+ d) hs, 0)
                          Last -> (applyToLast (+ d) hs, 0)
                          None -> (hs, d)
              widths' = minSpaces getWidth (transpose $ tbw_rows tbw)
              (widths, rightMargin) =
                  if sum widths' > width
                      then
                          error
                              ( "table too wide: width="
                                  ++ show (sum widths')
                                  ++ ", available width="
                                  ++ show width
                              )
                      else case tbwopt_fillCol $ tbw_options tbw of
                          Just i
                              | i >= 0 && i < ncols ->
                                  ( take i widths'
                                      ++ case drop i widths' of
                                          [] -> error "rest unexpectedly empty"
                                          (w : ws) -> (w + width - sum widths') : ws
                                  , Nothing
                                  )
                          _ ->
                              let diff = width - sum widths'
                                  msz = (height, diff)
                                  m =
                                      if diff > 0
                                          then Just (sum widths', msz)
                                          else Nothing
                               in (widths', m)
              dummyHeights = if heightDummy == 0 then [] else [heightDummy]
              dummyRows =
                  if heightDummy == 0
                      then []
                      else
                          [ map
                              (\w -> TableCell (OpaqueWidget (heightDummy, w)))
                              widths
                          ]
           in TBWDisplayInfo
                  { tbwdisp_height = height
                  , tbwdisp_width = width
                  , tbwdisp_firstVis = colOffset
                  , tbwdisp_lastVis = colOffset + nrows - 1
                  , tbwdisp_rows = rows ++ dummyRows
                  , tbwdisp_nrows = nrows + length dummyRows
                  , tbwdisp_heights = heights ++ dummyHeights
                  , tbwdisp_widths = widths
                  , tbwdisp_rightMargin = rightMargin
                  }
    where
      minSpaces f ls =
          snd $
              mapAccumL
                  ( \acc ws ->
                      (acc, acc + maximum (map (f . minSize) ws))
                  )
                  0
                  ls
      getNRows (h : hs) n acc | h + n <= height = getNRows hs (h + n) (acc + 1)
      getNRows _ _ acc = acc
      isQuadratic [] = True
      isQuadratic (x : xs) = isQuadratic' xs (length x)
      isQuadratic' (x : xs) n = length x == n && isQuadratic' xs n
      isQuadratic' [] _ = True
      applyToFirst _ [] = []
      applyToFirst f (x : xs) = f x : xs
      applyToLast _ [] = []
      applyToLast f (x : xs) =
          let rev = NonEmpty.reverse $ x :| xs
              (h, t) = (NonEmpty.head rev, NonEmpty.tail rev)
           in reverse $ f h : t
  
  getCellInfo :: Pos -> Size -> TableWidget -> (Int, Int) -> (Pos, Size)
  getCellInfo (y, x) sz tbw (row, col) =
      let info = tableWidgetDisplayInfo sz tbw
          heights = tbwdisp_heights info
          widths = tbwdisp_widths info
          h = heights !! row
          w = widths !! col
          yoff = sum $ take row heights
          xoff = sum $ take col widths
       in ((y + yoff, x + xoff), (h, w))
  
  drawTableWidget :: Pos -> Size -> DrawingHint -> TableWidget -> IO ()
  drawTableWidget (y, x) sz hint tbw =
      let info = tableWidgetDisplayInfo sz tbw
          heights = tbwdisp_heights info
          widths = tbwdisp_widths info
          firstVis = tbwdisp_firstVis info
          rows = tbwdisp_rows info
          rightMargin = tbwdisp_rightMargin info
       in do
              drawRows rows heights widths 0 firstVis hint
              case rightMargin of
                  Nothing -> return ()
                  Just (xoff, s) -> draw (y, x + xoff) s hint (OpaqueWidget s)
              Curses.refresh
    where
      drawRows ::
          [Row] ->
          [Int] ->
          [Int] ->
          Int ->
          Int ->
          DrawingHint ->
          IO ()
      drawRows [] _ _ _ _ _ = return ()
      drawRows (r : rs) (h : hs) widths yoffset rowIndex hint' =
          do
              drawCols r h widths yoffset 0 (rowIndex, 0) hint'
              drawRows rs hs widths (yoffset + h) (rowIndex + 1) hint'
      drawRows _ _ _ _ _ _ = return ()
      drawCols ::
          Row ->
          Int ->
          [Int] ->
          Int ->
          Int ->
          (Int, Int) ->
          DrawingHint ->
          IO ()
      drawCols [] _ _ _ _ _ _ = return ()
      drawCols (c : cs) h (w : ws) yoffset xoffset (rowIndex, colIndex) hint' =
          let hint'' = case tbw_pos tbw of
                  Just (z, a)
                      | z == rowIndex && a == colIndex ->
                          DHFocus
                  _ -> hint'
           in do
                  draw (y + yoffset, x + xoffset) (h, w) hint'' c
                  drawCols
                      cs
                      h
                      ws
                      yoffset
                      (xoffset + w)
                      (rowIndex, colIndex + 1)
                      hint'
      drawCols _ _ _ _ _ _ _ = return ()
  
  tableWidgetScrollDown :: Size -> TableWidget -> TableWidget
  tableWidgetScrollDown (h, _) tbw =
      let dataLen = length $ tbw_rows tbw
          offset = tbw_colOffset tbw
          newOffset = scrollForward dataLen offset h
          newTbw = tbw {tbw_colOffset = newOffset}
       in case tbw_pos newTbw of
              Nothing -> newTbw
              Just (y, x) -> newTbw {tbw_pos = Just (max newOffset y, x)}
  
  tableWidgetScrollUp :: Size -> TableWidget -> TableWidget
  tableWidgetScrollUp sz@(h, _) tbw =
      let dataLen = length $ tbw_rows tbw
          offset = tbw_colOffset tbw
          newOffset = scrollBackward dataLen offset h
          newTbw = tbw {tbw_colOffset = newOffset}
          newLastVis = tbwdisp_lastVis (tableWidgetDisplayInfo sz newTbw)
       in case tbw_pos newTbw of
              Nothing -> newTbw
              Just (y, x) ->
                  newTbw {tbw_pos = Just (min newLastVis y, x)}
  
  tableWidgetActivateCurrent ::
      (MonadIO m, MonadMask m) =>
      m () ->
      Pos ->
      Size ->
      DrawingHint ->
      TableWidget ->
      m (TableWidget, Maybe String)
  tableWidgetActivateCurrent refresh (y, x) sz _ tbw =
      case tbw_pos tbw of
          Nothing -> do
              debug "tableWidgetActivateCurrent: pos=Nothing"
              return (tbw, Nothing)
          Just p ->
              let w = getCellWidget tbw p
               in if not $ isActive w
                      then do
                          debug "tableWidgetActivateCurrent: not active"
                          return (tbw, Nothing)
                      else activate' w p
    where
      activate' widget colyx@(coly, colx) =
          let info = tableWidgetDisplayInfo sz tbw
              vcol = colx
              vrow = coly - tbwdisp_firstVis info
              heights = tbwdisp_heights info
              widths = tbwdisp_widths info
              h = heights !! vrow
              w = widths !! vcol
              yoffset = sum (take vrow heights)
              xoffset = sum (take vcol widths)
           in do
                  (new, res) <-
                      _activateTableCell
                          refresh
                          (y + yoffset, x + xoffset)
                          (h, w)
                          widget
                  return (setCellWidget tbw colyx new, Just res)
  
  tableWidgetGoLeft :: Size -> TableWidget -> TableWidget
  tableWidgetGoLeft = tableWidgetMove DirLeft
  
  tableWidgetGoRight :: Size -> TableWidget -> TableWidget
  tableWidgetGoRight = tableWidgetMove DirRight
  
  tableWidgetGoUp :: Size -> TableWidget -> TableWidget
  tableWidgetGoUp = tableWidgetMove DirUp
  
  tableWidgetGoDown :: Size -> TableWidget -> TableWidget
  tableWidgetGoDown = tableWidgetMove DirDown
  
  tableWidgetMove ::
      Direction ->
      (Int, Int) ->
      TableWidget ->
      TableWidget
  tableWidgetMove dir sz tbw =
      let pos = tbw_pos tbw
          opts = tbw_options tbw
          nrows = length (tbw_rows tbw)
       in case pos of
              Nothing -> tbw
              Just p -> case findNextActiveCell opts nrows p dir of
                  Nothing -> tbw
                  newP@(Just (y, _)) ->
                      tableWidgetMakeVisible (tbw {tbw_pos = newP}) sz y
  
  tableWidgetMakeVisible ::
      TableWidget ->
      (Int, Int) ->
      Int ->
      TableWidget
  tableWidgetMakeVisible tbw sz@(_, _) y =
      let info = tableWidgetDisplayInfo sz tbw
          firstVis = tbwdisp_firstVis info
          lastVis = tbwdisp_lastVis info
       in if y < firstVis
              then tableWidgetMakeVisible (tableWidgetScrollUp sz tbw) sz y
              else
                  if y > lastVis
                      then
                          tableWidgetMakeVisible
                              (tableWidgetScrollDown sz tbw)
                              sz
                              y
                      else tbw
  
  findFirstActiveCell :: [Row] -> TableWidgetOptions -> Maybe Pos
  findFirstActiveCell rows opts =
      let nrows = length rows
          firstActiveCells =
              map
                  ( \y ->
                      findNextActiveCell
                          opts
                          nrows
                          (y, -1)
                          DirRight
                  )
                  [0 .. nrows - 1]
       in case catMaybes firstActiveCells of
              [] -> Nothing
              (x : _) -> Just x
  
  findNextActiveCell ::
      TableWidgetOptions ->
      Int ->
      Pos ->
      Direction ->
      Maybe Pos
  findNextActiveCell opts nrows (y, x) dir =
      --    trace ("findNextActiveCell (opts=" ++ show opts ++ ", nrows=" ++ show nrows
      --           ++ ", pos=" ++ show pos ++ ", dir=" ++ show dir) $
      let rows = [0 .. (nrows - 1)]
          cols = sort (tbwopt_activeCols opts)
          horiz f = case f cols x rows y of
              Nothing -> Nothing
              Just z -> Just (y, z)
          vert f = case f rows y cols x of
              Nothing -> Nothing
              Just z -> Just (z, x)
          res = case dir of
              DirLeft -> horiz goLeft
              DirRight -> horiz goRight
              DirUp -> vert goLeft
              DirDown -> vert goRight
       in -- trace ("result of findNextActiveCell: " ++ show res)
          res
    where
      goLeft _ _ rows a | not (a `elem` rows) = Nothing
      goLeft cols b _ _ =
          case reverse (takeWhile (< b) cols) of
              [] -> Nothing
              (c : _) -> Just c
      goRight _ _ rows a | not (a `elem` rows) = Nothing
      goRight cols a _ _ =
          case dropWhile (a >=) cols of
              [] -> Nothing
              (b : _) -> Just b
  
  tableWidgetDeleteRow :: Int -> TableWidget -> TableWidget
  tableWidgetDeleteRow n tbw =
      let rows = tbw_rows tbw
          rows' = deleteAt n rows
          pos' =
              case tbw_pos tbw of
                  Nothing -> Nothing
                  Just (row, col) ->
                      let row' = min row (length rows' - 1)
                       in if row' >= 0
                              then Just (row', col)
                              else Nothing
       in tbw {tbw_rows = rows', tbw_pos = pos'}
  
  --
  -- BorderWidget
  --
  
  --
  -- Selection Widget
  --
  
  --
  -- Utility functions
  --
  
  -- | Join a list by some delimiter
  joinLists :: [[a]] -> [a] -> [a]
  joinLists l s = if (null l) then [] else foldr1 (\x -> \y -> x ++ s ++ y) l
  
  -- | Split a list by some delimiter
  splitList :: (Eq a) => [a] -> [a] -> [[a]]
  splitList d l =
      unfoldr
          ( \x ->
              if (null x)
                  then Nothing
                  else Just $ nextToken d [] (snd $ splitAt (length d) x)
          )
          (d ++ l)
    where
      nextToken _ r [] = (r, [])
      nextToken e r m@(h : t)
          | (e `isPrefixOf` m) = (r, m)
          | otherwise = nextToken e (r ++ [h]) t
  
  listReplace :: [a] -> a -> Int -> [a]
  listReplace l a i =
      case splitAt i l of
          (_, []) ->
              error
                  ( "listReplace: index to large. index="
                      ++ show i
                      ++ ", length="
                      ++ show (length l)
                  )
          ([], _)
              | i < 0 ->
                  error
                      ( "listReplace: negative index. index="
                          ++ show i
                      )
          (xs, (_ : ys)) -> xs ++ (a : ys)
  
  -- alignRows :: [[String]] -> Char -> String -> [String]
  alignRows :: [[[a]]] -> a -> [a] -> [[a]]
  alignRows rows fill delim =
      let widths = foldr maxWidths (repeat 0) rows
       in map (alignRow widths) rows
    where
      maxWidths :: [[a]] -> [Int] -> [Int]
      maxWidths row acc = map (uncurry max) (zip acc (map length row))
      alignRow widths row = concatMap (uncurry alignCell) (zip widths row)
      alignCell width cell =
          let diff = width - length cell
           in cell ++ (take diff $ repeat fill) ++ delim
  
  align :: HAlignment -> Int -> a -> [a] -> [a]
  align a w f l =
      let space = w - length l
       in case a of
              AlignLeft -> l ++ (fill space)
              AlignRight -> (fill space) ++ l
              AlignCenter ->
                  let left = space `div` 2
                      right = left + (space `mod` 2)
                   in fill left ++ l ++ fill right
    where
      fill n = take n (repeat f)
  
  deleteAt :: Int -> [a] -> [a]
  deleteAt n l =
      if n >= 0 && n < length l
          then
              let (a, b) = splitAt n l
               in case b of
                      [] -> error "deleteAt: impossible"
                      (_ : rest) -> a ++ rest
          else error ("deleteAt: illegal index: " ++ show n)
  