{-# OPTIONS -fglasgow-exts #-} -- glasgow-exts needed for existentials and multi-parameter type classes. -- Copyright (c) 2005 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 HSCurses.Widgets where import Char import List import Maybe import qualified HSCurses.Curses as Curses import qualified HSCurses.CursesHelper as CursesH import HSCurses.Logging import Control.Monad.Trans import Control.Exception (assert) import HSCurses.MonadException 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 = 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 = 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 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 dataLen 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 pos@(y,x) sz@(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 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 = 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 = mkKeyHandler editWidgetGoLeft' editWidgetGoRight = mkKeyHandler editWidgetGoRight' editWidgetDeleteLeft = mkKeyHandler editWidgetDeleteLeft' editWidgetDeleteUnderCursor = mkKeyHandler editWidgetDeleteUnderCursor' editWidgetDeleteToEnd = mkKeyHandler editWidgetDeleteToEnd' editWidgetGoHome = mkKeyHandler editWidgetGoHome' editWidgetGoEnd = mkKeyHandler editWidgetGoEnd' editWidgetHistoryUp = mkKeyHandler editWidgetHistoryUp' editWidgetHistoryDown = mkKeyHandler editWidgetHistoryDown' 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 ew = ew_content ew editWidgetSetContent ew s = addToHistory (ew { ew_content = s, ew_xoffset = 0, ew_xcursor = 0 }) s editWidgetGetOptions ew = ew_options ew editWidgetSetOptions ew opts = ew { ew_options = opts } drawEditWidget :: Pos -> Size -> DrawingHint -> EditWidget -> IO () drawEditWidget (y, x) (height, 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@(height, width) ew = CursesH.withCursor Curses.CursorVisible $ processKey ew where processKey ew = do liftIO $ draw ew k <- CursesH.getKey refresh case lookup k (ewopt_keyHandlers $ ew_options ew) of Nothing -> case k of Curses.KeyChar c | isAscii c && isPrint c -> processKey $ insertChar ew c _ -> processKey ew Just f -> do x <- liftIO $ f pos sz ew case x of Cont ew' -> processKey ew' Done ew' -> do liftIO $ drawEditWidget pos sz DHActive ew' return (ew', editWidgetGetContent ew') 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 }) draw 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' _ _ 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' _ (_, 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' _ _ ew = let pos = ew_contentPos ew oldContent = ew_content ew newContent = take pos oldContent ++ drop (pos+1) oldContent in ew { ew_content = newContent } editWidgetDeleteToEnd' _ _ ew = let pos = ew_contentPos ew oldContent = ew_content ew newContent = take pos oldContent in ew { ew_content = newContent } 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 _ _ ew = return (Done (addToHistory ew (ew_content ew))) maxHistoryLength = 50 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' _ _ ew = editWidgetHistory (+) ew 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 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 = 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 pos@(y, x) sz@(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 = 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 sz@(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 f [] = [] applyToFirst f (x:xs) = f x : xs applyToLast f [] = [] 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 pos@(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 pos@(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 (y, x) | y == rowIndex && x == 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 pos@(y, x) sz hint 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 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 tbw sz@(height,_) 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 pos@(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 x -> Just (y, x) vert f = case f rows y cols x of Nothing -> Nothing Just y -> Just (y, 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 y | not (y `elem` rows) = Nothing goLeft cols x _ _ = case reverse (takeWhile ( Nothing (x:_) -> Just x goRight _ _ rows y | not (y `elem` rows) = Nothing goRight cols x _ _ = case dropWhile (x>=) cols of [] -> Nothing (x:_) -> Just x 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 d r l@(h:t) | (d `isPrefixOf` l) = (r, l) | otherwise = nextToken d (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,(y: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)