monomer 1.4.0.0 → 1.4.1.0

raw patch · 23 files changed

+389/−108 lines, 23 files

Files

• ChangeLog.md +20/−0
• monomer.cabal +1/−1
• src/Monomer/Common/BasicTypes.hs +12/−0
• src/Monomer/Core/ThemeTypes.hs +1/−2
• src/Monomer/Core/Themes/BaseTheme.hs +2/−1
• src/Monomer/Core/Themes/SampleThemes.hs +4/−4
• src/Monomer/Core/Util.hs +3/−3
• src/Monomer/Core/WidgetTypes.hs +18/−11
• src/Monomer/Graphics/NanoVGRenderer.hs +1/−1
• src/Monomer/Widgets/Composite.hs +4/−4
• src/Monomer/Widgets/Container.hs +1/−1
• src/Monomer/Widgets/Containers/Box.hs +20/−1
• src/Monomer/Widgets/Containers/Scroll.hs +7/−2
• src/Monomer/Widgets/Containers/Tooltip.hs +2/−2
• src/Monomer/Widgets/Singles/Button.hs +8/−6
• src/Monomer/Widgets/Singles/Image.hs +25/−10
• src/Monomer/Widgets/Singles/Label.hs +1/−1
• src/Monomer/Widgets/Singles/ToggleButton.hs +5/−5
• src/Monomer/Widgets/Util/Drawing.hs +100/−49
• src/Monomer/Widgets/Util/Theme.hs +82/−0
• test/unit/Monomer/Widgets/Containers/BoxSpec.hs +25/−0
• test/unit/Monomer/Widgets/Containers/ScrollSpec.hs +42/−0
• test/unit/Monomer/Widgets/Singles/ImageSpec.hs +5/−4

@@ -1,3 +1,23 @@+## 1.4.1.0++### Added++- Support for switching vertical wheel scrolling to horizontal in scroll widget by pressing the shift key ([PR #137](https://github.com/fjvallarino/monomer/pull/137)).+- Drawing and theme utility functions ([PR #138](https://github.com/fjvallarino/monomer/pull/138)).+- `boxFilterEvent` config option, exposing Container's filterEvent functionality ([PR #146](https://github.com/fjvallarino/monomer/pull/146)).+- `pointToLineDistance` utility function ([PR #150](https://github.com/fjvallarino/monomer/pull/150)).++### Fixed++- Bug where memory based image widget would not render their new state after a merge ([PR #147](https://github.com/fjvallarino/monomer/pull/147)). Thanks @CamdenKuwahara!+- Fix memory leak in NanoVGRenderer's image initialization. Dispose unused images in image widget ([PR #149](https://github.com/fjvallarino/monomer/pull/149)).++### Changed++- Restricts toggleButton's type argument for configuration options to Bool (the only valid type) ([PR #150](https://github.com/fjvallarino/monomer/pull/150)).+- Avoids drawing borders if width == 0 ([PR #150](https://github.com/fjvallarino/monomer/pull/150)).+- Updates default style for tooltip widget ([PR #150](https://github.com/fjvallarino/monomer/pull/150)).+ ## 1.4.0.0  ### Breaking changes

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           monomer-version:        1.4.0.0+version:        1.4.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.

@@ -101,6 +101,18 @@ negPoint :: Point -> Point negPoint (Point x y) = Point (-x) (-y) +{-|+Returns the minimum distance from the point given as first argument to the line+formed by the points given as second and third arguments.+-}+pointToLineDistance :: Point -> Point -> Point -> Double+pointToLineDistance p0 p1 p2 = distNum / distDen where+  Point px0 py0 = p0+  Point px1 py1 = p1+  Point px2 py2 = p2+  distNum = abs ((px2 - px1) * (py1 - py0) - (px1 - px0) * (py2 - py1))+  distDen = sqrt ((px2 - px1) ** 2 + (py2 - py1) ** 2)+ -- | Checks if a coordinate is inside the horizontal range of a rect. coordInRectH :: Double -> Rect -> Bool coordInRectH px (Rect x y w h) = px >= x && px < x + w

@@ -9,7 +9,7 @@ Theme configuration types. -} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE Strict #-}+{-# LANGUAGE StrictData #-}  module Monomer.Core.ThemeTypes where @@ -19,7 +19,6 @@  import qualified Data.Map.Strict as M -import Monomer.Common import Monomer.Core.StyleTypes import Monomer.Graphics.ColorTable import Monomer.Graphics.Types

@@ -215,7 +215,8 @@   & L.text . non def . L.fontColor ?~ tooltipText themeMod   & L.bgColor ?~ tooltipBg themeMod   & L.border ?~ border 1 (tooltipBorder themeMod)-  & L.padding ?~ padding 4+  & L.padding ?~ padding 6+  & L.radius ?~ radius 4  baseBasic :: BaseThemeColors -> ThemeState baseBasic themeMod = def

@@ -117,8 +117,8 @@   slSelectedText = black,   slSelectedFocusBorder = blue07, -  tooltipBorder = gray09,-  tooltipBg = gray10,+  tooltipBorder = gray08,+  tooltipBg = gray07,   tooltipText = black } @@ -216,8 +216,8 @@   slSelectedText = white,   slSelectedFocusBorder = blue08, -  tooltipBorder = gray09,-  tooltipBg = gray04,+  tooltipBorder = gray05,+  tooltipBg = rgbHex "#1D212B",   tooltipText = white } 

@@ -31,19 +31,19 @@ import qualified Monomer.Core.Lens as L  -- | Returns the 'Path' associated to a given 'WidgetKey', if any. The search is---   restricted to the parent _Composite_.+--   restricted to the parent "Monomer.Widgets.Composite". pathFromKey :: WidgetEnv s e -> WidgetKey -> Maybe Path pathFromKey wenv key = fmap (^. L.info . L.path) node where   node = Map.lookup key (wenv ^. L.widgetKeyMap)  -- | Returns the 'WidgetId' associated to a given 'WidgetKey', if any. The---   search is restricted to the parent _Composite_.+--   search is restricted to the parent "Monomer.Widgets.Composite". widgetIdFromKey :: WidgetEnv s e -> WidgetKey -> Maybe WidgetId widgetIdFromKey wenv key = fmap (^. L.info . L.widgetId) node where   node = Map.lookup key (wenv ^. L.widgetKeyMap)  -- | Returns the 'WidgetNodeInfo' associated to the given 'WidgetKey', if any.---   The search is restricted to the parent _Composite_.+--   The search is restricted to the parent "Monomer.Widgets.Composite". nodeInfoFromKey :: WidgetEnv s e -> WidgetKey -> Maybe WidgetNodeInfo nodeInfoFromKey wenv key = path >>= nodeInfoFromPath wenv where   path = pathFromKey wenv key

@@ -68,7 +68,7 @@   | FocusBwd  -- ^ Focus moving backward (usually right to left, top to bottom).   deriving (Eq, Show) --- | "WidgetRequest" specific for window related operations.+-- | 'WidgetRequest' specific for window related operations. data WindowRequest   = WindowSetTitle Text  -- ^ Sets the title of the window to the given text.   | WindowSetFullScreen  -- ^ Switches to fullscreen mode.@@ -216,9 +216,12 @@   -- | Requests to exit the application. Can also be used to cancel a previous   --   request (or a window close).   | ExitApplication Bool-  -- | Performs a "WindowRequest".+  -- | Performs a 'WindowRequest'.   | UpdateWindow WindowRequest-  -- | Request a model update. This usually involves lenses and "widgetDataSet".+  {-|+  Request a model update. This usually involves lenses and+  'Monomer.Widgets.Util.Widget.widgetDataSet'.+  -}   | UpdateModel (s -> s)   -- | Updates the path of a given widget. Both "Monomer.Widgets.Single" and   --   "Monomer.Widgets.Container" handle this automatically.@@ -273,11 +276,13 @@  {-| Result of widget operations (init, merge, handleEvent, etc). The node is-mandatory. The "resultNode", "resultEvts", "resultReqs" and "resultReqsEvts"-helper functions can also be used.+mandatory. The 'Monomer.Widgets.Util.Widget.resultNode',+'Monomer.Widgets.Util.Widget.resultEvts',+'Monomer.Widgets.Util.Widget.resultReqs' and+'Monomer.Widgets.Util.Widget.resultReqsEvts' helper functions can also be used.  In general a result starts in a child widget, but parent widgets can append-requets or new versions of themselves.+requests or new versions of themselves. -} data WidgetResult s e = WidgetResult {   _wrNode :: WidgetNode s e,              -- ^ The updated widget node.@@ -322,10 +327,12 @@   _weWindowSize :: Size,   -- | The active map of shared data.   _weWidgetShared :: MVar (Map Text WidgetShared),-  {-+  {-|   The active map of WidgetKey -> WidgetNode, if any. This map is restricted to-  to the parent 'Composite'. Do not use this map directly, rely instead on the-  'widgetIdFromKey', 'nodeInfoFromKey' and 'nodeInfoFromPath' utility functions.+  to the parent "Monomer.Widgets.Composite". Do not use this map directly, rely+  instead on the 'Monomer.Core.Util.widgetIdFromKey',+  'Monomer.Core.Util.nodeInfoFromKey' and 'Monomer.Core.Util.nodeInfoFromPath'+  utility functions.   -}   _weWidgetKeyMap :: WidgetKeyMap s e,   -- | The currently hovered path, if any.@@ -625,8 +632,8 @@     Receives a message and, optionally, returns a result. This can include an     updated version of the widget (in case it has internal state), user events     or requests to the runtime. There is no validation regarding the message-    type, and the widget should take care of _casting_ to the correct type using-    "Data.Typeable.cast"+    type, and the widget should take care of /casting/ to the correct type using+    'Data.Typeable.cast'.      Arguments: 

@@ -471,7 +471,7 @@  imgInsertNew :: Text -> ImageDef -> ImagesMap -> VG.Image -> ImagesMap imgInsertNew name imageDef imagesMap nvImg = newImagesMap where-  image = Image imageDef nvImg 0+  image = Image imageDef nvImg 1   newImagesMap = M.insert name image imagesMap  imgDelete :: Text -> ImagesMap -> ImagesMap

@@ -170,14 +170,14 @@   = Model s   -- | Raises a new event, which will be handled in the same cycle.   | Event e-  -- | Raises an event that will be handled by the parent.+  -- | Raises an event that will be handled by the parent Composite.   | Report ep   -- | Generates a 'WidgetRequest'.   | Request (WidgetRequest s e)   {-|-  Generates a 'WidgetRequest' matching the parent's types. Useful when receiving-  requests as configuration from the parent, since the types will not match-  otherwise.+  Generates a 'WidgetRequest' matching the parent Composite's type. Useful when+  receiving requests as configuration from the parent, since the types will not+  match otherwise.   -}   | RequestParent (WidgetRequest sp ep)   {-|

@@ -258,7 +258,7 @@  {-| Receives a System event and, optionally, modifies the event, its target, or-cancels the event propagation by returning null.+stops the event propagation by returning Nothing.  Examples can be found in "Monomer.Widgets.Containers.Base.LabeledItem". -}

@@ -58,7 +58,8 @@   -- * Constructors   box,   box_,-  expandContent+  expandContent,+  boxFilterEvent ) where  import Control.Applicative ((<|>))@@ -101,11 +102,13 @@ - 'onClickEmptyReq': generates a WidgetRequest on click in empty area. - 'expandContent': if the inner widget should use all the available space. To be   able to use alignment options, this must be False (the default).+- 'boxFilterEvent': allows filtering or modifying a 'SystemEvent'. -} data BoxCfg s e = BoxCfg {   _boxExpandContent :: Maybe Bool,   _boxIgnoreEmptyArea :: Maybe Bool,   _boxSizeReqUpdater :: [SizeReqUpdater],+  _boxFilterEvent :: Maybe (ContainerFilterHandler s e),   _boxMergeRequired :: Maybe (WidgetEnv s e -> s -> s -> Bool),   _boxAlignH :: Maybe AlignH,   _boxAlignV :: Maybe AlignV,@@ -124,6 +127,7 @@     _boxExpandContent = Nothing,     _boxIgnoreEmptyArea = Nothing,     _boxSizeReqUpdater = [],+    _boxFilterEvent = Nothing,     _boxMergeRequired = Nothing,     _boxAlignH = Nothing,     _boxAlignV = Nothing,@@ -142,6 +146,7 @@     _boxExpandContent = _boxExpandContent t2 <|> _boxExpandContent t1,     _boxIgnoreEmptyArea = _boxIgnoreEmptyArea t2 <|> _boxIgnoreEmptyArea t1,     _boxSizeReqUpdater = _boxSizeReqUpdater t1 <> _boxSizeReqUpdater t2,+    _boxFilterEvent = _boxFilterEvent t2 <|> _boxFilterEvent t1,     _boxMergeRequired = _boxMergeRequired t2 <|> _boxMergeRequired t1,     _boxAlignH = _boxAlignH t2 <|> _boxAlignH t1,     _boxAlignV = _boxAlignV t2 <|> _boxAlignV t1,@@ -295,6 +300,15 @@   _boxExpandContent = Just True } +{-|+Receives a System event and, optionally, modifies the event, its target, or+stops the event propagation by returning Nothing.+-}+boxFilterEvent :: ContainerFilterHandler s e -> BoxCfg  s e+boxFilterEvent handler = def {+  _boxFilterEvent = Just handler+}+ newtype BoxState s = BoxState {   _bxsModel :: Maybe s }@@ -330,6 +344,7 @@     containerInit = init,     containerMergeChildrenReq = mergeRequired,     containerMerge = merge,+    containerFilterEvent = filterEvent,     containerHandleEvent = handleEvent,     containerGetSizeReq = getSizeReq,     containerResize = resize@@ -357,6 +372,10 @@   getCurrentStyle = currentStyle_ currentStyleConfig where     currentStyleConfig = def       & L.isActive .~ isNodeTreeActive++  filterEvent = case _boxFilterEvent config of+    Just handler -> handler+    _ -> \wenv node target evt -> Just (target, evt)    handleEvent wenv node target evt = case evt of     Focus prev -> handleFocusChange node prev (_boxOnFocusReq config)

@@ -588,8 +588,12 @@       result         | needsUpdate = Just $ makeResult newState         | otherwise = Nothing-      stepX = wheelRate * wx-      stepY = wheelRate * wy+      stepX+        | shiftPressed && changedY = wheelRate * wy+        | otherwise = wheelRate * wx+      stepY+        | shiftPressed = 0+        | otherwise = wheelRate * wy       newState = state {         _sstDeltaX = scrollAxisH (stepX + dx),         _sstDeltaY = scrollAxisV (stepY + dy)@@ -601,6 +605,7 @@       style = scrollCurrentStyle wenv node       contentArea = getContentArea node style       mousePos = wenv ^. L.inputStatus . L.mousePos+      shiftPressed = isShiftPressed (wenv ^. L.inputStatus . L.keyMod)        Rect cx cy cw ch = contentArea       sctx = scrollStatus config wenv node state mousePos

@@ -11,8 +11,8 @@  Tooltip styling is a bit unusual, since it is applied to the overlaid element. This means padding will not be shown for the contained child element, but only-on the message when the tooltip is active. If you need padding around the child-element, you can use a "Monomer.Widgets.Containers.Box" around it.+on the message when the tooltip is active. If padding around the child element+is needed, "Monomer.Widgets.Containers.Box" can be used to wrap it.  @ tooltip "Click the button" (buttom \"Accept\" AcceptAction)

@@ -59,6 +59,7 @@ - 'ellipsis': if ellipsis should be used for overflown text. - 'multiline': if text may be split in multiple lines. - 'maxLines': maximum number of text lines to show.+- 'ignoreTheme': whether to load default style from theme or start empty. - 'resizeFactor': flexibility to have more or less spaced assigned. - 'resizeFactorW': flexibility to have more or less horizontal spaced assigned. - 'resizeFactorH': flexibility to have more or less vertical spaced assigned.@@ -184,14 +185,14 @@  {-| Creates a button with main styling. Useful to highlight an option, such as-"Accept", when multiple buttons are available.+\"Accept\", when multiple buttons are available. -} mainButton :: WidgetEvent e => Text -> e -> WidgetNode s e mainButton caption handler = button_ caption handler [mainConfig]  {-| Creates a button with main styling. Useful to highlight an option, such as-"Accept", when multiple buttons are available. Accepts config.+\"Accept\", when multiple buttons are available. Accepts config. -} mainButton_ :: WidgetEvent e => Text -> e -> [ButtonCfg s e] -> WidgetNode s e mainButton_ caption handler configs = button_ caption handler newConfigs where@@ -199,7 +200,7 @@  {-| Creates a button with main styling. Useful to highlight an option, such as-"Accept", when multiple buttons are available. Accepts config but does not+\"Accept\", when multiple buttons are available. Accepts config but does not require an event. See 'buttonD_'. -} mainButtonD_ :: WidgetEvent e => Text -> [ButtonCfg s e] -> WidgetNode s e@@ -220,9 +221,10 @@ use this version, adding an 'onClick' handler in configs.  Using this constructor directly can be helpful in cases where the event to be-raised belongs in a _Composite_ above in the widget tree, outside the scope of-the Composite that contains the button. This parent Composite can be reached by-sending a message ('SendMessage') to its 'WidgetId' using 'onClickReq'.+raised belongs in a "Monomer.Widgets.Composite" above in the widget tree,+outside the scope of the Composite that contains the button. This parent+Composite can be reached by sending a message ('SendMessage') to its 'WidgetId'+using 'onClickReq'. -} buttonD_ :: WidgetEvent e => Text -> [ButtonCfg s e] -> WidgetNode s e buttonD_ caption configs = buttonNode where

@@ -48,7 +48,7 @@ import Data.ByteString (ByteString) import Data.Char (toLower) import Data.Default-import Data.Map (Map)+import Data.Map.Strict (Map) import Data.Maybe import Data.List (isPrefixOf) import Data.Text (Text)@@ -62,7 +62,7 @@ import qualified Codec.Picture as Pic import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL-import qualified Data.Map as Map+import qualified Data.Map.Strict as Map import qualified Data.Text as T import qualified Network.Wreq.Session as Sess @@ -303,7 +303,7 @@     singleRender = render   } -  !isImageMem = case imgSource of+  isImageMem !source = case source of     ImageMem{} -> True     _ -> False @@ -324,20 +324,30 @@   merge wenv newNode oldNode oldState = result where     wid = newNode ^. L.info . L.widgetId     path = newNode ^. L.info . L.path+     oldSource = isImageSource oldState-    imgPath = imgName imgSource-    prevPath = imgName oldSource +    newPath = imgName imgSource+    oldPath = imgName oldSource+    isNewMem = isImageMem imgSource+    isOldMem = isImageMem oldSource+     sameImgNode = newNode       & L.widget .~ makeImage imgSource config oldState-    newMemReqs = [ RemoveRendererImage prevPath ]-    newImgReqs = [-        RemoveRendererImage prevPath,-        RunTask wid path (handleImageLoad config wenv imgPath)++    disposeOld = [ RunTask wid path (handleImageDispose wenv oldPath) | not isOldMem ]++    newMemReqs = disposeOld ++ [+        RemoveRendererImage oldPath,+        ResizeWidgets wid       ]+    newImgReqs = disposeOld ++ [+        RemoveRendererImage oldPath,+        RunTask wid path (handleImageLoad config wenv newPath)+      ]     result       | oldSource == imgSource = resultNode sameImgNode-      | isImageMem = resultReqs newNode newMemReqs+      | isNewMem = resultReqs newNode newMemReqs       | otherwise = resultReqs newNode newImgReqs    dispose wenv node = resultReqs node reqs where@@ -458,6 +468,7 @@   -- loading images in parallel. The main MVar is only taken until the image's   -- MVar is retrieved/created.   (sharedMap, sess) <- takeMVar sharedMapMVar >>= getImagesSession+   sharedImgMVar <- case useShared (Map.lookup key sharedMap) of     Just mvar -> return mvar     Nothing -> newMVar emptyImgState@@ -465,6 +476,7 @@    -- Take the image's MVar until done   sharedImg <- takeMVar sharedImgMVar+   (result, newSharedImg) <- case sharedImg of     Just (oldState, oldCount) -> do       return (ImageLoaded oldState, Just (oldState, oldCount + 1))@@ -488,15 +500,18 @@ handleImageDispose :: WidgetEnv s e -> Text -> IO () handleImageDispose wenv path = do   sharedMap <- takeMVar sharedMapMVar+   newSharedMap <- case useShared (Map.lookup key sharedMap) of     Just mvar -> do       sharedImg <- takeMVar mvar+       return $ case sharedImg of         Just (oldState :: ImageState, oldCount :: Int)           | oldCount > 1 ->               sharedMap & at key ?~ WidgetShared (oldState, oldCount - 1)         _ -> sharedMap & at key .~ Nothing     Nothing -> return sharedMap+   putMVar sharedMapMVar newSharedMap   where     sharedMapMVar = wenv ^. L.widgetShared

@@ -17,7 +17,7 @@ Multi-line label:  @-label_ "This is a\nmultiline label" [multiline]+label_ "This is a\\nmultiline label" [multiline] @ -} {-# LANGUAGE DeriveGeneric #-}

@@ -67,10 +67,10 @@ - 'onChange': event to raise when the value changes. - 'onChangeReq': 'WidgetRequest' to generate when the value changes. -}-type ToggleButtonCfg = OptionButtonCfg+type ToggleButtonCfg s e = OptionButtonCfg s e Bool  -- | Sets the style for the Off state of the toggle button.-toggleButtonOffStyle :: Style -> ToggleButtonCfg s e a+toggleButtonOffStyle :: Style -> ToggleButtonCfg s e toggleButtonOffStyle = optionButtonOffStyle  -- | Creates a toggleButton using the given lens.@@ -84,7 +84,7 @@ toggleButton_   :: Text   -> ALens' s Bool-  -> [ToggleButtonCfg s e Bool]+  -> [ToggleButtonCfg s e]   -> WidgetNode s e toggleButton_ caption field cfgs = newNode where   newNode = toggleButtonD_ caption (WidgetLens field) cfgs@@ -106,7 +106,7 @@   => Text   -> Bool   -> (Bool -> e)-  -> [ToggleButtonCfg s e Bool]+  -> [ToggleButtonCfg s e]   -> WidgetNode s e toggleButtonV_ caption value handler configs = newNode where   widgetData = WidgetValue value@@ -117,7 +117,7 @@ toggleButtonD_   :: Text   -> WidgetData s Bool-  -> [ToggleButtonCfg s e Bool]+  -> [ToggleButtonCfg s e]   -> WidgetNode s e toggleButtonD_ caption widgetData configs = toggleButtonNode where   config = mconcat configs

@@ -22,6 +22,8 @@   drawLine,   drawRect,   drawRectBorder,+  drawTriangle,+  drawTriangleBorder,   drawArc,   drawArcBorder,   drawEllipse,@@ -205,6 +207,49 @@ drawRectBorder renderer rect border (Just radius) =   drawRoundedRectBorder renderer rect border radius +{-|+Draws a filled triangle with the given color.++The points should be provided in clockwise order.+-}+drawTriangle+  :: Renderer     -- ^ The renderer.+  -> Point        -- ^ The first point.+  -> Point        -- ^ The second point.+  -> Point        -- ^ The third point.+  -> Maybe Color  -- ^ The color. If Nothing, the triangle will not be drawn.+  -> IO ()        -- ^ The resulting action.+drawTriangle _ _ _ _ Nothing = return ()+drawTriangle renderer p1 p2 p3 (Just color) = do+  beginPath renderer+  setFillColor renderer color+  moveTo renderer p1+  renderLineTo renderer p2+  renderLineTo renderer p3+  closePath renderer+  fill renderer++-- | Draws a triangle's border with the given color and width.+drawTriangleBorder+  :: Renderer     -- ^ The renderer.+  -> Point        -- ^ The first point.+  -> Point        -- ^ The second point.+  -> Point        -- ^ The third point.+  -> Double       -- ^ The border width.+  -> Maybe Color  -- ^ The color. If Nothing, the triangle will not be drawn.+  -> IO ()        -- ^ The resulting action.+drawTriangleBorder _ _ _ _ _ Nothing = return ()+drawTriangleBorder renderer p1 p2 p3 width (Just color) =+  when (width > 0) $ do+    beginPath renderer+    setStrokeColor renderer color+    setStrokeWidth renderer width+    moveTo renderer p1+    renderLineTo renderer p2+    renderLineTo renderer p3+    closePath renderer+    stroke renderer+ -- | Draws a filled arc, delimited by a rect and within the given angles. drawArc   :: Renderer      -- ^ The renderer.@@ -236,12 +281,13 @@   -> Double        -- ^ The arc width.   -> IO ()         -- ^ The resulting action. drawArcBorder renderer rect start end winding Nothing width = return ()-drawArcBorder renderer rect start end winding (Just color) width = do-  beginPath renderer-  setStrokeColor renderer color-  setStrokeWidth renderer width-  renderArc renderer center radius start end winding-  stroke renderer+drawArcBorder renderer rect start end winding (Just color) width =+  when (width > 0) $ do+    beginPath renderer+    setStrokeColor renderer color+    setStrokeWidth renderer width+    renderArc renderer center radius start end winding+    stroke renderer   where     Rect rx ry rw rh = rect     radius = min ((rw - width) / 2) ((rh - width) / 2)@@ -269,12 +315,13 @@   -> IO ()         -- ^ The resulting action. drawEllipseBorder renderer rect Nothing _ = return () drawEllipseBorder renderer rect (Just color) width =-  forM_ contentRect $ \finalRect -> do-    beginPath renderer-    setStrokeColor renderer color-    setStrokeWidth renderer width-    renderEllipse renderer finalRect-    stroke renderer+  when (width > 0) $+    forM_ contentRect $ \finalRect -> do+      beginPath renderer+      setStrokeColor renderer color+      setStrokeWidth renderer width+      renderEllipse renderer finalRect+      stroke renderer   where     contentRect = subtractFromRect rect w w w w     w = width / 2@@ -437,19 +484,21 @@ drawRectCorner _ _ ocorner Nothing Nothing = return points where   points = (ocorner, ocorner, ocorner) drawRectCorner renderer cor ocorner ms1 ms2 = do-  beginPath renderer+  when (w1 > 0 && w2 > 0) $ do+    beginPath renderer -  if color1 == color2-    then setFillColor renderer color1-    else setFillLinearGradient renderer g1 g2 color1 color2+    if color1 == color2+      then setFillColor renderer color1+      else setFillLinearGradient renderer g1 g2 color1 color2 -  moveTo renderer o1-  renderLineTo renderer icorner-  renderLineTo renderer o2-  renderLineTo renderer ocorner-  closePath renderer+    moveTo renderer o1+    renderLineTo renderer icorner+    renderLineTo renderer o2+    renderLineTo renderer ocorner+    closePath renderer -  fill renderer+    fill renderer+   return (o1, o2, icorner)   where     Point cx cy = ocorner@@ -530,30 +579,31 @@ drawRoundedCorner _ _ _ center _ Nothing Nothing = return points where   points = (center, center, center, center) drawRoundedCorner renderer cor bounds ocenter mrcor ms1 ms2 = do-  beginPath renderer+  when (w1 > 0 || w2 > 0) $ do+    beginPath renderer -  if color1 == color2-    then setFillColor renderer color1-    else setFillLinearGradient renderer g1 g2 color1 color2+    if color1 == color2+      then setFillColor renderer color1+      else setFillLinearGradient renderer g1 g2 color1 color2 -  if round orad == 0-    then drawRectArc renderer cor icenter w1 w2-    else renderArc renderer ocenter orad deg (deg - 90) CCW+    if round orad == 0+      then drawRectArc renderer cor icenter w1 w2+      else renderArc renderer ocenter orad deg (deg - 90) CCW -  renderLineTo renderer o1+    renderLineTo renderer o1 -  if round orad > 0 && round irad > 0-    then do-      renderLineTo renderer i1-      renderArc renderer icenter irad (deg - 90) deg CW-      renderLineTo renderer i2-    else do-      renderLineTo renderer icenter+    if round orad > 0 && round irad > 0+      then do+        renderLineTo renderer i1+        renderArc renderer icenter irad (deg - 90) deg CW+        renderLineTo renderer i2+      else do+        renderLineTo renderer icenter -  renderLineTo renderer o2+    renderLineTo renderer o2 -  closePath renderer-  fill renderer+    closePath renderer+    fill renderer    return bordersCorners   where@@ -619,15 +669,16 @@  drawQuad :: Renderer -> Point -> Point -> Point -> Point -> Maybe BorderSide -> IO () drawQuad renderer p1 p2 p3 p4 Nothing = pure ()-drawQuad renderer p1 p2 p3 p4 (Just BorderSide{..}) = do-  beginPath renderer-  setFillColor renderer _bsColor-  moveTo renderer p1-  renderLineTo renderer p2-  renderLineTo renderer p3-  renderLineTo renderer p4-  closePath renderer-  fill renderer+drawQuad renderer p1 p2 p3 p4 (Just BorderSide{..}) =+  when (_bsWidth > 0) $ do+    beginPath renderer+    setFillColor renderer _bsColor+    moveTo renderer p1+    renderLineTo renderer p2+    renderLineTo renderer p3+    renderLineTo renderer p4+    closePath renderer+    fill renderer  cornerGradientPoints :: Point -> Point -> (Point, Point) cornerGradientPoints outer inner = (g1, g2) where

@@ -8,6 +8,7 @@  Helper functions for loading theme values. -}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Strict #-} @@ -73,3 +74,84 @@   active = wenv ^. L.theme . L.active . L.userStyleMap . at name   disabled = wenv ^. L.theme . L.disabled . L.userStyleMap . at name   style = Style basic hover focus focusHover active disabled++{-|+Sets the given value, overwriting the previous one, for each of the states of a+theme.++Useful for customizing a base theme.++@+theme = darkTheme+  & setThemeValue L.sliderRadius (Just 10)+  & setThemeValue L.sliderWidth 10+@+-}+setThemeValue+  :: Lens' ThemeState a+  -> a+  -> Theme+  -> Theme+setThemeValue field value theme = newTheme where+  newTheme = theme+    & L.basic . field .~ value+    & L.hover . field .~ value+    & L.focus . field .~ value+    & L.focusHover . field .~ value+    & L.active . field .~ value+    & L.disabled . field .~ value++{-|+Sets the given style options, overwriting the previous style, for each of the+states of a theme.++Useful for customizing a base theme.++@+theme = darkTheme+  & setThemeStyle L.dropdownStyle [padding 6, paddingV 6]+@++Note: In most cases 'mergeThemeStyle' is a better choice, since it keeps all the+other style settings intact.+-}+setThemeStyle+  :: Lens' ThemeState StyleState+  -> [StyleState]+  -> Theme+  -> Theme+setThemeStyle field styles theme = newTheme where+  !value = mconcat styles+  newTheme = theme+    & L.basic . field .~ value+    & L.hover . field .~ value+    & L.focus . field .~ value+    & L.focusHover . field .~ value+    & L.active . field .~ value+    & L.disabled . field .~ value++{-|+Merges the given style options with the existing style, for each of the states+of a theme.++Useful for customizing a base theme.++@+theme = darkTheme+  & mergeThemeStyle L.dropdownStyle [padding 6, paddingV 6]+@+-}+mergeThemeStyle+  :: Lens' ThemeState StyleState+  -> [StyleState]+  -> Theme+  -> Theme+mergeThemeStyle field styles theme = newTheme where+  !value = mconcat styles+  newTheme = theme+    & L.basic . field <>~ value+    & L.hover . field <>~ value+    & L.focus . field <>~ value+    & L.focusHover . field <>~ value+    & L.active . field <>~ value+    & L.disabled . field <>~ value

@@ -26,6 +26,7 @@ import Monomer.TestEventUtil import Monomer.TestUtil import Monomer.Widgets.Containers.Box+import Monomer.Widgets.Containers.Grid import Monomer.Widgets.Containers.ZStack import Monomer.Widgets.Singles.Button import Monomer.Widgets.Singles.Label@@ -45,6 +46,7 @@ spec :: Spec spec = describe "Box" $ do   mergeReq+  filterEvent   handleEvent   handleEventIgnoreEmpty   handleEventSinkEmpty@@ -74,6 +76,29 @@     mergeWith newNode oldNode = result ^?! L.node . L.children . ix 0 where       oldNode2 = nodeInit wenv oldNode       result = widgetMerge (newNode ^. L.widget) wenv newNode oldNode2++filterEvent :: Spec+filterEvent = describe "filterEvent" $ do+  it "should click the first button, since the click event was directed to it" $+    evts False [evtClick point1] `shouldBe` Seq.singleton (BtnClick 1)++  it "should click the second button, since the click event's target was modified" $+    evts True [evtClick point1] `shouldBe` Seq.singleton (BtnClick 2)++  where+    wenv = mockWenv ()+    point1 = Point 320 200+    point2 = Point 320 400++    filterEvent wenv node target evt = Just (target & ix 2 .~ 1, evtClick point2)++    btnBox ignore = box_ (expandContent : [boxFilterEvent filterEvent | ignore]) $+      vgrid [+        button "Button 1" (BtnClick 1),+        button "Button 2" (BtnClick 2)+      ]+    evts ignore es = nodeHandleEventEvts wenv es $+      nodeInit wenv (btnBox ignore)  handleEvent :: Spec handleEvent = describe "handleEvent" $ do

@@ -53,6 +53,7 @@   handleBarClick   handleThumbDrag   handleChildrenFocus+  handleWheel   handleNestedWheel   handleMessageReset   raiseOnChange@@ -167,6 +168,47 @@     followNode = scroll stackNode     evtsIgnore es = nodeHandleEventEvts wenv es ignoreNode     evtsFollow es = nodeHandleEventEvts wenv es followNode++handleWheel :: Spec+handleWheel = describe "handleWheel" $ do+  it "should scroll horizontally with the horizontal wheel and click the second button" $ do+    eventsH False `shouldBe` Seq.fromList [Button2]++  it "should scroll horizontally with the horizontal wheel, ignoring shift, and click the second button" $ do+    eventsH True `shouldBe` Seq.fromList [Button2]++  it "should scroll vertically with the vertical wheel and click the third button" $ do+    eventsV False `shouldBe` Seq.fromList [Button3]++  it "should scroll horizontally with the vertical wheel, since shift is pressed, and click the second button" $ do+    eventsV True `shouldBe` Seq.fromList [Button2]++  where+    wenv shiftPressed = mockWenv ()+      & L.windowSize .~ Size 640 480+      & L.inputStatus . L.keyMod . L.leftShift .~ shiftPressed++    point = Point 160 240+    st = [width 640, height 480]+    stackNode = vstack [+        hstack [+          button "Button 1" Button1 `styleBasic` st,+          button "Button 2" Button2 `styleBasic` st+        ],+        hstack [+          button "Button 3" Button3 `styleBasic` st,+          button "Button 4" Button4 `styleBasic` st+        ]+      ]+    scrollNode = scroll stackNode++    eventsH shift = nodeHandleEventEvts (wenv shift) es scrollNode where+      evtWheel = WheelScroll point (Point (-2000) 0) WheelNormal+      es = [evtWheel, evtClick point]++    eventsV shift = nodeHandleEventEvts (wenv shift) es scrollNode where+      evtWheel = WheelScroll point (Point 0 (-2000)) WheelNormal+      es = [evtWheel, evtClick point]  handleNestedWheel :: Spec handleNestedWheel = describe "handleNestedWheel" $ do

@@ -36,10 +36,11 @@   it "should not create a task when merging to the same path" $     Seq.length reqs2 `shouldBe` 0 -  it "should create a task when merging to a different path" $ do-    Seq.length reqs3 `shouldBe` 2-    Seq.index reqs3 0 `shouldSatisfy` isRemoveRendererImage-    Seq.index reqs3 1 `shouldSatisfy` isRunTask+  it "should create two tasks when merging to a different path" $ do+    Seq.length reqs3 `shouldBe` 3+    Seq.index reqs3 0 `shouldSatisfy` isRunTask+    Seq.index reqs3 1 `shouldSatisfy` isRemoveRendererImage+    Seq.index reqs3 2 `shouldSatisfy` isRunTask    it "should have one widgetId on init (loading)" $     ctx1 ^. L.widgetPaths `shouldSatisfy` (== 1) . length