never executed always true always false
    1 {-|
    2 Module: Flaw.UI.ListBox
    3 Description: List box.
    4 License: MIT
    5 -}
    6 
    7 {-# LANGUAGE GADTs, RankNTypes #-}
    8 
    9 module Flaw.UI.ListBox
   10   ( ListBox(..)
   11   , ListBoxColumn(..)
   12   , newListBox
   13   , addListBoxItem
   14   , removeListBoxItem
   15   , changeListBoxItem
   16   , clearListBox
   17   , reorderListBox
   18   , getListBoxSelectedValues
   19   , newListBoxTextColumnDesc
   20   ) where
   21 
   22 import Control.Concurrent.STM
   23 import Control.Monad
   24 import Control.Monad.Fix
   25 import Data.Bits
   26 import qualified Data.IntMap.Strict as IM
   27 import qualified Data.IntSet as IS
   28 import Data.Maybe
   29 import qualified Data.Set as S
   30 import qualified Data.Text as T
   31 
   32 import Flaw.Graphics
   33 import Flaw.Graphics.Canvas
   34 import Flaw.Input.Keyboard
   35 import Flaw.Input.Mouse
   36 import Flaw.Math
   37 import Flaw.UI
   38 import Flaw.UI.Drawer
   39 import Flaw.UI.Label
   40 import Flaw.UI.Metrics
   41 import Flaw.UI.Panel
   42 import Flaw.UI.PileBox
   43 import Flaw.UI.ScrollBox
   44 import Flaw.UI.VisualElement
   45 
   46 -- | `ListBox` is an extendable element allowing user to work with multiple items.
   47 -- It creates and caches temporary element for every cell, sends input events
   48 -- and renders them as a scrollable list efficiently.
   49 data ListBox v = ListBox
   50   { listBoxPanel :: !Panel
   51   , listBoxColumnHeaderHeight :: {-# UNPACK #-} !Metric
   52   , listBoxItemHeight :: {-# UNPACK #-} !Metric
   53   -- | Values ordered by item index.
   54   , listBoxValuesVar :: !(TVar (IM.IntMap v))
   55   -- | Items ordered by current sort function.
   56   , listBoxItemsVar :: !(TVar (ListBoxItems v))
   57   -- | Selected values.
   58   , listBoxSelectedValuesVar :: {-# UNPACK #-} !(TVar IS.IntSet)
   59   -- | Index to assign next added item.
   60   , listBoxNextItemIndexVar :: !(TVar Int)
   61   -- | Columns.
   62   , listBoxColumns :: [ListBoxColumn v]
   63   -- | Change handler.
   64   , listBoxChangeHandlerVar :: {-# UNPACK #-} !(TVar (STM ()))
   65   }
   66 
   67 -- | Handle for list box item.
   68 -- Allows to remove item from list.
   69 newtype ListBoxItemHandle v = ListBoxItemHandle Int
   70 
   71 -- | Wrapper for list box item sorted by some key.
   72 data ListBoxItem k v = ListBoxItem Int (v -> k) v
   73 
   74 instance Eq (ListBoxItem k v) where
   75   {-# INLINE (==) #-}
   76   ListBoxItem i1 _f1 _v1 == ListBoxItem i2 _f2 _v2 = i1 == i2
   77 
   78 instance Ord k => Ord (ListBoxItem k v) where
   79   {-# INLINE compare #-}
   80   compare (ListBoxItem i1 f1 v1) (ListBoxItem i2 f2 v2) = case compare (f1 v1) (f2 v2) of
   81     LT -> LT
   82     EQ -> compare i1 i2
   83     GT -> GT
   84 
   85 -- | List box items sorted by some key.
   86 data ListBoxItems v where
   87   ListBoxItems :: Ord k => (v -> k) -> S.Set (ListBoxItem k v) -> ListBoxItems v
   88 
   89 -- | Column (also works as column header element).
   90 data ListBoxColumn v = ListBoxColumn
   91   { listBoxColumnParent :: !(ListBox v)
   92   , listBoxColumnDesc :: !(ListBoxColumnDesc v)
   93   , listBoxColumnElementsCacheVar :: {-# UNPACK #-} !(TVar (IM.IntMap SomeElement))
   94   , listBoxColumnWidthVar :: {-# UNPACK #-} !(TVar Metric)
   95   , listBoxColumnMousedVar :: {-# UNPACK #-} !(TVar Bool)
   96   , listBoxColumnPressedVar :: {-# UNPACK #-} !(TVar Bool)
   97   }
   98 
   99 -- | Immutable column descrition.
  100 data ListBoxColumnDesc v where
  101   ListBoxColumnDesc :: Ord k =>
  102     { listBoxColumnDescVisual :: !SomeVisual
  103     , listBoxColumnDescWidth :: {-# UNPACK #-} !Metric
  104     , listBoxColumnDescKeyFunc :: !(v -> k)
  105     , listBoxColumnDescElementFunc :: !(v -> STM SomeElement)
  106     } -> ListBoxColumnDesc v
  107 
  108 data ListBoxContent v = ListBoxContent
  109   { listBoxContentParent :: !(ListBox v)
  110   , listBoxContentScrollBarVar :: {-# UNPACK #-} !(TVar ScrollBar)
  111   , listBoxContentSizeVar :: {-# UNPACK #-} !(TVar Size)
  112   , listBoxContentFocusedVar :: {-# UNPACK #-} !(TVar Bool)
  113   , listBoxContentLastMousePositionVar :: {-# UNPACK #-} !(TVar (Maybe Position))
  114   , listBoxContentLastMousedCellVar :: {-# UNPACK #-} !(TVar (Maybe (Int, Int)))
  115   }
  116 
  117 newListBox :: Metrics -> [ListBoxColumnDesc v] -> STM (ListBox v)
  118 newListBox metrics@Metrics
  119   { metricsListBoxColumnHeaderHeight = columnHeaderHeight
  120   , metricsListBoxItemHeight = itemHeight
  121   , metricsScrollBarWidth = scrollBarWidth
  122   } columnDescs = do
  123   panel <- newPanel False
  124   listBox@ListBox
  125     { listBoxColumns = columns
  126     } <- mfix $ \listBox -> do
  127     columns <- forM columnDescs $ \columnDesc -> do
  128       elementsCacheVar <- newTVar IM.empty
  129       widthVar <- newTVar 0
  130       mousedVar <- newTVar False
  131       pressedVar <- newTVar False
  132       return ListBoxColumn
  133         { listBoxColumnParent = listBox
  134         , listBoxColumnDesc = columnDesc
  135         , listBoxColumnElementsCacheVar = elementsCacheVar
  136         , listBoxColumnWidthVar = widthVar
  137         , listBoxColumnMousedVar = mousedVar
  138         , listBoxColumnPressedVar = pressedVar
  139         }
  140 
  141     valuesVar <- newTVar IM.empty
  142     itemsVar <- newTVar $ ListBoxItems (const (0 :: Int)) S.empty
  143     selectedValuesVar <- newTVar IS.empty
  144     nextItemIndexVar <- newTVar 0
  145     changeHandlerVar <- newTVar $ return ()
  146     return ListBox
  147       { listBoxPanel = panel
  148       , listBoxColumnHeaderHeight = columnHeaderHeight
  149       , listBoxItemHeight = itemHeight
  150       , listBoxValuesVar = valuesVar
  151       , listBoxItemsVar = itemsVar
  152       , listBoxSelectedValuesVar = selectedValuesVar
  153       , listBoxNextItemIndexVar = nextItemIndexVar
  154       , listBoxColumns = columns
  155       , listBoxChangeHandlerVar = changeHandlerVar
  156       }
  157 
  158   -- pile box for column headers
  159   pileBox <- newPileBox metrics $ flip map columns $ \column@ListBoxColumn
  160     { listBoxColumnDesc = ListBoxColumnDesc
  161       { listBoxColumnDescWidth = columnWidth
  162       }
  163     } -> PileBoxItemDesc
  164     { pileBoxItemDescElement = SomeElement column
  165     , pileBoxItemDescWidth = columnWidth
  166     }
  167   pileBoxChild <- addFreeChild panel pileBox
  168 
  169   -- content element
  170   scrollBarVar <- newTVar undefined
  171   contentSizeVar <- newTVar $ Vec2 0 0
  172   focusedVar <- newTVar False
  173   lastMousePositionVar <- newTVar Nothing
  174   lastMousedCellVar <- newTVar Nothing
  175   let
  176     content = ListBoxContent
  177       { listBoxContentParent = listBox
  178       , listBoxContentScrollBarVar = scrollBarVar
  179       , listBoxContentSizeVar = contentSizeVar
  180       , listBoxContentFocusedVar = focusedVar
  181       , listBoxContentLastMousePositionVar = lastMousePositionVar
  182       , listBoxContentLastMousedCellVar = lastMousedCellVar
  183       }
  184 
  185   -- scroll box
  186   scrollBox <- newScrollBox content
  187   scrollBoxChild <- addFreeChild panel scrollBox
  188 
  189   -- scroll bar
  190   scrollBar <- newVerticalScrollBar scrollBox
  191   scrollBarChild <- addFreeChild panel scrollBar
  192 
  193   writeTVar scrollBarVar scrollBar
  194 
  195   setLayoutHandler panel $ \(Vec2 sx sy) -> do
  196     placeFreeChild panel pileBoxChild $ Vec2 1 1
  197     layoutElement pileBox $ Vec2 (sx - 2) columnHeaderHeight
  198     placeFreeChild panel scrollBoxChild $ Vec2 1 (1 + columnHeaderHeight)
  199     layoutElement scrollBox $ Vec2 (sx - 1 - scrollBarWidth) (sy - 2 - columnHeaderHeight)
  200     placeFreeChild panel scrollBarChild $ Vec2 (sx - scrollBarWidth) (1 + columnHeaderHeight)
  201     layoutElement scrollBar $ Vec2 scrollBarWidth (sy - 1 - columnHeaderHeight)
  202 
  203   return listBox
  204 
  205 -- | Add new list item to listbox.
  206 addListBoxItem :: ListBox v -> v -> STM (ListBoxItemHandle v)
  207 addListBoxItem ListBox
  208   { listBoxValuesVar = valuesVar
  209   , listBoxItemsVar = itemsVar
  210   , listBoxNextItemIndexVar = nextItemIndexVar
  211   } value = do
  212   itemIndex <- readTVar nextItemIndexVar
  213   writeTVar nextItemIndexVar $ itemIndex + 1
  214   modifyTVar' valuesVar $ IM.insert itemIndex value
  215   modifyTVar' itemsVar $ \(ListBoxItems keyFunc items) ->
  216     ListBoxItems keyFunc $ S.insert (ListBoxItem itemIndex keyFunc value) items
  217   return $ ListBoxItemHandle itemIndex
  218 
  219 -- | Remove list item by handle.
  220 removeListBoxItem :: ListBox v -> ListBoxItemHandle v -> STM ()
  221 removeListBoxItem ListBox
  222   { listBoxValuesVar = valuesVar
  223   , listBoxItemsVar = itemsVar
  224   , listBoxSelectedValuesVar = selectedValuesVar
  225   , listBoxChangeHandlerVar = changeHandlerVar
  226   } (ListBoxItemHandle itemIndex) = do
  227   values <- readTVar valuesVar
  228   case IM.lookup itemIndex values of
  229     Just value -> do
  230       writeTVar valuesVar $ IM.delete itemIndex values
  231       modifyTVar' itemsVar $ \(ListBoxItems keyFunc items) ->
  232         ListBoxItems keyFunc $ S.delete (ListBoxItem itemIndex keyFunc value) items
  233     Nothing -> return ()
  234   selectedValues <- readTVar selectedValuesVar
  235   when (IS.member itemIndex selectedValues) $ do
  236     writeTVar selectedValuesVar $ IS.delete itemIndex selectedValues
  237     join $ readTVar changeHandlerVar
  238 
  239 -- | Change list item by handle.
  240 -- List item's handle remains valid.
  241 changeListBoxItem :: ListBox v -> ListBoxItemHandle v -> v -> STM ()
  242 changeListBoxItem ListBox
  243   { listBoxValuesVar = valuesVar
  244   , listBoxItemsVar = itemsVar
  245   , listBoxSelectedValuesVar = selectedValuesVar
  246   , listBoxChangeHandlerVar = changeHandlerVar
  247   } (ListBoxItemHandle itemIndex) newValue = do
  248   values <- readTVar valuesVar
  249   case IM.lookup itemIndex values of
  250     Just oldValue -> do
  251       writeTVar valuesVar $ IM.insert itemIndex newValue values
  252       modifyTVar' itemsVar $ \(ListBoxItems keyFunc items) ->
  253         ListBoxItems keyFunc
  254         $ S.insert (ListBoxItem itemIndex keyFunc newValue)
  255         $ S.delete (ListBoxItem itemIndex keyFunc oldValue) items
  256       selectedValues <- readTVar selectedValuesVar
  257       when (IS.member itemIndex selectedValues) $ join $ readTVar changeHandlerVar
  258     Nothing -> return ()
  259 
  260 -- | Remove all items from list box.
  261 clearListBox :: ListBox v -> STM ()
  262 clearListBox ListBox
  263   { listBoxValuesVar = valuesVar
  264   , listBoxItemsVar = itemsVar
  265   , listBoxSelectedValuesVar = selectedValuesVar
  266   , listBoxChangeHandlerVar = changeHandlerVar
  267   } = do
  268   writeTVar valuesVar IM.empty
  269   modifyTVar' itemsVar $ \(ListBoxItems keyFunc _items) -> ListBoxItems keyFunc S.empty
  270   selectionWasEmpty <- IS.null <$> readTVar selectedValuesVar
  271   writeTVar selectedValuesVar IS.empty
  272   unless selectionWasEmpty $ join $ readTVar changeHandlerVar
  273 
  274 -- | Reorder list box using new sort function.
  275 reorderListBox :: Ord k => ListBox v -> (v -> k) -> STM ()
  276 reorderListBox ListBox
  277   { listBoxItemsVar = itemsVar
  278   } newSortFunc = modifyTVar' itemsVar $ \(ListBoxItems _oldSortFunc items) ->
  279   ListBoxItems newSortFunc $ S.fromList $ flip map (S.toList items)
  280   $ \(ListBoxItem itemIndex _oldSortFunc value) -> ListBoxItem itemIndex newSortFunc value
  281 
  282 -- | Get list of selected values from list box.
  283 getListBoxSelectedValues :: ListBox v -> STM [v]
  284 getListBoxSelectedValues ListBox
  285   { listBoxValuesVar = valuesVar
  286   , listBoxSelectedValuesVar = selectedValuesVar
  287   } = do
  288   values <- readTVar valuesVar
  289   selectedValues <- readTVar selectedValuesVar
  290   return $ map (fromJust . flip IM.lookup values) $ IS.toList selectedValues
  291 
  292 instance Element (ListBox v) where
  293   layoutElement = layoutElement . listBoxPanel
  294   dabElement = dabElement . listBoxPanel
  295   elementMouseCursor = elementMouseCursor . listBoxPanel
  296   renderElement ListBox
  297     { listBoxPanel = panel@Panel
  298       { panelSizeVar = sizeVar
  299       }
  300     } drawer@Drawer
  301     { drawerCanvas = canvas
  302     , drawerStyles = DrawerStyles
  303       { drawerLoweredStyleVariant = StyleVariant
  304         { styleVariantNormalStyle = Style
  305           { styleFillColor = fillColor
  306           , styleBorderColor = borderColor
  307           }
  308         }
  309       }
  310     } position@(Vec2 px py) = do
  311     size <- readTVar sizeVar
  312     let Vec2 sx sy = size
  313     r <- renderElement panel drawer position
  314     return $ do
  315       drawBorderedRectangle canvas
  316         (Vec4 px (px + 1) (px + sx - 1) (px + sx))
  317         (Vec4 py (py + 1) (py + sy - 1) (py + sy))
  318         fillColor borderColor
  319       renderIntersectScissor $ Vec4 (px + 1) (py + 1) (px + sx - 2) (py + sy - 2)
  320       r
  321   processInputEvent = processInputEvent . listBoxPanel
  322   focusElement = focusElement . listBoxPanel
  323   unfocusElement = unfocusElement . listBoxPanel
  324 
  325 instance HasChangeHandler (ListBox v) where
  326   setChangeHandler = writeTVar . listBoxChangeHandlerVar
  327 
  328 instance Element (ListBoxContent v) where
  329 
  330   layoutElement ListBoxContent
  331     { listBoxContentSizeVar = sizeVar
  332     } = writeTVar sizeVar
  333 
  334   dabElement _ _ = return True
  335 
  336   renderElement _ _ _ = return $ return ()
  337 
  338   processInputEvent ListBoxContent
  339     { listBoxContentParent = ListBox
  340       { listBoxItemHeight = itemHeight
  341       , listBoxValuesVar = valuesVar
  342       , listBoxItemsVar = itemsVar
  343       , listBoxSelectedValuesVar = selectedValuesVar
  344       , listBoxColumns = columns
  345       , listBoxChangeHandlerVar = changeHandlerVar
  346       }
  347     , listBoxContentScrollBarVar = scrollBarVar
  348     , listBoxContentLastMousePositionVar = lastMousePositionVar
  349     , listBoxContentLastMousedCellVar = lastMousedCellVar
  350     } inputEvent inputState@InputState
  351     { inputStateKeyboard = keyboardState
  352     } = do
  353     scrollBar@ScrollBar
  354       { scrollBarScrollBox = scrollBox@ScrollBox
  355         { scrollBoxSizeVar = boxSizeVar
  356         }
  357       } <- readTVar scrollBarVar
  358 
  359     let
  360       moveSelection getEdgeItemIndex adjustItemOrderIndex = do
  361         selectedValues <- readTVar selectedValuesVar
  362         if IS.null selectedValues then selectByItemOrderIndex 0 else do
  363           values <- readTVar valuesVar
  364           ListBoxItems keyFunc items <- readTVar itemsVar
  365           let
  366             itemIndex = getEdgeItemIndex selectedValues
  367             value = fromJust $ IM.lookup itemIndex values
  368             itemOrderIndex = S.findIndex (ListBoxItem itemIndex keyFunc value) items
  369             itemOrderIndexToSelect = adjustItemOrderIndex itemOrderIndex
  370           selectByItemOrderIndex itemOrderIndexToSelect
  371       -- select by item order index, possibly unselecting currently selected items
  372       selectByItemOrderIndex itemOrderIndex = do
  373         ListBoxItems _keyFunc items <- readTVar itemsVar
  374         when (itemOrderIndex >= 0 && itemOrderIndex < S.size items) $ do
  375           shiftLPressed <- getKeyState keyboardState KeyShiftL
  376           shiftRPressed <- getKeyState keyboardState KeyShiftR
  377           ctrlLPressed <- getKeyState keyboardState KeyControlL
  378           ctrlRPressed <- getKeyState keyboardState KeyControlR
  379           -- clear selection if shift or ctrl is not pressed
  380           selectedValues <- if shiftLPressed || shiftRPressed || ctrlLPressed || ctrlRPressed then readTVar selectedValuesVar else return IS.empty
  381           writeTVar selectedValuesVar $
  382             let ListBoxItem itemIndex _keyFunc _value = S.elemAt itemOrderIndex items
  383             in IS.insert itemIndex selectedValues
  384           -- ensure selected item is visible
  385           let itemY = itemOrderIndex * itemHeight
  386           ensureVisibleScrollBoxArea scrollBox $ Vec4 0 itemY 0 (itemY + itemHeight)
  387           -- call change handler
  388           join $ readTVar changeHandlerVar
  389       getCellElement (itemIndex, columnIndex) = let
  390         ListBoxColumn
  391           { listBoxColumnElementsCacheVar = elementsCacheVar
  392           } = columns !! columnIndex
  393         in IM.lookup itemIndex <$> readTVar elementsCacheVar
  394       passInputEventToLastMousedCell = do
  395         maybeLastMousedCell <- readTVar lastMousedCellVar
  396         case maybeLastMousedCell of
  397           Just lastMousedCell -> do
  398             maybeCellElement <- getCellElement lastMousedCell
  399             case maybeCellElement of
  400               Just (SomeElement cellElement) -> processInputEvent cellElement inputEvent inputState
  401               Nothing -> return False
  402           Nothing -> return False
  403 
  404     processedByScrollBar <- processScrollBarEvent scrollBar inputEvent inputState
  405     if processedByScrollBar then return True else do
  406       processedByContainer <- case inputEvent of
  407         KeyboardInputEvent keyboardEvent -> case keyboardEvent of
  408           KeyDownEvent KeyDown -> do
  409             moveSelection IS.findMax (+ 1)
  410             return True
  411           KeyDownEvent KeyUp -> do
  412             moveSelection IS.findMin (+ (-1))
  413             return True
  414           KeyDownEvent KeyPageDown -> do
  415             boxSize <- readTVar boxSizeVar
  416             let Vec2 _sx sy = boxSize
  417             ListBoxItems _keyFunc items <- readTVar itemsVar
  418             moveSelection IS.findMax $ \i -> min (S.size items - 1) $ i + sy `quot` itemHeight
  419             return True
  420           KeyDownEvent KeyPageUp -> do
  421             boxSize <- readTVar boxSizeVar
  422             let Vec2 _sx sy = boxSize
  423             moveSelection IS.findMin $ \i -> max 0 $ i - sy `quot` itemHeight
  424             return True
  425           KeyDownEvent KeyHome -> do
  426             selectByItemOrderIndex 0
  427             return True
  428           KeyDownEvent KeyEnd -> do
  429             ListBoxItems _keyFunc items <- readTVar itemsVar
  430             unless (S.null items) $ selectByItemOrderIndex (S.size items - 1)
  431             return True
  432           _ -> return False
  433         MouseInputEvent mouseEvent -> case mouseEvent of
  434           MouseDownEvent LeftMouseButton -> do
  435             maybeLastMousePosition <- readTVar lastMousePositionVar
  436             case maybeLastMousePosition of
  437               Just (Vec2 _x y) -> do
  438                 selectByItemOrderIndex $ y `quot` itemHeight
  439                 return True
  440               Nothing -> return False
  441           CursorMoveEvent x y -> do
  442             writeTVar lastMousePositionVar $ Just $ Vec2 x y
  443             return True
  444           _ -> return False
  445         MouseLeaveEvent -> do
  446           writeTVar lastMousePositionVar Nothing
  447           return True
  448       processedByItem <- case inputEvent of
  449         MouseInputEvent mouseEvent -> case mouseEvent of
  450           MouseDownEvent {} -> passInputEventToLastMousedCell
  451           MouseUpEvent {} -> passInputEventToLastMousedCell
  452           RawMouseMoveEvent {} -> passInputEventToLastMousedCell
  453           CursorMoveEvent x y -> do
  454             let (itemOrderIndex, yy) = y `quotRem` itemHeight
  455             ListBoxItems _keyFunc items <- readTVar itemsVar
  456             maybeMousedElementAndXAndCell <-
  457               if itemOrderIndex >= 0 && itemOrderIndex < S.size items then do
  458                 let ListBoxItem itemIndex _keyFunc _value = S.elemAt itemOrderIndex items
  459 
  460                 -- find currently moused cell and column
  461                 let
  462                   findCell xx i (ListBoxColumn
  463                     { listBoxColumnWidthVar = widthVar
  464                     , listBoxColumnElementsCacheVar = elementsCacheVar
  465                     } : restColumns) = do
  466                     width <- readTVar widthVar
  467                     if xx < width then do
  468                       elementsCache <- readTVar elementsCacheVar
  469                       return $ case IM.lookup itemIndex elementsCache of
  470                         Just mousedElement -> Just (mousedElement, xx, (itemIndex, i))
  471                         Nothing -> Nothing
  472                     else findCell (xx - width) (i + 1) restColumns
  473                   findCell _ _ [] = return Nothing
  474 
  475                 findCell x 0 columns
  476               else return Nothing
  477 
  478             let
  479               (maybeMousedElementAndX, maybeMousedCell) = case maybeMousedElementAndXAndCell of
  480                 Just (mousedElement, xx, mousedCell) -> (Just (mousedElement, xx), Just mousedCell)
  481                 Nothing -> (Nothing, Nothing)
  482 
  483             -- get last moused cell
  484             maybeLastMousedCell <- readTVar lastMousedCellVar
  485             maybeLastMousedElement <- maybe (return Nothing) getCellElement maybeLastMousedCell
  486 
  487             -- if current cell is not the same as before
  488             when (maybeMousedCell /= maybeLastMousedCell) $ do
  489               -- remember new cell
  490               writeTVar lastMousedCellVar maybeMousedCell
  491               -- send mouse leave event to previously moused element
  492               case maybeLastMousedElement of
  493                 Just (SomeElement lastMousedElement) -> void $ processInputEvent lastMousedElement MouseLeaveEvent inputState
  494                 Nothing -> return ()
  495             -- send event to currently moused element
  496             case maybeMousedElementAndX of
  497               Just (SomeElement mousedElement, xx) -> processInputEvent mousedElement (MouseInputEvent (CursorMoveEvent xx yy)) inputState
  498               Nothing -> return False
  499 
  500         MouseLeaveEvent -> do
  501           maybeLastMousedCell <- readTVar lastMousedCellVar
  502           case maybeLastMousedCell of
  503             Just (lastMousedItemIndex, lastMousedColumnIndex) -> do
  504               let
  505                 ListBoxColumn
  506                   { listBoxColumnElementsCacheVar = elementsCacheVar
  507                   } = columns !! lastMousedColumnIndex
  508               elementsCache <- readTVar elementsCacheVar
  509               case IM.lookup lastMousedItemIndex elementsCache of
  510                 Just (SomeElement element) -> processInputEvent element inputEvent inputState
  511                 Nothing -> return False
  512             Nothing -> return False
  513         _ -> return False
  514       return $ processedByContainer || processedByItem
  515 
  516   focusElement ListBoxContent
  517     { listBoxContentFocusedVar = focusedVar
  518     } = do
  519     writeTVar focusedVar True
  520     return True
  521 
  522   unfocusElement ListBoxContent
  523     { listBoxContentFocusedVar = focusedVar
  524     } = writeTVar focusedVar False
  525 
  526 instance Scrollable (ListBoxContent v) where
  527   renderScrollableElement ListBoxContent
  528     { listBoxContentParent = listBox@ListBox
  529       { listBoxItemHeight = itemHeight
  530       , listBoxItemsVar = itemsVar
  531       , listBoxSelectedValuesVar = selectedValuesVar
  532       , listBoxColumns = columns
  533       }
  534     , listBoxContentFocusedVar = focusedVar
  535     } drawer@Drawer
  536     { drawerCanvas = canvas
  537     , drawerStyles = DrawerStyles
  538       { drawerLoweredStyleVariant = StyleVariant
  539         { styleVariantNormalStyle = normalStyle
  540         , styleVariantMousedStyle = mousedStyle
  541         , styleVariantSelectedFocusedStyle = selectedFocusedStyle
  542         , styleVariantSelectedUnfocusedStyle = selectedUnfocusedStyle
  543         }
  544       }
  545     } (Vec2 px py) (Vec4 left top right bottom) = do
  546     -- get state
  547     focused <- readTVar focusedVar
  548     let
  549       unselectedStyle = if focused then mousedStyle else normalStyle
  550       selectedStyle = if focused then selectedFocusedStyle else selectedUnfocusedStyle
  551     selectedValues <- readTVar selectedValuesVar
  552   
  553     -- calculate rendering of items
  554     renderItemColumns <- let
  555       f x (column@ListBoxColumn
  556         { listBoxColumnWidthVar = widthVar
  557         } : restColumns) = do
  558         width <- readTVar widthVar
  559         ((x, width, column) :) <$> f (x + width) restColumns
  560       f _ [] = return []
  561       in f px columns
  562 
  563     ListBoxItems _keyFunc items <- readTVar itemsVar
  564 
  565     let
  566       renderItems _i y _ | y >= py + bottom = return (IS.empty, return ())
  567       renderItems _i _y [] = return (IS.empty, return ())
  568       renderItems i y (ListBoxItem itemIndex _keyFunc value : restItems) = do
  569         let
  570           selected = IS.member itemIndex selectedValues
  571           isOdd = (i .&. 1) > 0
  572           style = if selected then selectedStyle else unselectedStyle
  573         r <- (sequence_ <$>) . forM renderItemColumns $ \(x, width, column) -> do
  574           SomeElement cellElement <- getItemElement listBox column value itemIndex
  575           r <- renderElement cellElement drawer (Vec2 (x + 1) (y + 1))
  576           return $ renderScope $ do
  577             renderIntersectScissor $ Vec4 (x + 1) (y + 1) (x + width - 2) (y + itemHeight - 2)
  578             r
  579         let
  580           itemRender =
  581             if selected then do
  582               drawBorderedRectangle canvas
  583                 (Vec4 (px + left) (px + left + 1) (px + right - 1) (px + right))
  584                 (Vec4 y (y + 1) (y + itemHeight - 1) (y + itemHeight))
  585                 (styleFillColor style) (styleBorderColor style)
  586               r
  587             else if isOdd then do
  588               let evenColor = styleFillColor selectedUnfocusedStyle * Vec4 1 1 1 0.05
  589               drawBorderedRectangle canvas
  590                 (Vec4 (px + left) (px + left) (px + right) (px + right))
  591                 (Vec4 y y (y + itemHeight) (y + itemHeight))
  592                 evenColor evenColor
  593               r
  594             else r
  595         (visibleItemIndices, restItemsRender) <- renderItems (i + 1) (y + itemHeight) restItems
  596         return (IS.insert itemIndex visibleItemIndices, itemRender >> restItemsRender)
  597       topOrderedIndex = top `quot` itemHeight
  598       (visibleItems, firstVisibleItemOrderedIndex) =
  599         if topOrderedIndex <= 0 then (items, 0)
  600         else if topOrderedIndex >= S.size items then (S.empty, 0)
  601         else let
  602           ListBoxItem firstVisibleItemIndex firstVisibleItemKeyFunc firstVisibleItemValue = S.elemAt topOrderedIndex items
  603           -- split by special non-existent item which will be just before first item
  604           in (snd $ S.split (ListBoxItem (firstVisibleItemIndex - 1) firstVisibleItemKeyFunc firstVisibleItemValue) items, topOrderedIndex)
  605 
  606     (visibleItemIndices, itemsRender) <- renderItems firstVisibleItemOrderedIndex (py + firstVisibleItemOrderedIndex * itemHeight) $ S.toAscList visibleItems
  607 
  608     -- filter out invisible items from column caches
  609     forM_ columns $ \ListBoxColumn
  610       { listBoxColumnElementsCacheVar = elementsCacheVar
  611       } -> modifyTVar' elementsCacheVar $ IM.filterWithKey $ \itemIndex _element -> IS.member itemIndex visibleItemIndices
  612 
  613     return itemsRender
  614 
  615   scrollableElementSize ListBoxContent
  616     { listBoxContentParent = ListBox
  617       { listBoxItemHeight = itemHeight
  618       , listBoxValuesVar = valuesVar
  619       }
  620     , listBoxContentSizeVar = sizeVar
  621     } = do
  622     size <- readTVar sizeVar
  623     let Vec2 sx _sy = size
  624     height <- (itemHeight *) . IM.size <$> readTVar valuesVar
  625     return $ Vec2 sx height
  626 
  627 -- | Get element representing item for the given column.
  628 -- Gets an element either from cache, or creates new one.
  629 getItemElement :: ListBox v -> ListBoxColumn v -> v -> Int -> STM SomeElement
  630 getItemElement ListBox
  631   { listBoxItemHeight = itemHeight
  632   } ListBoxColumn
  633   { listBoxColumnDesc = ListBoxColumnDesc
  634     { listBoxColumnDescElementFunc = elementFunc
  635     }
  636   , listBoxColumnElementsCacheVar = elementsCacheVar
  637   , listBoxColumnWidthVar = widthVar
  638   } value itemIndex = do
  639   -- get element from cache or create new
  640   elementsCache <- readTVar elementsCacheVar
  641   someElement@(SomeElement element) <- case IM.lookup itemIndex elementsCache of
  642     Just someElement -> return someElement
  643     Nothing -> do
  644       someElement <- elementFunc value
  645       writeTVar elementsCacheVar $! IM.insert itemIndex someElement elementsCache
  646       return someElement
  647   -- layout element
  648   width <- readTVar widthVar
  649   layoutElement element $ Vec2 (width - 2) (itemHeight - 2)
  650   return someElement
  651 
  652 instance Element (ListBoxColumn v) where
  653 
  654   layoutElement ListBoxColumn
  655     { listBoxColumnWidthVar = widthVar
  656     } (Vec2 sx _sy) = writeTVar widthVar sx
  657 
  658   dabElement ListBoxColumn
  659     { listBoxColumnParent = ListBox
  660       { listBoxColumnHeaderHeight = columnHeaderHeight
  661       }
  662     , listBoxColumnWidthVar = widthVar
  663     } (Vec2 x y) = do
  664     if x < 0 || y < 0 || y >= columnHeaderHeight then return False
  665     else (x <) <$> readTVar widthVar
  666 
  667   renderElement ListBoxColumn
  668     { listBoxColumnParent = ListBox
  669       { listBoxColumnHeaderHeight = columnHeaderHeight
  670       }
  671     , listBoxColumnDesc = ListBoxColumnDesc
  672       { listBoxColumnDescVisual = SomeVisual visual
  673       }
  674     , listBoxColumnWidthVar = widthVar
  675     , listBoxColumnMousedVar = mousedVar
  676     , listBoxColumnPressedVar = pressedVar
  677     } drawer@Drawer
  678     { drawerCanvas = canvas
  679     , drawerStyles = DrawerStyles
  680       { drawerRaisedStyleVariant = StyleVariant
  681         { styleVariantNormalStyle = normalStyle
  682         , styleVariantMousedStyle = mousedStyle
  683         , styleVariantPressedStyle = pressedStyle
  684         }
  685       }
  686     } (Vec2 px py) = do
  687     -- get state
  688     sx <- readTVar widthVar
  689     let sy = columnHeaderHeight
  690     moused <- readTVar mousedVar
  691     pressed <- readTVar pressedVar
  692     -- get style
  693     let
  694       style
  695         | pressed = pressedStyle
  696         | moused = mousedStyle
  697         | otherwise = normalStyle
  698     -- calculate visual rendering
  699     visualRender <- renderVisual visual drawer (Vec2 (px + 1) (py + 1)) (Vec2 sx sy) style
  700     -- return rendering
  701     return $ do
  702       drawBorderedRectangle canvas
  703         (Vec4 px px (px + sx - 1) (px + sx))
  704         (Vec4 py py (py + sy - 1) (py + sy))
  705         (styleFillColor style) (styleBorderColor style)
  706       renderIntersectScissor $ Vec4 (px + 1) (py + 1) (px + sx - 1) (py + sy - 1)
  707       renderScope visualRender
  708 
  709   processInputEvent ListBoxColumn
  710     { listBoxColumnParent = parent
  711     , listBoxColumnDesc = ListBoxColumnDesc
  712       { listBoxColumnDescKeyFunc = keyFunc
  713       }
  714     , listBoxColumnMousedVar = mousedVar
  715     , listBoxColumnPressedVar = pressedVar
  716     } inputEvent _inputState = case inputEvent of
  717     MouseInputEvent mouseEvent -> case mouseEvent of
  718       MouseDownEvent LeftMouseButton -> do
  719         writeTVar pressedVar True
  720         reorderListBox parent keyFunc
  721         return True
  722       MouseUpEvent LeftMouseButton -> do
  723         writeTVar pressedVar False
  724         return True
  725       CursorMoveEvent _x _y -> do
  726         writeTVar mousedVar True
  727         return True
  728       _ -> return False
  729     MouseLeaveEvent -> do
  730       writeTVar mousedVar False
  731       writeTVar pressedVar False
  732       return True
  733     _ -> return False
  734 
  735 -- | Description of most normal column: text column title, item is shown as text.
  736 newListBoxTextColumnDesc
  737   :: Ord k
  738   => T.Text -- ^ Column title.
  739   -> Metric -- ^ Column width.
  740   -> (v -> k) -- ^ Key function, returns key to sort by.
  741   -> (v -> T.Text) -- ^ Display text function, returns text to display for item.
  742   -> STM (ListBoxColumnDesc v)
  743 newListBoxTextColumnDesc title width keyFunc textFunc = do
  744   columnLabel <- newTextLabel
  745   setText columnLabel title
  746   return ListBoxColumnDesc
  747     { listBoxColumnDescVisual = SomeVisual columnLabel
  748     , listBoxColumnDescWidth = width
  749     , listBoxColumnDescKeyFunc = keyFunc
  750     , listBoxColumnDescElementFunc = \value -> do
  751       cellLabel <- newTextLabel
  752       setText cellLabel $ textFunc value
  753       SomeElement <$> newVisualElement cellLabel
  754     }