basic gui working... somehow (no painting yet)
This commit is contained in:
tpajenka
parent
2de621d73f
commit
1898758eb5
@ -9,14 +9,37 @@ import UI.UITypes
|
||||
data Pixel = Pixel Int Int
|
||||
|
||||
getGUI :: [GUIAny]
|
||||
getGUI = (GUIAny $ GUIContainer 0 0 120 80 [] 1):(GUIAny $ GUIContainer 50 60 300 700 [(GUIAny $ GUIContainer 55 65 200 400 [] 5)] 1):[]
|
||||
getGUI = [ toGUIAny $ GUIContainer 0 0 120 80 [] 1
|
||||
, toGUIAny $ GUIPanel $ GUIContainer 0 0 0 0
|
||||
[toGUIAny $ GUIContainer 0 80 100 200 [] 4
|
||||
,GUIAnyB (GUIButton 50 400 200 175 2 (testMessage) defaultUIState)
|
||||
] 3
|
||||
]
|
||||
|
||||
testMessage :: (Show w) => w -> ScreenUnit -> ScreenUnit -> IO w
|
||||
testMessage w x y = do
|
||||
putStrLn ("\tclick on " ++ show x ++ "," ++ show y)
|
||||
return w
|
||||
|
||||
-- | Handler for UI-Inputs.
|
||||
-- Indicates a primary click on something (e.g. left-click, touch on Touchpad, fire on Gamepad, ...
|
||||
clickHandler :: Pixel -> Pioneers ()
|
||||
clickHandler (Pixel x y) = case concat $ map (isInside x y) getGUI of
|
||||
clickHandler (Pixel x y) = case concatMap (isInside x y) getGUI of
|
||||
[] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"]
|
||||
hit -> liftIO $ putStrLn $ unwords $ foldl (++) ["hitting"] ([map (\w -> (show.getBoundary) w ++ ' ':(show.getPriority) w) hit])
|
||||
hit -> liftIO $ do
|
||||
_ <- sequence $ map (\w ->
|
||||
case w of
|
||||
(GUIAnyB b) -> do
|
||||
putStrLn $ "hitting " ++ getShorthand w ++ ": " ++ show (getBoundary w) ++ " " ++ show (getPriority w)
|
||||
++ " at ["++show x++","++show y++"]"
|
||||
(b', _) <- onMousePressed x y b b
|
||||
_ <- onMouseReleased x y b' b'
|
||||
return ()
|
||||
_ -> putStrLn $ "hitting " ++ getShorthand w ++ ": " ++ show (getBoundary w) ++ " " ++ show (getPriority w)
|
||||
++ " at ["++show x++","++show y++"]"
|
||||
) hit
|
||||
return ()
|
||||
|
||||
|
||||
-- | Handler for UI-Inputs.
|
||||
-- Indicates an alternate click on something (e.g. right-click, touch&hold on Touchpad, ...
|
||||
|
||||
@ -1,16 +1,54 @@
|
||||
{-# LANGUAGE InstanceSigs, ExistentialQuantification #-}
|
||||
{-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-}
|
||||
|
||||
module UI.UITypes where
|
||||
|
||||
import Data.List
|
||||
import Foreign.C (CFloat)
|
||||
import Linear.Matrix (M44)
|
||||
|
||||
type IntScreen = Int
|
||||
-- |Unit of screen/window
|
||||
type ScreenUnit = Int
|
||||
|
||||
data GUIAny = forall wg. GUIWidget wg => GUIAny wg
|
||||
-- |A viewport to an OpenGL scene.
|
||||
data Viewport = Viewport
|
||||
{ _viewportXAngle :: !Double
|
||||
, _viewportYAngle :: !Double
|
||||
, _viewportZDist :: !Double
|
||||
, _viewportFrustum :: !(M44 CFloat)
|
||||
, _viewportPositionX :: !ScreenUnit -- ^x position in window
|
||||
, _viewportPositionY :: !ScreenUnit -- ^y position in window
|
||||
, _viewportWidth :: !ScreenUnit -- ^viewport width in window
|
||||
, _viewportHeight :: !ScreenUnit -- ^viewport height in window
|
||||
} deriving (Eq, Show)
|
||||
|
||||
class GUIWidget uiw where
|
||||
data UIState = UIState
|
||||
{ _uistateIsFiring :: Bool
|
||||
-- ^firing if pressed but not confirmed
|
||||
, _uistateIsFiringAlt :: Bool
|
||||
-- ^firing if pressed but not confirmed (secondary mouse button)
|
||||
, _uistateIsDeferred :: Bool -- ^ deferred if e. g. dragging but outside component
|
||||
, _uistateIsDeferredAlt :: Bool
|
||||
-- ^deferred if e. g. dragging but outside component (secondary mouse button)
|
||||
, _uistateIsReady :: Bool
|
||||
-- ^ready if mouse is above component
|
||||
, _uistateIsActivated :: Bool
|
||||
-- ^in activated state (e. g. toggle button)
|
||||
} deriving (Eq, Show)
|
||||
|
||||
|
||||
defaultUIState :: UIState
|
||||
defaultUIState = UIState False False False False False False
|
||||
|
||||
class GUIAnyMap w where
|
||||
guiAnyMap :: (w -> b) -> GUIAny -> b
|
||||
toGUIAny :: w -> GUIAny
|
||||
fromGUIAny :: GUIAny -> w
|
||||
|
||||
|
||||
class (GUIAnyMap uiw) => GUIWidget uiw where
|
||||
-- |The 'getBoundary' function gives the outer extents of the 'UIWidget'.
|
||||
-- The bounding box wholly contains all children components.
|
||||
getBoundary :: uiw -> (IntScreen, IntScreen, IntScreen ,IntScreen) -- ^@(x, y, width, height)@ in pixels (screen coordinates)
|
||||
getBoundary :: uiw -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -- ^@(x, y, width, height)@ in pixels (screen coordinates)
|
||||
|
||||
-- |The 'getChildren' function returns all children associated with this widget.
|
||||
--
|
||||
@ -19,9 +57,13 @@ class GUIWidget uiw where
|
||||
getChildren _ = []
|
||||
|
||||
-- |The function 'isInsideSelf' 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.
|
||||
isInsideSelf :: IntScreen -- ^screen x coordinate
|
||||
-> IntScreen -- ^screen y coordinate
|
||||
-- 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.
|
||||
isInsideSelf :: ScreenUnit -- ^screen x coordinate
|
||||
-> ScreenUnit -- ^screen y coordinate
|
||||
-> uiw -- ^the parent widget
|
||||
-> Bool
|
||||
isInsideSelf x' y' wg = let (x, y, w, h) = getBoundary wg
|
||||
@ -31,15 +73,15 @@ class GUIWidget uiw where
|
||||
-- A screen position may be inside the bounding box of a widget but not considered part of the component.
|
||||
-- The function returns all hit widgets that have no hit children or 'Nothing' if the point neither hits any
|
||||
-- component nor the parent widget itself.
|
||||
isInside :: IntScreen -- ^screen x coordinate
|
||||
-> IntScreen -- ^screen y coordinate
|
||||
isInside :: ScreenUnit -- ^screen x coordinate
|
||||
-> ScreenUnit -- ^screen y coordinate
|
||||
-> uiw -- ^the parent widget
|
||||
-> [GUIAny]
|
||||
isInside x' y' wg =
|
||||
case isInsideSelf x' y' wg of -- test inside parent's bounding box
|
||||
False -> []
|
||||
True -> case concat $ map (isInside x' y') (getChildren wg) of
|
||||
[] -> [GUIAny wg]
|
||||
[] -> [toGUIAny wg]
|
||||
l -> l
|
||||
--TODO: Priority queue?
|
||||
|
||||
@ -48,21 +90,296 @@ class GUIWidget uiw where
|
||||
getPriority :: uiw -> Int
|
||||
getPriority _ = 0
|
||||
|
||||
-- |The 'getShorthand' function returns a descriptive 'String' mainly for debuggin prupose.
|
||||
-- The shorthand should be unique for each instance.
|
||||
getShorthand :: uiw -> String
|
||||
|
||||
class MouseHandler a w where
|
||||
-- |The function 'onMousePressed' is called when the primary button is pressed
|
||||
-- while inside a screen coordinate within the widget ('isInside').
|
||||
onMousePressed :: ScreenUnit -- ^screen x coordinate
|
||||
-> ScreenUnit -- ^screen y coordinate
|
||||
-> w -- ^widget the event is invoked on
|
||||
-> a -> IO (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 :: ScreenUnit -- ^screen x coordinate
|
||||
-> ScreenUnit -- ^screen x coordinate
|
||||
-> w -- ^wdiget the event is invoked on
|
||||
-> a -> IO (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 :: ScreenUnit -- ^screen x coordinate
|
||||
-> ScreenUnit -- ^screen y coordinate
|
||||
-> w -- ^widget the event is invoked on
|
||||
-> a -> IO (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 :: ScreenUnit -- ^screen x coordinate
|
||||
-> ScreenUnit -- ^screen x coordinate
|
||||
-> w -- ^wdiget the event is invoked on
|
||||
-> a -> IO (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 :: ScreenUnit -- ^screen x coordinate
|
||||
-> ScreenUnit -- ^screen y coordinate
|
||||
-> w -- ^widget the event is invoked on
|
||||
-> a -> IO (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 :: ScreenUnit -- ^screen x coordinate
|
||||
-> ScreenUnit -- ^screen y coordinate
|
||||
-> w -- ^widget the event is invoked on
|
||||
-> a -> IO (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 :: ScreenUnit -- ^screen x coordinate
|
||||
-> ScreenUnit -- ^screen y coordinate
|
||||
-> w -- ^widget the event is invoked on
|
||||
-> a -> IO (w, a) -- ^widget after the event and the altered handler
|
||||
onMouseLeave _ _ wg a = return (wg, a)
|
||||
|
||||
-- |Switches primary and secondary mouse actions.
|
||||
data MouseHandlerSwitch w h = MouseHandlerSwitch h deriving (Eq, Show)
|
||||
instance Functor (MouseHandlerSwitch w) where
|
||||
fmap :: (h1 -> h2) -> MouseHandlerSwitch w h1 -> MouseHandlerSwitch w h2
|
||||
fmap f (MouseHandlerSwitch h) = MouseHandlerSwitch (f h)
|
||||
instance Monad (MouseHandlerSwitch w) where
|
||||
(>>=) :: (MouseHandlerSwitch w h1) -> (h1 -> MouseHandlerSwitch w h2) -> MouseHandlerSwitch w h2
|
||||
(MouseHandlerSwitch h) >>= f = f h
|
||||
return :: h -> MouseHandlerSwitch w h
|
||||
return h = MouseHandlerSwitch h
|
||||
instance (MouseHandler h w) => MouseHandler (MouseHandlerSwitch w h) w where
|
||||
onMousePressed x y w (MouseHandlerSwitch h) = do
|
||||
(w', h') <- onMousePressedAlt x y w h
|
||||
return (w', MouseHandlerSwitch h')
|
||||
onMouseReleased x y w (MouseHandlerSwitch h) = do
|
||||
(w', h') <- onMouseReleasedAlt x y w h
|
||||
return (w', MouseHandlerSwitch h')
|
||||
onMousePressedAlt x y w (MouseHandlerSwitch h) = do
|
||||
(w', h') <- onMousePressed x y w h
|
||||
return (w', MouseHandlerSwitch h')
|
||||
onMouseReleasedAlt x y w (MouseHandlerSwitch h) = do
|
||||
(w', h') <- onMouseReleased x y w h
|
||||
return (w', MouseHandlerSwitch h')
|
||||
onMouseMove x y w (MouseHandlerSwitch h) = do
|
||||
(w', h') <- onMouseMove x y w h
|
||||
return (w', MouseHandlerSwitch h')
|
||||
onMouseEnter x y w (MouseHandlerSwitch h) = do
|
||||
(w', h') <- onMouseEnter x y w h
|
||||
return (w', MouseHandlerSwitch h')
|
||||
onMouseLeave x y w (MouseHandlerSwitch h) = do
|
||||
(w', h') <- onMouseLeave x y w h
|
||||
return (w', MouseHandlerSwitch h')
|
||||
|
||||
|
||||
-- !!Important: one handler can only handle one single widget!!
|
||||
data ButtonHandler w = ButtonHandler
|
||||
{ _action :: (w -> ScreenUnit -> ScreenUnit -> IO w)
|
||||
, _handlerState :: UIState
|
||||
}
|
||||
instance (Show w) => Show (ButtonHandler w) where
|
||||
show (ButtonHandler _ w) = "ButtonHandler [" ++ show w ++ "] " ++ "[action]"
|
||||
instance MouseHandler (ButtonHandler w) w where
|
||||
-- |Change 'UIState's '_uistateIsFiring' to @True@.
|
||||
onMousePressed _ _ wg h@(ButtonHandler _ s) = do
|
||||
return (wg, h {_handlerState = s {_uistateIsFiring = True}})
|
||||
|
||||
-- |Change 'UIState's '_uistateIsFiring' to @False@ and
|
||||
-- call 'action' if inside the widget or
|
||||
-- set '_uistateIsDeferred' to false otherwise.
|
||||
onMouseReleased x y wg h@(ButtonHandler f s) = if _uistateIsFiring s
|
||||
then do
|
||||
wg' <- f wg x y
|
||||
return (wg', h {_handlerState = s {_uistateIsFiring = False}})
|
||||
else return (wg, h {_handlerState = s {_uistateIsDeferred = False}})
|
||||
|
||||
-- |Do nothing.
|
||||
onMouseMove _ _ wg h = return (wg, h)
|
||||
|
||||
-- |Set 'UIState's '_uistateIsReady' to @True@ and
|
||||
-- update dragging state (only drag if inside widget).
|
||||
-- In detail, change 'UIState's '_uistateIsDeferred' to '_uistateIsFiring's current value
|
||||
-- and set '_uistateIsFiring' to @False@.
|
||||
onMouseEnter _ _ wg h@(ButtonHandler _ s) = return
|
||||
(wg, h {_handlerState = s { _uistateIsFiring = _uistateIsDeferred s
|
||||
, _uistateIsDeferred = False
|
||||
, _uistateIsReady = True
|
||||
}})
|
||||
|
||||
-- |Set 'UIState's 'uistateIsReady' to @False@ and
|
||||
-- update dragging state (only drag if inside widget).
|
||||
-- In detail, change 'UIState's '_uistateIsFiring' to '_uistateIsDeferred's current value
|
||||
-- and set '_uistateIsDeferred's' to @False@.
|
||||
onMouseLeave _ _ wg h@(ButtonHandler _ s) = return
|
||||
(wg, h {_handlerState = s { _uistateIsFiring = False
|
||||
, _uistateIsDeferred = _uistateIsFiring s
|
||||
, _uistateIsReady = False
|
||||
}})
|
||||
|
||||
|
||||
data GUIAny = GUIAnyC GUIContainer
|
||||
| GUIAnyP GUIPanel
|
||||
| GUIAnyB GUIButton
|
||||
deriving (Show)
|
||||
instance GUIAnyMap GUIAny where
|
||||
guiAnyMap f w = f w
|
||||
toGUIAny = id
|
||||
fromGUIAny = id
|
||||
|
||||
instance GUIWidget GUIAny where
|
||||
getBoundary (GUIAny wg) = getBoundary wg
|
||||
isInsideSelf x y (GUIAny wg) = isInsideSelf x y wg
|
||||
isInside x y (GUIAny wg) = isInside x y wg
|
||||
getChildren (GUIAny wg) = getChildren wg
|
||||
getPriority (GUIAny wg) = getPriority wg
|
||||
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
|
||||
isInsideSelf x y (GUIAnyC w) = (isInsideSelf x y) w
|
||||
isInsideSelf x y (GUIAnyP w) = (isInsideSelf x y) w
|
||||
isInsideSelf x y (GUIAnyB w) = (isInsideSelf x y) w
|
||||
isInside x y (GUIAnyC w) = (isInside x y) w
|
||||
isInside x y (GUIAnyP w) = (isInside x y) w
|
||||
isInside x y (GUIAnyB w) = (isInside x y) w
|
||||
getPriority (GUIAnyC w) = getPriority w
|
||||
getPriority (GUIAnyP w) = getPriority w
|
||||
getPriority (GUIAnyB w) = getPriority w
|
||||
getShorthand (GUIAnyC w) = "A" ++ getShorthand w
|
||||
getShorthand (GUIAnyP w) = "A" ++ getShorthand w
|
||||
getShorthand (GUIAnyB w) = "A" ++ getShorthand w
|
||||
|
||||
data GUIContainer = GUIContainer {_screenX :: IntScreen, _screenY :: IntScreen
|
||||
, _width :: IntScreen, _height :: IntScreen
|
||||
-- |A 'GUIContainer' is a widget that may contain additional widgets but does not have a
|
||||
-- functionality itself.
|
||||
data GUIContainer = GUIContainer { _screenX :: ScreenUnit, _screenY :: ScreenUnit
|
||||
, _width :: ScreenUnit, _height :: ScreenUnit
|
||||
, _children :: [GUIAny]
|
||||
, _priority :: Int}
|
||||
, _priority :: Int
|
||||
} deriving (Show)
|
||||
|
||||
instance GUIAnyMap GUIContainer where
|
||||
guiAnyMap f (GUIAnyC c) = f c
|
||||
guiAnyMap _ _ = error "invalid types in guiAnyMap"
|
||||
toGUIAny cnt = GUIAnyC cnt
|
||||
fromGUIAny (GUIAnyC cnt) = cnt
|
||||
fromGUIAny _ = error "invalid GUIAny type"
|
||||
instance GUIWidget GUIContainer where
|
||||
getBoundary :: GUIContainer -> (IntScreen, IntScreen, IntScreen ,IntScreen)
|
||||
getBoundary :: GUIContainer -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit)
|
||||
getBoundary cnt = (_screenX cnt, _screenY cnt, _width cnt, _height cnt)
|
||||
getChildren cnt = _children cnt
|
||||
getPriority cnt = _priority cnt
|
||||
getShorthand _ = "CNT"
|
||||
|
||||
-- |A 'GUIPanel' is much like a 'GUIContainer' but it resizes automatically according to its
|
||||
-- children components.
|
||||
data GUIPanel = GUIPanel { _panelContainer :: GUIContainer} deriving (Show)
|
||||
instance GUIAnyMap GUIPanel where
|
||||
guiAnyMap f (GUIAnyP p) = f p
|
||||
guiAnyMap _ _ = error "invalid types in guiAnyMap"
|
||||
toGUIAny pnl = GUIAnyP pnl
|
||||
fromGUIAny (GUIAnyP pnl) = pnl
|
||||
fromGUIAny _ = error "invalid GUIAny type"
|
||||
instance GUIWidget GUIPanel where
|
||||
getBoundary pnl = case getChildren $ _panelContainer pnl of
|
||||
[] -> getBoundary $ _panelContainer pnl
|
||||
cs -> foldl1' determineSize $ map getBoundary cs
|
||||
where
|
||||
determineSize :: (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit)
|
||||
determineSize (x, y, w, h) (x', y', w', h') =
|
||||
let x'' = if x' < x then x' else x
|
||||
y'' = if y' < y then y' else y
|
||||
w'' = if x' + w' > x + w then x' + w' - x'' else x + w - x''
|
||||
h'' = if y' + h' > y + h then y' + h' - y'' else y + h - y''
|
||||
in (x'', y'', w'', h'')
|
||||
|
||||
getChildren pnl = getChildren $ _panelContainer pnl
|
||||
getPriority pnl = getPriority $ _panelContainer pnl
|
||||
getShorthand _ = "PNL"
|
||||
|
||||
-- |A 'GUIButton' is a dummy datatype for a clickable 'GUIWidget'. Its functinality must be
|
||||
-- provided by an appropriate 'MouseHanlder'.
|
||||
data GUIButton = GUIButton { _screenXB :: ScreenUnit, _screenYB :: ScreenUnit
|
||||
, _widthB :: ScreenUnit, _heightB :: ScreenUnit
|
||||
, _priorityB :: Int
|
||||
, _actionB :: (GUIButton -> ScreenUnit -> ScreenUnit -> IO GUIButton)
|
||||
, _handlerStateB :: UIState
|
||||
} deriving ()
|
||||
|
||||
instance Show GUIButton where
|
||||
show w = "GUIButton {_screenXB = " ++ show (_screenXB w)
|
||||
++ " _screenYB = " ++ show (_screenYB w)
|
||||
++ " _widthB = " ++ show (_widthB w)
|
||||
++ " _heightB = " ++ show (_heightB w)
|
||||
++ " _priorityB = " ++ show (_screenYB w)
|
||||
++ " _actionB = " ++ "***"
|
||||
++ " _handlerStateB = " ++ show (_handlerStateB w)
|
||||
++ "}"
|
||||
instance MouseHandler GUIButton GUIButton where
|
||||
-- |Change 'UIState's '_uistateIsFiring' to @True@.
|
||||
onMousePressed _ _ _ h = let
|
||||
h' = h {_handlerStateB = (_handlerStateB h) {_uistateIsFiring = True}}
|
||||
in return (h', h')
|
||||
|
||||
-- |Change 'UIState's '_uistateIsFiring' to @False@ and
|
||||
-- call '_actionB' if inside the widget or
|
||||
-- set '_uistateIsDeferred' to false otherwise.
|
||||
onMouseReleased x y wg h =
|
||||
if _uistateIsFiring (_handlerStateB h) then do
|
||||
wg' <- _actionB h wg x y
|
||||
wg'' <- return wg' {_handlerStateB = (_handlerStateB wg') {_uistateIsFiring = False}}
|
||||
return (wg'', wg'')
|
||||
else let
|
||||
wg' = wg {_handlerStateB = (_handlerStateB wg) {_uistateIsDeferred = False}}
|
||||
in return (wg', wg')
|
||||
|
||||
-- |Do nothing.
|
||||
onMouseMove _ _ wg h = return (wg, h)
|
||||
|
||||
-- |Set 'UIState's '_uistateIsReady' to @True@ and
|
||||
-- update dragging state (only drag if inside widget).
|
||||
-- In detail, change 'UIState's '_uistateIsDeferred' to '_uistateIsFiring's current value
|
||||
-- and set '_uistateIsFiring' to @False@.
|
||||
onMouseEnter _ _ _ h = let
|
||||
s = _handlerStateB h
|
||||
h' = h {_handlerStateB = s { _uistateIsFiring = _uistateIsDeferred s
|
||||
, _uistateIsDeferred = False
|
||||
, _uistateIsReady = True
|
||||
}}
|
||||
in return (h', h')
|
||||
|
||||
-- |Set 'UIState's 'uistateIsReady' to @False@ and
|
||||
-- update dragging state (only drag if inside widget).
|
||||
-- In detail, change 'UIState's 'uistateIsFiring' to 'uistateIsDeferred's current value
|
||||
-- and set 'uistateIsDeferred's' to @False@.
|
||||
onMouseLeave _ _ _ h = let
|
||||
s = _handlerStateB h
|
||||
h' = h {_handlerStateB = s { _uistateIsFiring = False
|
||||
, _uistateIsDeferred = _uistateIsFiring s
|
||||
, _uistateIsReady = False
|
||||
}}
|
||||
in return (h', h')
|
||||
instance GUIAnyMap GUIButton where
|
||||
guiAnyMap f (GUIAnyB btn) = f btn
|
||||
guiAnyMap _ _ = error "invalid types in guiAnyMap"
|
||||
toGUIAny btn = GUIAnyB btn
|
||||
fromGUIAny (GUIAnyB btn) = btn
|
||||
fromGUIAny _ = error "invalid GUIAny type"
|
||||
instance GUIWidget GUIButton where
|
||||
getBoundary btn = (_screenXB btn, _screenYB btn, _widthB btn, _heightB btn)
|
||||
getChildren _ = []
|
||||
getPriority btn = _priorityB btn
|
||||
getShorthand _ = "BTN"
|
||||
Loading…
Reference in New Issue
Block a user