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