mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-09-20 16:27:49 +03:00
Add basic handling of custom widget tasks
This commit is contained in:
parent
616743e3f6
commit
783a706b61
48
app/Main.hs
48
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
|
||||
|
17
app/Types.hs
17
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 })
|
||||
--}
|
@ -23,6 +23,7 @@ default-extensions:
|
||||
- OverloadedStrings
|
||||
|
||||
dependencies:
|
||||
- async
|
||||
- base >= 4.7 && < 5
|
||||
- containers
|
||||
- data-default
|
||||
|
@ -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)
|
||||
|
@ -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 =
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user