diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,33 +1,62 @@ -### 1.1.0.0 +## 1.1.1.0 +### Added + +- `appInvertWheelX` and `appInvertWheelY` configuration options. + +### Fixed + +- Horizontal wheel/trackpad scrolling on Linux. +- Scroll: do not use direction argument to modify wheel/trackpad direction (event provides correct value). +- Only replace composite model with user model on init and merge. + +## 1.1.0.0 + +### Added + +- `sizeUpdater` helpers. Support multiple handlers in box, grid and stack. +- `dpr` field to `WidgetEnv`. +- `RunInRenderThread` to support initialization of low level OpenGL resources. +- OpenGL example. +- `containerDrawDecorations`. Simplify button/externalLink internals. +- `ThemeState` entries for future `optionButton` and `toggleButton` widgets. +- `singleDrawDecorations`. Make it consistent with Container. + +### Fixed + - Reduce memory usage by sharing wreq session among image widget instances. -- Add sizeUpdater helpers. Support multiple handlers in box, grid and stack. -- Add `dpr` field to `WidgetEnv`. -- Add `RunInRenderThread` to support initialization of low level OpenGL resources. - Set correct `WidgetEnv` viewport from scroll (it looked good because of scissoring). - Fix issue with scrollbars using child coordinates for detecting clicks. -- Add OpenGL example. -- Add `containerDrawDecorations`. Simplify button/externalLink internals. -- Add ThemeState entries for optionButton and toggleButton widgets. -- Add `singleDrawDecorations`. Make it consistent with Container. -### 1.0.0.3 +## 1.0.0.3 -- Consume and forward all available messages from Producers on each cycle. +### Added + - Add Nix and GitHub Actions support (thanks @smunix!). + +### Fixed + +- Consume and forward all available messages from Producers on each cycle. - Fix space leak when rebuilding the UI or handling events. -### 1.0.0.2 +## 1.0.0.2 -- Use the recently published nanovg-0.8.0.0 from Hackage, instead of the version from the PR's commit. +### Added + - Add `appRenderOnMainThread` option. -### 1.0.0.1 +### Changed +- Use the recently published nanovg-0.8.0.0 from Hackage, instead of the version from the PR's commit. + +## 1.0.0.1 + +### Fixed + - Fix Haddocks for widget configuration types. -### 1.0.0.0 +## 1.0.0.0 -Initial public release +### Initial public release - Supports Windows, Linux and macOS diff --git a/examples/todo/Main.hs b/examples/todo/Main.hs --- a/examples/todo/Main.hs +++ b/examples/todo/Main.hs @@ -73,13 +73,15 @@ todoEdit :: TodoWenv -> TodoModel -> TodoNode todoEdit wenv model = editNode where sectionBg = wenv ^. L.theme . L.sectionColor + isValidInput = model ^. activeTodo . description /= "" - saveTodoBtn = case model ^. action of - TodoAdding -> mainButton "Add" TodoAdd - TodoEditing idx -> mainButton "Save" (TodoSave idx) - _ -> spacer + (saveAction, saveLabel) = case model ^. action of + TodoEditing idx -> (TodoSave idx, "Save") + _ -> (TodoAdd, "Add") - editNode = vstack [ + saveTodoBtn = mainButton saveLabel saveAction + + editFields = keystroke [("Enter", saveAction) | isValidInput] $ vstack [ hstack [ label "Task:", spacer, @@ -98,11 +100,15 @@ spacer, textDropdownS (activeTodo . status) todoStatuses ] - ], + ] + ] + + editNode = keystroke [("Esc", TodoCancel)] $ vstack [ + editFields, spacer, hstack [ filler, - saveTodoBtn `nodeEnabled` (model ^. activeTodo . description /= ""), + saveTodoBtn `nodeEnabled` isValidInput, spacer, button "Cancel" TodoCancel ] @@ -123,10 +129,6 @@ `nodeVisible` not isEditing editLayer = content where - saveAction = case model ^. action of - TodoEditing idx -> TodoSave idx - _ -> TodoAdd - dualSlide content = outer where inner = animSlideIn_ [slideTop, duration 200] content `nodeKey` "animEditIn" @@ -134,9 +136,7 @@ `nodeKey` "animEditOut" content = vstack [ - dualSlide $ - keystroke [("Enter", saveAction), ("Esc", TodoCancel)] $ - todoEdit wenv model, + dualSlide (todoEdit wenv model), filler ] `styleBasic` [bgColor (grayDark & L.a .~ 0.5)] diff --git a/monomer.cabal b/monomer.cabal --- a/monomer.cabal +++ b/monomer.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: monomer -version: 1.1.0.0 +version: 1.1.1.0 synopsis: A GUI library for writing native Haskell applications. description: Monomer is an easy to use, cross platform, GUI library for writing native Haskell applications. diff --git a/src/Monomer/Event/Core.hs b/src/Monomer/Event/Core.hs --- a/src/Monomer/Event/Core.hs +++ b/src/Monomer/Event/Core.hs @@ -9,6 +9,7 @@ Core functions for SDL event processing and conversion. -} module Monomer.Event.Core ( + ConvertEventsCfg(..), isActionEvent, convertEvents, translateEvent @@ -16,6 +17,7 @@ import Control.Applicative ((<|>)) import Data.Maybe (catMaybes, fromMaybe) +import Data.Text (Text) import qualified Data.Map.Strict as M import qualified SDL @@ -37,19 +39,27 @@ isActionEvent SDL.TextInputEvent{} = True isActionEvent _ = False +data ConvertEventsCfg = ConvertEventsCfg { + _cecOs :: Text, -- ^ The host operating system. + _cecDpr :: Double, -- ^ Device pixel rate. + _cecEpr :: Double, -- ^ Event pixel rate. + _cecInvertWheelX :: Bool, -- ^ Whether wheel/trackpad x direction should be inverted. + _cecInvertWheelY :: Bool -- ^ Whether wheel/trackpad y direction should be inverted. +} deriving (Eq, Show) + -- | Converts SDL events to Monomer's SystemEvent convertEvents - :: Double -- ^ Device pixel rate. - -> Double -- ^ Event pixel rate. + :: ConvertEventsCfg -- ^ Settings for event conversion. -> Point -- ^ Mouse position. -> [SDL.EventPayload] -- ^ List of SDL events. -> [SystemEvent] -- ^ List of Monomer events. -convertEvents dpr epr mousePos events = catMaybes convertedEvents where +convertEvents cfg mousePos events = catMaybes convertedEvents where + ConvertEventsCfg os dpr epr invertX invertY = cfg convertedEvents = fmap convertEvent events convertEvent evt = mouseMoveEvent mousePos evt <|> mouseClick mousePos evt - <|> mouseWheelEvent epr mousePos evt + <|> mouseWheelEvent cfg mousePos evt <|> mouseMoveLeave mousePos evt <|> keyboardEvent evt <|> textEvent evt @@ -94,18 +104,25 @@ evt = Just $ Move (Point (-1) (-1)) mouseMoveLeave mousePos _ = Nothing -mouseWheelEvent :: Double -> Point -> SDL.EventPayload -> Maybe SystemEvent -mouseWheelEvent epr mousePos (SDL.MouseWheelEvent eventData) = systemEvent where +mouseWheelEvent :: ConvertEventsCfg -> Point -> SDL.EventPayload -> Maybe SystemEvent +mouseWheelEvent cfg pos (SDL.MouseWheelEvent eventData) = systemEvent where + ConvertEventsCfg os dpr epr invertX invertY = cfg + signX = if invertX then -1 else 1 + signY = if invertY then -1 else 1 + factorX + | os == "Windows" || os == "Mac OS X" = -signX + | otherwise = signX + factorY = signY wheelDirection = case SDL.mouseWheelEventDirection eventData of SDL.ScrollNormal -> WheelNormal SDL.ScrollFlipped -> WheelFlipped SDL.V2 x y = SDL.mouseWheelEventPos eventData - wheelDelta = Point (fromIntegral x * epr) (fromIntegral y * epr) + wheelDelta = Point (factorX * fromIntegral x * epr) (factorY * fromIntegral y * epr) systemEvent = case SDL.mouseWheelEventWhich eventData of - SDL.Mouse _ -> Just $ WheelScroll mousePos wheelDelta wheelDirection + SDL.Mouse _ -> Just $ WheelScroll pos wheelDelta wheelDirection SDL.Touch -> Nothing -mouseWheelEvent epr mousePos _ = Nothing +mouseWheelEvent cfg mousePos _ = Nothing keyboardEvent :: SDL.EventPayload -> Maybe SystemEvent keyboardEvent (SDL.KeyboardEvent eventData) = Just keyAction where diff --git a/src/Monomer/Main/Core.hs b/src/Monomer/Main/Core.hs --- a/src/Monomer/Main/Core.hs +++ b/src/Monomer/Main/Core.hs @@ -244,7 +244,10 @@ let windowResized = currWinSize /= windowSize && isWindowResized eventsPayload let windowExposed = isWindowExposed eventsPayload let mouseEntered = isMouseEntered eventsPayload - let baseSystemEvents = convertEvents dpr epr mousePos eventsPayload + let invertX = fromMaybe False (_apcInvertWheelX config) + let invertY = fromMaybe False (_apcInvertWheelY config) + let convertCfg = ConvertEventsCfg _mlOS dpr epr invertX invertY + let baseSystemEvents = convertEvents convertCfg mousePos eventsPayload -- when newSecond $ -- liftIO . putStrLn $ "Frames: " ++ show _mlFrameCount diff --git a/src/Monomer/Main/Types.hs b/src/Monomer/Main/Types.hs --- a/src/Monomer/Main/Types.hs +++ b/src/Monomer/Main/Types.hs @@ -185,7 +185,11 @@ -- | Defines which mouse button is considered main. _apcMainButton :: Maybe Button, -- | Defines which mouse button is considered secondary or context button. - _apcContextButton :: Maybe Button + _apcContextButton :: Maybe Button, + -- | Whether wheel/trackpad horizontal movement should be inverted. + _apcInvertWheelX :: Maybe Bool, + -- | Whether wheel/trackpad vertical movement should be inverted. + _apcInvertWheelY :: Maybe Bool } instance Default (AppConfig e) where @@ -204,7 +208,9 @@ _apcExitEvent = [], _apcResizeEvent = [], _apcMainButton = Nothing, - _apcContextButton = Nothing + _apcContextButton = Nothing, + _apcInvertWheelX = Nothing, + _apcInvertWheelY = Nothing } instance Semigroup (AppConfig e) where @@ -223,7 +229,9 @@ _apcExitEvent = _apcExitEvent a1 ++ _apcExitEvent a2, _apcResizeEvent = _apcResizeEvent a1 ++ _apcResizeEvent a2, _apcMainButton = _apcMainButton a2 <|> _apcMainButton a1, - _apcContextButton = _apcContextButton a2 <|> _apcContextButton a1 + _apcContextButton = _apcContextButton a2 <|> _apcContextButton a1, + _apcInvertWheelX = _apcInvertWheelX a2 <|> _apcInvertWheelX a1, + _apcInvertWheelY = _apcInvertWheelY a2 <|> _apcInvertWheelY a1 } instance Monoid (AppConfig e) where @@ -337,4 +345,22 @@ appContextButton :: Button -> AppConfig e appContextButton btn = def { _apcContextButton = Just btn +} + +{-| +Whether the horizontal wheel/trackpad movement should be inverted. In general +platform detection should do the right thing. +-} +appInvertWheelX :: Bool -> AppConfig e +appInvertWheelX invert = def { + _apcInvertWheelX = Just invert +} + +{-| +Whether the vertical wheel/trackpad movement should be inverted. In general +platform detection should do the right thing. +-} +appInvertWheelY :: Bool -> AppConfig e +appInvertWheelY invert = def { + _apcInvertWheelY = Just invert } diff --git a/src/Monomer/Widgets/Composite.hs b/src/Monomer/Widgets/Composite.hs --- a/src/Monomer/Widgets/Composite.hs +++ b/src/Monomer/Widgets/Composite.hs @@ -416,7 +416,7 @@ -> WidgetResult sp ep compositeInit comp state wenv widgetComp = newResult where CompositeState{..} = state - !model = getModel comp wenv + !model = getUserModel comp wenv !cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model -- Creates UI using provided function !builtRoot = _cmpUiBuilder comp cwenv model @@ -449,7 +449,7 @@ oldState = widgetGetState (oldComp ^. L.widget) wenv oldComp validState = fromMaybe state (useState oldState) CompositeState oldModel oldRoot oldWidgetKeys = validState - model = getModel comp wenv + model = getUserModel comp wenv -- Creates new UI using provided function cwenv = convertWidgetEnv wenv oldWidgetKeys model tempRoot = cascadeCtx wenv newComp (_cmpUiBuilder comp cwenv model) @@ -504,7 +504,8 @@ -> WidgetResult sp ep compositeDispose comp state wenv widgetComp = result where CompositeState{..} = state - model = getModel comp wenv + + model = getCompositeModel state cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model widget = _cpsRoot ^. L.widget newEvts = RaiseEvent <$> Seq.fromList (_cmpOnDispose comp) @@ -523,7 +524,7 @@ compositeGetInstanceTree comp state wenv node = instTree where CompositeState{..} = state widget = _cpsRoot ^. L.widget - model = getModel comp wenv + model = getCompositeModel state cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model cInstTree = widgetGetInstanceTree widget cwenv _cpsRoot instTree = WidgetInstanceNode { @@ -545,7 +546,7 @@ compositeFindNextFocus comp state wenv widgetComp dir start = nextFocus where CompositeState{..} = state widget = _cpsRoot ^. L.widget - model = getModel comp wenv + model = getCompositeModel state cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model nextFocus = widgetFindNextFocus widget cwenv _cpsRoot dir start @@ -565,7 +566,7 @@ where CompositeState{..} = state widget = _cpsRoot ^. L.widget - model = getModel comp wenv + model = getCompositeModel state cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model next = nextTargetStep widgetComp start validStep = isNothing next || next == Just 0 @@ -585,7 +586,7 @@ | otherwise = Seq.empty where CompositeState{..} = state - model = getModel comp wenv + model = getCompositeModel state cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model info = widgetComp ^. L.info nextStep = nextTargetStep widgetComp path @@ -605,7 +606,7 @@ compositeHandleEvent comp state wenv widgetComp target evt = result where CompositeState{..} = state widget = _cpsRoot ^. L.widget - !model = getModel comp wenv + !model = getCompositeModel state !cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model rootEnabled = _cpsRoot ^. L.info . L.enabled compVisible = widgetComp ^. L.info . L.visible @@ -637,7 +638,7 @@ | otherwise = fmap processEvent result where processEvent = toParentResult comp state wenv widgetComp cmpWidget = _cpsRoot ^. L.widget - !model = getModel comp wenv + !model = getCompositeModel state !cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model result = widgetHandleMessage cmpWidget cwenv _cpsRoot target arg @@ -689,7 +690,7 @@ style = currentStyle wenv widgetComp carea = fromMaybe def (removeOuterBounds style viewport) widget = _cpsRoot ^. L.widget - model = getModel comp wenv + model = getCompositeModel state cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model WidgetResult newRoot newReqs = widgetResize widget cwenv _cpsRoot carea rszReq @@ -717,7 +718,7 @@ compositeRender comp state wenv widgetComp renderer = action where CompositeState{..} = state widget = _cpsRoot ^. L.widget - !model = getModel comp wenv + !model = getCompositeModel state !cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model !action = widgetRender widget cwenv _cpsRoot renderer @@ -731,10 +732,8 @@ -> WidgetResult sp ep handleMsgEvent comp state wenv widgetComp event = newResult where CompositeState{..} = state - model - | isJust _cpsModel = fromJust _cpsModel - | otherwise = getModel comp wenv evtHandler = _cmpEventHandler comp + !model = getCompositeModel state !cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model !response = evtHandler cwenv _cpsRoot model event !newReqs = evtResponseToRequest widgetComp _cpsWidgetKeyMap <$> response @@ -750,9 +749,7 @@ -> WidgetResult sp ep handleMsgUpdate comp state wenv widgetComp fnUpdate = result where CompositeState{..} = state - model - | isJust _cpsModel = fromJust _cpsModel - | otherwise = getModel comp wenv + !model = getCompositeModel state !newModel = fnUpdate model !result | model == newModel = resultNode widgetComp @@ -825,12 +822,20 @@ !newResult = result & L.requests <>~ Seq.fromList newReqs -getModel +getUserModel :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, CompParentModel sp) => Composite s e sp ep -> WidgetEnv sp ep -> s -getModel comp wenv = widgetDataGet (_weModel wenv) (_cmpWidgetData comp) +getUserModel comp wenv = widgetDataGet (_weModel wenv) (_cmpWidgetData comp) + +getCompositeModel + :: (CompositeModel s, CompositeEvent e) + => CompositeState s e + -> s +getCompositeModel state = case _cpsModel state of + Just model -> model + _ -> error "Error calling getCompositeModel: widgetInit has not been invoked." toParentReq :: (CompositeModel s, CompParentModel sp) diff --git a/src/Monomer/Widgets/Container.hs b/src/Monomer/Widgets/Container.hs --- a/src/Monomer/Widgets/Container.hs +++ b/src/Monomer/Widgets/Container.hs @@ -578,7 +578,7 @@ oldState = widgetGetState (oldNode ^. L.widget) wenv oldNode mergeRequired = case useState oldState of - Just state -> mergeRequiredHandler wenv newNode oldNode state + Just ostate -> mergeRequiredHandler wenv newNode oldNode ostate Nothing -> True styledNode = initNodeStyle getBaseStyle wenv newNode @@ -623,7 +623,7 @@ & L.info . L.sizeReqW .~ oldInfo ^. L.sizeReqW & L.info . L.sizeReqH .~ oldInfo ^. L.sizeReqH result = case useState oldState of - Just state -> mergeHandler wenv tempNode oldNode state + Just ostate -> mergeHandler wenv tempNode oldNode ostate Nothing -> resultNode tempNode mergeChildren diff --git a/src/Monomer/Widgets/Containers/Scroll.hs b/src/Monomer/Widgets/Containers/Scroll.hs --- a/src/Monomer/Widgets/Containers/Scroll.hs +++ b/src/Monomer/Widgets/Containers/Scroll.hs @@ -510,12 +510,8 @@ result | needsUpdate = Just $ makeResult newState | otherwise = Nothing - stepX - | wheelDirection == WheelNormal = -wheelRate * wx - | otherwise = wheelRate * wx - stepY - | wheelDirection == WheelNormal = wheelRate * wy - | otherwise = -wheelRate * wy + stepX = wheelRate * wx + stepY = wheelRate * wy newState = state { _sstDeltaX = scrollAxisH (stepX + dx), _sstDeltaY = scrollAxisV (stepY + dy) diff --git a/test/unit/Monomer/Widgets/CompositeSpec.hs b/test/unit/Monomer/Widgets/CompositeSpec.hs --- a/test/unit/Monomer/Widgets/CompositeSpec.hs +++ b/test/unit/Monomer/Widgets/CompositeSpec.hs @@ -40,6 +40,7 @@ import Monomer.Widgets.Containers.Stack import Monomer.Widgets.Containers.ZStack import Monomer.Widgets.Singles.Button +import Monomer.Widgets.Singles.Checkbox import Monomer.Widgets.Singles.Label import Monomer.Widgets.Singles.TextField import Monomer.Widgets.Util.Widget @@ -59,6 +60,10 @@ | ChildResize Rect deriving (Eq, Show) +data DeepEvt + = DeepInit + deriving (Eq, Show) + data MainModel = MainModel { _tmClicks :: Int, _tmChild :: ChildModel @@ -72,15 +77,26 @@ data ChildModel = ChildModel { _cmClicks :: Int, - _cmMessage :: String + _cmMessage :: String, + _cmDeep :: DeepModel } deriving (Eq, Show) instance Default ChildModel where def = ChildModel { _cmClicks = 0, - _cmMessage = "" + _cmMessage = "", + _cmDeep = def } +newtype DeepModel = DeepModel { + _dmClicked :: Bool +} deriving (Eq, Show) + +instance Default DeepModel where + def = DeepModel { + _dmClicked = False + } + data TestModel = TestModel { _tmItems :: [Int], _tmText1 :: Text, @@ -104,6 +120,7 @@ makeLensesWith abbreviatedFields ''MainModel makeLensesWith abbreviatedFields ''ChildModel +makeLensesWith abbreviatedFields ''DeepModel makeLensesWith abbreviatedFields ''TestModel baseLens idx = L.children . ix 0 . L.children . ix idx . L.children . ix 0 @@ -155,17 +172,35 @@ it "should not generate an event if clicked outside" $ do model [evtClick (Point 3000 3000)] ^. clicks `shouldBe` 0 model [evtClick (Point 3000 3000)] ^. child . clicks `shouldBe` 0 + model [evtClick (Point 3000 3000)] ^. child . deep . clicked `shouldBe` False it "should generate a main event when clicked in main button" $ do model [evtClick (Point 10 10)] ^. clicks `shouldBe` 1 model [evtClick (Point 10 10)] ^. child . clicks `shouldBe` 0 + model [evtClick (Point 10 10)] ^. child . deep . clicked `shouldBe` False it "should generate a child event when clicked in child button" $ do model [evtClick (Point 10 30)] ^. clicks `shouldBe` 0 model [evtClick (Point 10 30)] ^. child . clicks `shouldBe` 1 + model [evtClick (Point 10 30)] ^. child . deep . clicked `shouldBe` False + it "should update the nested model when the checkbox is clicked" $ do + model [evtClick (Point 10 50)] ^. clicks `shouldBe` 0 + model [evtClick (Point 10 50)] ^. child . clicks `shouldBe` 0 + model [evtClick (Point 10 50)] ^. child . deep . clicked `shouldBe` True + where wenv = mockWenv def + + handleDeep + :: WidgetEnv DeepModel DeepEvt + -> WidgetNode DeepModel DeepEvt + -> DeepModel + -> DeepEvt + -> [EventResponse DeepModel DeepEvt ChildModel ChildEvt] + handleDeep wenv node model evt = [] + buildDeep wenv model = checkbox clicked + handleChild :: WidgetEnv ChildModel ChildEvt -> WidgetNode ChildModel ChildEvt @@ -173,7 +208,11 @@ -> ChildEvt -> [EventResponse ChildModel ChildEvt MainModel MainEvt] handleChild wenv node model evt = [Model (model & clicks %~ (+1))] - buildChild wenv model = button "Click" ChildBtnClicked + buildChild wenv model = vstack [ + button "Click" ChildBtnClicked, + composite "deep" deep buildDeep handleDeep + ] + handleEvent :: WidgetEnv MainModel MainEvt -> WidgetNode MainModel MainEvt @@ -185,6 +224,7 @@ button "Click" MainBtnClicked, composite "child" child buildChild handleChild ] + cmpNode = composite "main" id buildUI handleEvent model es = nodeHandleEventModel wenv es cmpNode