monomer-hagrid-0.4.0.0: src/Monomer/Hagrid.hs
{-# OPTIONS_GHC -Wno-name-shadowing #-}
-- | A datagrid widget for the Monomer UI library.
module Monomer.Hagrid
( -- * Types
HagridCfg,
Column (..),
ColumnAlign (..),
ColumnWidget (..),
ColumnFooterWidget (..),
ColumnSortKey (..),
SortDirection (..),
ItemWithIndex,
ScrollToRowCallback,
-- * Configuration options
estimatedItemHeight,
initialSort,
-- * Hagrid constructors
hagrid,
hagrid_,
-- * Column Constructors
textColumn,
showOrdColumn,
widgetColumn,
-- * Messages
scrollToRow,
)
where
import Control.Applicative ((<|>))
import Control.Lens (ix, (.~), (^.), (^?!))
import Control.Lens.Combinators (non)
import Control.Lens.Lens ((&))
import Control.Lens.Operators ((%~))
import Control.Monad as X (forM_)
import Data.Data (Typeable)
import Data.Default (Default, def)
import Data.Foldable (foldl')
import Data.Maybe (catMaybes, isNothing, maybeToList)
import Data.Maybe as X (fromMaybe)
import Data.Ord (Down (Down))
import Data.Sequence (Seq ((:<|), (:|>)))
import qualified Data.Sequence as S
import Data.Text (Text)
import qualified Data.Text as T
import Data.Typeable (cast)
import Monomer
import qualified Monomer.Lens as L
import Monomer.Widgets.Container
import Monomer.Widgets.Single
-- | Configuration options for Hagrid widgets.
data HagridCfg s e = HagridCfg
{ cfgEstimatedItemHeight :: Maybe Double,
cfgInitialSort :: Maybe (Int, SortDirection)
}
instance Default (HagridCfg s e) where
def =
HagridCfg
{ cfgEstimatedItemHeight = Nothing,
cfgInitialSort = Nothing
}
instance Semigroup (HagridCfg s e) where
c1 <> c2 =
HagridCfg
{ cfgEstimatedItemHeight = c2.cfgEstimatedItemHeight <|> c1.cfgEstimatedItemHeight,
cfgInitialSort = c2.cfgInitialSort <|> c1.cfgInitialSort
}
instance Monoid (HagridCfg s e) where
mempty = def
-- | Configures the estimated item height. This should be the average row height you expect
-- in your grid (including padding). This is used to show scrollbar size and position when
-- there are lots of rows and so not all the rows have been "inflated" into widgets. More
-- accurate values will improve performance and scrollbar position accuracy.
--
-- The default value is 40, which is roughly the height of a single line of text with the default
-- column padding (10).
estimatedItemHeight :: Double -> HagridCfg s e
estimatedItemHeight h =
def {cfgEstimatedItemHeight = Just h}
-- | Configures the initial sort column and direction.
initialSort ::
-- | The initial sort column (zero-indexed, out of bounds values will have no effect).
Int ->
-- | The initial sort direction.
SortDirection ->
HagridCfg s e
initialSort column direction =
def {cfgInitialSort = Just (column, direction)}
-- | A column definition.
data Column e a = Column
{ -- | The name of the column, displayed in the column header.
name :: Text,
-- | Creates the widget for each cell in the column.
widget :: ColumnWidget e a,
-- | Creates the widget for the column footer, if any.
footerWidget :: ColumnFooterWidget e a,
-- | How to align the widget within each cell in the column.
align :: ColumnAlign,
-- | Determines if and how the column can be sorted by clicking the column header.
sortKey :: ColumnSortKey a,
-- | The initial width of the column, in pixels. The user can then change the
-- width by dragging the edge of the column header.
initialWidth :: Int,
-- | The minimum allowed width of the column, in pixels.
minWidth :: Int,
-- | The padding to the left and right of the widget in each cell of the column, in pixels (the default is 10).
paddingW :: Double,
-- | The padding above and below the widget in each cell in the column, in pixels (the default is 10).
paddingH :: Double,
-- | An optional event to emit when a user has finished resizing the column. The function receives the new width in pixels.
resizeHandler :: Maybe (Int -> e),
-- | An optional event to emit when a user has sorted the column by clicking the header. The function receives the new sort direction.
sortHandler :: Maybe (SortDirection -> e)
}
-- | How to create the widget that displays each cell in a column.
data ColumnWidget e a
= -- | Create a label widget.. The function receives the original item index (i.e.
-- not the index in the sorted list) and the item itself.
LabelWidget (Int -> a -> Text)
| -- | Create a widget of arbitrary type. The function receives the original item
-- index (i.e. not the index in the sorted list) and the item itself.
CustomWidget (forall s. (WidgetModel s) => Int -> a -> WidgetNode s e)
-- | How to create the footer widget for a column.
data ColumnFooterWidget e a
= -- | No footer widget for this column.
NoFooterWidget
| -- | Create a footer widget. The function receives the items in their current sort
-- order, and also along with each item it's original (unsorted) index.
CustomFooterWidget (forall s. (WidgetModel s) => Seq (ItemWithIndex a) -> WidgetNode s e)
-- | How to align the widget within each cell of a column.
data ColumnAlign
= ColumnAlignLeft
| ColumnAlignRight
deriving (Eq, Show)
-- | Whether a column can be sorted by the user clicking the column header, and if so, how.
data ColumnSortKey a
= -- | Means that a column can't be sorted.
DontSort
| -- | Means that a column can be sorted, using the specified sort key function.
forall b. (Ord b) => SortWith (a -> b)
-- | Whether a column is being sorted in ascending or descending order.
data SortDirection
= SortAscending
| SortDescending
deriving (Eq, Show)
-- | A item in the grid, with its row index.
type ItemWithIndex a = (a, Int)
-- | Picks an item to scroll to, based on the sorted or original grid contents.
type ScrollToRowCallback a =
-- | The items in the grid, in the originally provided order, along with each item's index
-- in the current grid order.
Seq (ItemWithIndex a) ->
-- | The row to scroll to, as an index into the sorted items (e.g. 0 is always the first row
-- in the grid, regardless of the current order). 'Nothing' will cancel the scroll.
Maybe Int
data HagridEvent e
= ContentScrollChange ScrollStatus
| OrderByColumn Int
| ResizeColumn Int Int
| ResizeColumnFinished Int
| forall a. (Typeable a) => ScrollToRow (ScrollToRowCallback a)
| ScrollToRect Rect
| ParentEvent e
data HagridModel a = HagridModel
{ sortedItems :: Seq (ItemWithIndex a),
columns :: [ModelColumn],
sortColumn :: Maybe (Int, SortDirection),
mdlEstimatedItemHeight :: Double
}
deriving (Eq, Show)
data ModelColumn = ModelColumn
{ currentWidth :: Int,
name :: Text
}
deriving (Eq, Show)
-- | The state of the header or footer.
data HeaderFooterState = HeaderFooterState
{ -- | The width of each column.
columnWidths :: [Int],
-- | The horizontal scroll position: always matches the content pane horizontal scroll position.
offsetX :: Double
}
deriving (Eq, Show)
newtype HeaderFooterEvent = SetOffsetX Double
data HeaderDragHandleState = HeaderDragHandleState
{ dragStartMouseX :: Double,
dragStartColumnW :: Int
}
deriving (Eq, Show)
data ContentPaneModel a = ContentPaneModel
{ -- | The width of each column.
columnWidths :: [Int],
-- | The visible area (relative to the content pane).
visibleArea :: Rect,
-- | The index in items of the special row that we try and keep in the same position
-- (relative to the viewport) when items get resized.
fixedRowIndex :: Int,
-- | The Y position of the fixed row within the viewport. When items get resized, we try
-- and keep this value fixed: it should only change when the user scrolls the viewport itself.
fixedRowViewportOffset :: Double,
-- | How many items there are before the inflated items.
itemsBeforeInflated :: Int,
-- | The items that have been inflated into actual widgets.
inflatedItems :: Seq (ItemWithIndex a),
-- | How many items there are after the inflated items.
itemsAfterInflated :: Int,
phase :: ContentPanePhase
}
deriving (Eq, Show)
data ContentPanePhase
= ContentPaneIdle
| ContentPaneReinflating
deriving (Eq, Show)
data ContentPaneEvent e
= SetVisibleArea {visibleArea :: Rect}
| InnerResizeComplete
| ContentPaneParentEvent e
| forall a. (Typeable a) => ContentPaneScrollToRow (ScrollToRowCallback a)
-- | Creates a hagrid widget, using the default configuration.
hagrid ::
forall a s e.
(CompositeModel a, WidgetModel s, WidgetEvent e) =>
-- | The definitions for each column in the grid.
[Column e a] ->
-- | The items for each row in the grid.
Seq a ->
WidgetNode s e
hagrid = hagrid_ def
-- | Creates a hagrid widget, using the given configuration.
hagrid_ ::
forall a s e.
(CompositeModel a, WidgetModel s, WidgetEvent e) =>
[HagridCfg s e] ->
-- | The definitions for each column in the grid.
[Column e a] ->
-- | The items for each row in the grid.
Seq a ->
WidgetNode s e
hagrid_ cfg columnDefs items = widget
where
-- todo: accept lens ?
widget =
compositeD_
"Hagrid.Root"
(WidgetValue (initialModel cfg columnDefs items))
buildUI
handleEvent
[compositeMergeModel mergeModel]
buildUI :: UIBuilder (HagridModel a) (HagridEvent e)
buildUI _wenv model = tree
where
tree =
vstack
[ headerPane columnDefs model `nodeKey` headerPaneKey,
contentScroll
`styleBasic` [sizeReqW useExtra, sizeReqH useExtra]
`nodeKey` contentScrollKey,
footerPane columnDefs model `nodeKey` footerPaneKey
]
contentScroll =
scroll_ [onChange ContentScrollChange] $
contentPaneOuter columnDefs model `nodeKey` contentPaneOuterKey
useExtra =
SizeReq
{ _szrFixed = 0,
_szrFlex = 0,
_szrExtra = 1,
_szrFactor = 1
}
handleEvent :: EventHandler (HagridModel a) (HagridEvent e) sp e
handleEvent _wenv _node model = \case
ScrollToRow callback ->
[Message (WidgetKey contentPaneOuterKey) (ContentPaneScrollToRow callback :: ContentPaneEvent e)]
ScrollToRect rect ->
[Message (WidgetKey contentScrollKey) (ScrollTo rect)]
ContentScrollChange ScrollStatus {scrollDeltaX, scrollDeltaY, scrollVpSize} ->
[ Message (WidgetKey headerPaneKey) (SetOffsetX scrollDeltaX),
Message (WidgetKey contentPaneOuterKey) (SetVisibleArea {visibleArea} :: ContentPaneEvent e),
Message (WidgetKey footerPaneKey) (SetOffsetX scrollDeltaX)
]
where
visibleArea = Rect (-scrollDeltaX) (-scrollDeltaY) scrollVpSize._sW scrollVpSize._sH
OrderByColumn colIndex -> result
where
Column {sortHandler, sortKey} = columnDefs !! colIndex
(sortColumn, sortedItems)
| Just (c, dir) <- model.sortColumn,
c == colIndex =
let sortColumn = Just (colIndex, flipSortDirection dir)
sortedItems = S.reverse model.sortedItems
in (sortColumn, sortedItems)
| otherwise =
let sortColumn = Just (colIndex, SortAscending)
sortedItems = sortItems columnDefs sortColumn model.sortedItems
in (sortColumn, sortedItems)
result = case sortKey of
DontSort -> []
SortWith _ -> Model model {sortColumn, sortedItems} : handler
handler =
Report <$> maybeToList (sortHandler <*> (snd <$> sortColumn))
ResizeColumn colIndex newWidth ->
[Model model {columns = model.columns & ix colIndex %~ (\c -> c {currentWidth = newWidth})}]
ResizeColumnFinished colIndex -> result
where
ModelColumn {currentWidth} = model.columns !! colIndex
Column {resizeHandler} = columnDefs !! colIndex
result =
Report <$> maybeToList (resizeHandler <*> Just currentWidth)
ParentEvent e ->
[Report e]
-- If the column names have not changed then preseve the column widths and sort
-- order too, otherwise unrelated model changes will reset the column widths/sort.
mergeModel :: MergeModelHandler (HagridModel a) (HagridEvent e) s
mergeModel _wenv _parentModel oldModel newModel = resultModel
where
resultModel
| columnNames oldModel == columnNames newModel =
newModel
{ columns = oldModel.columns,
sortColumn = oldModel.sortColumn,
sortedItems = sortItems columnDefs oldModel.sortColumn newModel.sortedItems
}
| otherwise =
newModel
columnNames m =
(.name) <$> m.columns
drawSortIndicator :: Renderer -> Rect -> Maybe Color -> SortDirection -> IO ()
drawSortIndicator renderer rect color dir = drawCmd
where
drawCmd = case dir of
SortAscending -> drawTriangle renderer p2 p4 p3 color
SortDescending -> drawTriangle renderer p1 p2 p4 color
Rect x y w h = rect
p1 = Point x y
p2 = Point (x + w) y
p3 = Point x (y + h)
p4 = Point (x + w) (y + h)
accentColor :: WidgetEnv s e -> Color
accentColor wenv = transColor
where
style = wenv ^. L.theme . L.basic . L.btnStyle
color = fromMaybe (rgb 255 255 255) (_sstText style >>= _txsFontColor)
transColor = color {_colorA = 0.7}
headerPane :: forall e a. (WidgetEvent e) => [Column e a] -> HagridModel a -> WidgetNode (HagridModel a) (HagridEvent e)
headerPane columnDefs model = makeNode (initialHeaderFooterState model)
where
makeNode :: HeaderFooterState -> WidgetNode (HagridModel a) (HagridEvent e)
makeNode state = node
where
node =
defaultWidgetNode "Hagrid.HeaderPane" (makeWidget state)
& L.children .~ S.fromList childWidgets
childWidgets =
mconcat (zipWith3 childWidgetPair [0 ..] columnDefs model.columns)
childWidgetPair i columnDef column = [btn, handle]
where
btn = headerButton i columnDef
handle = headerDragHandle i columnDef column
makeWidget :: HeaderFooterState -> Widget (HagridModel a) (HagridEvent e)
makeWidget state = container
where
container =
createHeaderFooter
state
makeWidget
def {containerResize = resize, containerRenderAfter = renderAfter}
resize _wenv node viewport _children = (resultNode node, assignedAreas)
where
Rect l t _w h = viewport
widgetWidths = do
-- center the drag handle inbetween the columns
let wDeltas = dragHandleWidth / 2 : repeat dragHandleWidth
(wd, w) <- zip wDeltas ((.currentWidth) <$> model.columns)
[fromIntegral w - wd, dragHandleWidth]
(assignedAreas, _) = foldl' assignArea (mempty, l) widgetWidths
assignArea (areas, colX) columnWidth =
(areas :|> Rect colX t columnWidth h, colX + columnWidth)
renderAfter wenv node renderer =
forM_ model.sortColumn (renderSortIndicator wenv node renderer)
renderSortIndicator wenv node renderer (sortCol, sortDirection) = do
drawSortIndicator renderer indRect (Just (accentColor wenv)) sortDirection
where
Rect l t w h = node ^?! L.children . ix (sortCol * 2) . L.info . L.viewport
style = wenv ^. L.theme . L.basic . L.btnStyle
size = style ^. L.text . non def . L.fontSize . non def
-- put triangle corners at integer positions because it looks nicer
indW = ceilingDouble (unFontSize size * 2 / 3)
pad = ceilingDouble (unFontSize size * 2 / 9)
indT = case sortDirection of
SortAscending -> t + h - pad - indW
SortDescending -> t + pad
indL = l + w + state.offsetX - indW - pad
indRect = Rect indL indT indW indW
headerButton :: (WidgetEvent e) => Int -> Column e a -> WidgetNode (HagridModel a) (HagridEvent e)
headerButton colIndex columnDef =
button_ columnDef.name (OrderByColumn colIndex) [ellipsis]
`styleBasic` [radius 0]
footerPane ::
forall e a.
(CompositeModel a, WidgetEvent e) =>
[Column e a] ->
HagridModel a ->
WidgetNode (HagridModel a) (HagridEvent e)
footerPane columnDefs model = makeNode (initialHeaderFooterState model)
where
makeNode :: HeaderFooterState -> WidgetNode (HagridModel a) (HagridEvent e)
makeNode state = node
where
node =
defaultWidgetNode "Hagrid.FooterPane" (makeWidget state)
& L.children .~ S.fromList (catMaybes childWidgets)
childWidgets :: [Maybe (WidgetNode (HagridModel a) (HagridEvent e))]
childWidgets = footerWidgetNode model.sortedItems . (.footerWidget) <$> columnDefs
makeWidget :: HeaderFooterState -> Widget (HagridModel a) (HagridEvent e)
makeWidget state = container
where
container =
createHeaderFooter
state
makeWidget
def {containerResize = resize}
resize _wenv node viewport _children = (resultNode node, assignedAreas)
where
Rect l t _w h = viewport
(assignedAreas, _) = foldl' assignArea (mempty, l) (zip childWidgets model.columns)
assignArea (areas, colX) (childWidget, ModelColumn {currentWidth}) = (newAreas, newColX)
where
newAreas
| isNothing childWidget = areas
| otherwise = areas :|> Rect colX t (fromIntegral currentWidth) h
newColX = colX + fromIntegral currentWidth
initialHeaderFooterState :: HagridModel a -> HeaderFooterState
initialHeaderFooterState model =
HeaderFooterState
{ columnWidths = (.currentWidth) <$> model.columns,
offsetX = 0
}
createHeaderFooter ::
forall a e.
HeaderFooterState ->
(HeaderFooterState -> Widget (HagridModel a) (HagridEvent e)) ->
Container (HagridModel a) (HagridEvent e) HeaderFooterState ->
Widget (HagridModel a) (HagridEvent e)
createHeaderFooter state makeWidget container =
createContainer
state
container
{ containerChildrenOffset = Just (Point state.offsetX 0),
containerUpdateCWenv = updateCWenv,
containerMerge = merge,
containerHandleMessage = handleMessage,
containerGetSizeReq = getSizeReq,
containerUseScissor = True -- otherwise the buttons extend outside the header when the grid scrolls horizontally
}
where
-- ensures child widgets don't disappear when scrolling
updateCWenv wenv node _cnode _cidx = newWenv
where
style = currentStyle wenv node
carea = getContentArea node style
newWenv = wenv & L.viewport .~ moveRect (Point (-state.offsetX) 0) carea
merge _wenv node _oldNode oldState = resultReqs newNode reqs
where
newNode = node & L.widget .~ makeWidget state {offsetX = oldState.offsetX}
reqs = [ResizeWidgets (node ^. L.info . L.widgetId) | needResize]
needResize = oldState.columnWidths /= state.columnWidths
getSizeReq _wenv _node children = (w, h)
where
w = fixedSize (fromIntegral (sum state.columnWidths) + hScrollFudgeFactor)
h = foldl' sizeReqMergeMax (fixedSize 0) (_wniSizeReqH . _wnInfo <$> children)
handleMessage :: ContainerMessageHandler (HagridModel a) (HagridEvent e)
handleMessage _wenv node _target msg = result
where
handleTypedMessage (SetOffsetX offsetX)
| offsetX == state.offsetX = Nothing
| otherwise =
Just . resultNode $
node & L.widget .~ makeWidget state {offsetX}
result = cast msg >>= handleTypedMessage
headerDragHandle :: (WidgetEvent e) => Int -> Column e a -> ModelColumn -> WidgetNode s (HagridEvent e)
headerDragHandle colIndex columnDef column = tree
where
tree = defaultWidgetNode "Hagrid.HeaderDragHandle" (headerDragHandleWidget Nothing)
headerDragHandleWidget state = single
where
single =
createSingle
state
def
{ singleGetBaseStyle = getBaseStyle,
singleGetSizeReq = getSizeReq,
singleMerge = merge,
singleHandleEvent = handleEvent,
singleRender = render
}
getBaseStyle _wenv _node =
Just def {_styleBasic = Just def {_sstCursorIcon = Just CursorSizeH}}
getSizeReq _wenv _node =
(fixedSize dragHandleWidth, fixedSize dragHandleHeight)
merge _wenv newNode _oldNode oldState =
-- preserve the drag state (this will be called continually as the column resizes)
resultNode $ newNode & L.widget .~ headerDragHandleWidget oldState
handleEvent wenv node _target = \case
ButtonAction (Point _pX _pY) _btn BtnPressed _clicks -> Just result
where
-- todo: only if not focussed? set focus?
result = resultNode newNode
newNode = node & L.widget .~ headerDragHandleWidget newState
newState = Just (HeaderDragHandleState _pX column.currentWidth)
ButtonAction _point _btn BtnReleased _clicks -> Just result
where
result = resultReqs newNode [RaiseEvent (ResizeColumnFinished colIndex)]
newNode = node & L.widget .~ headerDragHandleWidget Nothing
Move (Point _pX _pY) -> Just result
where
result
| Just nw <- newColumnW =
resizeRequest
& L.requests %~ (:|> RaiseEvent (ResizeColumn colIndex nw))
| otherwise =
resultReqs node []
newColumnW = do
HeaderDragHandleState clickX columnW <- state
pure (max columnDef.minWidth (columnW + fromFractional (_pX - clickX)))
_ -> Nothing
where
resizeRequest = widgetResize (node ^. L.widget) wenv node vp (const True)
vp = node ^. L.info . L.viewport
render wenv node renderer = do
drawRect renderer vp (Just (accentColor wenv)) Nothing
where
vp = node ^. L.info . L.viewport
-- | This needs to be at least as big as the width of a vertical scrollbar.
hScrollFudgeFactor :: Double
hScrollFudgeFactor = 20
-- | Composite wrapper to allow creating/removing child widgets during resize.
contentPaneOuter ::
forall a e.
(CompositeModel a, WidgetEvent e) =>
[Column e a] ->
HagridModel a ->
WidgetNode (HagridModel a) (HagridEvent e)
contentPaneOuter columnDefs model =
compositeD_
"Hagrid.ContentPaneOuter"
(WidgetValue initialModel)
buildUI
handleEvent
[compositeMergeModel mergeModel]
where
initialModel =
ContentPaneModel
{ columnWidths = (.currentWidth) <$> model.columns,
visibleArea = Rect 0 0 0 0,
fixedRowIndex = 0,
fixedRowViewportOffset = 0,
itemsBeforeInflated = 0,
inflatedItems = mempty,
itemsAfterInflated = 0,
phase = ContentPaneIdle
}
mergeModel :: MergeModelHandler (ContentPaneModel a) (ContentPaneEvent e) (HagridModel a)
mergeModel _wenv parentModel oldModel newModel =
oldModel {columnWidths, fixedRowIndex, itemsBeforeInflated, inflatedItems, itemsAfterInflated}
where
columnWidths = newModel.columnWidths
fixedRowIndex = min (max 0 (length parentModel.sortedItems - 1)) oldModel.fixedRowIndex
itemsBeforeInflated = min (length parentModel.sortedItems) oldModel.itemsBeforeInflated
itemsAfterInflated = length parentModel.sortedItems - itemsBeforeInflated - length inflatedItems
inflatedItems = takeAt itemsBeforeInflated (length oldModel.inflatedItems) parentModel.sortedItems
buildUI _wenv =
contentPaneInner (S.fromList columnDefs) model
handleEvent _wenv node cpModel = \case
SetVisibleArea visibleArea -> result
where
result = case cpModel.phase of
ContentPaneIdle
| visibleAreaMoved && (startItemsMissing || endItemsMissing) ->
let newModel =
cpModel
{ visibleArea,
fixedRowIndex,
fixedRowViewportOffset,
itemsBeforeInflated = fixedRowIndex,
inflatedItems = mempty,
itemsAfterInflated = length model.sortedItems - fixedRowIndex,
phase = ContentPaneReinflating
}
in [Model newModel]
| visibleAreaMoved ->
[Model cpModel {visibleArea, fixedRowIndex, fixedRowViewportOffset}]
| otherwise -> []
ContentPaneReinflating
| visibleAreaMoved ->
[Model (cpModel :: ContentPaneModel a) {visibleArea}]
| otherwise -> []
(fixedRowIndex, fixedRowViewportOffset) = fixedRow minVisibleY rowHeights model cpModel
(rowsStartY, rowHeights, rowsEndY) = rowPositions node
visibleAreaMoved = not (roundedRectEq visibleArea cpModel.visibleArea)
minVisibleY = visibleArea._rY
maxVisibleY = visibleArea._rY + visibleArea._rH
startItemsMissing = cpModel.itemsBeforeInflated > 0 && minVisibleY < rowsStartY
endItemsMissing = cpModel.itemsAfterInflated > 0 && maxVisibleY > rowsEndY
ContentPaneScrollToRow callback -> result
where
result
| Just typedCb <- cast callback,
Just row <- typedCb indexedItems =
-- set the fixed index to the target row and let the viewport position be sorted out by the
-- adjustment that follows the addition and resizing of the rows around the target row.
let newModel =
cpModel
{ fixedRowIndex = row,
fixedRowViewportOffset = 0,
itemsBeforeInflated = row,
inflatedItems = mempty,
phase = ContentPaneReinflating
}
in [Model newModel]
| otherwise =
[]
indexedItems =
model.sortedItems
& S.mapWithIndex (,)
& S.sortOn (snd . snd)
& fmap (\(sortedIndex, (item, _originalIndex)) -> (item, sortedIndex))
InnerResizeComplete -> result
where
(rowsStartY, rowHeights, rowsEndY) = rowPositions node
fixedRowY = rowsStartY + sum (S.take (cpModel.fixedRowIndex - cpModel.itemsBeforeInflated) rowHeights)
result
| itemsToPrepend > 0 || itemsToAppend > 0 =
let inflatedItems =
takeAt
(cpModel.itemsBeforeInflated - itemsToPrepend)
(itemsToPrepend + length cpModel.inflatedItems + itemsToAppend)
model.sortedItems
itemsBeforeInflated = cpModel.itemsBeforeInflated - itemsToPrepend
itemsAfterInflated = length model.sortedItems - length inflatedItems - itemsBeforeInflated
in [Model cpModel {itemsBeforeInflated, inflatedItems, itemsAfterInflated}]
| otherwise =
-- Once we have finished adding items then, if the added items are not the same size as estimated,
-- the row we want to scroll to might no longer be at the correct position in the viewport, so we
-- need to adjust the scroll position to position it correctly.
let adjustScrollEvt = [Report (ScrollToRect adjustScrollRect) | needAdjustScroll]
adjustScrollRect = Rect (vp._rX + cpModel.visibleArea._rX) (vp._rY + fixedRowY - cpModel.fixedRowViewportOffset) visibleWidth visibleHeight
needAdjustScroll = abs ((fixedRowY - cpModel.visibleArea._rY) - cpModel.fixedRowViewportOffset) >= 1
in [Model cpModel {phase = ContentPaneIdle}] <> adjustScrollEvt
itemsToPrepend = itemsToAdd (fixedRowY - rowsStartY) 1 cpModel.itemsBeforeInflated
itemsToAppend = itemsToAdd (rowsEndY - fixedRowY) 2 cpModel.itemsAfterInflated
itemsToAdd existingItemsHeight f availableItems
| not (null model.sortedItems) && existingItemsHeight < visibleHeight * f =
let n = ceiling ((visibleHeight * f - existingItemsHeight) / model.mdlEstimatedItemHeight)
in min (max 8 (min 64 n)) availableItems
| otherwise = 0
vp = node ^. L.info . L.viewport
visibleWidth = cpModel.visibleArea._rW
visibleHeight = cpModel.visibleArea._rH
ContentPaneParentEvent e ->
[Report (ParentEvent e)]
contentPaneInner ::
forall a e.
(CompositeModel a, WidgetEvent e) =>
Seq (Column e a) ->
HagridModel a ->
ContentPaneModel a ->
WidgetNode (ContentPaneModel a) (ContentPaneEvent e)
contentPaneInner columnDefs model cpModel = node
where
node =
defaultWidgetNode "Hagrid.ContentPaneInner" contentPaneContainer
& L.children .~ rowWidgets
contentPaneContainer =
createContainer
cpModel
def
{ containerMerge = merge,
containerGetSizeReq = getSizeReq,
containerResize = resize
}
rowWidgets = S.mapWithIndex (contentPaneRow columnDefs cpModel) cpModel.inflatedItems
merge _wenv newNode _oldNode oldState = resultReqs newNode reqs
where
reqs = [ResizeWidgets (newNode ^. L.info . L.widgetId) | needResize]
needResize =
oldState.columnWidths /= cpModel.columnWidths
|| oldState.itemsBeforeInflated /= cpModel.itemsBeforeInflated
|| length oldState.inflatedItems /= length cpModel.inflatedItems
|| oldState.itemsAfterInflated /= cpModel.itemsAfterInflated
getSizeReq _wenv _node children = (w, h)
where
w = fixedSize (fromIntegral (sum cpModel.columnWidths))
h = fixedSize (uninflatedHeights + inflatedHeights)
uninflatedHeights = fromIntegral uninflatedItems * model.mdlEstimatedItemHeight
uninflatedItems = cpModel.itemsBeforeInflated + cpModel.itemsAfterInflated
inflatedHeights = sum (_szrFixed . _wniSizeReqH . _wnInfo <$> children)
resize wenv node viewport children = (resultEvts node [InnerResizeComplete], rowAreas)
where
style = currentStyle wenv node
innerVp = fromMaybe def (removeOuterBounds style viewport)
startX = innerVp._rX
startY = innerVp._rY + fromIntegral cpModel.itemsBeforeInflated * model.mdlEstimatedItemHeight
sumColumnWidths = fromIntegral (sum cpModel.columnWidths)
rowAreas = snd (foldl' foldRowAreas (startY, mempty) children)
foldRowAreas (y, areas) child =
(y + h, areas :|> Rect startX y sumColumnWidths h)
where
h = child ^. L.info . L.sizeReqH . L.fixed
contentPaneRow ::
forall a e.
(CompositeModel a, WidgetEvent e) =>
Seq (Column e a) ->
ContentPaneModel a ->
Int ->
ItemWithIndex a ->
WidgetNode (ContentPaneModel a) (ContentPaneEvent e)
contentPaneRow columnDefs cpModel sortedIdx item = tree
where
tree =
defaultWidgetNode "Hagrid.Row" widget
& L.children .~ cellWidgets
widget =
createContainer
(cpModel.columnWidths, item, sortedIdx)
def
{ containerGetSizeReq = getSizeReq,
containerResize = resize,
containerRender = render
}
cellWidgets = do
Column {widget} <- columnDefs
pure (cellWidget item widget)
getSizeReq _wenv _node children = (w, h)
where
w = fixedSize (fromIntegral (sum cpModel.columnWidths))
h = fixedSize (toRowHeight columnDefs children)
resize wenv node viewport children = (resultNode node, cellAreas)
where
style = currentStyle wenv node
innerVp = fromMaybe def (removeOuterBounds style viewport)
startX = innerVp._rX
startY = innerVp._rY
columnWidths = fromIntegral <$> S.fromList cpModel.columnWidths
cellAreas = snd (foldl' foldCellAreas (startX, mempty) (S.zip3 columnWidths columnDefs children))
foldCellAreas (x, areas) (colW, Column {paddingW, paddingH, align}, widget) =
(x + colW, areas :|> Rect chX cellY chW cellH)
where
(chX, chW) = case align of
ColumnAlignLeft -> (cellX, cellW)
ColumnAlignRight -> (cellX + cellW - widgetW, widgetW)
cellX = x + paddingW
cellY = startY + paddingH
cellW = colW - paddingW * 2
cellH = viewport._rH - paddingH * 2
widgetW =
widget
& _wnInfo
& _wniSizeReqW
& (\r -> _szrFixed r + _szrFlex r)
& min cellW
render wenv node renderer = do
drawRect renderer vp bgColor Nothing
drawLine renderer (Point vp._rX (vp._rY + vp._rH)) (Point (vp._rX + vp._rW) (vp._rY + vp._rH)) 1 (Just lineColor)
forM_ (drop 1 colXs) $ \colX -> do
drawLine renderer (Point (vp._rX + colX) vp._rY) (Point (vp._rX + colX) (vp._rY + vp._rH)) 1 (Just lineColor)
where
colXs = scanl (+) 0 (fromIntegral <$> cpModel.columnWidths)
bgColor
| mouseover = Just mouseOverColor
| sortedIdx `mod` 2 == 1 = Just oddRowBgColor
| otherwise = Nothing
vp = node ^. L.info . L.viewport
mouseover = pointInRect mouse vp
mouse = wenv ^. L.inputStatus . L.mousePos
mouseOverColor = (accentColor wenv) {_colorA = 0.3}
oddRowBgColor = (accentColor wenv) {_colorA = 0.1}
lineColor = accentColor wenv
initialModel :: [HagridCfg s e] -> [Column e a] -> Seq a -> HagridModel a
initialModel cfgs columnDefs items = model
where
model =
HagridModel
{ sortedItems = sortItems columnDefs sortColumn (S.zip items (S.fromFunction (length items) id)),
columns = initialColumn <$> columnDefs,
sortColumn,
mdlEstimatedItemHeight = max 1 (fromMaybe 40 cfg.cfgEstimatedItemHeight)
}
cfg = mconcat cfgs
sortColumn
| Just (col, dir) <- cfg.cfgInitialSort,
col >= 0,
col < length columnDefs =
Just (col, dir)
| otherwise = Nothing
initialColumn Column {name, initialWidth, minWidth} =
ModelColumn
{ name,
currentWidth = max minWidth initialWidth
}
-- | When the viewport position changes, this function computes the index and
-- position within the viewport of the new fixed row. This is the first row
-- whose y-position is at least minVisibleY
fixedRow :: Double -> Seq Double -> HagridModel a -> ContentPaneModel a -> (Int, Double)
fixedRow minVisibleY inflatedItemHeights model cpModel = (min maxRow row, offset)
where
(row, offset)
| minVisibleY < inflatedStartY =
let row = ceiling (minVisibleY / model.mdlEstimatedItemHeight)
offset = (fromIntegral row * model.mdlEstimatedItemHeight) - minVisibleY
in (row, offset)
| otherwise =
inflatedItem itemsBeforeInflated inflatedStartY inflatedItemHeights
maxRow = length model.sortedItems - 1
ContentPaneModel {itemsBeforeInflated} = cpModel
inflatedStartY = fromIntegral itemsBeforeInflated * model.mdlEstimatedItemHeight
inflatedItem i y = \case
itemHeight :<| itemHeights
| y + itemHeight >= minVisibleY ->
(i + 1, (y + itemHeight) - minVisibleY)
| otherwise ->
inflatedItem (i + 1) (y + itemHeight) itemHeights
S.Empty ->
let indexInSection = ceiling ((minVisibleY - y) / model.mdlEstimatedItemHeight)
row = i + indexInSection
offset = (y + fromIntegral indexInSection * model.mdlEstimatedItemHeight) - minVisibleY
in (row, offset)
dragHandleWidth :: Double
dragHandleWidth = 4
dragHandleHeight :: Double
dragHandleHeight = 40
headerPaneKey :: Text
headerPaneKey = "Hagrid.headerPane"
contentScrollKey :: Text
contentScrollKey = "Hagrid.contentScroll"
contentPaneOuterKey :: Text
contentPaneOuterKey = "Hagrid.contentPaneOuter"
footerPaneKey :: Text
footerPaneKey = "Hagrid.footerPane"
sortItems ::
[Column e a] ->
Maybe (Int, SortDirection) ->
Seq (ItemWithIndex a) ->
Seq (ItemWithIndex a)
sortItems columnDefs sortColumn items =
case modelSortKey columnDefs sortColumn of
DontSort -> items
SortWith f -> S.sortOn (f . fst) items
modelSortKey :: [Column e a] -> Maybe (Int, SortDirection) -> ColumnSortKey a
modelSortKey columnDefs sortColumn = case sortColumn of
Just (sc, dir)
| Column {sortKey = SortWith f} <- columnDefs !! sc ->
case dir of
SortAscending -> SortWith f
SortDescending -> SortWith (Down . f)
_ ->
DontSort
toRowHeight :: Seq (Column e a) -> Seq (WidgetNode s (ContentPaneEvent e)) -> Double
toRowHeight columnDefs = mergeHeights
where
mergeHeights rowWidgets =
foldl' max 0 (S.zipWith widgetHeight columnDefs rowWidgets)
widgetHeight Column {paddingH} widget =
widget
& _wnInfo
& _wniSizeReqH
& \r -> _szrFixed r + _szrFlex r + paddingH * 2
rowPositions :: forall s e. WidgetNode s e -> (Double, Seq Double, Double)
rowPositions node = (rowsStartY, rowHeights, rowsEndY)
where
vp = node._wnInfo._wniViewport
childVps = _wniViewport . _wnInfo <$> node._wnChildren
rowsStartY = case childVps of
cvp :<| _ -> cvp._rY - vp._rY
_ -> 0
rowsEndY = case childVps of
_ :|> cvp -> (cvp._rY - vp._rY) + cvp._rH
_ -> 0
rowHeights = _rH <$> childVps
takeAt :: Int -> Int -> Seq a -> Seq a
takeAt at len s =
S.take len (S.drop at s)
-- | Creates a column that displays a text value, and is sortable by the text.
textColumn ::
-- | Name of the column, to display in the header.
Text ->
-- | Called with the item for each row to get the text to display for that row.
(a -> Text) ->
Column e a
textColumn name get = (defaultColumn name widget) {sortKey}
where
widget = LabelWidget (const get)
sortKey = SortWith get
-- | Creates a column that displays the result of calling @'show'@ on a value, and is sortable by the value.
showOrdColumn ::
(Show b, Ord b) =>
-- | Name of the column, to display in the header.
Text ->
-- | Called with the item for each row to get the value to display (via @'show'@) and sort by.
(a -> b) ->
Column e a
showOrdColumn name get = (defaultColumn name widget) {sortKey}
where
widget = LabelWidget (const (T.pack . show . get))
sortKey = SortWith get
-- | Creates a column that displays the a custom widget in each cell.
widgetColumn ::
-- | Name of the column, to display in the header.
Text ->
-- | Called with the (original, not sorted) index and the item for each row to get the widget to
-- display for that row.
(forall s. (WidgetModel s) => Int -> a -> WidgetNode s e) ->
Column e a
widgetColumn name get = defaultColumn name (CustomWidget get)
defaultColumn :: Text -> ColumnWidget e a -> Column e a
defaultColumn name widget =
Column
{ name,
widget,
footerWidget = NoFooterWidget,
align = ColumnAlignLeft,
initialWidth = defaultColumnInitialWidth,
sortKey = DontSort,
minWidth = defaultColumnMinWidth,
paddingW = defaultColumnPadding,
paddingH = defaultColumnPadding,
resizeHandler = Nothing,
sortHandler = Nothing
}
cellWidget ::
(CompositeModel a, WidgetEvent e) =>
ItemWithIndex a ->
ColumnWidget e a ->
WidgetNode (ContentPaneModel a) (ContentPaneEvent e)
cellWidget (item, idx) = \case
LabelWidget get -> label_ (get idx item) [ellipsis]
CustomWidget get -> widget
where
widget =
compositeD_ "Hagrid.Cell" (WidgetValue item) buildUI handleEvent []
buildUI _wenv =
get idx
handleEvent _wenv _node _model e =
[Report (ContentPaneParentEvent e)]
footerWidgetNode ::
(CompositeModel a, WidgetEvent e) =>
Seq (ItemWithIndex a) ->
ColumnFooterWidget e a ->
Maybe (WidgetNode (HagridModel a) (HagridEvent e))
footerWidgetNode items = \case
NoFooterWidget -> Nothing
CustomFooterWidget get -> Just widget
where
widget =
compositeD_ "Hagrid.FooterCell" (WidgetValue items) buildUI handleEvent []
buildUI _wenv _model =
get items
handleEvent _wenv _node _model e =
[Report (ParentEvent e)]
-- | Sends a message to the targeted 'hagrid' widget, that causes the
-- widget to scroll such that a specified row becomes visible.
--
-- Note that this is inherently dynamically typed. If the type of the callback
-- does not match the type of the targeted hagrid widget then the message
-- will be ignored.
scrollToRow ::
forall s e sp ep a.
(Typeable a, Typeable e) =>
-- | The widget to target.
WidgetKey ->
-- | Determines which row to scroll to.
ScrollToRowCallback a ->
EventResponse s e sp ep
scrollToRow key row =
Message key (ScrollToRow row :: HagridEvent e)
defaultColumnInitialWidth :: Int
defaultColumnInitialWidth = 100
defaultColumnMinWidth :: Int
defaultColumnMinWidth = 60
defaultColumnPadding :: Double
defaultColumnPadding = 10
flipSortDirection :: SortDirection -> SortDirection
flipSortDirection SortAscending = SortDescending
flipSortDirection SortDescending = SortAscending
ceilingDouble :: Double -> Double
ceilingDouble x = fromIntegral (ceiling x :: Int)
roundedRectEq :: Rect -> Rect -> Bool
roundedRectEq r1 r2 =
roundedEq r1._rX r2._rX
&& roundedEq r1._rY r2._rY
&& roundedEq (r1._rX + r1._rW) (r2._rX + r2._rW)
&& roundedEq (r1._rY + r1._rH) (r2._rY + r2._rH)
where
roundedEq x y = (round x :: Int) == round y