{-# 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)