    {-# LANGUAGE ScopedTypeVariables, ExistentialQuantification #-}
    -- glasgow-exts needed for existentials and multi-parameter type classes.

    -- 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)
    import Control.Monad.Trans
    import Data.Char
    import Data.List
    import Data.Maybe

    import UI.HSCurses.Logging
    import UI.HSCurses.MonadException
    import qualified UI.HSCurses.Curses as Curses
    import qualified UI.HSCurses.CursesHelper as CursesH

    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  :: MonadExcIO 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 :: MonadExcIO 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 :: MonadExcIO 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 to 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' ++
                                         let rest = drop i widths'
                                         in (head rest + width - sum widths') : tail rest
                                        , 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 l =
                let (h, t) = (head $ reverse l, tail $ reverse l)
                    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'
              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'

    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 :: MonadExcIO 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 (y, z)
            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 a ++ (tail b)
                      else error ("deleteAt: illegal index: " ++ show n)