restructured GUI widgets' data representation from class type/instance-based

to function-based
advantage: single constructor for any widget type, no branching necessary

src/Types.hs

@@ -135,7 +135,7 @@ data GLState = GLState
 
 data UIState = UIState
     { _uiHasChanged        :: !Bool
-    , _uiMap               :: Map.HashMap UIId (GUIAny Pioneers)
+    , _uiMap               :: Map.HashMap UIId (GUIWidget Pioneers)
     , _uiRoots             :: [UIId]
     }
 

src/UI/Callbacks.hs

@@ -9,27 +9,27 @@ import           Control.Monad.Trans                  (liftIO)
 import qualified Data.HashMap.Strict                  as Map
 import           Data.List                            (foldl')
 import           Data.Maybe
-import           Foreign.Marshal.Array (pokeArray)
+import           Foreign.Marshal.Array                (pokeArray)
-import           Foreign.Marshal.Alloc (allocaBytes)
+import           Foreign.Marshal.Alloc                (allocaBytes)
 import qualified Graphics.UI.SDL                      as SDL
 import           Render.Misc                          (genColorData)
 
 import Types
-import Render.Misc                                    (curb)
+import Render.Misc                                    (curb) -- TODO: necessary import ?
 import UI.UIBaseData
 import UI.UIClasses
 import UI.UIOperations
 
 
-createGUI :: (Map.HashMap UIId (GUIAny Pioneers), [UIId])
+createGUI :: (Map.HashMap UIId (GUIWidget Pioneers), [UIId])
-createGUI = (Map.fromList [ (UIId 0, GUIAnyP $ GUIPanel $ GUIContainer 0 0 0 0 [UIId 1, UIId 2] 0)
+createGUI = (Map.fromList [ (UIId 0, createPanel (0, 0, 0, 0) [UIId 1, UIId 2] 0)
-                          , (UIId 1, GUIAnyC $ GUIContainer 20 50 120 80 [] 1)
+                          , (UIId 1, createContainer (20, 50, 120, 80) [] 1)
-                          , (UIId 2, GUIAnyP $ GUIPanel $ GUIContainer 100 140 0 0 [UIId 3, UIId 4] 3)
+                          , (UIId 2, createPanel (100, 140, 0, 0) [UIId 3, UIId 4] 3)
-                          , (UIId 3, GUIAnyC $ GUIContainer  100 140 130 200 [] 4 )
+                          , (UIId 3, createContainer (100, 140, 130, 200) [] 4 )
-                          , (UIId 4, GUIAnyB (GUIButton 30 200 60 175 2 defaultUIState ) (ButtonHandler testMessage))
+                          , (UIId 4, createButton (30, 200, 60, 175) 2 testMessage)
                           ], [UIId 0])
          
-getGUI :: Map.HashMap UIId (GUIAny Pioneers) -> [GUIAny Pioneers]
+getGUI :: Map.HashMap UIId (GUIWidget Pioneers) -> [GUIWidget Pioneers]
 getGUI = Map.elems
 {-# INLINE getGUI #-}
 
@@ -38,23 +38,36 @@ getRootIds = do
   state <- get
   return $ state ^. ui.uiRoots
 
-getRoots :: Pioneers [GUIAny Pioneers]
+getRoots :: Pioneers [GUIWidget Pioneers]
 getRoots = do
   state <- get
   rootIds <- getRootIds
   let hMap = state ^. ui.uiMap
   return $ toGUIAnys hMap rootIds
 
-testMessage :: w -> Pixel -> Pioneers w
+testMessage :: MouseButton -> w -> Pixel -> Pioneers w
-testMessage w (x, y) = do
+testMessage btn w (x, y) = do
-  liftIO $ putStrLn ("\tclick on " ++ show x ++ "," ++ show y)
+  case btn of
+       LeftButton -> liftIO $ putStrLn ("\tleft click on " ++ show x ++ "," ++ show y)
+       RightButton -> liftIO $ putStrLn ("\tright click on " ++ show x ++ "," ++ show y)
+       MiddleButton -> liftIO $ putStrLn ("\tmiddle click on " ++ show x ++ "," ++ show y)
+       MouseX1 -> liftIO $ putStrLn ("\tX1 click on " ++ show x ++ "," ++ show y)
+       MouseX2 -> liftIO $ putStrLn ("\tX2 click on " ++ show x ++ "," ++ show y)
   return w
 
+transformButton :: SDL.MouseButton -> Maybe MouseButton
+transformButton SDL.LeftButton = Just LeftButton
+transformButton SDL.RightButton = Just RightButton
+transformButton SDL.MiddleButton = Just MiddleButton
+transformButton SDL.MouseX1 = Just MouseX1
+transformButton SDL.MouseX2 = Just MouseX2
+transformButton _ = Nothing
+
 eventCallback :: SDL.Event -> Pioneers ()
 eventCallback e = do
         env <- ask
         case SDL.eventData e of
-            SDL.Window _ winEvent -> -- windowID event
+            SDL.Window _ _ -> -- windowID event
                 -- TODO: resize GUI
                 return ()
             SDL.Keyboard movement _ _ key -> -- keyMovement windowID keyRepeat keySym
@@ -109,11 +122,9 @@ eventCallback e = do
                             if st ^. mouse.isDragging then
                                 modify $ mouse.isDragging .~ False
                             else
-                                clickHandler (x, y)
+                                clickHandler LeftButton (x, y)
-                    SDL.RightButton -> do
+                    _ -> do when (state == SDL.Released)
-                        when (state == SDL.Released) $ alternateClickHandler (x, y)
+                                $ maybe (return ()) (`clickHandler` (x, y)) $ transformButton button
-                    _ ->
-                        return ()
             SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll
                 do
                 state <- get
@@ -122,46 +133,38 @@ eventCallback e = do
             -- there is more (joystic, touchInterface, ...), but currently ignored
             SDL.Quit -> modify $ window.shouldClose .~ True
             _ ->  liftIO $ putStrLn $ unwords ["Not processing Event:", show e]
-          
+
 
 -- | Handler for UI-Inputs.
 --   Indicates a primary click on something (e.g. left-click, touch on Touchpad, fire on Gamepad, ...
-clickHandler :: Pixel -> Pioneers ()
+clickHandler :: MouseButton -> Pixel -> Pioneers ()
-clickHandler pos@(x,y) = do
+clickHandler btn pos@(x,y) = do
   state <- get
   let hMap = state ^. ui.uiMap
   roots <- getRootIds
   hits <- liftM concat $ mapM (getInsideId hMap pos) roots
   case hits of
-       [] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"]
+       [] -> liftIO $ putStrLn $ unwords [show btn ++ ":press on (",show x,",",show y,")"]
        _  -> do
          changes <- mapM (\uid -> do
            let w = toGUIAny hMap uid
-           short <- getShorthand w
+               short = w ^. baseProperties.shorthand
-           bound <- getBoundary w
+           bound <- w ^. baseProperties.boundary
-           prio <- getPriority w
+           prio <- w ^. baseProperties.priority
            liftIO $ putStrLn $ "hitting " ++ short ++ ": " ++ show bound ++ " " ++ show prio
                             ++ " at [" ++ show x ++ "," ++ show y ++ "]"
-           case w of
+           case w ^. mouseActions of
-                (GUIAnyB b h) -> do
+                Just ma -> do w'  <- (ma ^. onMousePress) btn pos w
-                    (b', h') <- onMousePressed pos b h
+                              w'' <- (ma ^. onMouseRelease) btn pos w'
-                    (b'', h'') <- onMouseReleased pos b' h'
+                              return $ Just (uid, w'')
-                    return $ Just (uid, GUIAnyB b'' h'')
+                Nothing  -> return Nothing
-                _ -> return Nothing
            ) $ hits
-         let newMap :: Map.HashMap UIId (GUIAny Pioneers)
+         let newMap :: Map.HashMap UIId (GUIWidget Pioneers)
              newMap = foldl' (\hm (uid, w') -> Map.insert uid w' hm) hMap $ catMaybes changes
          modify $ ui.uiMap .~ newMap
          return ()
          
 
-
--- | Handler for UI-Inputs.
---   Indicates an alternate click on something (e.g. right-click, touch&hold on Touchpad, ...
-alternateClickHandler :: Pixel -> Pioneers ()
-alternateClickHandler (x,y) = liftIO $ putStrLn $ unwords ["alternate press on (",show x,",",show y,")"]
-
-
 -- | informs the GUI to prepare a blitting of state ^. gl.glHud.hudTexture
 --
 --TODO: should be done asynchronously at one point.
@@ -183,19 +186,20 @@ prepareGUI = do
                 modify $ ui.uiHasChanged .~ False
 
 --TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates..
-copyGUI :: GL.TextureObject -> GUIAny Pioneers -> Pioneers ()
+copyGUI :: GL.TextureObject -> GUIWidget Pioneers -> Pioneers ()
 copyGUI tex widget = do
-                        (xoff, yoff, wWidth, wHeight) <- getBoundary widget
+                        (xoff, yoff, wWidth, wHeight) <- widget ^. baseProperties.boundary
                         state <- get
                         let 
                             hMap = state ^. ui.uiMap
                             int = fromInteger.toInteger --conversion between Int8, GLInt, Int, ...
                             --temporary color here. lateron better some getData-function to
                             --get a list of pixel-data or a texture.
-                            color = case widget of
+                            color = case widget ^. baseProperties.shorthand of
-                                (GUIAnyC _)   -> [255,0,0,128]
+                                "CNT" -> [255,0,0,128]
-                                (GUIAnyB _ _) -> [255,255,0,255]
+                                "BTN" -> [255,255,0,255]
-                                (GUIAnyP _)   -> [128,128,128,128]
+                                "PNL" -> [128,128,128,128]
+                                _     -> [255,0,255,255]
                         liftIO $ allocaBytes (wWidth*wHeight*4) $ \ptr -> do
                                 --copy data into C-Array
                                 pokeArray ptr (genColorData (wWidth*wHeight) color)
@@ -205,7 +209,7 @@ copyGUI tex widget = do
                                         (GL.TexturePosition2D (int xoff) (int yoff))
                                         (GL.TextureSize2D (int wWidth) (int wHeight))
                                         (GL.PixelData GL.RGBA GL.UnsignedByte ptr)
-                        nextChildrenIds <- getChildren widget
+                        nextChildrenIds <- widget ^. baseProperties.children
                         mapM_ (copyGUI tex) $ toGUIAnys hMap $ nextChildrenIds
 
 --TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc.

src/UI/UIBaseData.hs

@@ -1,10 +1,15 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell, DeriveGeneric #-}
 -- data and classes are separated into several modules to avoid cyclic dependencies with the Type module
-
+-- TODO: exclude UIMouseState constructor
 module UI.UIBaseData where
 
-import Data.Hashable
+import           Control.Lens             ((^.), (.~), (%~), (&), ix, to, mapped, traverse, makeLenses)
-import Data.Ix
+import           Control.Monad            (liftM)
+import           Data.Array
+import           Data.Hashable
+import           Data.Ix                  ()
+import           Data.Maybe
+import           GHC.Generics (Generic)
 
 -- |Unit of screen/window
 type ScreenUnit = Int
@@ -12,21 +17,30 @@ type ScreenUnit = Int
 -- | @x@ and @y@ position on screen. 
 type Pixel = (ScreenUnit, ScreenUnit)
 
-newtype UIId = UIId Int deriving (Eq,Ord,Show,Read,Bounded,Ix,Hashable)
+newtype UIId = UIId Int deriving (Eq, Ord, Bounded, Ix, Hashable, Show, Read)
+
+data MouseButton = LeftButton | RightButton | MiddleButton | MouseX1 | MouseX2
+    deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)
+
+instance Hashable MouseButton
+
+firstButton :: MouseButton
+firstButton = LeftButton
+
+lastButton :: MouseButton
+lastButton = MiddleButton
+
+-- |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)
 
 -- |The state of a clickable ui widget.
-data UIButtonState = UIButtonState
+data UIMouseState = MouseState
-    { _buttonstateIsFiring      :: Bool
+    { _mouseStates :: Array MouseButton UIMouseStateSingle
-    -- ^firing if pressed but not confirmed 
+    , _mouseIsReady       :: Bool -- ^ready if mouse is above component
-    , _buttonstateIsFiringAlt   :: Bool
-    -- ^firing if pressed but not confirmed (secondary mouse button)
-    , _buttonstateIsDeferred    :: Bool -- ^ deferred if e. g. dragging but outside component
-    , _buttonstateIsDeferredAlt :: Bool
-    -- ^deferred if e. g. dragging but outside component (secondary mouse button)
-    , _buttonstateIsReady       :: Bool
-    -- ^ready if mouse is above component
-    , _buttonstateIsActivated   :: Bool
-    -- ^in activated state (e. g. toggle button)
     } deriving (Eq, Show)
 
 
@@ -36,41 +50,183 @@ 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) }
+    { _action :: w -> Pixel -> m w }
 instance Show (ButtonHandler m w) where
   show _ = "ButtonHandler ***"
 
--- |A collection data type that may hold any usable ui element. @m@ is a monad.
+-- |A @GUIWidget@ is a visual object the HUD is composed of. 
-data GUIAny m = GUIAnyC GUIContainer
+data GUIWidget m = Widget
-              | GUIAnyP GUIPanel
+    {_baseProperties :: GUIBaseProperties m
-              | GUIAnyB GUIButton (ButtonHandler m GUIButton)
+    ,_mouseActions :: Maybe (GUIMouseActions m)
-              deriving (Show)
+    ,_graphics :: GUIGraphics m
+    }
+
+-- |Base properties are fundamental settings of any 'GUIWidget'.
+--  They mostly control positioning and widget hierarchy.
+data GUIBaseProperties m = BaseProperties
+    {
+    -- |The @_getBoundary@ function gives the outer extents of the @GUIWidget@.
+    --  The bounding box wholly contains all children components.
+    _boundary :: m (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -- ^@(x, y, width, height)@ in pixels (screen coordinates)
+    ,
+    -- |The @_getChildren@ function returns all children associated with this widget.
+    --
+    --  All children must be wholly inside the parent's bounding box specified by '_boundary'.
+    _children :: m [UIId]
+    ,
+    -- |The function @_isInside@ tests whether a point is inside the widget itself.
+    --  A screen position may be inside the bounding box of a widget but not considered part of the
+    --  component.
+    --  
+    --  The default implementations tests if the point is within the rectangle specified by the 
+    --  'getBoundary' function.
+    _isInside :: GUIWidget m
+              -> Pixel  -- ^screen position
+              -> m Bool
+    ,
+    -- |The @_getPriority@ function returns the priority score of a @GUIWidget@.
+    --  A widget with a high score is more in the front than a low scored widget.
+    _priority :: m Int
+    ,
+    -- |The @_getShorthand@ function returns a descriptive 'String' mainly for debuggin prupose.
+    --  The shorthand should be unique for each instance.
+    _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
+    }
 
 
--- |A 'GUIContainer' is a widget that may contain additional widgets but does not have a
+-- |@GUIGraphics@ functions define the look of a 'GUIWidget'.
---  functionality itself.
-data GUIContainer = GUIContainer { _uiScreenX :: ScreenUnit, _uiScreenY :: ScreenUnit
-                                 , _uiWidth :: ScreenUnit, _uiHeight :: ScreenUnit
-                                 , _uiChildren :: [UIId]
-                                 , _uiPriority :: Int
-                                 } deriving (Show)
 
--- |A 'GUIPanel' is much like a 'GUIContainer' but it resizes automatically according to its
+data GUIGraphics m = Graphics 
---  children components.
+    {temp :: m Int}
-data GUIPanel = GUIPanel { _panelContainer :: GUIContainer} deriving (Show)
+
+$(makeLenses ''UIMouseState)
+$(makeLenses ''UIMouseStateSingle)
+$(makeLenses ''GUIWidget)
+$(makeLenses ''GUIBaseProperties)
+$(makeLenses ''GUIMouseActions)
+$(makeLenses ''GUIGraphics)
+
+initialMouseStateS :: UIMouseStateSingle
+initialMouseStateS = MouseStateSingle False False
+{-# INLINE initialMouseStateS #-}
+
+-- |Creates a @UIMouseState@ its @_mouseStates@ are valid 'UIMouseStateSingle' for any @MouseButton@
+--  provided in the passed list.
+initialMouseState :: UIMouseState
+initialMouseState = MouseState (array (minBound, maxBound) [(i, initialMouseStateS) | i <- range (minBound, maxBound)])
+                               False
+{-# 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 @GUIMouseActions@ handler that enables button clicks.
+-- 
+--  The action is peformed right before the button state change.
+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@.
+    press' b _ w =
+        return $ w & mouseActions.traverse.mouseState.mouseStates.(ix b).mouseIsFiring .~ True
+
+    -- |Change 'UIMouseState's '_mouseIsFiring' and '_mouseIsDeferred' to @False@ and
+    --  call action if '_mouseIsFiring' was @True@.
+    release' b p w =
+      let fire = w ^. mouseActions.(to fromJust).mouseState.mouseStates.(to (!b)).mouseIsFiring -- TODO? may break if initialized and called wrongly
+      in do w' <- if fire
+                  then a b w p
+                  else return w
+            return $ w' & mouseActions.traverse.mouseState.mouseStates.(ix b) %~
+                (mouseIsFiring .~ False) . (mouseIsDeferred .~ False)
+    
+    -- |Do nothing.
+    move' _ = return
+    
+    -- |Set 'UIMouseState's '_mouseIsReady' to @True@ and
+    --  update dragging state (only drag if inside widget).
+    --  In detail, change 'UIMouseState's '_mouseIsDeferred' to '_mouseIsFiring's current value
+    --  and set '_mouseIsFiring' to @False@. 
+    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
+    --  update dragging state (only drag if inside widget).
+    --  In detail, change 'UIMouseState's '_buttonstateIsFiring' to '_buttonstateIsDeferred's current value
+    --  and set '_buttonstateIsDeferred's' to @False@.
+    leave' _ w = return $ w & mouseActions.traverse.mouseState %~ (mouseIsReady .~ False)
+                        .(mouseStates.mapped %~ (mouseIsFiring .~ False)
+                            -- following line executed BEFORE above line
+                            .(\sState -> sState & mouseIsDeferred .~ not (sState ^. mouseIsFiring)))
+
+emptyGraphics :: (Monad m) => GUIGraphics m
+emptyGraphics = Graphics (return 3)
+
+isInsideRect :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> Pixel -> Bool
+isInsideRect (x,y,w,h) (x',y') = (x' - x <= w) && (x' - x >= 0) && (y' - y <= h) && (y' - y >= 0)
+
+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))
+                   (return prio) short
+
+debugShowWidget' :: (Monad m) => GUIWidget m -> m String
+debugShowWidget' (Widget base mouse _) = 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]
     
--- |A 'GUIButton' is a clickable 'GUIWidget'. Its functinality must be
---  provided by an appropriate 'MouseHanlder'.
-data GUIButton = GUIButton { _uiScreenXB :: ScreenUnit, _uiScreenYB :: ScreenUnit
-                           , _uiWidthB :: ScreenUnit, _uiHeightB :: ScreenUnit
-                           , _uiPriorityB :: Int
-                           , _uiButtonState :: UIButtonState
-                           } deriving ()
-instance Show GUIButton where
-  show w = "GUIButton {_screenXB = " ++ show (_uiScreenXB w)
-        ++ " _screenYB = " ++ show (_uiScreenYB w)
-        ++ " _widthB = " ++ show (_uiWidthB w)
-        ++ " _heightB = " ++ show (_uiHeightB w)
-        ++ " _priorityB = " ++ show (_uiScreenYB w)
-        ++ " _buttonState = " ++ show (_uiButtonState w)
-        ++ "}"

src/UI/UIClasses.hs

@@ -1,8 +1,8 @@
 {-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-}
 
-module UI.UIClasses where
+module UI.UIClasses (module UI.UIClasses, module UI.UIBaseData) where
 
-import           Control.Lens                         ((^.))
+import           Control.Lens                         ((^.), (.~), (&))
 import           Control.Monad
 --import           Control.Monad.IO.Class -- MonadIO
 import           Control.Monad.RWS.Strict             (get)
@@ -10,234 +10,39 @@ import           Data.List
 import           Data.Maybe
 import qualified Data.HashMap.Strict as Map
 
-import qualified Types as T
+import           Types
 import UI.UIBaseData
 
-class GUIAnyMap m w where
-    guiAnyMap :: (w -> b) -> GUIAny m -> b
-    
-class (Monad m) => GUIWidget m uiw where
-    -- |The 'getBoundary' function gives the outer extents of the 'UIWidget'.
-    --  The bounding box wholly contains all children components.
-    getBoundary :: uiw -> m (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -- ^@(x, y, width, height)@ in pixels (screen coordinates)
 
-    -- |The 'getChildren' function returns all children associated with this widget.
+createContainer :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget m
-    --
+createContainer bnd chld prio = Widget (rectangularBase bnd chld prio "CNT")
-    --  All children must be wholly inside the parent's bounding box specified by 'getBoundary'.
+                                          Nothing
-    getChildren :: uiw -> m [UIId]
+                                          emptyGraphics
-    getChildren _ = return []
 
-    -- |The function 'isInside' tests whether a point is inside the widget itself.
-    --  A screen position may be inside the bounding box of a widget but not considered part of the
-    --  component.
-    --  
-    --  The default implementations tests if the point is within the rectangle specified by the 
-    --  'getBoundary' function.
-    isInside :: Pixel  -- ^screen position
-             -> uiw    -- ^the parent widget
-             -> m Bool
-    isInside (x',y') wg = do
-        (x, y, w, h) <- getBoundary wg
-        return $ (x' - x <= w) && (x' - x >= 0) && (y' - y <= h) && (y' - y >= 0)
 
-    -- |The 'getPriority' function returns the priority score of a 'GUIWidget'.
+createPanel :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget Pioneers
-    --  A widget with a high score is more in the front than a low scored widget.
+createPanel bnd chld prio = Widget (rectangularBase bnd chld prio "PNL" & boundary .~ autosize')
-    getPriority :: uiw -> m Int
+                                      Nothing
-    getPriority _ = return 0
+                                      emptyGraphics
-    
+  where
-    -- |The 'getShorthand' function returns a descriptive 'String' mainly for debuggin prupose.
+    autosize' :: Pioneers (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit)
-    --  The shorthand should be unique for each instance.
+    autosize' = do
-    getShorthand :: uiw -> m String
-
--- |A 'GUIClickable' represents a widget with a 'UIButtonState'.
--- 
---  Minimal complete definition: 'getButtonState' and either 'updateButtonState' or 'setButtonState'.
-class GUIClickable w where
-    updateButtonState :: (UIButtonState -> UIButtonState) -> w -> w
-    updateButtonState f w = setButtonState (f $ getButtonState w) w
-    setButtonState :: UIButtonState -> w -> w
-    setButtonState s = updateButtonState (\_ -> s)
-    getButtonState :: w -> UIButtonState
-
-class Monad m => MouseHandler a m w where
-    -- |The function 'onMousePressed' is called when the primary button is pressed
-    --  while inside a screen coordinate within the widget ('isInside').
-    onMousePressed :: Pixel -- ^screen position
-                   -> w -- ^widget the event is invoked on
-                   -> a -> m (w, a) -- ^widget after the event and the altered handler
-    onMousePressed _ wg a = return (wg, a)
-
-    -- |The function 'onMouseReleased' is called when the primary 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.
-    onMouseReleased :: Pixel  -- ^screen position
-                    -> w -- ^wdiget the event is invoked on
-                    -> a -> m (w, a) -- ^widget after the event and the altered handler
-    onMouseReleased _ wg a = return (wg, a)
-
-    -- |The function 'onMousePressed' is called when the secondary button is pressed
-    --  while inside a screen coordinate within the widget ('isInside').
-    onMousePressedAlt :: Pixel  -- ^screen position
-                      -> w -- ^widget the event is invoked on
-                      -> a -> m (w, a) -- ^widget after the event and the altered handler
-    onMousePressedAlt _ wg a = return (wg, a)
-
-    -- |The function 'onMouseReleased' is called when the secondary 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.
-    onMouseReleasedAlt :: Pixel  -- ^screen position
-                       -> w -- ^wdiget the event is invoked on
-                       -> a -> m (w, a) -- ^widget after the event and the altered handler
-    onMouseReleasedAlt _ wg a = return (wg, a)
-                        
-    -- |The function 'onMouseMove' is invoked when the mouse is moved inside the
-    --  widget's space ('isInside').
-    onMouseMove :: Pixel  -- ^screen position
-                -> w -- ^widget the event is invoked on
-                -> a -> m (w, a) -- ^widget after the event and the altered handler
-    onMouseMove _ wg a = return (wg, a)
-    
-    -- |The function 'onMouseMove' is invoked when the mouse enters the
-    --  widget's space ('isInside').
-    onMouseEnter :: Pixel  -- ^screen position
-                 -> w -- ^widget the event is invoked on
-                 -> a -> m (w, a) -- ^widget after the event and the altered handler
-    onMouseEnter _ wg a = return (wg, a)
-    
-    -- |The function 'onMouseMove' is invoked when the mouse leaves the
-    --  widget's space ('isInside').
-    onMouseLeave :: Pixel  -- ^screen position
-                 -> w -- ^widget the event is invoked on
-                 -> a -> m (w, a) -- ^widget after the event and the altered handler
-    onMouseLeave _ wg a = return (wg, a)
-
-instance (MouseHandler h m w) => MouseHandler (MouseHandlerSwitch h) m w where
-    onMousePressed p w (MouseHandlerSwitch h) = do
-        (w', h') <- onMousePressedAlt p w h
-        return (w', MouseHandlerSwitch h')
-    onMouseReleased p w (MouseHandlerSwitch h) = do
-        (w', h') <- onMouseReleasedAlt p w h
-        return (w', MouseHandlerSwitch h')
-    onMousePressedAlt p w (MouseHandlerSwitch h) = do
-        (w', h') <- onMousePressed p w h
-        return (w', MouseHandlerSwitch h')
-    onMouseReleasedAlt p w (MouseHandlerSwitch h) = do
-        (w', h') <- onMouseReleased p w h
-        return (w', MouseHandlerSwitch h')
-    onMouseMove p w (MouseHandlerSwitch h) = do
-        (w', h') <- onMouseMove p w h
-        return (w', MouseHandlerSwitch h')
-    onMouseEnter p w (MouseHandlerSwitch h) = do
-        (w', h') <- onMouseEnter p w h
-        return (w', MouseHandlerSwitch h')
-    onMouseLeave p w (MouseHandlerSwitch h) = do
-        (w', h') <- onMouseLeave p w h
-        return (w', MouseHandlerSwitch h')
-
-instance (Monad m, GUIClickable w) => MouseHandler (ButtonHandler m w) m w where
-    -- |Change 'UIButtonState's '_buttonstateIsFiring' to @True@.
-    onMousePressed _ wg h =
-        return (updateButtonState (\s -> s {_buttonstateIsFiring = True}) wg, h)
-
-    -- |Change 'UIButtonState's '_buttonstateIsFiring' to @False@ and
-    --  call 'action' if inside the widget or
-    --  set '_buttonstateIsDeferred' to false otherwise.
-    onMouseReleased p wg h@(ButtonHandler action) = if _buttonstateIsFiring $ getButtonState wg 
-        then do
-            wg' <- action wg p
-            return (updateButtonState (\s -> s {_buttonstateIsFiring = False}) wg', h)
-        else return (updateButtonState (\s -> s {_buttonstateIsDeferred = False}) wg, h)
-    
-    -- |Do nothing.
-    onMouseMove _ wg h = return (wg, h)
-    
-    -- |Set 'UIButtonState's '_buttonstateIsReady' to @True@ and
-    --  update dragging state (only drag if inside widget).
-    --  In detail, change 'UIButtonState's '_buttonstateIsDeferred' to '_buttonstateIsFiring's current value
-    --   and set '_buttonstateIsFiring' to @False@. 
-    onMouseEnter _ wg h = return
-        (updateButtonState (\s -> s { _buttonstateIsFiring = _buttonstateIsDeferred s
-                                    , _buttonstateIsDeferred = False
-                                    , _buttonstateIsReady = True
-                                    }) wg
-                                    , h)
-    
-    -- |Set 'UIButtonState's 'buttonstateIsReady' to @False@ and
-    --  update dragging state (only drag if inside widget).
-    --  In detail, change 'UIButtonState's '_buttonstateIsFiring' to '_buttonstateIsDeferred's current value
-    --  and set '_buttonstateIsDeferred's' to @False@.
-    onMouseLeave _ wg h = return
-        (updateButtonState (\s -> s { _buttonstateIsFiring = False
-                                    , _buttonstateIsDeferred = _buttonstateIsFiring s
-                                    , _buttonstateIsReady = False
-                                    }) wg
-                                    , h)
-
-instance (Monad m) => GUIAnyMap m (GUIAny m) where
-    guiAnyMap f w = f w
-
-instance GUIWidget T.Pioneers (GUIAny T.Pioneers) where
-    getBoundary (GUIAnyC w) = getBoundary w
-    getBoundary (GUIAnyP w) = getBoundary w
-    getBoundary (GUIAnyB w _) = getBoundary w
-    getChildren (GUIAnyC w) = getChildren w
-    getChildren (GUIAnyP w) = getChildren w
-    getChildren (GUIAnyB w _) = getChildren w
-    isInside p (GUIAnyC w) = (isInside p) w
-    isInside p (GUIAnyP w) = (isInside p) w
-    isInside p (GUIAnyB w _) = (isInside p) w
-    getPriority (GUIAnyC w) = getPriority w
-    getPriority (GUIAnyP w) = getPriority w
-    getPriority (GUIAnyB w _) = getPriority w
-    getShorthand (GUIAnyC w) = do { str <- getShorthand w; return $ "A" ++ str }
-    getShorthand (GUIAnyP w) = do { str <- getShorthand w; return $ "A" ++ str }
-    getShorthand (GUIAnyB w _) = do { str <- getShorthand w; return $ "A" ++ str }
-
-instance (Monad m) => GUIAnyMap m GUIContainer where
-    guiAnyMap f (GUIAnyC c) = f c
-    guiAnyMap _ _ = error "invalid types in guiAnyMap"
-instance (Monad m) => GUIWidget m GUIContainer where
-    getBoundary :: GUIContainer -> m (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit)
-    getBoundary cnt = return (_uiScreenX cnt, _uiScreenY cnt, _uiWidth cnt, _uiHeight cnt)
-    getChildren cnt = return $ _uiChildren cnt
-    getPriority cnt = return $ _uiPriority cnt
-    getShorthand _ = return $ "CNT"
-    
-instance GUIAnyMap m GUIPanel where
-    guiAnyMap f (GUIAnyP p) = f p
-    guiAnyMap _ _ = error "invalid types in guiAnyMap"
-instance GUIWidget T.Pioneers GUIPanel where
-    getBoundary pnl = do
         state <- get
-        let hmap = state ^. T.ui . T.uiMap
+        let hmap = state ^. ui . uiMap
-        case _uiChildren $ _panelContainer pnl of
+            -- TODO: local coordinates
-                           [] -> getBoundary $ _panelContainer pnl
+            determineSize' :: (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit)
-                           cs -> do
+            determineSize' (x, y, w, h) (x', y', w', h') =
-                                 let widgets = catMaybes $ map (flip Map.lookup hmap) cs
+               let x'' = if x' < x then x' else x
-                                 foldl' (liftM2 determineSize) (getBoundary $ _panelContainer pnl) $ map getBoundary widgets
+                   y'' = if y' < y then y' else y
-      where
+                   w'' = if x' + w' > x + w then x' + w' - x'' else x + w - x''
-        determineSize :: (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit)
+                   h'' = if y' + h' > y + h then y' + h' - y'' else y + h - y''
-        determineSize (x, y, w, h) (x', y', w', h') =
+                in (x'', y'', w'', h'')
-            let x'' = if x' < x then x' else x
+        case chld of
-                y'' = if y' < y then y' else y
+             [] -> return bnd
-                w'' = if x' + w' > x + w then x' + w' - x'' else x + w - x''
+             cs -> do let widgets = mapMaybe (`Map.lookup` hmap) cs
-                h'' = if y' + h' > y + h then y' + h' - y'' else y + h - y''
+                      foldl' (liftM2 determineSize') (return bnd) $ map (\w -> w ^. baseProperties.boundary) widgets
-            in (x'', y'', w'', h'')
-            
-    getChildren pnl = getChildren $ _panelContainer pnl
-    getPriority pnl = getPriority $ _panelContainer pnl
-    getShorthand _ = return $ "PNL"
 
-instance (Monad m) => GUIAnyMap m GUIButton where
+createButton :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> Int -> (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -> GUIWidget m
-    guiAnyMap f (GUIAnyB btn _) = f btn
+createButton bnd prio action = Widget (rectangularBase bnd [] prio "BTN")
-    guiAnyMap _ _ = error "invalid types in guiAnyMap"
+                                         (Just $ buttonMouseActions action)
-instance GUIClickable GUIButton where
+                                         emptyGraphics
-    getButtonState = _uiButtonState
-    updateButtonState f btn = btn {_uiButtonState = f $ _uiButtonState btn}
-instance (Monad m) => GUIWidget m GUIButton where
-    getBoundary btn = return (_uiScreenXB btn, _uiScreenYB btn, _uiWidthB btn, _uiHeightB btn)
-    getChildren _ = return []
-    getPriority btn = return $ _uiPriorityB btn
-    getShorthand _ = return "BTN"

src/UI/UIOperations.hs

@@ -1,23 +1,19 @@
 module UI.UIOperations where
 
-import           Control.Monad       (liftM)
+import           Control.Lens                    ((^.))
-import qualified Data.HashMap.Strict as Map
+import           Control.Monad                   (liftM)
+import qualified Data.HashMap.Strict             as Map
 import           Data.Maybe
 
 import Types
 import UI.UIBaseData
-import UI.UIClasses
 
-defaultUIState :: UIButtonState
+toGUIAny :: Map.HashMap UIId (GUIWidget m) -> UIId -> GUIWidget m
-defaultUIState = UIButtonState False False False False False False
-{-# INLINE defaultUIState #-}
-
-toGUIAny :: Map.HashMap UIId (GUIAny m) -> UIId -> GUIAny m
 toGUIAny m uid = fromMaybe (error "map does not contain requested key") (Map.lookup uid m)
 {-# INLINE toGUIAny #-}
 
-toGUIAnys :: Map.HashMap UIId (GUIAny m) -> [UIId] -> [GUIAny m]
+toGUIAnys :: Map.HashMap UIId (GUIWidget m) -> [UIId] -> [GUIWidget m]
-toGUIAnys m = mapMaybe (flip Map.lookup m)
+toGUIAnys m = mapMaybe (`Map.lookup` m)
 {-# INLINE toGUIAnys #-}
 -- TODO: check for missing components?
 
@@ -31,19 +27,19 @@ toGUIAnys m = mapMaybe (flip Map.lookup m)
 --  or @[]@ if the point does not hit the widget.
 --  
 --  This function returns the widgets themselves unlike 'getInsideId'.
-getInside :: Map.HashMap UIId (GUIAny Pioneers) -- ^map containing ui widgets
+getInside :: Map.HashMap UIId (GUIWidget Pioneers) -- ^map containing ui widgets
-             -> Pixel  -- ^screen position
+          -> Pixel  -- ^screen position
-             -> GUIAny Pioneers  -- ^the parent widget
+          -> GUIWidget Pioneers  -- ^the parent widget
-             -> Pioneers [GUIAny Pioneers]
+          -> Pioneers [GUIWidget Pioneers]
-getInside hMap (x',y') wg = do
+getInside hMap px wg = do
-  inside <- isInside (x',y') wg
+  inside <- (wg ^. baseProperties.isInside) wg px
   if inside -- test inside parent's bounding box
   then do
-       childrenIds <- getChildren wg
+       childrenIds <- wg ^. baseProperties.children
-       hitChildren <- liftM concat $ mapM (getInside hMap (x',y')) (toGUIAnys hMap childrenIds)
+       hitChildren <- liftM concat $ mapM (getInside hMap px) (toGUIAnys hMap childrenIds)
        case hitChildren of
             [] -> return [wg]
-            _ -> return hitChildren
+            _  -> return hitChildren
   else return []
 --TODO: Priority queue?
 
@@ -56,17 +52,17 @@ getInside hMap (x',y') wg = do
 --  or @[]@ if the point does not hit the widget.
 --  
 --  This function returns the 'UIId's of the widgets unlike 'getInside'.
-getInsideId :: Map.HashMap UIId (GUIAny Pioneers) -- ^map containing ui widgets
+getInsideId :: Map.HashMap UIId (GUIWidget Pioneers) -- ^map containing ui widgets
             -> Pixel  -- ^screen position
             -> UIId  -- ^the parent widget
             -> Pioneers [UIId]
-getInsideId hMap (x',y') uid = do
+getInsideId hMap px uid = do
   let wg = toGUIAny hMap uid
-  inside <- isInside (x',y') wg
+  inside <- (wg ^. baseProperties.isInside) wg px
   if inside -- test inside parent's bounding box
     then do
-      childrenIds <- getChildren wg
+      childrenIds <- wg ^. baseProperties.children
-      hitChildren <- liftM concat $ mapM (getInsideId hMap (x',y')) childrenIds
+      hitChildren <- liftM concat $ mapM (getInsideId hMap px) childrenIds
       case hitChildren of
            [] -> return [uid]
            _  -> return hitChildren