Create initial ListView component

app/Main.hs

@@ -123,5 +123,9 @@ handleAppEvent app evt = traceShow app $
     UpdateText txt -> Model (app & textField1 .~ txt)
 
 buildUI model = widgetTree where
+  widgetTree = listView textField1 items id
+  items = fmap showt [1..100::Int]
+
+buildUI2 model = widgetTree where
   widgetTree = scroll $ vgrid items
   items = [1..100::Int] <&> \i -> label ("Item: " <> showt i) `style` textAlignLeft

src/Monomer/Widget/BaseContainer.hs

@@ -6,7 +6,10 @@
 
 module Monomer.Widget.BaseContainer (
   createContainer,
+  containerInit,
+  containerMergeTrees,
   containerHandleEvent,
+  containerHandleMessage,
   containerPreferredSize,
   containerResize,
   containerRender,
@@ -37,8 +40,9 @@ import Monomer.Widget.Util
 type ChildSizeReq s e = (WidgetInstance s e, Tree SizeReq)
 
 type WidgetInitHandler s e = WidgetContext s e -> PathContext -> WidgetInstance s e -> WidgetResult s e
-type WidgetMergeHandler s e = WidgetContext s e -> Maybe WidgetState -> WidgetInstance s e -> WidgetInstance s e
+type WidgetMergeHandler s e = WidgetContext s e -> PathContext -> Maybe WidgetState -> WidgetInstance s e -> WidgetInstance s e
 type WidgetEventHandler s e m = WidgetContext s e -> PathContext -> SystemEvent -> WidgetInstance s e -> Maybe (WidgetResult s e)
+type WidgetMessageHandler i s e m = Typeable i => WidgetContext s e -> PathContext -> i -> WidgetInstance s e -> Maybe (WidgetResult s e)
 type WidgetPreferredSizeHandler s e m = Monad m => Renderer m -> WidgetContext s e -> Seq (WidgetInstance s e, Tree SizeReq) -> Tree SizeReq
 type WidgetResizeHandler s e = WidgetContext s e -> Rect -> Rect -> WidgetInstance s e -> Seq (ChildSizeReq s e) -> (WidgetInstance s e, Seq (Rect, Rect))
 type WidgetRenderHandler s e m = (Monad m) => Renderer m -> WidgetContext s e -> PathContext -> WidgetInstance s e -> m ()
@@ -51,7 +55,7 @@ createContainer = Widget {
   _widgetNextFocusable = containerNextFocusable,
   _widgetFind = containerFind,
   _widgetHandleEvent = containerHandleEvent ignoreEvent,
-  _widgetHandleMessage = containerHandleMessage,
+  _widgetHandleMessage = containerHandleMessage ignoreMessage,
   _widgetPreferredSize = containerPreferredSize defaultPreferredSize,
   _widgetResize = containerResize defaultResize,
   _widgetRender = containerRender defaultRender
@@ -81,14 +85,14 @@ ignoreGetState _ = Nothing
 
 -- | Merging
 ignoreOldInstance :: WidgetMergeHandler s e
-ignoreOldInstance app state newInstance = newInstance
+ignoreOldInstance wctx ctx state newInstance = newInstance
 
-{-- This implementation is far from complete --}
 containerMergeTrees :: WidgetMergeHandler s e -> WidgetContext s e -> PathContext -> WidgetInstance s e -> WidgetInstance s e -> WidgetResult s e
 containerMergeTrees mergeWidgetState wctx ctx newInstance oldInstance = result where
   oldState = _widgetGetState (_instanceWidget oldInstance) wctx
+  updatedInstance = mergeWidgetState wctx ctx oldState newInstance
   oldChildren = _instanceChildren oldInstance
-  newChildren = _instanceChildren newInstance
+  newChildren = _instanceChildren updatedInstance
   indexes = Seq.fromList [0..length newChildren]
   newPairs = Seq.zipWith (\idx child -> (addToCurrent ctx idx, child)) indexes newChildren
   mergedResults = mergeChildren wctx newPairs oldChildren
@@ -96,7 +100,7 @@ containerMergeTrees mergeWidgetState wctx ctx newInstance oldInstance = result w
   concatSeq seqs = foldl' (><) Seq.empty seqs
   mergedReqs = concatSeq $ fmap _resultRequests mergedResults
   mergedEvents = concatSeq $ fmap _resultEvents mergedResults
-  mergedInstance = (mergeWidgetState wctx oldState newInstance) {
+  mergedInstance = updatedInstance {
     _instanceChildren = mergedChildren
   }
   result = WidgetResult mergedReqs mergedEvents mergedInstance
@@ -177,10 +181,13 @@ mergeParentChildWidgetResults original (Just pResponse) (Just cResponse) idx
       userEvents = _resultEvents pResponse >< _resultEvents cResponse
       newWidget = replaceChild (_resultWidget pResponse) (_resultWidget cResponse) idx
 
--- | Custom Handling
-containerHandleMessage :: forall i s e m . Typeable i => WidgetContext s e -> PathContext -> i -> WidgetInstance s e -> Maybe (WidgetResult s e)
-containerHandleMessage wctx ctx arg widgetInstance
-  | isTargetReached ctx || not (isTargetValid ctx (_instanceChildren widgetInstance)) = Nothing
+-- | Message Handling
+ignoreMessage :: WidgetMessageHandler i s e m
+ignoreMessage wctx ctx message widgetInstance = Nothing
+
+containerHandleMessage :: forall i s e m . Typeable i => WidgetMessageHandler i s e m -> WidgetContext s e -> PathContext -> i -> WidgetInstance s e -> Maybe (WidgetResult s e)
+containerHandleMessage mHandler wctx ctx arg widgetInstance
+  | isTargetReached ctx || not (isTargetValid ctx (_instanceChildren widgetInstance)) = mHandler wctx ctx arg widgetInstance
   | otherwise = messageResult where
       nextCtx = fromJust $ moveToTarget ctx
       childIdx = fromJust $ nextTargetStep ctx

src/Monomer/Widget/Widgets/Container.hs

@@ -21,16 +21,17 @@ import Monomer.Widget.BaseContainer
 
 import qualified Monomer.Common.Style as St
 
-data ContainerConfig e = ContainerConfig {
-  _ctOnClick :: Maybe e,
+data ContainerConfig s e = ContainerConfig {
+  _ctOnClick :: [e],
+  _ctOnClickReq :: [WidgetRequest s],
   _ctBgColor :: Maybe Color,
   _ctHoverColor :: Maybe Color
 }
 
-instance Default (ContainerConfig e) where
-  def = ContainerConfig Nothing Nothing Nothing
+instance Default (ContainerConfig s e) where
+  def = ContainerConfig [] [] Nothing Nothing
 
-container :: ContainerConfig e -> WidgetInstance s e -> WidgetInstance s e
+container :: ContainerConfig s e -> WidgetInstance s e -> WidgetInstance s e
 container config managedWidget = makeInstance (makeContainer config) managedWidget
 
 makeInstance :: Widget s e -> WidgetInstance s e -> WidgetInstance s e
@@ -39,7 +40,7 @@ makeInstance widget managedWidget = (defaultWidgetInstance "container" widget) {
   _instanceFocusable = False
 }
 
-makeContainer :: ContainerConfig e -> Widget s e
+makeContainer :: ContainerConfig s e -> Widget s e
 makeContainer config = createContainer {
     _widgetHandleEvent = containerHandleEvent handleEvent,
     _widgetPreferredSize = containerPreferredSize preferredSize,
@@ -50,8 +51,10 @@ makeContainer config = createContainer {
     handleEvent wctx ctx evt widgetInstance = case evt of
       Click point btn status -> result where
         isPressed = status == PressedBtn && btn == LeftBtn
-        result = if isPressed && isJust (_ctOnClick config)
-                    then Just $ resultEvents [fromJust $ _ctOnClick config] widgetInstance
+        events = _ctOnClick config
+        requests = _ctOnClickReq config
+        result = if isPressed && not (null events && null requests)
+                    then Just $ resultReqsEvents requests events widgetInstance
                     else Nothing
       _ -> Nothing
 

src/Monomer/Widget/Widgets/Dropdown.hs

@@ -196,7 +196,7 @@ makeOverlayList items selected highlightedIdx itemToText = scroll makeGrid where
   makeGrid = vstack $ fmap (uncurry makeItem) pairs
   makeItem idx item = container (config idx item) $ label (itemToText item)
   config idx item = def {
-    _ctOnClick = Just $ ItemClicked item,
+    _ctOnClick = [ItemClicked item],
     _ctBgColor = highlightedColor idx <|> selectedColor item,
     _ctHoverColor = Just lightGray
   }

src/Monomer/Widget/Widgets/ListView.hs

@@ -0,0 +1,133 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Monomer.Widget.Widgets.ListView (listView) where
+
+import Debug.Trace
+
+import Control.Applicative ((<|>))
+import Control.Monad
+import Data.Default
+import Data.Foldable (find)
+import Data.List (foldl')
+import Data.Maybe (fromMaybe)
+import Data.Sequence (Seq(..), (<|), (|>))
+import Data.Text (Text)
+import Data.Traversable
+import Data.Typeable (Typeable, cast)
+import Lens.Micro
+
+import qualified Data.Map as M
+import qualified Data.Sequence as Seq
+
+import Monomer.Common.Geometry
+import Monomer.Common.Style
+import Monomer.Common.Tree
+import Monomer.Event.Keyboard
+import Monomer.Event.Types
+import Monomer.Graphics.Color
+import Monomer.Graphics.Drawing
+import Monomer.Graphics.Renderer
+import Monomer.Graphics.Types
+import Monomer.Widget.BaseContainer
+import Monomer.Widget.PathContext
+import Monomer.Widget.Types
+import Monomer.Widget.Util
+import Monomer.Widget.Widgets.Container
+import Monomer.Widget.Widgets.Label
+import Monomer.Widget.Widgets.Scroll
+import Monomer.Widget.Widgets.Spacer
+import Monomer.Widget.Widgets.Stack
+
+newtype ListView = ListView {
+  _highlighted :: Int
+}
+
+newtype ClickMessage = ClickMessage Int deriving Typeable
+
+listView :: (Traversable t, Eq a) => Lens' s a -> t a -> (a -> Text) -> WidgetInstance s e
+listView field items itemToText = makeInstance (makeListView newStatus field newItems itemToText) where
+  newItems = foldl' (|>) Empty items
+  newStatus = ListView 0
+
+makeInstance :: Widget s e -> WidgetInstance s e
+makeInstance widget = (defaultWidgetInstance "listView" widget) {
+  _instanceFocusable = True
+}
+
+makeListView :: (Eq a) => ListView -> Lens' s a -> Seq a -> (a -> Text) -> Widget s e
+makeListView state field items itemToText = createContainer {
+    _widgetInit = init,
+    _widgetGetState = getState,
+    _widgetMerge = containerMergeTrees merge,
+    _widgetHandleEvent = containerHandleEvent handleEvent,
+    _widgetHandleMessage = containerHandleMessage handleMessage,
+    _widgetPreferredSize = containerPreferredSize preferredSize,
+    _widgetResize = containerResize resize
+  }
+  where
+    createListView wctx ctx newState = newInstance where
+      selected = _wcApp wctx ^. field
+      newInstance = (makeInstance $ makeListView newState field items itemToText) {
+        _instanceChildren = Seq.singleton $ makeScrollableList ctx field items selected (_highlighted newState) itemToText
+      }
+
+    init wctx ctx widgetInstance = resultWidget $ createListView wctx ctx state
+
+    getState = makeState state
+
+    merge wctx ctx oldState newInstance = createListView wctx ctx newState where
+      newState = fromMaybe state (useState oldState)
+
+    handleEvent wctx ctx evt widgetInstance = case evt of
+      KeyAction mode code status
+        | isKeyDown code && status == KeyPressed -> handleSelectNext wctx ctx
+        | isKeyUp code && status == KeyPressed -> handleSelectPrev wctx ctx
+        | isKeyReturn code && status == KeyPressed -> Just $ selectItem wctx ctx (_highlighted state)
+      _ -> Nothing
+
+    handleSelectNext wctx ctx = Just $ resultWidget newInstance where
+      tempIdx = _highlighted state
+      nextIdx = if tempIdx < length items - 1 then tempIdx + 1 else tempIdx
+      newInstance = createListView wctx ctx $ ListView nextIdx
+
+    handleSelectPrev wctx ctx = Just $ resultWidget newInstance where
+      tempIdx = _highlighted state
+      nextIdx = if tempIdx > 0 then tempIdx - 1 else tempIdx
+      newInstance = createListView wctx ctx $ ListView nextIdx
+
+--    handleMessage wctx ctx message widgetInstance = case cast message of
+--      Just (ClickMessage idx) -> selectItem wctx ctx idx
+--      Nothing -> Nothing
+
+    handleMessage wctx ctx message widgetInstance = fmap handleSelect (cast message) where
+      handleSelect (ClickMessage idx) = selectItem wctx ctx idx
+
+    selectItem wctx ctx idx = resultReqs requests newInstance where
+      selected = _wcApp wctx ^. field
+      value = fromMaybe selected (Seq.lookup idx items)
+      requests = [UpdateUserState $ \model -> model & field .~ value]
+      newInstance = createListView wctx ctx $ ListView idx
+
+    preferredSize renderer wctx childrenPairs = Node sizeReq childrenReqs where
+      childrenReqs = fmap snd childrenPairs
+      sizeReq = nodeValue $ Seq.index childrenReqs 0
+
+    resize wctx viewport renderArea widgetInstance childrenPairs = (widgetInstance, assignedArea) where
+      assignedArea = Seq.singleton (viewport, renderArea)
+
+makeScrollableList :: (Eq a) => PathContext -> Lens' s a -> Seq a -> a -> Int -> (a -> Text) -> WidgetInstance s e
+makeScrollableList ctx field items selected highlightedIdx itemToText = scroll makeGrid where
+  path = _pathCurrent ctx
+  isSelected item = item == selected
+  selectedColor item = if isSelected item then Just gray else Nothing
+  highlightedColor idx = if idx == highlightedIdx then Just darkGray else Nothing
+  pairs = Seq.zip (Seq.fromList [0..length items]) items
+  makeGrid = vstack $ fmap (uncurry makeItem) pairs
+  makeItem idx item = container (config idx item) $ label (itemToText item)
+  config idx item = def {
+    _ctOnClickReq = [SendMessage path (ClickMessage idx)],
+    _ctBgColor = highlightedColor idx <|> selectedColor item,
+    _ctHoverColor = Just lightGray
+  }

src/Monomer/Widgets.hs

@@ -3,6 +3,7 @@ module Monomer.Widgets (
   module Monomer.Widget.Widgets.Dropdown,
   module Monomer.Widget.Widgets.Grid,
   module Monomer.Widget.Widgets.Label,
+  module Monomer.Widget.Widgets.ListView,
   module Monomer.Widget.Widgets.Sandbox,
   module Monomer.Widget.Widgets.Scroll,
   module Monomer.Widget.Widgets.Spacer,
@@ -15,6 +16,7 @@ import Monomer.Widget.Widgets.Container
 import Monomer.Widget.Widgets.Dropdown
 import Monomer.Widget.Widgets.Grid
 import Monomer.Widget.Widgets.Label
+import Monomer.Widget.Widgets.ListView
 import Monomer.Widget.Widgets.Sandbox
 import Monomer.Widget.Widgets.Scroll
 import Monomer.Widget.Widgets.Spacer

tasks.md

@@ -92,8 +92,6 @@
     - Find way of providing instance config (style, visibility, etc) before providing children (some sort of flip operator)
       - Just provide `style` after children. SwiftUI does it this way
     - Fix border drawing. Handle simple case (more efficient)
-
-- Pending
   - Fix scroll click navigation
     - Highlight bar when mouse over
     - Highlight handle when mouse over
@@ -102,16 +100,18 @@
     - Mouse over on overlapping axis gives precedence to vertical scroll
   - Keep sending mouse move event if mouse is away but button is still pressed
     - Handle mouse enter/leave window events
+
+- Pending
   - Add support for scroll requests from children
-  - Unify criteria for instantiation
-    - Component name without underscore receives parameters positionally
-    - Component name with underscore receives Config instance
   - Improve Dropdown
     - Create self rendered version
     - Expose customizable interface
     - Request scroll when needed
     - Validate Maybe values are supported
     - Create nullable version which takes care of fmapping traversable with Just
+  - Unify criteria for instantiation
+    - Component name without underscore receives parameters positionally
+    - Component name with underscore receives Config instance
   - Should Resize be restored?
   - Create layer widget to handle overlays/dialog boxes/tooltips (takes care of overlays)
   - Improve textField
@@ -125,6 +125,8 @@
     - This is also needed for _widgetPreferredSize and _widgetResize
   - Create Checkbox
   - Create Radio
+  - Create Slider
+  - Create Dial
   - Create Color Selector
   - Create Dialog
   - Create File Selector