Add basic handling of custom widget tasks

app/Main.hs

@@ -6,11 +6,15 @@
 module Main where
 
 import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async (async, poll)
+import Control.Exception.Base
 import Control.Monad
+import Control.Monad.Extra
 import Control.Monad.IO.Class
 import Control.Monad.State
 import Data.Default
 import Data.Maybe
+import Data.Typeable
 import Foreign.C.Types
 import Lens.Micro.TH (makeLenses)
 import Lens.Micro.Mtl
@@ -170,8 +174,10 @@ mainLoop window c renderer prevTicks widgets = do
   let eventsPayload = fmap SDL.eventPayload events
   let quit = elem SDL.QuitEvent eventsPayload
 
+  handledWidgets <- processCustomHandlers widgets
+
   focus <- getCurrentFocus
-  newWidgets <- handleSystemEvents renderer (convertEvents mousePos eventsPayload) focus widgets
+  newWidgets <- handleSystemEvents renderer (convertEvents mousePos eventsPayload) focus handledWidgets
 
   renderWidgets window c renderer newWidgets ticks
 
@@ -201,6 +207,7 @@ handleSystemEvent :: Renderer WidgetM -> W.SystemEvent -> TR.Path -> WidgetTree
 handleSystemEvent renderer systemEvent currentFocus widgets = do
   let (W.ChildEventResult stop eventRequests appEvents newWidgets) = handleEvent renderer systemEvent currentFocus widgets
   let newRoot = fromMaybe widgets newWidgets
+  let customHandlers = L.filter isCustomHandler eventRequests
 
   updatedRoot <- if (not stop && isKeyPressed systemEvent keycodeTab) then do
     ring <- use focusRing
@@ -215,10 +222,47 @@ handleSystemEvent renderer systemEvent currentFocus widgets = do
   else
     handleAppEvents renderer appEvents updatedRoot
 
-  case L.find (\evt -> snd evt == W.ResizeChildren) eventRequests of
+  updatedRoot3 <- case L.find (\evt -> snd evt == W.ResizeChildren) eventRequests of
     Just (path, event) -> updateUI renderer updatedRoot2
     Nothing -> return updatedRoot2
 
+  tasks <- forM customHandlers $ \(path, W.RunCustom handler) -> do
+    asyncTask <- liftIO $ async (liftIO handler)
+
+    return $ W.WidgetTask path asyncTask
+
+  previousTasks <- use widgetTasks
+  widgetTasks .= previousTasks ++ tasks
+
+  return updatedRoot3
+
+isCustomHandler :: (TR.Path, W.EventRequest) -> Bool
+isCustomHandler (_, W.RunCustom _) = True
+isCustomHandler _ = False
+
+processCustomHandlers :: WidgetTree -> AppM WidgetTree
+processCustomHandlers widgets = do
+  tasks <- use widgetTasks
+  (active, finished) <- partitionM (\(W.WidgetTask _ task) -> fmap isNothing (liftIO $ poll task)) tasks
+  widgetTasks .= active
+
+  newWidgets <- runCustomHandlers widgets finished
+
+  return newWidgets
+
+runCustomHandlers :: WidgetTree -> [W.WidgetTask] -> AppM WidgetTree
+runCustomHandlers widgets tasks = do
+  newWidgets <- foldM (\widgets (W.WidgetTask path task) -> do
+    taskStatus <- fmap fromJust (liftIO $ poll task)
+    processCustomHandler widgets path taskStatus) widgets tasks
+  return newWidgets
+
+processCustomHandler :: (Typeable a) => WidgetTree -> TR.Path -> Either SomeException a -> AppM WidgetTree
+processCustomHandler widgets _ (Left _) = return widgets
+processCustomHandler widgets path (Right val) = do
+  let !res = W.handleCustomCommand path widgets val
+  return widgets
+
 keycodeTab = fromIntegral $ Keyboard.unwrapKeycode SDL.KeycodeTab
 
 isKeyboardEvent :: W.SystemEvent -> Bool

app/Types.hs

@@ -2,12 +2,16 @@
 
 module Types where
 
+import Lens.Micro
 import Lens.Micro.TH (makeLenses)
 
 import Data.Default
 
+import Control.Monad
+import Control.Monad.State
+
 import qualified GUI.Data.Tree as TR
-import GUI.Widget.Core (GUIContext)
+import GUI.Widget.Core (GUIContext, WidgetTask, _appContext, _focusRing, _widgetTasks)
 
 data App = App {
   _clickCount :: !Int
@@ -18,3 +22,14 @@ instance Default App where
 
 makeLenses ''App
 makeLenses ''GUIContext
+
+{--
+appContext :: (MonadState s m) => Lens' (GUIContext s m) s
+appContext = lens _appContext (\app val -> app { _appContext = val })
+
+focusRing :: (MonadState s m) => Lens' (GUIContext s m) [TR.Path]
+focusRing = lens _focusRing (\app val -> app { _focusRing = val })
+
+widgetTasks :: (MonadState s m) => Lens' (GUIContext s m) [WidgetTask s m]
+widgetTasks = lens _widgetTasks (\app val -> app { _widgetTasks = val })
+--}

package.yaml

@@ -23,6 +23,7 @@ default-extensions:
 - OverloadedStrings
 
 dependencies:
+- async
 - base >= 4.7 && < 5
 - containers
 - data-default

src/GUI/Data/Tree.hs

@@ -40,13 +40,13 @@ lookup (idx:xs) (Node val seq) = case S.lookup idx seq of
   Just tree -> lookup xs tree
   otherwise -> Nothing
 
-updateNode :: Path -> Tree a -> (Tree a -> Tree a) -> Tree a
-updateNode [] old updateFn = updateFn old
+updateNode :: Path -> Tree a -> (Tree a -> Tree a) -> Maybe (Tree a)
+updateNode [] old updateFn = Just $ updateFn old
 updateNode (idx:xs) node@(Node val seq) updateFn = case S.lookup idx seq of
-  Just tree -> Node val newChildren where
-    newChildren = S.update idx newNode seq
-    newNode = updateNode xs tree updateFn
-  Nothing -> node
+  Just tree -> case updateNode xs tree updateFn of
+    Just newNode -> Just $ Node val (S.update idx newNode seq) where
+    Nothing -> Nothing
+  Nothing -> Nothing
 
-replaceNode :: Path -> Tree a -> Tree a -> Tree a
-replaceNode path root new = updateNode path root (\_ -> new)
+replaceNode :: Path -> Tree a -> Tree a -> Maybe (Tree a)
+replaceNode path root new = updateNode path root (const new)

src/GUI/Widget/Button.hs

@@ -7,6 +7,9 @@ module GUI.Widget.Button (button) where
 import Control.Monad
 import Control.Monad.State
 
+import Data.Typeable
+import Debug.Trace
+
 import GUI.Common.Core
 import GUI.Common.Drawing
 import GUI.Common.Style
@@ -15,26 +18,35 @@ import GUI.Widget.Core
 
 import qualified Data.Text as T
 
-button :: (MonadState s m) => e -> WidgetNode s e m
+data ButtonData = ButtonData | Button2Data deriving (Eq, Show, Typeable)
+
+button :: (MonadState s m, MonadIO m) => e -> WidgetNode s e m
 button onClick = singleWidget (makeButton 0 onClick)
 
-makeButton :: (MonadState s m) => Int -> e -> Widget s e m
+makeButton :: (MonadState s m, MonadIO m) => Int -> e -> Widget s e m
 makeButton state onClick = Widget {
     _widgetType = "button",
     _widgetFocusable = False,
     _widgetHandleEvent = handleEvent,
-    _widgetHandleCustom = defaultCustomHandler,
+    _widgetHandleCustom = handleCustom,
     _widgetPreferredSize = preferredSize,
     _widgetResizeChildren = resizeChildren,
     _widgetRender = render
   }
   where
     handleEvent view evt = case evt of
-      Click (Point x y) _ status -> eventResult events (makeButton newState onClick) where
+      Click (Point x y) _ status -> eventResultRequest requests events (makeButton newState onClick) where
         isPressed = status == PressedBtn && inRect view (Point x y)
         newState = if isPressed then state + 1 else state
         events = if isPressed then [onClick] else []
+        requests = if isPressed then [RunCustom runCustom] else []
       _ -> Nothing
+    runCustom = do
+      liftIO $ putStrLn "Hello!"
+      return Button2Data
+    handleCustom bd = case cast bd of
+      Just val -> if val == Button2Data then Nothing else Nothing
+      Nothing -> Nothing
     preferredSize renderer (style@Style{..}) _ = calcTextBounds renderer _textStyle (T.pack (show state))
     resizeChildren _ _ _ = Nothing
     render renderer WidgetInstance{..} _ ts =

src/GUI/Widget/Core.hs

@@ -2,11 +2,14 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TupleSections #-}
 
 module GUI.Widget.Core where
 
+import Control.Concurrent.Async
+
 import Control.Monad
 import Control.Monad.State
 
@@ -15,6 +18,8 @@ import Data.Maybe
 import Data.String
 import Data.Typeable (cast, Typeable)
 
+import Debug.Trace
+
 import GUI.Common.Core
 import GUI.Common.Style
 import GUI.Data.Tree
@@ -48,7 +53,14 @@ data EventRequest = IgnoreParentEvents
                   | IgnoreChildrenEvents
                   | ResizeChildren
                   | ResizeAll
-                  deriving (Show, Eq)
+                  | forall a . Typeable a => RunCustom (IO a)
+
+instance Eq EventRequest where
+  IgnoreParentEvents == IgnoreParentEvents = True
+  IgnoreChildrenEvents == IgnoreChildrenEvents = True
+  ResizeChildren == ResizeChildren = True
+  ResizeAll == ResizeAll = True
+  _ == _ = False
 
 data WidgetEventResult s e m = WidgetEventResult {
   _eventResultRequest :: [EventRequest],
@@ -80,25 +92,32 @@ instance IsString WidgetKey where
 newtype NodePath = NodePath [Int]
 data NodeInfo = NodeInfo WidgetType (Maybe WidgetKey)
 
+data WidgetTask = forall a . Typeable a => WidgetTask {
+  widgetTaskPath :: Path,
+  widgetTask :: Async a
+}
+
 data GUIContext app = GUIContext {
   _appContext :: app,
-  _focusRing :: [Path]
-} deriving (Show, Eq)
+  _focusRing :: [Path],
+  _widgetTasks :: [WidgetTask]
+}
 
 initGUIContext :: app -> GUIContext app
 initGUIContext app = GUIContext {
   _appContext = app,
-  _focusRing = []
+  _focusRing = [],
+  _widgetTasks = []
 }
 
 isFocusable :: (MonadState s m) => WidgetInstance s e m -> Bool
 isFocusable (WidgetInstance { _widgetInstanceWidget = Widget{..}, ..}) = _widgetInstanceEnabled  && _widgetFocusable
 
-defaultCustomHandler :: Int -> Maybe (WidgetEventResult s e m)
+defaultCustomHandler :: a -> Maybe (WidgetEventResult s e m)
 defaultCustomHandler _ = Nothing
 
-data Widget s e m = forall i .
-  (MonadState s m, Typeable i) => Widget {
+data Widget s e m =
+  (MonadState s m) => Widget {
     -- | Type of the widget
     _widgetType :: WidgetType,
     -- | Indicates whether the widget can receive focus
@@ -115,7 +134,7 @@ data Widget s e m = forall i .
     -- Result of asynchronous computation
     --
     -- Returns: the list of generated events and, maybe, a new version of the widget if internal state changed
-    _widgetHandleCustom :: i -> Maybe (WidgetEventResult s e m),
+    _widgetHandleCustom ::  forall i . Typeable i => i -> Maybe (WidgetEventResult s e m),
     -- | Minimum size desired by the widget
     --
     -- Style options
@@ -235,7 +254,8 @@ handleChildEvent selectorFn selector path treeNode@(Node wn@WidgetInstance{..} c
   (ipeChild, erChild, ueChild, tnChild, tnChildIdx) = case selectorFn selector children of
     (_, Nothing) -> (False, [], SQ.empty, Nothing, 0)
     (newSelector, Just idx) -> (ipe2, er2, ue2, tn2, idx) where
-      (ChildEventResult ipe2 er2 ue2 tn2) = handleChildEvent selectorFn newSelector (idx:path) (SQ.index children idx) systemEvent
+      (ChildEventResult ipe2 er2 ue2 tn2) = handleChildEvent selectorFn newSelector widgetPath (SQ.index children idx) systemEvent
+      widgetPath = reverse (idx:path)
   -- Current widget
   (ice, ipe, er, ue, tn) = case handleWidgetEvents _widgetInstanceWidget _widgetInstanceRenderArea systemEvent of
     Nothing -> (False, False, [], SQ.empty, Nothing)
@@ -256,19 +276,27 @@ handleChildEvent selectorFn selector path treeNode@(Node wn@WidgetInstance{..} c
     (Just (Node wn _), Just tnChild) -> Just $ Node wn (SQ.update tnChildIdx tnChild children)
 
 handleEventFromPath :: (MonadState s m) => Path -> WidgetNode s e m -> SystemEvent -> ChildEventResult s e m
-handleEventFromPath path widgetInstance systemEvent = handleChildEvent pathSelector path [0] widgetInstance systemEvent where
+handleEventFromPath path widgetInstance systemEvent = handleChildEvent pathSelector path [] widgetInstance systemEvent where
   pathSelector [] _ = ([], Nothing)
   pathSelector (p:ps) children
     | length children > p = (ps, Just p)
     | otherwise = ([], Nothing)
 
 handleEventFromPoint :: (MonadState s m) => Point -> WidgetNode s e m -> SystemEvent -> ChildEventResult s e m
-handleEventFromPoint cursorPos widgetInstance systemEvent = handleChildEvent rectSelector cursorPos [0] widgetInstance systemEvent where
+handleEventFromPoint cursorPos widgetInstance systemEvent = handleChildEvent rectSelector cursorPos [] widgetInstance systemEvent where
   rectSelector point children = (point, SQ.lookup 0 inRectList) where
     inRectList = fmap snd $ SQ.filter inNodeRect childrenPair
     inNodeRect = \(Node (WidgetInstance {..}) _, _) -> inRect _widgetInstanceViewport point
     childrenPair = SQ.zip children (SQ.fromList [0..(length children - 1)])
 
+handleCustomCommand :: (MonadState s m, Typeable i) => Path -> WidgetNode s e m -> i -> ChildEventResult s e m
+handleCustomCommand path treeNode customData = traceShow path $ case GUI.Data.Tree.lookup path treeNode of
+  Just (WidgetInstance{ _widgetInstanceWidget = Widget{..}, ..}) ->
+    case _widgetHandleCustom customData of
+      Just (WidgetEventResult er ue tn) -> ChildEventResult False (fmap (path,) er) (SQ.fromList ue) Nothing
+      Nothing -> ChildEventResult False [] SQ.Empty Nothing
+  Nothing -> ChildEventResult False [] SQ.Empty Nothing
+
 handleRender :: (MonadState s m) => Renderer m -> WidgetNode s e m -> Timestamp -> m ()
 handleRender renderer (Node (widgetInstance@WidgetInstance { _widgetInstanceWidget = Widget{..}, .. }) children) ts = do
   _widgetRender renderer widgetInstance children ts
@@ -277,11 +305,14 @@ handleRenderChildren :: (MonadState s m) => Renderer m -> WidgetChildren s e m -
 handleRenderChildren renderer children ts = do
   mapM_ (\treeNode -> handleRender renderer treeNode ts) children
 
-updateWidgetInstance :: Path -> WidgetNode s e m -> (WidgetInstance s e m -> WidgetInstance s e m) -> WidgetNode s e m
+updateWidgetInstance :: Path -> WidgetNode s e m -> (WidgetInstance s e m -> WidgetInstance s e m) -> Maybe (WidgetNode s e m)
 updateWidgetInstance path root updateFn = updateNode path root (\(Node widgetInstance children) -> Node (updateFn widgetInstance) children)
 
 setFocusedStatus :: Path -> Bool -> WidgetNode s e m -> WidgetNode s e m
-setFocusedStatus path focused root = updateWidgetInstance path root updateFn where
+setFocusedStatus path focused root = case updateWidgetInstance path root updateFn of
+    Just newRoot -> newRoot
+    Nothing -> root
+  where
     updateFn wn@(WidgetInstance {..}) = wn {
       _widgetInstanceFocused = focused
     }