fjvallarino/monomer
1
1
Fork 0
mirror of https://github.com/fjvallarino/monomer.git synced 2024-09-21 00:38:01 +03:00
Code Issues Projects Releases Wiki Activity

Refactor event handling logic, make textField handle Unicode text

Browse Source
This commit is contained in:
Francisco Vallarino 2019-12-18 01:02:52 -03:00
parent af4fe933f5
commit 3cdc2e3c13
9 changed files with 145 additions and 105 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
app/Main.hs
View File

@ -40,8 +40,11 @@ import qualified SDL.Input.Keyboard.Codes as KeyCodes
import qualified SDL.Input.Mouse as Mouse
import qualified SDL.Raw.Error as SRE
import qualified SDL.Raw.Event as SREv
import Types
import GUI.Common.Core
import GUI.Common.Event
import GUI.Common.Style
import GUI.Widgets
@ -99,6 +102,8 @@ main = do
fontRes <- createFont c "sans" (FileName "./assets/fonts/Roboto-Regular.ttf")
SREv.startTextInput
runStateT (runWidgets window c) (W.initGUIContext def)
putStrLn "About to destroyWindow"
@ -222,17 +227,18 @@ getCurrentFocus = do
ring <- use focusRing
return (if length ring > 0 then ring!!0 else [])
handleSystemEvents :: Renderer WidgetM -> [W.SystemEvent] -> TR.Path -> WidgetTree -> AppM WidgetTree
handleSystemEvents :: Renderer WidgetM -> [SystemEvent] -> TR.Path -> WidgetTree -> AppM WidgetTree
handleSystemEvents renderer systemEvents currentFocus widgets =
foldM (\newWidgets event -> handleSystemEvent renderer event currentFocus newWidgets) widgets systemEvents
handleEvent :: Renderer WidgetM -> W.SystemEvent -> TR.Path -> WidgetTree -> W.ChildEventResult App AppEvent WidgetM
handleEvent :: Renderer WidgetM -> SystemEvent -> TR.Path -> WidgetTree -> W.ChildEventResult App AppEvent WidgetM
handleEvent renderer systemEvent currentFocus widgets = case systemEvent of
W.Click point _ _ -> W.handleEventFromPoint point widgets systemEvent
W.WheelScroll point _ _ -> W.handleEventFromPoint point widgets systemEvent
W.KeyAction _ _ -> W.handleEventFromPath currentFocus widgets systemEvent
Click point _ _ -> W.handleEventFromPoint point widgets systemEvent
WheelScroll point _ _ -> W.handleEventFromPoint point widgets systemEvent
KeyAction _ _ -> W.handleEventFromPath currentFocus widgets systemEvent
TextInput _ -> W.handleEventFromPath currentFocus widgets systemEvent
handleSystemEvent :: Renderer WidgetM -> W.SystemEvent -> TR.Path -> WidgetTree -> AppM WidgetTree
handleSystemEvent :: Renderer WidgetM -> SystemEvent -> TR.Path -> WidgetTree -> AppM WidgetTree
handleSystemEvent renderer systemEvent currentFocus widgets = do
let (W.ChildEventResult stopProcessing eventRequests appEvents newWidgets) = handleEvent renderer systemEvent currentFocus widgets
let newRoot = fromMaybe widgets newWidgets
@ -243,7 +249,7 @@ handleSystemEvent renderer systemEvent currentFocus widgets = do
>>= handleAppEvents renderer appEvents
>>= handleResizeChildren renderer eventRequests
handleFocusChange :: TR.Path -> W.SystemEvent -> Bool -> WidgetTree -> AppM WidgetTree
handleFocusChange :: TR.Path -> SystemEvent -> Bool -> WidgetTree -> AppM WidgetTree
handleFocusChange currentFocus systemEvent stopProcessing widgetRoot
| focusChangeRequested = do
ring <- use focusRing
@ -311,18 +317,18 @@ processCustomHandler renderer widgets path (Right val) = do
keycodeTab :: (Integral a) => a
keycodeTab = fromIntegral $ Keyboard.unwrapKeycode SDL.KeycodeTab
isKeyboardEvent :: W.SystemEvent -> Bool
isKeyboardEvent (W.KeyAction _ _) = True
isKeyboardEvent :: SystemEvent -> Bool
isKeyboardEvent (KeyAction _ _) = True
isKeyboardEvent _ = False
isKeyPressed :: W.SystemEvent -> W.KeyCode -> Bool
isKeyPressed (W.KeyAction keyCode W.KeyPressed) keyCodeChecked = keyCode == keyCodeChecked
isKeyPressed :: SystemEvent -> KeyCode -> Bool
isKeyPressed (KeyAction keyCode KeyPressed) keyCodeChecked = keyCode == keyCodeChecked
isKeyPressed _ _ = False
isKeyTab :: W.KeyCode -> Bool
isKeyTab :: KeyCode -> Bool
isKeyTab key = matchesSDLKeyCode key SDL.KeycodeTab
matchesSDLKeyCode :: W.KeyCode -> SDL.Keycode -> Bool
matchesSDLKeyCode :: KeyCode -> SDL.Keycode -> Bool
matchesSDLKeyCode keyCode sdlKeyCode = keyCode == (fromIntegral $ Keyboard.unwrapKeycode sdlKeyCode)
handleAppEvents :: Renderer WidgetM -> SQ.Seq AppEvent -> WidgetTree -> AppM WidgetTree
@ -364,59 +370,3 @@ collectPaths :: (MonadState s m) => TR.Tree (W.WidgetInstance s e m) -> TR.Path
collectPaths (TR.Node widgetNode children) path = (widgetNode, reverse path) : remainingItems where
pairs = zip (TR.seqToNodeList children) (map (: path) [0..])
remainingItems = concatMap (\(wn, path) -> collectPaths wn path) pairs
convertEvents :: Point -> [SDL.EventPayload] -> [W.SystemEvent]
convertEvents mousePos events = newEvents
where
newEvents = mouseEvents ++ mouseWheelEvents ++ keyboardEvents
mouseEvents = mouseClick events
mouseWheelEvents = mouseWheelEvent mousePos events
keyboardEvents = keyboardEvent events
mouseClick :: [SDL.EventPayload] -> [W.SystemEvent]
mouseClick events =
case clickEvent of
Just (SDL.MouseButtonEvent SDL.MouseButtonEventData
{ SDL.mouseButtonEventMotion = motion,
SDL.mouseButtonEventButton = button,
SDL.mouseButtonEventPos = SDL.P (SDL.V2 x y) }) -> leftClicked ++ leftReleased ++ rightClicked ++ rightReleased
where isLeft = button == SDL.ButtonLeft
isRight = button == SDL.ButtonRight
isClicked = motion == SDL.Pressed
isReleased = motion == SDL.Released
mousePos = Point (fromIntegral x) (fromIntegral y)
leftClicked = if isLeft && isClicked then [W.Click mousePos W.LeftBtn W.PressedBtn] else []
leftReleased = if isLeft && isReleased then [W.Click mousePos W.LeftBtn W.ReleasedBtn] else []
rightClicked = if isRight && isClicked then [W.Click mousePos W.RightBtn W.PressedBtn] else []
rightReleased = if isRight && isReleased then [W.Click mousePos W.RightBtn W.ReleasedBtn] else []
otherwise -> []
where clickEvent = L.find (\evt -> case evt of
SDL.MouseButtonEvent _ -> True
otherwise -> False
) events
mouseWheelEvent :: Point -> [SDL.EventPayload] -> [W.SystemEvent]
mouseWheelEvent mousePos events =
case touchEvent of
Just (SDL.MouseWheelEvent SDL.MouseWheelEventData
{ SDL.mouseWheelEventPos = (SDL.V2 x y),
SDL.mouseWheelEventDirection = direction,
SDL.mouseWheelEventWhich = which }) -> if which == SDL.Touch then [] else [W.WheelScroll mousePos wheelDelta wheelDirection]
where wheelDirection = if direction == SDL.ScrollNormal then W.WheelNormal else W.WheelFlipped
wheelDelta = Point (fromIntegral x) (fromIntegral y)
otherwise -> []
where touchEvent = L.find (\evt -> case evt of
SDL.MouseWheelEvent _ -> True
otherwise -> False
) events
keyboardEvent :: [SDL.EventPayload] -> [W.SystemEvent]
keyboardEvent events = activeKeys
where
activeKeys = map (\(SDL.KeyboardEvent k) -> W.KeyAction (keyCode k) (keyMotion k)) (unsafeCoerce keyboardEvents)
keyCode event = fromIntegral $ SDL.unwrapKeycode $ SDL.keysymKeycode $ SDL.keyboardEventKeysym event
keyMotion event = if SDL.keyboardEventKeyMotion event == SDL.Pressed then W.KeyPressed else W.KeyReleased
keyboardEvents = filter (\e -> case e of
SDL.KeyboardEvent k -> True
_ -> False) events

104
src/GUI/Common/Event.hs Normal file
View File

@ -0,0 +1,104 @@
{-# LANGUAGE RecordWildCards #-}
module GUI.Common.Event where
import qualified Data.List as L
import qualified Data.Text as T
import Unsafe.Coerce
import Control.Monad (when)
import Data.Maybe
import GUI.Common.Core
import GUI.Common.Style
import qualified SDL
type KeyCode = Int
data Button = LeftBtn | RightBtn deriving (Show, Eq)
data ButtonState = PressedBtn | ReleasedBtn deriving (Show, Eq)
data KeyMotion = KeyPressed | KeyReleased deriving (Show, Eq)
data Direction = Horizontal | Vertical deriving (Show, Eq)
data WheelDirection = WheelNormal | WheelFlipped deriving (Show, Eq)
data SystemEvent = Click Point Button ButtonState
| WheelScroll Point Point WheelDirection
| KeyAction KeyCode KeyMotion
| TextInput T.Text
deriving (Show, Eq)
getKeycode :: SDL.Keycode -> Int
getKeycode keyCode = fromIntegral $ SDL.unwrapKeycode keyCode
keyBackspace = getKeycode SDL.KeycodeBackspace
keyLeft = getKeycode SDL.KeycodeLeft
keyRight = getKeycode SDL.KeycodeRight
convertEvents :: Point -> [SDL.EventPayload] -> [SystemEvent]
convertEvents mousePos events = newEvents
where
newEvents = mouseEvents ++ mouseWheelEvents ++ keyboardEvents ++ textEvents
mouseEvents = mouseClick events
mouseWheelEvents = mouseWheelEvent mousePos events
keyboardEvents = keyboardEvent events
textEvents = textEvent events
mouseClick :: [SDL.EventPayload] -> [SystemEvent]
mouseClick events =
case clickEvent of
Just (SDL.MouseButtonEvent SDL.MouseButtonEventData
{ SDL.mouseButtonEventMotion = motion,
SDL.mouseButtonEventButton = button,
SDL.mouseButtonEventPos = SDL.P (SDL.V2 x y) }) -> leftClicked ++ leftReleased ++ rightClicked ++ rightReleased
where isLeft = button == SDL.ButtonLeft
isRight = button == SDL.ButtonRight
isClicked = motion == SDL.Pressed
isReleased = motion == SDL.Released
mousePos = Point (fromIntegral x) (fromIntegral y)
leftClicked = if isLeft && isClicked then [Click mousePos LeftBtn PressedBtn] else []
leftReleased = if isLeft && isReleased then [Click mousePos LeftBtn ReleasedBtn] else []
rightClicked = if isRight && isClicked then [Click mousePos RightBtn PressedBtn] else []
rightReleased = if isRight && isReleased then [Click mousePos RightBtn ReleasedBtn] else []
otherwise -> []
where clickEvent = L.find (\evt -> case evt of
SDL.MouseButtonEvent _ -> True
otherwise -> False
) events
mouseWheelEvent :: Point -> [SDL.EventPayload] -> [SystemEvent]
mouseWheelEvent mousePos events =
case touchEvent of
Just (SDL.MouseWheelEvent SDL.MouseWheelEventData
{ SDL.mouseWheelEventPos = (SDL.V2 x y),
SDL.mouseWheelEventDirection = direction,
SDL.mouseWheelEventWhich = which }) -> if which == SDL.Touch then [] else [WheelScroll mousePos wheelDelta wheelDirection]
where wheelDirection = if direction == SDL.ScrollNormal then WheelNormal else WheelFlipped
wheelDelta = Point (fromIntegral x) (fromIntegral y)
otherwise -> []
where touchEvent = L.find (\evt -> case evt of
SDL.MouseWheelEvent _ -> True
otherwise -> False
) events
keyboardEvent :: [SDL.EventPayload] -> [SystemEvent]
keyboardEvent events = activeKeys
where
activeKeys = map (\(SDL.KeyboardEvent k) -> KeyAction (keyCode k) (keyMotion k)) (unsafeCoerce keyboardEvents)
keyCode event = fromIntegral $ SDL.unwrapKeycode $ SDL.keysymKeycode $ SDL.keyboardEventKeysym event
keyMotion event = if SDL.keyboardEventKeyMotion event == SDL.Pressed then KeyPressed else KeyReleased
keyboardEvents = filter (\e -> case e of
SDL.KeyboardEvent k -> True
_ -> False) events
textEvent :: [SDL.EventPayload] -> [SystemEvent]
textEvent events = inputText
where
inputText = map (\(SDL.TextInputEvent t) -> TextInput (SDL.textInputEventText t)) (unsafeCoerce inputTextEvents)
inputTextEvents = filter (\e -> case e of
SDL.TextInputEvent _ -> True
_ -> False) events

1
src/GUI/Widget/Button.hs
View File

@ -9,6 +9,7 @@ import Data.Typeable
import Debug.Trace
import GUI.Common.Core
import GUI.Common.Event
import GUI.Common.Drawing
import GUI.Common.Style
import GUI.Data.Tree

16
src/GUI/Widget/Core.hs
View File

@ -22,6 +22,7 @@ import Data.Typeable (cast, Typeable)
import Debug.Trace
import GUI.Common.Core
import GUI.Common.Event
import GUI.Common.Style
import GUI.Data.Tree
@ -33,31 +34,16 @@ import qualified Data.Sequence as SQ
type Timestamp = Int
type Enabled = Bool
type Focused = Bool
type KeyCode = Int
type WidgetNode s e m = Tree (WidgetInstance s e m)
type WidgetChildren s e m = SQ.Seq (WidgetNode s e m)
data Direction = Horizontal | Vertical deriving (Show, Eq)
data WheelDirection = WheelNormal | WheelFlipped deriving (Show, Eq)
data SizeReq = SizeReq {
_srSize :: Size,
_srPolicyWidth :: SizePolicy,
_srPolicyHeight :: SizePolicy
} deriving (Show, Eq)
data Button = LeftBtn | RightBtn deriving (Show, Eq)
data ButtonState = PressedBtn | ReleasedBtn deriving (Show, Eq)
data KeyMotion = KeyPressed | KeyReleased deriving (Show, Eq)
data SystemEvent = Click Point Button ButtonState
| WheelScroll Point Point WheelDirection
| KeyAction KeyCode KeyMotion
deriving (Show, Eq)
data EventRequest = IgnoreParentEvents
| IgnoreChildrenEvents
| ResizeChildren

1
src/GUI/Widget/Grid.hs
View File

@ -8,6 +8,7 @@ import Control.Monad.State
import Data.Default
import GUI.Common.Core
import GUI.Common.Event
import GUI.Common.Style
import GUI.Data.Tree
import GUI.Widget.Core

1
src/GUI/Widget/Sandbox.hs
View File

@ -12,6 +12,7 @@ import Data.Typeable
import Debug.Trace
import GUI.Common.Core
import GUI.Common.Event
import GUI.Common.Drawing
import GUI.Common.Style
import GUI.Data.Tree

1
src/GUI/Widget/Scroll.hs
View File

@ -13,6 +13,7 @@ import Control.Monad.State
import qualified Data.Text as T
import GUI.Common.Core
import GUI.Common.Event
import GUI.Common.Drawing
import GUI.Common.Style
import GUI.Data.Tree

1
src/GUI/Widget/Stack.hs
View File

@ -7,6 +7,7 @@ import Control.Monad
import Control.Monad.State
import GUI.Common.Core
import GUI.Common.Event
import GUI.Common.Style
import GUI.Data.Tree
import GUI.Widget.Core

37
src/GUI/Widget/TextField.hs
View File

@ -13,6 +13,7 @@ import Data.Typeable
import Debug.Trace
import GUI.Common.Core
import GUI.Common.Event
import GUI.Common.Drawing
import GUI.Common.Style
import GUI.Data.Tree
@ -23,7 +24,7 @@ import GHC.Generics
import qualified Data.Text as T
data TextFieldState = TextFieldState {
_tfText :: String,
_tfText :: T.Text,
_tfPosition :: Int
} deriving (Eq, Show, Typeable, Generic)
@ -46,40 +47,34 @@ makeTextField tfs@(TextFieldState txt tp) = Widget {
_widgetRender = render
}
where
(part1, part2) = splitAt tp txt
printedText = part1 ++ "|" ++ part2
(part1, part2) = T.splitAt tp txt
printedText = T.concat [part1, "|", part2]
handleKeyPress currText currTp code
| isKeyBackspace code && currTp > 0 = (init part1 ++ part2, currTp - 1)
| isKeyBackspace code && currTp > 0 = (T.append (T.init part1) part2, currTp - 1)
| isKeyLeft code && currTp > 0 = (currText, currTp - 1)
| isKeyRight code && currTp < length currText = (currText, currTp + 1)
| isKeyRight code && currTp < T.length currText = (currText, currTp + 1)
| isKeyBackspace code || isKeyLeft code || isKeyRight code = (currText, currTp)
| length newText > 0 = (part1 ++ newText ++ part2, currTp + length newText)
| otherwise = (currText, currTp)
where
newText = if isKeyPrintable code then [chr code] else ""
(part1, part2) = splitAt currTp currText
(part1, part2) = T.splitAt currTp currText
handleEvent _ evt = case evt of
KeyAction code KeyPressed -> resultEventsWidget [] (makeTextField newState) where
(txt2, tp2) = handleKeyPress txt tp code
newState = TextFieldState txt2 tp2
TextInput newText -> resultEventsWidget [] (makeTextField newState) where
txt2 = T.concat [part1, newText, part2]
tp2 = tp + T.length newText
newState = TextFieldState txt2 tp2
_ -> Nothing
preferredSize renderer (style@Style{..}) _ = do
size <- calcTextBounds renderer _textStyle (T.pack (if txt == "" then " " else txt))
size <- calcTextBounds renderer _textStyle (if txt == "" then " " else txt)
return $ SizeReq size FlexibleSize FlexibleSize
resizeChildren _ _ _ _ = Nothing
render renderer WidgetInstance{..} _ ts =
do
drawBgRect renderer _widgetInstanceRenderArea _widgetInstanceStyle
drawText renderer _widgetInstanceRenderArea (_textStyle _widgetInstanceStyle) (T.pack printedText)
drawText renderer _widgetInstanceRenderArea (_textStyle _widgetInstanceStyle) printedText
isKeyPrintable :: KeyCode -> Bool
isKeyPrintable key = key >= 32 && key < 126
isKeyBackspace :: KeyCode -> Bool
isKeyBackspace key = key == 8
isKeyLeft :: KeyCode -> Bool
isKeyLeft key = key == 1073741904
isKeyRight :: KeyCode -> Bool
isKeyRight key = key == 1073741903
isKeyBackspace = (== keyBackspace)
isKeyLeft = (== keyLeft)
isKeyRight = (== keyRight)