hscurses-1.5.0.0: UI/HSCurses/Widgets.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- 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.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe
import qualified UI.HSCurses.Curses as Curses
import qualified UI.HSCurses.CursesHelper as CursesH
import UI.HSCurses.Logging
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 too 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'
++ case drop i widths' of
[] -> error "rest unexpectedly empty"
(w : ws) -> (w + width - sum widths') : ws
, 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 (x : xs) =
let rev = NonEmpty.reverse $ x :| xs
(h, t) = (NonEmpty.head rev, NonEmpty.tail rev)
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'
drawRows _ _ _ _ _ _ = return ()
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'
drawCols _ _ _ _ _ _ _ = return ()
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 (< 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 case b of
[] -> error "deleteAt: impossible"
(_ : rest) -> a ++ rest
else error ("deleteAt: illegal index: " ++ show n)