{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, CPP #-} -- Copyright (c) 2005-2011 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public -- License as published by the Free Software Foundation; either -- version 2.1 of the License, or (at your option) any later version. -- -- This library is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- Lesser General Public License for more details. -- -- You should have received a copy of the GNU Lesser General Public -- License along with this library; if not, write to the Free Software -- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA module UI.HSCurses.Widgets where import Control.Exception (assert) #if MIN_VERSION_exceptions(0,6,0) import Control.Monad.Catch (MonadMask) #else import Control.Monad.Catch (MonadCatch) #define MonadMask MonadCatch #endif import Control.Monad.Trans import Data.Char import Data.List import Data.Maybe import UI.HSCurses.Logging 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 :: (MonadIO m, MonadMask m) => m () -> Pos -> Size -> a -> m (a, String) type KeyHandler a = Pos -> Size -> a -> IO (Cont a) mkKeyHandler :: (Pos -> Size -> a -> a) -> KeyHandler a mkKeyHandler f pos sz w = return (Cont (f pos sz w)) -- -- Drawing -- data DrawingHint = DHNormal | DHFocus | DHActive deriving (Eq, Show, Ord) data DrawingStyle = DStyle { dstyle_normal :: CursesH.CursesStyle , dstyle_focus :: CursesH.CursesStyle , dstyle_active :: CursesH.CursesStyle } deriving (Eq, Show) mkDrawingStyle :: CursesH.CursesStyle -> DrawingStyle mkDrawingStyle defStyle = let revStyle = CursesH.changeCursesStyle defStyle [CursesH.Reverse] in DStyle { dstyle_normal = defStyle , dstyle_focus = revStyle , dstyle_active = revStyle } defaultDrawingStyle :: DrawingStyle defaultDrawingStyle = mkDrawingStyle CursesH.defaultCursesStyle _draw :: DrawingHint -> DrawingStyle -> IO a -> IO a _draw DHActive sty io = CursesH.withStyle (dstyle_active sty) io _draw DHNormal sty io = CursesH.withStyle (dstyle_normal sty) io _draw DHFocus sty io = CursesH.withStyle (dstyle_focus sty) io -- -- Helper functions for scrolling -- scrollFactor :: Double scrollFactor = 0.8 scrollBy :: Int -> Int scrollBy displayLen = let amount = floor ((fromInteger . toInteger) displayLen * scrollFactor) in max (displayLen - 1) (min 1 amount) -- returns the new offset for scrolling in forward direction -- dataLen: total number of data items -- offset: the index of the first data item shown on the current page -- displayLen: the number of data items that is shown in one page scrollForward :: Int -> Int -> Int -> Int scrollForward dataLen offset displayLen = if offset + displayLen >= dataLen then offset else min (offset + scrollBy displayLen) (dataLen - displayLen) -- returns the new offset for scrolling in backward direction. -- parameters as for scrollForward scrollBackward :: t -> Int -> Int -> Int scrollBackward _ offset displayLen = if offset == 0 then offset else max (offset - scrollBy displayLen) 0 -- -- EmptyWidget -- data EmptyWidget = EmptyWidget Size instance Widget EmptyWidget where draw _ _ _ _ = return () minSize (EmptyWidget sz) = sz -- -- An opaque widget -- data OpaqueWidget = OpaqueWidget Size instance Widget OpaqueWidget where draw (y,x) (h,w) _ _ = let draw' n = do Curses.wMove Curses.stdScr (y+n) x CursesH.drawLine w "" in do mapM draw' (take h [0..]) Curses.refresh minSize (OpaqueWidget sz) = sz -- -- Widget for text input -- data EditWidget = EditWidget { ew_content :: String, ew_xoffset :: Int, -- content!!xoffset is the 1st char shown ew_xcursor :: Int, -- cursor position ew_history :: [String], ew_historyIndex :: Int, ew_historySavedContent :: Maybe String, ew_options :: EditWidgetOptions } ew_contentPos :: EditWidget -> Int ew_contentPos ew = ew_xcursor ew + ew_xoffset ew instance Widget EditWidget where draw = drawEditWidget minSize ew = (1, ewopt_minWidth $ ew_options ew) instance ActiveWidget EditWidget where activate = activateEditWidget data EditWidgetOptions = EWOptions { ewopt_keyHandlers :: [(Curses.Key, KeyHandler EditWidget)], ewopt_minWidth :: Int, ewopt_style :: DrawingStyle } defaultEWOptions :: EditWidgetOptions defaultEWOptions = EWOptions { ewopt_keyHandlers = editWidgetKeyHandlers, ewopt_minWidth = 8, ewopt_style = defaultDrawingStyle } newEditWidget :: EditWidgetOptions -> String -> EditWidget newEditWidget opts = editWidgetSetContent (EditWidget { ew_content = "", ew_xoffset = 0, ew_xcursor = 0, ew_history = [], ew_historyIndex = -1, ew_historySavedContent = Nothing, ew_options = opts }) editWidgetGoLeft :: Pos -> Size -> EditWidget -> IO (Cont EditWidget) editWidgetGoLeft = mkKeyHandler editWidgetGoLeft' editWidgetGoRight :: Pos -> Size -> EditWidget -> IO (Cont EditWidget) editWidgetGoRight = mkKeyHandler editWidgetGoRight' editWidgetDeleteLeft :: Pos -> Size -> EditWidget -> IO (Cont EditWidget) editWidgetDeleteLeft = mkKeyHandler editWidgetDeleteLeft' editWidgetDeleteUnderCursor :: Pos -> Size -> EditWidget -> IO (Cont EditWidget) editWidgetDeleteUnderCursor = mkKeyHandler editWidgetDeleteUnderCursor' editWidgetDeleteToEnd :: Pos -> Size -> EditWidget -> IO (Cont EditWidget) editWidgetDeleteToEnd = mkKeyHandler editWidgetDeleteToEnd' editWidgetGoHome :: Pos -> Size -> EditWidget -> IO (Cont EditWidget) editWidgetGoHome = mkKeyHandler editWidgetGoHome' editWidgetGoEnd :: Pos -> Size -> EditWidget -> IO (Cont EditWidget) editWidgetGoEnd = mkKeyHandler editWidgetGoEnd' editWidgetHistoryUp :: Pos -> Size -> EditWidget -> IO (Cont EditWidget) editWidgetHistoryUp = mkKeyHandler editWidgetHistoryUp' editWidgetHistoryDown :: Pos -> Size -> EditWidget -> IO (Cont EditWidget) editWidgetHistoryDown = mkKeyHandler editWidgetHistoryDown' editWidgetKeyHandlers :: [(Curses.Key, Pos -> Size -> EditWidget -> IO (Cont EditWidget))] editWidgetKeyHandlers = [(Curses.KeyLeft, editWidgetGoLeft), (Curses.KeyRight, editWidgetGoRight), (Curses.KeyBackspace, editWidgetDeleteLeft), (Curses.KeyChar '\^D', editWidgetDeleteUnderCursor), (Curses.KeyDC, editWidgetDeleteUnderCursor), (Curses.KeyChar '\^K', editWidgetDeleteToEnd), (Curses.KeyHome, editWidgetGoHome), (Curses.KeyChar '\^A', editWidgetGoHome), (Curses.KeyEnd, editWidgetGoEnd), (Curses.KeyChar '\^E', editWidgetGoEnd), (Curses.KeyChar '\r', editWidgetFinish), (Curses.KeyChar '\t', editWidgetFinish), (Curses.KeyUp, editWidgetHistoryUp), (Curses.KeyDown, editWidgetHistoryDown) ] editWidgetGetContent :: EditWidget -> String editWidgetGetContent ew = ew_content ew editWidgetSetContent :: EditWidget -> String -> EditWidget editWidgetSetContent ew s = addToHistory (ew { ew_content = s, ew_xoffset = 0, ew_xcursor = 0 }) s editWidgetGetOptions :: EditWidget -> EditWidgetOptions editWidgetGetOptions ew = ew_options ew editWidgetSetOptions :: EditWidget -> EditWidgetOptions -> EditWidget editWidgetSetOptions ew opts = ew { ew_options = opts } drawEditWidget :: Pos -> Size -> DrawingHint -> EditWidget -> IO () drawEditWidget (y, x) (_, width) hint ew = _draw hint (ewopt_style . ew_options $ ew) $ do Curses.wMove Curses.stdScr y x CursesH.drawLine width (drop (ew_xoffset ew) $ ew_content ew) Curses.refresh activateEditWidget :: (MonadIO m, MonadMask m) => m () -> Pos -> Size -> EditWidget -> m (EditWidget, String) activateEditWidget refresh pos@(y, x) sz@(_, width) ew = CursesH.withCursor Curses.CursorVisible $ processKey ew where processKey ex = do liftIO $ drawLocal ex k <- CursesH.getKey refresh case lookup k (ewopt_keyHandlers $ ew_options ex) of Nothing -> case k of Curses.KeyChar c | isAscii c && isPrint c -> processKey $ insertChar ex c _ -> processKey ex Just f -> do x' <- liftIO $ f pos sz ex case x' of Cont ex' -> processKey ex' Done ex' -> do liftIO $ drawEditWidget pos sz DHActive ex' return (ex', editWidgetGetContent ex') insertChar ew' c = let pos' = ew_contentPos ew' oldContent = ew_content ew' newContent = take pos' oldContent ++ (c : drop pos' oldContent) in editWidgetGoRight' pos' sz (ew' { ew_content = newContent }) drawLocal ew' = _draw DHActive (ewopt_style . ew_options $ ew') $ do Curses.wMove Curses.stdScr y x CursesH.drawLine width (drop (ew_xoffset ew') $ ew_content ew') Curses.wMove Curses.stdScr y (x + ew_xcursor ew') Curses.refresh editWidgetGoLeft' :: t -> t1 -> EditWidget -> EditWidget editWidgetGoLeft' _ _ ew = let newXcursor = max (ew_xcursor ew - 1) 0 newXoffset = if ew_xcursor ew == 0 then max (ew_xoffset ew - 1) 0 else ew_xoffset ew in ew { ew_xoffset = newXoffset, ew_xcursor = newXcursor } editWidgetGoRight' :: t -> (t1, Int) -> EditWidget -> EditWidget editWidgetGoRight' _ (_, width) ew = let len = length (ew_content ew) lastChar = len - ew_xoffset ew - 1 newXcursor = minimum [ew_xcursor ew + 1, lastChar + 1, width - 1] newXoffset = if ew_xcursor ew == width - 1 then min (ew_xoffset ew + 1) (len - width + 1) else ew_xoffset ew in ew { ew_xoffset = newXoffset, ew_xcursor = newXcursor } editWidgetDeleteLeft' :: Pos -> Size -> EditWidget -> EditWidget editWidgetDeleteLeft' pos sz ew = let cpos = ew_contentPos ew - 1 oldContent = ew_content ew newContent = take cpos oldContent ++ drop (cpos+1) oldContent ew' = editWidgetGoLeft' pos sz (ew { ew_content = newContent }) in if ew_xcursor ew == 0 && ew_xoffset ew /= 0 then editWidgetGoRight' pos sz (editWidgetGoLeft' pos sz ew') else ew' editWidgetDeleteUnderCursor' :: t -> t1 -> EditWidget -> EditWidget editWidgetDeleteUnderCursor' _ _ ew = let pos = ew_contentPos ew oldContent = ew_content ew newContent = take pos oldContent ++ drop (pos+1) oldContent in ew { ew_content = newContent } editWidgetDeleteToEnd' :: t -> t1 -> EditWidget -> EditWidget editWidgetDeleteToEnd' _ _ ew = let pos = ew_contentPos ew oldContent = ew_content ew newContent = take pos oldContent in ew { ew_content = newContent } editWidgetGoHome' :: t -> t1 -> EditWidget -> EditWidget editWidgetGoHome' _ _ ew = ew { ew_xcursor = 0, ew_xoffset = 0 } editWidgetGoEnd' :: Pos -> Size -> EditWidget -> EditWidget editWidgetGoEnd' pos sz ew = let cpos = ew_contentPos ew len = length (ew_content ew) in if cpos == len then ew else editWidgetGoEnd' pos sz (editWidgetGoRight' pos sz ew) editWidgetFinish :: (Monad m) => t -> t1 -> EditWidget -> m (Cont EditWidget) editWidgetFinish _ _ ew = return (Done (addToHistory ew (ew_content ew))) maxHistoryLength :: Int maxHistoryLength = 50 addToHistory :: EditWidget -> [Char] -> EditWidget addToHistory ew s = let newHist = if not (null s) then take maxHistoryLength (s : ew_history ew) else ew_history ew in ew { ew_history = newHist, ew_historyIndex = -1, ew_historySavedContent = Nothing } editWidgetHistoryUp' :: t -> t1 -> EditWidget -> EditWidget editWidgetHistoryUp' _ _ ew = editWidgetHistory (+) ew editWidgetHistoryDown' :: t -> t1 -> EditWidget -> EditWidget editWidgetHistoryDown' _ _ ew = editWidgetHistory (-) ew -- ew_historyList: list of history items, i.e. non-null strings which were -- entered into the widget and confirmed with ENTER or which were added -- via editWidgetSetContent. -- ew_historyIndex: the index of the history item shown in the widget. The -- value -1 means that the value saved in ew_historySavedContent should -- be shown. editWidgetHistory :: (Num t) => (Int -> t -> Int) -> EditWidget -> EditWidget editWidgetHistory op ew = let i = ew_historyIndex ew l = ew_history ew j = i `op` 1 in if j >= 0 && j < length l then let savedContent = case ew_historySavedContent ew of Nothing -> Just (ew_content ew) x -> x in ew { ew_historyIndex = j, ew_content = l!!j, ew_historySavedContent = savedContent, ew_xcursor = 0, ew_xoffset = 0 } else if j == -1 then case ew_historySavedContent ew of Nothing -> ew Just x -> ew { ew_content = x, ew_historyIndex = j, ew_xcursor = 0, ew_xoffset = 0 } else ew -- -- Text widget -- data TextWidget = TextWidget { tw_text :: String, tw_yoffset :: Int, tw_xoffset :: Int, tw_options :: TextWidgetOptions } deriving (Eq, Show) instance Widget TextWidget where draw = drawTextWidget minSize tw = case twopt_size $ tw_options tw of TWSizeDefault -> let l = lines (tw_text tw) in (length l, if null l then 0 else maximum (map length l)) TWSizeFixed sz -> sz data TextWidgetSize = TWSizeDefault -- minimal size determined by content | TWSizeFixed Size -- minimal size is fixed, content is -- possibly cut off deriving (Eq, Show) {- | Autowrap -- minimal width determined by content, -- but lines are wrapped if necessary -} data TextWidgetOptions = TWOptions { twopt_size :: TextWidgetSize, twopt_style :: DrawingStyle, twopt_halign :: HAlignment } deriving (Eq, Show) defaultTWOptions :: TextWidgetOptions defaultTWOptions = TWOptions { twopt_size = TWSizeDefault, twopt_style = defaultDrawingStyle, twopt_halign = AlignLeft } newTextWidget :: TextWidgetOptions -> String -> TextWidget newTextWidget opts s = TextWidget { tw_text = s, tw_yoffset = 0, tw_xoffset = 0, tw_options = opts } drawTextWidget :: Pos -> Size -> DrawingHint -> TextWidget -> IO () drawTextWidget (y, x) (height, width) hint tw = let ly = take height $ drop (tw_yoffset tw) (lines (tw_text tw)) l = take height $ (map (drop (tw_xoffset tw)) ly ++ repeat []) l' = map (align (twopt_halign $ tw_options tw) width ' ') l in --trace ("drawing text widget at " ++ show pos ++ " with size " ++ show sz) $ do _draw hint (twopt_style . tw_options $ tw) (mapM drawLine $ zip l' [0..]) Curses.refresh where drawLine (s, i) = do Curses.wMove Curses.stdScr (y + i) x CursesH.drawLine width s textWidgetGetText :: TextWidget -> String textWidgetGetText = tw_text textWidgetSetText :: TextWidget -> String -> TextWidget textWidgetSetText tw s = tw { tw_text = s } textWidgetScrollDown :: Size -> TextWidget -> TextWidget textWidgetScrollDown (h, _) tw = let dataLen = length $ lines (tw_text tw) offset = tw_yoffset tw in tw { tw_yoffset = scrollForward dataLen offset h } textWidgetScrollUp :: Size -> TextWidget -> TextWidget textWidgetScrollUp (h, _) tw = let dataLen = length $ lines (tw_text tw) offset = tw_yoffset tw in tw { tw_yoffset = scrollBackward dataLen offset h } textWidgetScrollLeft :: Size -> TextWidget -> TextWidget textWidgetScrollLeft (_, w) tw = let dataLen = length $ lines (tw_text tw) offset = tw_xoffset tw in tw { tw_xoffset = scrollBackward dataLen offset w } textWidgetScrollRight :: Size -> TextWidget -> TextWidget textWidgetScrollRight (_, w) tw = let dataLen = length $ lines (tw_text tw) offset = tw_xoffset tw in tw { tw_xoffset = scrollForward dataLen offset w } -- -- Table widget -- data TableCell = forall w. Widget w => TableCell w | forall w. ActiveWidget w => ActiveTableCell w isActive :: TableCell -> Bool isActive (TableCell _) = False isActive (ActiveTableCell _) = True instance Widget TableCell where draw pos sz hint (TableCell w) = draw pos sz hint w draw pos sz hint (ActiveTableCell w) = draw pos sz hint w minSize (TableCell w) = minSize w minSize (ActiveTableCell w) = minSize w _activateTableCell :: (MonadIO m, MonadMask m) => m () -> Pos -> Size -> TableCell -> m (TableCell, String) _activateTableCell _ _ _ (TableCell _) = error "_activateTableCell: cannot activate non-active cell!" _activateTableCell refresh pos sz (ActiveTableCell w) = do (new, res) <- activate refresh pos sz w return (ActiveTableCell new, res) type Row = [TableCell] singletonRow :: TableCell -> Row singletonRow tc = [tc] getCellWidget :: TableWidget -> (Int, Int) -> TableCell getCellWidget tbw (row, col) = (tbw_rows tbw) !! row !! col setCellWidget :: TableWidget -> (Int, Int) -> TableCell -> TableWidget setCellWidget tbw (rowIndex, colIndex) w = let rows = tbw_rows tbw row = rows !! rowIndex newRow = listReplace row w colIndex newRows = listReplace rows newRow rowIndex in tbw { tbw_rows = newRows } data TableWidget = TableWidget { tbw_rows :: [Row], tbw_colOffset :: Int, tbw_pos :: Maybe Pos, tbw_options :: TableWidgetOptions } data FillRow = First | Last | None deriving (Eq,Show) data TableWidgetOptions = TBWOptions { tbwopt_fillCol :: Maybe Int, tbwopt_fillRow :: FillRow, tbwopt_activeCols :: [Int], tbwopt_minSize :: Size } deriving (Eq, Show) defaultTBWOptions :: TableWidgetOptions defaultTBWOptions = TBWOptions { tbwopt_fillCol = Nothing, tbwopt_fillRow = None, tbwopt_activeCols = [], tbwopt_minSize = (4, 10) } instance Widget TableWidget where draw = drawTableWidget minSize = tbwopt_minSize . tbw_options newTableWidget :: TableWidgetOptions -> [Row] -> TableWidget newTableWidget opts rows = TableWidget { tbw_rows = rows, tbw_colOffset = 0, tbw_pos = findFirstActiveCell rows opts, tbw_options = opts } data TableWidgetDisplayInfo = TBWDisplayInfo { tbwdisp_height :: Int -- height of the display area , tbwdisp_width :: Int -- width of the display area , tbwdisp_firstVis :: Int -- index of the first row visible , tbwdisp_lastVis :: Int -- index of the last row visible , tbwdisp_rows :: [Row] -- the rows which are visible , tbwdisp_nrows :: Int -- the number of rows visible , tbwdisp_heights :: [Int] -- the heights of the visible rows , tbwdisp_widths :: [Int] -- the widths of the visible rows -- free space at the right side (xoffset, size) , tbwdisp_rightMargin :: Maybe (Int, Size) } tableWidgetDisplayInfo :: Size -> TableWidget -> TableWidgetDisplayInfo tableWidgetDisplayInfo (height, width) tbw = assert (isQuadratic (tbw_rows tbw)) $ let allRows = tbw_rows tbw ncols = length (allRows!!0) colOffset = tbw_colOffset tbw allHeights = minSpaces getHeight allRows heights' = drop colOffset allHeights nrows = getNRows heights' 0 0 rows = take nrows $ drop colOffset allRows (heights, heightDummy) = let hs = take nrows heights' s = sum hs d = height - s in case tbwopt_fillRow $ tbw_options tbw of First -> (applyToFirst (+d) hs, 0) Last -> (applyToLast (+d) hs, 0) None -> (hs, d) widths' = minSpaces getWidth (transpose $ tbw_rows tbw) (widths, rightMargin) = if sum widths' > width then error ("table 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 :: (MonadIO m, MonadMask m) => m () -> Pos -> Size -> DrawingHint -> TableWidget -> m (TableWidget, Maybe String) tableWidgetActivateCurrent refresh (y, x) sz _ tbw = case tbw_pos tbw of Nothing -> do debug "tableWidgetActivateCurrent: pos=Nothing" return (tbw, Nothing) Just p -> let w = getCellWidget tbw p in if not $ isActive w then do debug "tableWidgetActivateCurrent: not active" return (tbw, Nothing) else activate' w p where activate' widget colyx@(coly, colx) = let info = tableWidgetDisplayInfo sz tbw vcol = colx vrow = coly - tbwdisp_firstVis info heights = tbwdisp_heights info widths = tbwdisp_widths info h = heights !! vrow w = widths !! vcol yoffset = sum (take vrow heights) xoffset = sum (take vcol widths) in do (new, res) <- _activateTableCell refresh (y+yoffset, x+xoffset) (h, w) widget return (setCellWidget tbw colyx new, Just res) tableWidgetGoLeft :: Size -> TableWidget -> TableWidget tableWidgetGoLeft = tableWidgetMove DirLeft tableWidgetGoRight :: Size -> TableWidget -> TableWidget tableWidgetGoRight = tableWidgetMove DirRight tableWidgetGoUp :: Size -> TableWidget -> TableWidget tableWidgetGoUp = tableWidgetMove DirUp tableWidgetGoDown :: Size -> TableWidget -> TableWidget tableWidgetGoDown = tableWidgetMove DirDown tableWidgetMove :: Direction -> (Int, Int) -> TableWidget -> TableWidget tableWidgetMove dir sz tbw = let pos = tbw_pos tbw opts = tbw_options tbw nrows = length (tbw_rows tbw) in case pos of Nothing -> tbw Just p -> case findNextActiveCell opts nrows p dir of Nothing -> tbw newP@(Just (y, _)) -> tableWidgetMakeVisible (tbw {tbw_pos=newP}) sz y tableWidgetMakeVisible :: TableWidget -> (Int, Int) -> Int -> TableWidget tableWidgetMakeVisible tbw sz@(_,_) y = let info = tableWidgetDisplayInfo sz tbw firstVis = tbwdisp_firstVis info lastVis = tbwdisp_lastVis info in if y < firstVis then tableWidgetMakeVisible (tableWidgetScrollUp sz tbw) sz y else if y > lastVis then tableWidgetMakeVisible (tableWidgetScrollDown sz tbw) sz y else tbw findFirstActiveCell :: [Row] -> TableWidgetOptions -> Maybe Pos findFirstActiveCell rows opts = let nrows = length rows firstActiveCells = map (\y -> findNextActiveCell opts nrows (y, -1) DirRight) [0..nrows-1] in case catMaybes firstActiveCells of [] -> Nothing (x:_) -> Just x findNextActiveCell :: TableWidgetOptions -> Int -> Pos -> Direction -> Maybe Pos findNextActiveCell opts nrows (y,x) dir = -- trace ("findNextActiveCell (opts=" ++ show opts ++ ", nrows=" ++ show nrows -- ++ ", pos=" ++ show pos ++ ", dir=" ++ show dir) $ let rows = [0..(nrows - 1)] cols = sort (tbwopt_activeCols opts) horiz f = case f cols x rows y of Nothing -> Nothing Just z -> Just (y, z) vert f = case f rows y cols x of Nothing -> Nothing Just z -> Just (z, x) res = case dir of DirLeft-> horiz goLeft DirRight -> horiz goRight DirUp -> vert goLeft DirDown -> vert goRight in --trace ("result of findNextActiveCell: " ++ show res) res where goLeft _ _ rows a | not (a `elem` rows) = Nothing goLeft cols b _ _ = case reverse (takeWhile ( 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)