diff --git a/app/Main.hs b/app/Main.hs index 38485c1c..855a294e 100644 --- a/app/Main.hs +++ b/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 diff --git a/app/Types.hs b/app/Types.hs index 97af3d43..0266901a 100644 --- a/app/Types.hs +++ b/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 }) +--} \ No newline at end of file diff --git a/package.yaml b/package.yaml index 6492f19e..6238fd2f 100644 --- a/package.yaml +++ b/package.yaml @@ -23,6 +23,7 @@ default-extensions: - OverloadedStrings dependencies: +- async - base >= 4.7 && < 5 - containers - data-default diff --git a/src/GUI/Data/Tree.hs b/src/GUI/Data/Tree.hs index 03b2491a..9d51fada 100644 --- a/src/GUI/Data/Tree.hs +++ b/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) diff --git a/src/GUI/Widget/Button.hs b/src/GUI/Widget/Button.hs index 83c475af..fef57b66 100644 --- a/src/GUI/Widget/Button.hs +++ b/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 = diff --git a/src/GUI/Widget/Core.hs b/src/GUI/Widget/Core.hs index ed917f3c..d852abc9 100644 --- a/src/GUI/Widget/Core.hs +++ b/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,14 +305,17 @@ 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 - updateFn wn@(WidgetInstance {..}) = wn { - _widgetInstanceFocused = focused - } +setFocusedStatus path focused root = case updateWidgetInstance path root updateFn of + Just newRoot -> newRoot + Nothing -> root + where + updateFn wn@(WidgetInstance {..}) = wn { + _widgetInstanceFocused = focused + } resizeUI :: (MonadState s m) => Renderer m -> Rect -> WidgetNode s e m -> m (WidgetNode s e m) resizeUI renderer assignedRect widgetInstance = do