purpose dependent widget states and widget actions are now stored inside HashMaps

src/UI/Callbacks.hs

@@ -2,7 +2,7 @@ module UI.Callbacks where
 
 
 import qualified Graphics.Rendering.OpenGL.GL         as GL
-import           Control.Lens                         ((^.), (.~), (%~))
+import           Control.Lens                         ((^.), (.~), (%~), (^?), at)
 import           Control.Monad                        (liftM, when, unless)
 import           Control.Monad.RWS.Strict             (ask, get, modify)
 import           Control.Monad.Trans                  (liftIO)
@@ -150,11 +150,11 @@ clickHandler btn pos@(x,y) = do
                short = w ^. baseProperties.shorthand
            bound <- w ^. baseProperties.boundary
            prio <- w ^. baseProperties.priority
-           liftIO $ putStrLn $ "hitting " ++ short ++ ": " ++ show bound ++ " " ++ show prio
+           liftIO $ putStrLn $ "hitting(" ++ show btn ++ ") " ++ short ++ ": " ++ show bound ++ " "
-                            ++ " at [" ++ show x ++ "," ++ show y ++ "]"
+                             ++ show prio ++ " at [" ++ show x ++ "," ++ show y ++ "]"
-           case w ^. mouseActions of
+           case w ^. eventHandlers.(at MouseEvent) of
-                Just ma -> do w'  <- (ma ^. onMousePress) btn pos w
+                Just ma -> do w'  <- fromJust (ma ^? onMousePress) btn pos w -- TODO unsafe fromJust
-                              w'' <- (ma ^. onMouseRelease) btn pos w'
+                              w'' <- fromJust (ma ^? onMouseRelease) btn pos True w' -- TODO unsafe fromJust
                               return $ Just (uid, w'')
                 Nothing  -> return Nothing
            ) $ hits

src/UI/UIBase.hs

@@ -3,12 +3,14 @@
 -- TODO: exclude UIMouseState constructor from export?
 module UI.UIBase where
 
-import           Control.Lens             ((^.), (.~), (%~), (&), ix, to, mapped, traverse, makeLenses)
+import           Control.Lens             ((^.), (.~), (%~), (&), ix, mapped, makeLenses)
 import           Control.Monad            (liftM)
 import           Data.Array
+import          Data.Bits                 (xor)
 import           Data.Hashable
+import qualified Data.HashMap.Strict      as Map
 import           Data.Ix                  ()
-import           Data.Maybe
+-- import           Data.Maybe
 import           GHC.Generics (Generic)
 
 -- |Unit of screen/window
@@ -42,48 +44,116 @@ f >: (x, y) = (f x, f y)
 (*:) = merge (*)
 {-# INLINABLE (*:) #-}
 
+-- |Id to reference a specific widget, must be unique.
 newtype UIId = UIId Int deriving (Eq, Ord, Bounded, Ix, Hashable, Show, Read)
 
+-- |Mouse buttons processed by the program.
 data MouseButton = LeftButton | RightButton | MiddleButton | MouseX1 | MouseX2
     deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)
 
-instance Hashable MouseButton
+instance Hashable MouseButton where -- TODO: generic deriving creates functions that run forever
+    hash = fromEnum
+    hashWithSalt salt x = (salt * 16777619)  `xor` hash x
 
-firstButton :: MouseButton
+---------------------------
-firstButton = LeftButton
+--- widget state
+---------------------------
+-- |A key to reference a specific type of 'WidgetState'.
+data WidgetStateKey = MouseStateKey
+    deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)
+    
+instance Hashable WidgetStateKey where -- TODO: generic deriving creates functions that run forever
+    hash = fromEnum
+    hashWithSalt salt x = (salt * 16777619)  `xor` hash x
 
-lastButton :: MouseButton
+-- |The button dependant state of a 'MouseState'.
-lastButton = MiddleButton
+data MouseButtonState = MouseButtonState
-
+    { _mouseIsDragging      :: Bool -- ^firing if pressed but not confirmed
--- |The button dependant state of a 'UIMouseState'.
-data UIMouseStateSingle = MouseStateSingle
-    { _mouseIsFiring      :: Bool -- ^firing if pressed but not confirmed
     , _mouseIsDeferred    :: Bool
       -- ^deferred if e. g. dragging but outside component
     } deriving (Eq, Show)
+    
+-- |An applied state a widget may take, depending on its usage and event handlers.
+data WidgetState = 
+    -- |The state of a mouse reactive ui widget. Referenced by 'MouseStateKey'.
+    MouseState
+        { _mouseStates   :: Array MouseButton MouseButtonState
+        , _mouseIsReady  :: Bool -- ^ready if mouse is above component
+        , _mousePixel :: Pixel -- ^current local position of the mouse, only updated if widget is the mouse-active component
+        }
+    deriving (Eq, Show)
 
--- |The state of a clickable ui widget.
+---------------------------
-data UIMouseState = MouseState
+--- events
-    { _mouseStates :: Array MouseButton UIMouseStateSingle
+---------------------------
-    , _mouseIsReady       :: Bool -- ^ready if mouse is above component
+
-    } deriving (Eq, Show)
+-- |A key to reference a specific 'EventHandler'.
+data EventKey = MouseEvent | MouseMotionEvent
+    deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)
+    
+instance Hashable EventKey where -- TODO: generic deriving creates functions that run forever
+    hash = fromEnum
+    hashWithSalt salt x = (salt * 16777619)  `xor` hash x
+
+--- event handlers
+
+-- |A handler to react on certain events.
+data EventHandler m = 
+    -- |Handler to control the functionality of a 'GUIWidget' on mouse button events. 
+    MouseHandler
+        {
+        -- |The function 'onMousePressed' is called when a button is pressed
+        --  while inside a screen coordinate within the widget ('isInside').
+        _onMousePress :: MouseButton       -- ^the pressed button
+                      -> Pixel             -- ^screen position
+                      -> GUIWidget m       -- ^widget the event is invoked on
+                      -> m (GUIWidget m)   -- ^widget after the event and the possibly altered mouse handler
+        ,
+        -- |The function 'onMouseReleased' is called when a button is released
+        --  while the pressing event occured within the widget ('isInside').
+        --  
+        --  Thus, the mouse is either within the widget or outside while still dragging.
+        _onMouseRelease :: MouseButton       -- ^the released button
+                        -> Pixel             -- ^screen position
+                        -> Bool              -- ^@True@ if the event occured inside the widget
+                        -> GUIWidget m       -- ^widget the event is invoked on
+                        -> m (GUIWidget m)   -- ^widget after the event and the altered handler
+        }
+    |
+    -- |Handler to control the functionality of a 'GUIWidget' on mouse movement. 
+    MouseMotionHandler
+        {
+        -- |The function 'onMouseMove' is invoked when the mouse is moved inside the
+        --  widget's space ('isInside').
+        _onMouseMove :: Pixel             -- ^screen position
+                     -> GUIWidget m       -- ^widget the event is invoked on
+                     -> m (GUIWidget m)   -- ^widget after the event and the altered handler
+        ,
+        -- |The function 'onMouseMove' is invoked when the mouse enters the
+        --  widget's space ('isInside').
+        _onMouseEnter :: Pixel           -- ^screen position
+                      -> GUIWidget m     -- ^widget the event is invoked on
+                      -> m (GUIWidget m) -- ^widget after the event and the altered handler
+        ,
+        -- |The function 'onMouseMove' is invoked when the mouse leaves the
+        --  widget's space ('isInside').
+        _onMouseLeave :: Pixel           -- ^screen position
+                      -> GUIWidget m     -- ^widget the event is invoked on
+                      -> m (GUIWidget m) -- ^widget after the event and the altered handler
+        }
+    deriving ()
 
 
--- |Switches primary and secondary mouse actions.
+---------------------------
---  "monad type" "widget type" "original handler"
+--- widgets
-data MouseHandlerSwitch h = MouseHandlerSwitch h deriving (Eq, Show)
+---------------------------
-
--- |A 'UI.UIClasses.MouseHandler' with button behaviour.
-data ButtonHandler m w = ButtonHandler 
-    { _action :: w -> Pixel -> m w }
-instance Show (ButtonHandler m w) where
-  show _ = "ButtonHandler ***"
 
 -- |A @GUIWidget@ is a visual object the HUD is composed of. 
 data GUIWidget m = Widget
     {_baseProperties :: GUIBaseProperties m
-    ,_mouseActions :: Maybe (GUIMouseActions m)
     ,_graphics :: GUIGraphics m
+    ,_widgetStates :: Map.HashMap WidgetStateKey WidgetState -- TODO? unsave mapping
+    ,_eventHandlers :: Map.HashMap EventKey (EventHandler m) -- no guarantee that data match key
     }
 
 -- |Base properties are fundamental settings of any 'GUIWidget'.
@@ -118,46 +188,6 @@ data GUIBaseProperties m = BaseProperties
     _shorthand :: String
     }
 
--- |Mouse actions control the functionality of a 'GUIWidget' on mouse events. 
-data GUIMouseActions m = MouseActions
-    {
-    -- |The @_mouseState@ function returns the current mouse state of a widget.
-    _mouseState :: UIMouseState
-    ,
-    -- |The function 'onMousePressed' is called when a button is pressed
-    --  while inside a screen coordinate within the widget ('isInside').
-    _onMousePress :: MouseButton       -- ^the pressed button
-                  -> Pixel             -- ^screen position
-                  -> GUIWidget m       -- ^widget the event is invoked on
-                  -> m (GUIWidget m)   -- ^widget after the event and the possibly altered mouse handler
-    ,
-    -- |The function 'onMouseReleased' is called when a button is released
-    --  while the pressing event occured within the widget ('isInside').
-    --  
-    --  Thus, the mouse is either within the widget or outside while still dragging.
-    _onMouseRelease :: MouseButton       -- ^the released button
-                    -> Pixel             -- ^screen position
-                    -> GUIWidget m       -- ^widget the event is invoked on
-                    -> m (GUIWidget m)   -- ^widget after the event and the altered handler
-    ,
-    -- |The function 'onMouseMove' is invoked when the mouse is moved inside the
-    --  widget's space ('isInside').
-    _onMouseMove :: Pixel             -- ^screen position
-                 -> GUIWidget m       -- ^widget the event is invoked on
-                 -> m (GUIWidget m)   -- ^widget after the event and the altered handler
-    ,
-    -- |The function 'onMouseMove' is invoked when the mouse enters the
-    --  widget's space ('isInside').
-    _onMouseEnter :: Pixel           -- ^screen position
-                  -> GUIWidget m     -- ^widget the event is invoked on
-                  -> m (GUIWidget m) -- ^widget after the event and the altered handler
-    ,
-    -- |The function 'onMouseMove' is invoked when the mouse leaves the
-    --  widget's space ('isInside').
-    _onMouseLeave :: Pixel           -- ^screen position
-                  -> GUIWidget m     -- ^widget the event is invoked on
-                  -> m (GUIWidget m) -- ^widget after the event and the altered handler
-    }
 
 
 -- |@GUIGraphics@ functions define the look of a 'GUIWidget'.
@@ -165,74 +195,82 @@ data GUIMouseActions m = MouseActions
 data GUIGraphics m = Graphics 
     {temp :: m Int}
 
-$(makeLenses ''UIMouseState)
+$(makeLenses ''WidgetStateKey)
-$(makeLenses ''UIMouseStateSingle)
+$(makeLenses ''WidgetState)
+$(makeLenses ''MouseButtonState)
+$(makeLenses ''EventKey)
+$(makeLenses ''EventHandler)
 $(makeLenses ''GUIWidget)
 $(makeLenses ''GUIBaseProperties)
-$(makeLenses ''GUIMouseActions)
 $(makeLenses ''GUIGraphics)
 
-initialMouseStateS :: UIMouseStateSingle
+initialButtonState :: MouseButtonState
-initialMouseStateS = MouseStateSingle False False
+initialButtonState = MouseButtonState False False
-{-# INLINE initialMouseStateS #-}
+{-# INLINE initialButtonState #-}
 
 -- |Creates a @UIMouseState@ its @_mouseStates@ are valid 'UIMouseStateSingle' for any @MouseButton@
 --  provided in the passed list.
-initialMouseState :: UIMouseState
+initialMouseState :: WidgetState
-initialMouseState = MouseState (array (minBound, maxBound) [(i, initialMouseStateS) | i <- range (minBound, maxBound)])
+initialMouseState = MouseState (array (minBound, maxBound) [(i, initialButtonState) | i <- range (minBound, maxBound)])
-                               False
+                               False (0, 0)
 {-# INLINE initialMouseState #-}
 
-emptyMouseAction :: (Monad m) => GUIMouseActions m
-emptyMouseAction = MouseActions initialMouseState empty'' empty'' empty' empty' empty'
-    where empty' _ = return
-          empty'' _ _ = return
-
 -- TODO: combined mouse handler
 
--- TODO? breaks if array not of sufficient size -- will be avoided by excluding constructor export
+-- |Creates a 'MouseHandler' that sets a widget's 'MouseButtonState' properties if present,
--- |Creates a @GUIMouseActions@ handler that enables button clicks.
+--  only fully functional in conjunction with 'setMouseMotionStateActions'.
--- 
+setMouseStateActions :: (Monad m) => EventHandler m
---  The action is peformed right before the button state change.
+setMouseStateActions = MouseHandler press' release'
-buttonMouseActions :: (Monad m) => (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press
-                                -> GUIMouseActions m
-buttonMouseActions a = MouseActions initialMouseState press' release' move' enter' leave'
   where 
-    -- |Change 'UIMouseState's '_mouseIsFiring' to @True@.
+    -- |Change 'MouseButtonState's '_mouseIsDragging' to @True@.
     press' b _ w =
-        return $ w & mouseActions.traverse.mouseState.mouseStates.(ix b).mouseIsFiring .~ True
+        return $ w & widgetStates.(ix MouseStateKey).mouseStates.(ix b).mouseIsDragging .~ True
 
-    -- |Change 'UIMouseState's '_mouseIsFiring' and '_mouseIsDeferred' to @False@ and
+    -- |Change 'MouseButtonState's '_mouseIsDragging' and '_mouseIsDeferred' to @False@.
-    --  call action if '_mouseIsFiring' was @True@.
+    release' b _ _ w =
-    release' b p w =
+        return $ w & widgetStates.(ix MouseStateKey).mouseStates.(ix b) %~
-      let fire = w ^. mouseActions.(to fromJust).mouseState.mouseStates.(to (!b)).mouseIsFiring -- TODO? may break if initialized and called wrongly
+                (mouseIsDragging .~ False) . (mouseIsDeferred .~ False)
-      in do w' <- if fire
+
-                  then a b w p
+-- |Creates a 'MouseHandler' that sets a widget's 'WidgetState MouseState' properties if present,
-                  else return w
+--  only fully functional in conjunction with 'setMouseStateActions'.
-            return $ w' & mouseActions.traverse.mouseState.mouseStates.(ix b) %~
+setMouseMotionStateActions :: (Monad m) => EventHandler m
-                (mouseIsFiring .~ False) . (mouseIsDeferred .~ False)
+setMouseMotionStateActions = MouseMotionHandler move' enter' leave'
+  where
+    -- |Updates mouse position.
+    move' p w = return $ w & widgetStates.(ix MouseStateKey).mousePixel .~ p
     
-    -- |Do nothing.
+    -- |Sets '_mouseIsReady' to @True@, changes '_mouseIsDeferred' to '_mouseIsDragging's current
-    move' _ = return
+    --  value and sets '_mouseIsDragging' to @False@. 
-    
+    enter' p w = return $ w & widgetStates.(ix MouseStateKey)
-    -- |Set 'UIMouseState's '_mouseIsReady' to @True@ and
+                    %~ (mouseIsReady .~ True) . (mousePixel .~ p)
-    --  update dragging state (only drag if inside widget).
+                     . (mouseStates.mapped %~ (mouseIsDeferred .~ False)
-    --  In detail, change 'UIMouseState's '_mouseIsDeferred' to '_mouseIsFiring's current value
+                         -- following line executed BEFORE above line
-    --  and set '_mouseIsFiring' to @False@. 
+                         . (\sState -> sState & mouseIsDragging .~ not (sState ^. mouseIsDeferred)))
-    enter' _ w = return $ w & mouseActions.traverse.mouseState %~ (mouseIsReady .~ True)
-                        .(mouseStates.mapped %~ (mouseIsDeferred .~ False)
-                            -- following line executed BEFORE above line
-                            .(\sState -> sState & mouseIsFiring .~ not (sState ^. mouseIsDeferred)))
    
     
-    -- |Set 'UIMouseState's 'buttonstateIsReady' to @False@ and
+    -- |Sets '_mouseIsReady' to @False@, changes '_mouseIsDragging' to '_mouseIsDeferred's current
-    --  update dragging state (only drag if inside widget).
+    --  value and sets '_mouseIsDeferred' to @False@. 
-    --  In detail, change 'UIMouseState's '_buttonstateIsFiring' to '_buttonstateIsDeferred's current value
+    leave' p w = return $ w & widgetStates.(ix MouseStateKey)
-    --  and set '_buttonstateIsDeferred's' to @False@.
+                    %~ (mouseIsReady .~ False) . (mousePixel .~ p)
-    leave' _ w = return $ w & mouseActions.traverse.mouseState %~ (mouseIsReady .~ False)
+                     . (mouseStates.mapped %~ (mouseIsDragging .~ False)
-                        .(mouseStates.mapped %~ (mouseIsFiring .~ False)
+                         -- following line executed BEFORE above line
-                            -- following line executed BEFORE above line
+                         . (\sState -> sState & mouseIsDeferred .~ not (sState ^. mouseIsDragging)))
-                            .(\sState -> sState & mouseIsDeferred .~ not (sState ^. mouseIsFiring)))
+
+                            
+-- TODO? breaks if array not of sufficient size -- will be avoided by excluding constructor export
+-- |Creates a MouseHandler that reacts on mouse clicks.
+-- 
+--  Does /not/ update 'WidgetState MouseState'!
+buttonMouseActions :: (Monad m) => (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press
+                                -> EventHandler m
+buttonMouseActions a = MouseHandler press' release'
+  where 
+    press' _ _ = return
+
+    release' b p isIn w =
+      if isIn
+      then a b w p
+      else return w
 
 emptyGraphics :: (Monad m) => GUIGraphics m
 emptyGraphics = Graphics (return 3)
@@ -243,14 +281,14 @@ isInsideRect (x,y,w,h) (x',y') = (x' - x <= w) && (x' - x >= 0) && (y' - y <= h)
 rectangularBase :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> String -> GUIBaseProperties m
 rectangularBase bnd chld prio short =
     BaseProperties (return bnd) (return chld)
-                   (\w p -> liftM (`isInsideRect` p) (w ^. baseProperties.boundary))
+                   (\w p -> liftM (`isInsideRect` p) (w ^. baseProperties.boundary)) -- isInside
                    (return prio) short
 
 debugShowWidget' :: (Monad m) => GUIWidget m -> m String
-debugShowWidget' (Widget base mouse _) = do
+debugShowWidget' (Widget base _ _ handler) = do
     bnd <- base ^. boundary
     chld <- base ^. children
     prio <- base ^. priority
     let short = base ^. shorthand
     return $ concat [short,"| boundary:", show bnd, ", children:", show chld,
-                    ",priority:",show prio, maybe "" (const ", with mouse handler") mouse]
+                    ",priority:",show prio, maybe "" (const ", with mouse handler") (Map.lookup MouseEvent handler)]

src/UI/UIWidgets.hs

@@ -16,14 +16,16 @@ import UI.UIBase
 
 createContainer :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget m
 createContainer bnd chld prio = Widget (rectangularBase bnd chld prio "CNT")
-                                          Nothing
+                                       emptyGraphics
-                                          emptyGraphics
+                                       Map.empty -- widget states
+                                       Map.empty -- event handlers
 
 
 createPanel :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget Pioneers
 createPanel bnd chld prio = Widget (rectangularBase bnd chld prio "PNL" & boundary .~ autosize')
-                                      Nothing
+                                   emptyGraphics
-                                      emptyGraphics
+                                   Map.empty -- widget states
+                                   Map.empty -- event handlers
   where
     autosize' :: Pioneers (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit)
     autosize' = do
@@ -38,5 +40,6 @@ createPanel bnd chld prio = Widget (rectangularBase bnd chld prio "PNL" & bounda
 
 createButton :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> Int -> (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -> GUIWidget m
 createButton bnd prio action = Widget (rectangularBase bnd [] prio "BTN")
-                                         (Just $ buttonMouseActions action)
+                                      emptyGraphics
-                                         emptyGraphics
+                                      (Map.fromList [(MouseStateKey, initialMouseState)]) -- widget states
+                                      (Map.fromList [(MouseEvent, buttonMouseActions action)]) -- event handlers