monomer 1.1.0.0 → 1.1.1.0

raw patch · 10 files changed

+189/−73 lines, 10 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +44/−15
• examples/todo/Main.hs +14/−14
• monomer.cabal +1/−1
• src/Monomer/Event/Core.hs +26/−9
• src/Monomer/Main/Core.hs +4/−1
• src/Monomer/Main/Types.hs +29/−3
• src/Monomer/Widgets/Composite.hs +24/−19
• src/Monomer/Widgets/Container.hs +2/−2
• src/Monomer/Widgets/Containers/Scroll.hs +2/−6
• test/unit/Monomer/Widgets/CompositeSpec.hs +43/−3

@@ -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

@@ -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)] 

@@ -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.

@@ -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

@@ -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

@@ -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 }

@@ -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)

@@ -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

@@ -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)

@@ -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