monomer 1.1.1.0 → 1.2.0.0

raw patch · 48 files changed

+1290/−133 lines, 48 filesdep ~aesondep ~sdl2PVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, sdl2

API changes (from Hackage documentation)

Files

• ChangeLog.md +31/−0
• examples/books/Main.hs +1/−1
• examples/generative/Main.hs +5/−3
• examples/ticker/Main.hs +5/−2
• examples/todo/Main.hs +9/−7
• examples/tutorial/Tutorial03_LifeCycle.hs +2/−1
• monomer.cabal +8/−4
• src/Monomer/Core/StyleUtil.hs +17/−1
• src/Monomer/Core/Themes/BaseTheme.hs +48/−0
• src/Monomer/Core/Themes/SampleThemes.hs +17/−9
• src/Monomer/Core/Util.hs +6/−0
• src/Monomer/Core/WidgetTypes.hs +2/−2
• src/Monomer/Graphics/Util.hs +26/−0
• src/Monomer/Main/Core.hs +2/−2
• src/Monomer/Main/Handlers.hs +2/−2
• src/Monomer/Main/Platform.hs +11/−0
• src/Monomer/Main/Types.hs +20/−3
• src/Monomer/Main/UserUtil.hs +2/−1
• src/Monomer/Widgets.hs +5/−1
• src/Monomer/Widgets/Composite.hs +147/−32
• src/Monomer/Widgets/Container.hs +41/−2
• src/Monomer/Widgets/Containers/Keystroke.hs +46/−11
• src/Monomer/Widgets/Containers/Scroll.hs +9/−1
• src/Monomer/Widgets/Containers/ZStack.hs +7/−3
• src/Monomer/Widgets/Singles/Base/InputField.hs +1/−1
• src/Monomer/Widgets/Singles/Checkbox.hs +3/−0
• src/Monomer/Widgets/Singles/ColorPicker.hs +8/−9
• src/Monomer/Widgets/Singles/Dial.hs +2/−1
• src/Monomer/Widgets/Singles/OptionButton.hs +346/−0
• src/Monomer/Widgets/Singles/Radio.hs +3/−0
• src/Monomer/Widgets/Singles/Slider.hs +2/−1
• src/Monomer/Widgets/Singles/ToggleButton.hs +122/−0
• src/Monomer/Widgets/Util/Style.hs +2/−1
• src/Monomer/Widgets/Util/Widget.hs +2/−1
• test/unit/Monomer/TestUtil.hs +16/−2
• test/unit/Monomer/Widgets/CompositeSpec.hs +3/−3
• test/unit/Monomer/Widgets/Containers/BoxSpec.hs +2/−2
• test/unit/Monomer/Widgets/Containers/KeystrokeSpec.hs +15/−5
• test/unit/Monomer/Widgets/Containers/ZStackSpec.hs +2/−2
• test/unit/Monomer/Widgets/Singles/ColorPickerSpec.hs +4/−4
• test/unit/Monomer/Widgets/Singles/DialSpec.hs +6/−0
• test/unit/Monomer/Widgets/Singles/NumericFieldSpec.hs +12/−0
• test/unit/Monomer/Widgets/Singles/OptionButtonSpec.hs +116/−0
• test/unit/Monomer/Widgets/Singles/SliderSpec.hs +6/−0
• test/unit/Monomer/Widgets/Singles/TextAreaSpec.hs +9/−3
• test/unit/Monomer/Widgets/Singles/TextFieldSpec.hs +9/−3
• test/unit/Monomer/Widgets/Singles/ToggleButtonSpec.hs +111/−0
• test/unit/Spec.hs +19/−7

@@ -1,3 +1,34 @@+## 1.2.0.0++### Added++- Add `customModelBuilder` in Composite, for custom models support. These can consume information+  from the parent model.+- Add `containerCreateContainerFromModel` to workaround issue when updating offset during merge.+- Add `appDisableCompositing` to allow requesting compositing to be disabled on startup.+- Add `optionButton` and `toggleButton` widgets.+- Add `SetFocusOnKey` and `MoveFocusFromKey` actions in `Composite`. Deprecate `setFocusOnKey` function.+  This function depended on information in `WidgetEnv`, which can become stale if several actions are+  returned at once. This change reduces confusion regarding order of operations and widget tree state.++### Fixed++- Keep old Composite root if model has not changed. This does not affect previous code,+  it is only relevant with new features.+- Generate `IgnoreParentEvents` request from widgets that handle Wheel event (avoids issues with scroll widget moving the content).+- Do not run tests which depend on SDL's video subsystem to be available unless an environment variable is defined.+  This allows for (hopefully) running tests on Hackage and, later on, deploying to Stackage.++### Changed++- Composite requests `RenderOnce` when model changes.+- Composite now renders decorations if a style is set.+- ZStack's `onlyTopActive` now follows the same pattern as other boolean combinators.+- Shortened labels for `ColorPicker`.+- Changed `_weFindByPath` to `_weFindBranchByPath`, now returning the complete branch up to the given path.+- Change SDL's default of requesting compositing to be disabled on startup (compositing is now left unchanged).+- Filter following `TextInput` event if a single letter binding matched previously on `keystroke`.+ ## 1.1.1.0  ### Added

@@ -141,7 +141,7 @@   -> BooksEvt   -> [EventResponse BooksModel BooksEvt BooksModel ()] handleEvent sess wenv node model evt = case evt of-  BooksInit -> [setFocusOnKey wenv "query"]+  BooksInit -> [SetFocusOnKey "query"]   BooksSearch -> [     Model $ model & searching .~ True,     Task $ searchBooks sess (model ^. query)

@@ -75,9 +75,10 @@         spacer,         textDropdown_ activeGen genTypes genTypeDesc [] `nodeKey` "activeType",         spacer,--        labeledCheckbox "Show config:" showCfg+        toggleButton remixSettings3Fill showCfg+          `styleBasic` [textFont "Remix", textSize 20, textMiddle]       ] `styleBasic` [padding 20, bgColor sectionBg],+       zstack [         hstack [           circlesGrid (model ^. circlesCfg) `styleBasic` [padding 20],@@ -102,7 +103,7 @@   -> GenerativeEvt   -> [EventResponse GenerativeModel GenerativeEvt GenerativeModel ()] handleEvent wenv node model evt = case evt of-  GenerativeInit -> [setFocusOnKey wenv "activeType"]+  GenerativeInit -> [SetFocusOnKey "activeType"]  main :: IO () main = do@@ -112,6 +113,7 @@     config = [       appWindowTitle "Generative",       appTheme darkTheme,+      appFontDef "Remix" "./assets/fonts/remixicon.ttf",       appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf",       appInitEvent GenerativeInit       ]

@@ -59,6 +59,7 @@  tickerRow :: TickerWenv -> Int -> Ticker -> TickerNode tickerRow wenv idx t = row where+  sectionBg = wenv ^. L.theme . L.sectionColor   dragColor = rgbaHex "#D3D3D3" 0.5   rowSep = rgbaHex "#A9A9A9" 0.5   rowBg = wenv ^. L.theme . L.userColorMap . at "rowBg" . non def@@ -68,6 +69,8 @@   trashIcon action = button remixDeleteBinLine action     `styleBasic` [textFont "Remix", textMiddle, textColor trashFg, bgColor transparent, border 0 transparent]     `styleHover` [bgColor trashBg]+    `styleFocus` [bgColor (sectionBg & L.a .~ 0.5)]+    `styleFocusHover` [bgColor trashBg]    dropTicker pair     = dropTarget_ (TickerMovePair pair) [dropTargetStyle [bgColor darkGray]]@@ -127,7 +130,7 @@       & symbolPairs .~ initialList,     Producer (startProducer env),     Task (subscribeInitial env initialList),-    setFocusOnKey wenv "newPair"+    SetFocusOnKey "newPair"     ]    TickerAddClick -> [@@ -135,7 +138,7 @@       & symbolPairs %~ (model ^. newPair <|)       & newPair .~ "",     Task $ subscribe env [model ^. newPair],-    setFocusOnKey wenv "newPair"+    SetFocusOnKey "newPair"     ]    TickerRemovePairBegin pair -> [

@@ -53,6 +53,8 @@   rowButton caption action = button caption action     `styleBasic` [textFont "Remix", textMiddle, textColor rowButtonColor, bgColor transparent, border 0 transparent]     `styleHover` [bgColor sectionBg]+    `styleFocus` [bgColor (sectionBg & L.a .~ 0.5)]+    `styleFocusHover` [bgColor sectionBg]    todoInfo = hstack [       vstack [@@ -160,32 +162,32 @@   -> TodoEvt   -> [EventResponse TodoModel TodoEvt TodoModel ()] handleEvent wenv node model evt = case evt of-  TodoInit -> [setFocusOnKey wenv "todoNew"]+  TodoInit -> [SetFocusOnKey "todoNew"]    TodoNew -> [     Event TodoShowEdit,     Model $ model       & action .~ TodoAdding       & activeTodo .~ def,-    setFocusOnKey wenv "todoDesc"]+    SetFocusOnKey "todoDesc"]    TodoEdit idx td -> [     Event TodoShowEdit,     Model $ model       & action .~ TodoEditing idx       & activeTodo .~ td,-    setFocusOnKey wenv "todoDesc"]+    SetFocusOnKey "todoDesc"]    TodoAdd -> [     Event TodoHideEdit,     Model $ addNewTodo wenv model,-    setFocusOnKey wenv "todoNew"]+    SetFocusOnKey "todoNew"]    TodoSave idx -> [     Event TodoHideEdit,     Model $ model       & todos . ix idx .~ (model ^. activeTodo),-    setFocusOnKey wenv "todoNew"]+    SetFocusOnKey "todoNew"]    TodoDeleteBegin idx todo -> [     Message (WidgetKey (todoRowKey todo)) AnimationStart]@@ -194,13 +196,13 @@     Model $ model       & action .~ TodoNone       & todos .~ remove idx (model ^. todos),-    setFocusOnKey wenv "todoNew"]+    SetFocusOnKey "todoNew"]    TodoCancel -> [     Event TodoHideEdit,     Model $ model       & activeTodo .~ def,-    setFocusOnKey wenv "todoNew"]+    SetFocusOnKey "todoNew"]    TodoShowEdit -> [     Message "animEditIn" AnimationStart,

@@ -84,13 +84,14 @@       Model $ model         & newItemText .~ ""         & items .~ newItem : model ^. items,-      setFocusOnKey wenv "description"]+      SetFocusOnKey "description"]   RemoveItem idx -> [Model $ model     & items .~ removeIdx idx (model ^. items)]   _ -> []   where     newItem = ListItem (wenv ^. L.timestamp) (model ^. newItemText) +removeIdx :: Int -> [a] -> [a] removeIdx idx lst = part1 ++ drop 1 part2 where   (part1, part2) = splitAt idx lst 

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           monomer-version:        1.1.1.0+version:        1.2.0.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.@@ -114,6 +114,7 @@       Monomer.Widgets.Singles.LabeledCheckbox       Monomer.Widgets.Singles.LabeledRadio       Monomer.Widgets.Singles.NumericField+      Monomer.Widgets.Singles.OptionButton       Monomer.Widgets.Singles.Radio       Monomer.Widgets.Singles.SeparatorLine       Monomer.Widgets.Singles.Slider@@ -122,6 +123,7 @@       Monomer.Widgets.Singles.TextDropdown       Monomer.Widgets.Singles.TextField       Monomer.Widgets.Singles.TimeField+      Monomer.Widgets.Singles.ToggleButton       Monomer.Widgets.Util       Monomer.Widgets.Util.Drawing       Monomer.Widgets.Util.Focus@@ -201,7 +203,7 @@   build-depends:       JuicyPixels >=3.2.9 && <3.5     , OpenGL ==3.0.*-    , aeson >=1.4 && <1.6+    , aeson >=1.4 && <2.1     , async >=2.1 && <2.3     , attoparsec >=0.12 && <0.15     , base >=4.11 && <5@@ -331,7 +333,7 @@   build-depends:       JuicyPixels >=3.2.9 && <3.5     , OpenGL ==3.0.*-    , aeson >=1.4 && <1.6+    , aeson >=1.4 && <2.1     , async >=2.1 && <2.3     , attoparsec >=0.12 && <0.15     , base >=4.11 && <5@@ -491,6 +493,7 @@       Monomer.Widgets.Singles.LabeledRadioSpec       Monomer.Widgets.Singles.LabelSpec       Monomer.Widgets.Singles.NumericFieldSpec+      Monomer.Widgets.Singles.OptionButtonSpec       Monomer.Widgets.Singles.RadioSpec       Monomer.Widgets.Singles.SeparatorLineSpec       Monomer.Widgets.Singles.SliderSpec@@ -498,6 +501,7 @@       Monomer.Widgets.Singles.TextAreaSpec       Monomer.Widgets.Singles.TextFieldSpec       Monomer.Widgets.Singles.TimeFieldSpec+      Monomer.Widgets.Singles.ToggleButtonSpec       Monomer.Widgets.Util.FocusSpec       Monomer.Widgets.Util.StyleSpec       Monomer.Widgets.Util.TextSpec@@ -506,7 +510,7 @@       test/unit   default-extensions:       OverloadedStrings-  ghc-options: -threaded -fwarn-incomplete-patterns+  ghc-options: -fwarn-incomplete-patterns   build-depends:       HUnit ==1.6.*     , JuicyPixels >=3.2.9 && <3.5

@@ -38,7 +38,8 @@   addPadding,   subtractBorder,   subtractPadding,-  subtractBorderFromRadius+  subtractBorderFromRadius,+  mapStyleStates ) where  import Control.Lens ((&), (^.), (^?), (.~), (+~), (%~), (?~), _Just, non)@@ -261,6 +262,21 @@   nbl = rbl & _Just . L.width %~ \w -> max 0 (w - max bl bb)   nbr = rbr & _Just . L.width %~ \w -> max 0 (w - max br bb)   newRadius = Radius ntl ntr nbl nbr++{-|+Applies a function to all states of a given style. Useful when trying to set or+reset the same property in all different states.+-}+mapStyleStates :: (StyleState -> StyleState) -> Style -> Style+mapStyleStates fn style = newStyle where+  newStyle = Style {+    _styleBasic = fn <$> _styleBasic style,+    _styleHover = fn <$> _styleHover style,+    _styleFocus = fn <$> _styleFocus style,+    _styleFocusHover = fn <$> _styleFocusHover style,+    _styleActive = fn <$> _styleActive style,+    _styleDisabled = fn <$> _styleDisabled style+  }  -- Internal addBorderSize :: Size -> Maybe Border -> Maybe Size

@@ -240,6 +240,8 @@   & L.labelStyle . L.text     ?~ (normalFont & L.fontColor ?~ labelText themeMod) <> textLeft   & L.numericFieldStyle .~ numericInputStyle themeMod+  & L.optionBtnOnStyle .~ btnMainStyle themeMod+  & L.optionBtnOffStyle .~ btnStyle themeMod   & L.selectListStyle . L.bgColor ?~ slMainBg themeMod   & L.selectListStyle . L.border ?~ border 1 (slMainBg themeMod)   & L.selectListItemStyle .~ selectListItemStyle themeMod@@ -266,6 +268,8 @@   & L.textAreaStyle .~ textInputStyle themeMod   & L.textFieldStyle .~ textInputStyle themeMod   & L.timeFieldStyle .~ timeInputStyle themeMod+  & L.toggleBtnOnStyle .~ btnMainStyle themeMod+  & L.toggleBtnOffStyle .~ btnStyle themeMod   & L.tooltipStyle .~ tooltipStyle themeMod  baseHover :: BaseThemeColors -> ThemeState@@ -297,6 +301,12 @@   & L.externalLinkStyle . L.text . non def . L.underline ?~ True   & L.externalLinkStyle . L.cursorIcon ?~ CursorHand   & L.numericFieldStyle . L.cursorIcon ?~ CursorIBeam+  & L.optionBtnOnStyle . L.bgColor ?~ btnMainBgHover themeMod+  & L.optionBtnOnStyle . L.border ?~ border 1 (btnMainBgHover themeMod)+  & L.optionBtnOnStyle . L.cursorIcon ?~ CursorHand+  & L.optionBtnOffStyle . L.bgColor ?~ btnBgHover themeMod+  & L.optionBtnOffStyle . L.border ?~ border 1 (btnBgHover themeMod)+  & L.optionBtnOffStyle . L.cursorIcon ?~ CursorHand   & L.selectListItemStyle . L.bgColor ?~ slNormalBgHover themeMod   & L.selectListItemStyle . L.border ?~ border 1 (slNormalBgHover themeMod)   & L.selectListItemStyle . L.cursorIcon ?~ CursorHand@@ -315,6 +325,12 @@   & L.textAreaStyle . L.cursorIcon ?~ CursorIBeam   & L.textFieldStyle . L.cursorIcon ?~ CursorIBeam   & L.timeFieldStyle . L.cursorIcon ?~ CursorIBeam+  & L.toggleBtnOnStyle . L.bgColor ?~ btnMainBgHover themeMod+  & L.toggleBtnOnStyle . L.border ?~ border 1 (btnMainBgHover themeMod)+  & L.toggleBtnOnStyle . L.cursorIcon ?~ CursorHand+  & L.toggleBtnOffStyle . L.bgColor ?~ btnBgHover themeMod+  & L.toggleBtnOffStyle . L.border ?~ border 1 (btnBgHover themeMod)+  & L.toggleBtnOffStyle . L.cursorIcon ?~ CursorHand  baseFocus :: BaseThemeColors -> ThemeState baseFocus themeMod = baseBasic themeMod@@ -335,6 +351,10 @@   & L.externalLinkStyle . L.text . non def . L.fontColor ?~ externalLinkFocus themeMod   & L.numericFieldStyle . L.border ?~ inputBorderFocus themeMod   & L.numericFieldStyle . L.hlColor ?~ inputSelFocus themeMod+  & L.optionBtnOnStyle . L.bgColor ?~ btnMainBgFocus themeMod+  & L.optionBtnOnStyle . L.border ?~ btnMainBorderFocus themeMod+  & L.optionBtnOffStyle . L.bgColor ?~ btnBgFocus themeMod+  & L.optionBtnOffStyle . L.border ?~ btnBorderFocus themeMod   & L.selectListStyle . L.border ?~ inputBorderFocus themeMod   & L.selectListItemStyle . L.border ?~ border 1 (slNormalFocusBorder themeMod)   & L.selectListItemSelectedStyle . L.border ?~ border 1 (slSelectedFocusBorder themeMod)@@ -349,6 +369,10 @@   & L.textFieldStyle . L.hlColor ?~ inputSelFocus themeMod   & L.timeFieldStyle . L.border ?~ inputBorderFocus themeMod   & L.timeFieldStyle . L.hlColor ?~ inputSelFocus themeMod+  & L.toggleBtnOnStyle . L.bgColor ?~ btnMainBgFocus themeMod+  & L.toggleBtnOnStyle . L.border ?~ btnMainBorderFocus themeMod+  & L.toggleBtnOffStyle . L.bgColor ?~ btnBgFocus themeMod+  & L.toggleBtnOffStyle . L.border ?~ btnBorderFocus themeMod  baseFocusHover :: BaseThemeColors -> ThemeState baseFocusHover themeMod = (baseHover themeMod <> baseFocus themeMod)@@ -357,6 +381,10 @@   & L.dropdownItemStyle . L.bgColor ?~ slNormalBgHover themeMod   & L.dropdownItemSelectedStyle . L.bgColor ?~ slSelectedBgHover themeMod   & L.externalLinkStyle . L.text . non def . L.fontColor ?~ externalLinkHover themeMod+  & L.optionBtnOnStyle . L.bgColor ?~ btnMainBgHover themeMod+  & L.optionBtnOffStyle . L.bgColor ?~ btnBgHover themeMod+  & L.toggleBtnOnStyle . L.bgColor ?~ btnMainBgHover themeMod+  & L.toggleBtnOffStyle . L.bgColor ?~ btnBgHover themeMod  baseActive :: BaseThemeColors -> ThemeState baseActive themeMod = baseFocusHover themeMod@@ -375,6 +403,10 @@   & L.externalLinkStyle . L.text . non def . L.fontColor ?~ externalLinkActive themeMod   & L.numericFieldStyle . L.border ?~ inputBorderFocus themeMod   & L.numericFieldStyle . L.hlColor ?~ inputSelFocus themeMod+  & L.optionBtnOnStyle . L.bgColor ?~ btnMainBgActive themeMod+  & L.optionBtnOnStyle . L.border ?~ btnMainBorderFocus themeMod+  & L.optionBtnOffStyle . L.bgColor ?~ btnBgActive themeMod+  & L.optionBtnOffStyle . L.border ?~ btnBorderFocus themeMod   & L.radioStyle . L.fgColor ?~ inputFgActive themeMod   & L.radioStyle . L.hlColor ?~ inputHlActive themeMod   & L.sliderStyle . L.fgColor ?~ inputFgActive themeMod@@ -386,6 +418,10 @@   & L.textFieldStyle . L.hlColor ?~ inputSelFocus themeMod   & L.timeFieldStyle . L.border ?~ inputBorderFocus themeMod   & L.timeFieldStyle . L.hlColor ?~ inputSelFocus themeMod+  & L.toggleBtnOnStyle . L.bgColor ?~ btnMainBgActive themeMod+  & L.toggleBtnOnStyle . L.border ?~ btnMainBorderFocus themeMod+  & L.toggleBtnOffStyle . L.bgColor ?~ btnBgActive themeMod+  & L.toggleBtnOffStyle . L.border ?~ btnBorderFocus themeMod  baseDisabled :: BaseThemeColors -> ThemeState baseDisabled themeMod = baseBasic themeMod@@ -407,6 +443,12 @@   & L.externalLinkStyle . L.text . non def . L.fontColor ?~ externalLinkDisabled themeMod   & L.numericFieldStyle . L.bgColor ?~ inputBgDisabled themeMod   & L.numericFieldStyle . L.text . non def . L.fontColor ?~ inputTextDisabled themeMod+  & L.optionBtnOnStyle . L.text . non def . L.fontColor ?~ btnMainTextDisabled themeMod+  & L.optionBtnOnStyle . L.bgColor ?~ btnMainBgDisabled themeMod+  & L.optionBtnOnStyle . L.border ?~ border 1 (btnMainBgDisabled themeMod)+  & L.optionBtnOffStyle . L.text . non def . L.fontColor ?~ btnTextDisabled themeMod+  & L.optionBtnOffStyle . L.bgColor ?~ btnBgDisabled themeMod+  & L.optionBtnOffStyle . L.border ?~ border 1 (btnBgDisabled themeMod)   & L.radioStyle . L.fgColor ?~ inputFgDisabled themeMod   & L.radioStyle . L.hlColor ?~ inputHlDisabled themeMod   & L.sliderStyle . L.fgColor ?~ inputFgDisabled themeMod@@ -418,3 +460,9 @@   & L.textFieldStyle . L.text . non def . L.fontColor ?~ inputTextDisabled themeMod   & L.timeFieldStyle . L.bgColor ?~ inputBgDisabled themeMod   & L.timeFieldStyle . L.text . non def . L.fontColor ?~ inputTextDisabled themeMod+  & L.toggleBtnOnStyle . L.text . non def . L.fontColor ?~ btnMainTextDisabled themeMod+  & L.toggleBtnOnStyle . L.bgColor ?~ btnMainBgDisabled themeMod+  & L.toggleBtnOnStyle . L.border ?~ border 1 (btnMainBgDisabled themeMod)+  & L.toggleBtnOffStyle . L.text . non def . L.fontColor ?~ btnTextDisabled themeMod+  & L.toggleBtnOffStyle . L.bgColor ?~ btnBgDisabled themeMod+  & L.toggleBtnOffStyle . L.border ?~ border 1 (btnBgDisabled themeMod)

@@ -35,17 +35,17 @@    btnFocusBorder = blue08,   btnBgBasic = gray07,-  btnBgHover = gray08,-  btnBgFocus = gray08,+  btnBgHover = gray07c,+  btnBgFocus = gray07b,   btnBgActive = gray06,   btnBgDisabled = gray05,   btnText = gray02,   btnTextDisabled = gray02,    btnMainFocusBorder = blue09,-  btnMainBgBasic = blue05,+  btnMainBgBasic = blue05b,   btnMainBgHover = blue06,-  btnMainBgFocus = blue06,+  btnMainBgFocus = blue05c,   btnMainBgActive = blue05,   btnMainBgDisabled = blue04,   btnMainText = white,@@ -133,18 +133,18 @@   sectionColor = gray02,    btnFocusBorder = blue09,-  btnBgBasic = gray07,-  btnBgHover = gray09,-  btnBgFocus = gray08,+  btnBgBasic = gray07b,+  btnBgHover = gray08,+  btnBgFocus = gray07c,   btnBgActive = gray06,   btnBgDisabled = gray05,    btnText = gray02,   btnTextDisabled = gray01,   btnMainFocusBorder = blue08,-  btnMainBgBasic = blue05,+  btnMainBgBasic = blue05b,   btnMainBgHover = blue06,-  btnMainBgFocus = blue06,+  btnMainBgFocus = blue05c,   btnMainBgActive = blue05,   btnMainBgDisabled = blue04,   btnMainText = white,@@ -229,8 +229,14 @@ blue03 = rgbHex "#03449E" blue04 = rgbHex "#0552B5" blue05 = rgbHex "#0967D2"+blue05b = rgbHex "#0F6BD7"+blue05c = rgbHex "#1673DE" blue06 = rgbHex "#2186EB"+blue06b = rgbHex "#2489EE"+blue06c = rgbHex "#2B8FF6" blue07 = rgbHex "#47A3F3"+blue07b = rgbHex "#50A6F6"+blue07c = rgbHex "#57ACFC" blue08 = rgbHex "#7CC4FA" blue09 = rgbHex "#BAE3FF" blue10 = rgbHex "#E6F6FF"@@ -258,6 +264,8 @@ gray05 = rgbHex "#7E7E7E" gray06 = rgbHex "#9E9E9E" gray07 = rgbHex "#B1B1B1"+gray07b = rgbHex "#B4B4B4"+gray07c = rgbHex "#BBBBBB" gray08 = rgbHex "#CFCFCF" gray09 = rgbHex "#E1E1E1" gray10 = rgbHex "#F7F7F7"

@@ -49,6 +49,12 @@       | child ^. L.path == target -> Just child     _ -> Nothing +-- | Returns the complete node info branch associated to a given path.+findWidgetBranchByPath+  :: WidgetEnv s e -> WidgetNode s e -> Path -> Seq WidgetNodeInfo+findWidgetBranchByPath wenv node target = branch where+  branch = widgetFindBranchByPath (node ^. L.widget) wenv node target+ -- | Helper functions that associates False to Vertical and True to Horizontal. getLayoutDirection :: Bool -> LayoutDirection getLayoutDirection False = LayoutVertical

@@ -295,8 +295,8 @@   _weDpr :: Double,   -- | Provides helper funtions for calculating text size.   _weFontManager :: FontManager,-  -- | Returns the information of a node given a path from root, if any.-  _weFindByPath :: Path -> Maybe WidgetNodeInfo,+  -- | Returns the node info, and its parents', given a path from root.+  _weFindBranchByPath :: Path -> Seq WidgetNodeInfo,   -- | The mouse button that is considered main.   _weMainButton :: Button,   -- | The mouse button that is considered as secondary or context button.

@@ -19,6 +19,8 @@   rgbaHex,   hsl,   hsla,+  colorToHsl,+  rgbToHsl,   transparent,   alignInRect,   alignHInRect,@@ -115,6 +117,30 @@ hsla h s l a = (hsl h s l) {     _colorA = clampAlpha a   }++-- | Converts a 'Color' instance to a tuple representing HSL values+colorToHsl :: Color -> (Int, Int, Int)+colorToHsl (Color cr cg cb ca) = rgbToHsl cr cg cb++-- | Converts RGB values to a tuple representing HSL values+rgbToHsl :: Int -> Int -> Int -> (Int, Int, Int)+rgbToHsl cr cg cb = (h, round (s * 255), round (l * 255)) where+  r = fromIntegral cr / 255+  g = fromIntegral cg / 255+  b = fromIntegral cb / 255+  minc = minimum [r, g, b]+  maxc = maximum [r, g, b]+  rngc = maxc - minc+  h+    | maxc == minc = 0+    | maxc == r = round (60 * (g - b) / rngc + 360) `mod` 360+    | maxc == g = round (60 * (b - r) / rngc + 120) `mod` 360+    | otherwise = round (60 * (r - g) / rngc + 240) `mod` 360+  l = (minc + maxc) * 0.5+  s+    | maxc == minc = 0+    | l < 0.5 = rngc / (2 * l)+    | otherwise = rngc / (2 - 2 * l)  -- | Creates a non visible color. transparent :: Color

@@ -155,7 +155,7 @@     _weOs = os,     _weDpr = dpr,     _weFontManager = fontManager,-    _weFindByPath = const Nothing,+    _weFindBranchByPath = const Seq.empty,     _weMainButton = mainBtn,     _weContextButton = contextBtn,     _weTheme = theme,@@ -265,7 +265,7 @@     _weOs = _mlOS,     _weDpr = dpr,     _weFontManager = fontManager,-    _weFindByPath = findWidgetByPath wenv _mlWidgetRoot,+    _weFindBranchByPath = findWidgetBranchByPath wenv _mlWidgetRoot,     _weMainButton = mainBtn,     _weContextButton = contextBtn,     _weTheme = _mlTheme,

@@ -108,9 +108,9 @@           & L.hoveredPath .~ hoveredPath           & L.mainBtnPress .~ mainBtnPress           & L.inputStatus .~ inputStatus-    let findByPath path = findWidgetByPath tmpWenv curRoot path+    let findBranchByPath path = findWidgetBranchByPath tmpWenv curRoot path     let newWenv = tmpWenv-          & L.findByPath .~ findByPath+          & L.findBranchByPath .~ findBranchByPath     (wenv2, root2, reqs2) <- handleSystemEvent newWenv curRoot evt target      when (isOnLeave evt) $ do

@@ -22,6 +22,7 @@   getDisplayDPI ) where +import Control.Monad (void) import Control.Monad.State import Data.Maybe import Data.Text (Text)@@ -55,6 +56,7 @@ initSDLWindow config = do   SDL.initialize [SDL.InitVideo]   SDL.HintRenderScaleQuality $= SDL.ScaleLinear+  setDisableCompositorHint compositingFlag    do renderQuality <- SDL.get SDL.HintRenderScaleQuality      when (renderQuality /= SDL.ScaleLinear) $@@ -118,6 +120,7 @@       SDL.glProfile = SDL.Core SDL.Normal 3 2,       SDL.glMultisampleSamples = 1     }+    compositingFlag = fromMaybe False (_apcDisableCompositing config)     userScaleFactor = fromMaybe 1 (_apcScaleFactor config)     (baseW, baseH) = case _apcWindowState config of       Just (MainWindowNormal size) -> size@@ -212,3 +215,11 @@     if width <= 1920       then return 1       else return (fromIntegral (ceiling baseFactor) / 2)++setDisableCompositorHint :: Bool -> IO ()+setDisableCompositorHint disable = void $+  withCString "SDL_VIDEO_X11_NET_WM_BYPASS_COMPOSITOR" $ \cHintNameStr ->+    withCString disableStr $ \cDisableStr ->+      Raw.setHint cHintNameStr cDisableStr+  where+    disableStr = if disable then "1" else "0"

@@ -189,7 +189,9 @@   -- | Whether wheel/trackpad horizontal movement should be inverted.   _apcInvertWheelX :: Maybe Bool,   -- | Whether wheel/trackpad vertical movement should be inverted.-  _apcInvertWheelY :: Maybe Bool+  _apcInvertWheelY :: Maybe Bool,+  -- | Whether compositing should be disabled. Defaults to False.+  _apcDisableCompositing :: Maybe Bool }  instance Default (AppConfig e) where@@ -210,7 +212,8 @@     _apcMainButton = Nothing,     _apcContextButton = Nothing,     _apcInvertWheelX = Nothing,-    _apcInvertWheelY = Nothing+    _apcInvertWheelY = Nothing,+    _apcDisableCompositing = Nothing   }  instance Semigroup (AppConfig e) where@@ -231,7 +234,8 @@     _apcMainButton = _apcMainButton a2 <|> _apcMainButton a1,     _apcContextButton = _apcContextButton a2 <|> _apcContextButton a1,     _apcInvertWheelX = _apcInvertWheelX a2 <|> _apcInvertWheelX a1,-    _apcInvertWheelY = _apcInvertWheelY a2 <|> _apcInvertWheelY a1+    _apcInvertWheelY = _apcInvertWheelY a2 <|> _apcInvertWheelY a1,+    _apcDisableCompositing = _apcDisableCompositing a2 <|> _apcDisableCompositing a1   }  instance Monoid (AppConfig e) where@@ -363,4 +367,17 @@ appInvertWheelY :: Bool -> AppConfig e appInvertWheelY invert = def {   _apcInvertWheelY = Just invert+}++{-|+Whether compositing should be disabled. Linux only, ignored in other platforms.+Defaults to False.++Desktop applications should leave compositing as is, since disabling it may+cause visual glitches in other programs. When creating games or fullscreen+applications, disabling compositing may improve performance.+-}+appDisableCompositing :: Bool -> AppConfig e+appDisableCompositing invert = def {+  _apcDisableCompositing = Just invert }

@@ -24,8 +24,9 @@ import qualified Monomer.Core.Lens as L import qualified Monomer.Main.Lens as L +{-# DEPRECATED setFocusOnKey "Use SetFocusOnKey instead (wenv argument should be removed)." #-} {-|-Generates a response to sets focus on the given key, provided as WidgetKey. If+Generates a response to set focus on the given key, provided as WidgetKey. If the key does not exist, focus will remain on the currently focused widget. -} setFocusOnKey :: WidgetEnv s e -> WidgetKey -> EventResponse s e sp ep

@@ -43,6 +43,7 @@   module Monomer.Widgets.Singles.LabeledCheckbox,   module Monomer.Widgets.Singles.LabeledRadio,   module Monomer.Widgets.Singles.NumericField,+  module Monomer.Widgets.Singles.OptionButton,   module Monomer.Widgets.Singles.Radio,   module Monomer.Widgets.Singles.SeparatorLine,   module Monomer.Widgets.Singles.Slider,@@ -50,7 +51,8 @@   module Monomer.Widgets.Singles.TextArea,   module Monomer.Widgets.Singles.TextDropdown,   module Monomer.Widgets.Singles.TextField,-  module Monomer.Widgets.Singles.TimeField+  module Monomer.Widgets.Singles.TimeField,+  module Monomer.Widgets.Singles.ToggleButton ) where  import Monomer.Widgets.Composite@@ -87,6 +89,7 @@ import Monomer.Widgets.Singles.LabeledCheckbox import Monomer.Widgets.Singles.LabeledRadio import Monomer.Widgets.Singles.NumericField+import Monomer.Widgets.Singles.OptionButton import Monomer.Widgets.Singles.Radio import Monomer.Widgets.Singles.SeparatorLine import Monomer.Widgets.Singles.Slider@@ -95,3 +98,4 @@ import Monomer.Widgets.Singles.TextDropdown import Monomer.Widgets.Singles.TextField import Monomer.Widgets.Singles.TimeField+import Monomer.Widgets.Singles.ToggleButton

@@ -42,12 +42,14 @@   CompositeEvent,   MergeRequired,   MergeReqsHandler,+  CompositeCustomModelBuilder,   EventHandler,   UIBuilder,   TaskHandler,   ProducerHandler,   CompMsgUpdate,   compositeMergeReqs,+  customModelBuilder,    -- * Constructors   composite,@@ -91,16 +93,26 @@ type CompositeEvent e = WidgetEvent e  -- | Checks if merging the composite is required.-type MergeRequired s = s -> s -> Bool+type MergeRequired s+  = s     -- ^ Old composite model.+  -> s    -- ^ New composite model+  -> Bool -- ^ True if merge is required.  -- | Generates requests during the merge process. type MergeReqsHandler s e-  = WidgetEnv s e-  -> WidgetNode s e-  -> WidgetNode s e-  -> s-  -> [WidgetRequest s e]+  = WidgetEnv s e         -- ^ Widget environment.+  -> WidgetNode s e       -- ^ New widget node.+  -> WidgetNode s e       -- ^ Old widget node.+  -> s                    -- ^ The current model.+  -> [WidgetRequest s e]  -- ^ The list of requests. +-- | Creates a custom composite model from the parent model.+type CompositeCustomModelBuilder s sp+  = sp -- ^ Parent model.+  -> s -- ^ Old custom composite model.+  -> s -- ^ New custom composite model.+  -> s -- ^ Custom composite model.+ -- | Handles a composite event and returns a set of responses. type EventHandler s e sp ep   = WidgetEnv s e@@ -122,6 +134,18 @@ data CompMsgUpdate   = forall s . CompositeModel s => CompMsgUpdate (s -> s) +{-|+Delayed request. Used to account for widget tree changes in previous steps. When+processing EventResponses that depend on WidgetKeys, resolving the key at the+time the response is created may result in missing/no longer valid keys. The+delayed message allows resolving the key right before the WidgetRequest is+processed.+-}+data CompMsgDelayedRequest+  = CompMsgSetFocus WidgetKey+  | CompMsgMoveFocus (Maybe WidgetKey) FocusDirection+  | forall i . Typeable i => CompMsgMessage WidgetKey i+ -- | Response options for an event handler. data EventResponse s e sp ep   -- | Modifies the current model, prompting a merge.@@ -139,6 +163,16 @@   -}   | RequestParent (WidgetRequest sp ep)   {-|+  Generates a request to set focus on the widget with the matching key. If the+  key does not exist, focus remains on the currently focused widget.+  -}+  | SetFocusOnKey WidgetKey+  {-|+  Generates a request to move focus forward/backward, optionally indicating the+  key of the starting widget.+  -}+  | MoveFocusFromKey (Maybe WidgetKey) FocusDirection+  {-|   Sends a message to the given key. If the key does not exist, the message will   not be delivered.   -}@@ -176,12 +210,17 @@ - 'onVisibleChange': event to raise when the visibility changes. - 'compositeMergeReqs': functions to generate WidgetRequests during the merge   process. Since merge is already handled by Composite (by merging its tree),-  this is complementary for the cases when it's required. For example, it is-  used in 'Monomer.Widgets.Containers.Confirm' to set the focus on its Accept-  button when visibility is restored (usually means it was brought to the front-  in a zstack).+  this is complementary for the cases when more control, and the previous+  version of the widget tree, is required.  For example, it is used in+  'Monomer.Widgets.Containers.Confirm' to set the focus on its Accept button+  when visibility is restored (usually means it was brought to the front in a+  zstack, and the visibility flag of the previous version needs to be checked).+- 'customModelBuilder': function for extracting a custom model from the current+  parent model and the previous composite model. Useful when the composite needs+  a more complex model than what the user is binding. -} data CompositeCfg s e sp ep = CompositeCfg {+  _cmcModelBuilder :: Maybe (CompositeCustomModelBuilder s sp),   _cmcMergeRequired :: Maybe (MergeRequired s),   _cmcMergeReqs :: [MergeReqsHandler s e],   _cmcOnInit :: [e],@@ -194,6 +233,7 @@  instance Default (CompositeCfg s e sp ep) where   def = CompositeCfg {+    _cmcModelBuilder = Nothing,     _cmcMergeRequired = Nothing,     _cmcMergeReqs = [],     _cmcOnInit = [],@@ -206,6 +246,7 @@  instance Semigroup (CompositeCfg s e sp ep) where   (<>) c1 c2 = CompositeCfg {+    _cmcModelBuilder = _cmcModelBuilder c2 <|> _cmcModelBuilder c1,     _cmcMergeRequired = _cmcMergeRequired c2 <|> _cmcMergeRequired c1,     _cmcMergeReqs = _cmcMergeReqs c1 <> _cmcMergeReqs c2,     _cmcOnInit = _cmcOnInit c1 <> _cmcOnInit c2,@@ -265,12 +306,25 @@   _cmcMergeReqs = [fn] } +{-|+Generates a custom model from the current parent model and the previous+composite model. Useful when the composite needs a more complex model than what+the user is binding.+-}+customModelBuilder+  :: CompositeCustomModelBuilder s sp+  -> CompositeCfg s e sp ep+customModelBuilder fn = def {+  _cmcModelBuilder = Just fn+}+ data Composite s e sp ep = Composite {   _cmpWidgetData :: !(WidgetData sp s),   _cmpEventHandler :: !(EventHandler s e sp ep),   _cmpUiBuilder :: !(UIBuilder s e),   _cmpMergeRequired :: MergeRequired s,   _cmpMergeReqs :: [MergeReqsHandler s e],+  _cmpModelBuilder :: Maybe (CompositeCustomModelBuilder s sp),   _cmpOnInit :: [e],   _cmpOnDispose :: [e],   _cmpOnResize :: [Rect -> e],@@ -373,6 +427,7 @@     _cmpUiBuilder = uiBuilder,     _cmpMergeRequired = mergeReq,     _cmpMergeReqs = _cmcMergeReqs config,+    _cmpModelBuilder = _cmcModelBuilder config,     _cmpOnInit = _cmcOnInit config,     _cmpOnDispose = _cmcOnDispose config,     _cmpOnResize = _cmcOnResize config,@@ -416,23 +471,31 @@   -> WidgetResult sp ep compositeInit comp state wenv widgetComp = newResult where   CompositeState{..} = state-  !model = getUserModel comp wenv-  !cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model++  !customModelBuilder = _cmpModelBuilder comp+  !parentModel = wenv ^. L.model+  !userModel = getUserModel comp wenv+  !model = case customModelBuilder of+    Just buildCustomModel -> buildCustomModel parentModel userModel userModel+    _ -> userModel+   -- Creates UI using provided function+  !cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model   !builtRoot = _cmpUiBuilder comp cwenv model   !tempRoot = cascadeCtx wenv widgetComp builtRoot    WidgetResult root reqs = widgetInit (tempRoot ^. L.widget) cwenv tempRoot-  newEvts = RaiseEvent <$> Seq.fromList (_cmpOnInit comp)   !newState = state {     _cpsModel = Just model,     _cpsRoot = root,     _cpsWidgetKeyMap = collectWidgetKeys M.empty root   } +  !newEvts = RaiseEvent <$> Seq.fromList (_cmpOnInit comp)+   getBaseStyle wenv node = Nothing   styledComp = initNodeStyle getBaseStyle wenv widgetComp-  tempResult = WidgetResult root (reqs <> newEvts)+  tempResult = WidgetResult root (RenderOnce <| reqs <> newEvts)   !newResult = toParentResult comp newState wenv styledComp tempResult  -- | Merge@@ -449,7 +512,14 @@   oldState = widgetGetState (oldComp ^. L.widget) wenv oldComp   validState = fromMaybe state (useState oldState)   CompositeState oldModel oldRoot oldWidgetKeys = validState-  model = getUserModel comp wenv++  !customModelBuilder = _cmpModelBuilder comp+  !parentModel = wenv ^. L.model+  !userModel = getUserModel comp wenv+  !model = case customModelBuilder of+    Just buildCustomModel -> buildCustomModel parentModel (fromJust oldModel) userModel+    _ -> userModel+   -- Creates new UI using provided function   cwenv = convertWidgetEnv wenv oldWidgetKeys model   tempRoot = cascadeCtx wenv newComp (_cmpUiBuilder comp cwenv model)@@ -466,6 +536,7 @@     | isJust oldModel = modelChanged || flagsChanged || themeChanged     | otherwise = True   initRequired = not (nodeMatches tempRoot oldRoot)+  useNewRoot = initRequired || mergeRequired    WidgetResult !newRoot !tmpReqs     | initRequired = widgetInit tempWidget cwenv tempRoot@@ -483,15 +554,22 @@     & L.info . L.sizeReqW .~ oldComp ^. L.info . L.sizeReqW     & L.info . L.sizeReqH .~ oldComp ^. L.info . L.sizeReqH -  visibleEvts = if visibleChg then _cmpOnVisibleChange comp else []-  enabledEvts = if enabledChg then _cmpOnEnabledChange comp else []+  visibleEvts+    | useNewRoot && visibleChg = _cmpOnVisibleChange comp+    | otherwise = []+  enabledEvts+    | useNewRoot && enabledChg = _cmpOnEnabledChange comp+    | otherwise = []+  evts = RaiseEvent <$> Seq.fromList (visibleEvts ++ enabledEvts)+   mergeReqsFns = _cmpMergeReqs comp   mergeReqs = concatMap (\fn -> fn cwenv newRoot oldRoot model) mergeReqsFns   extraReqs = seqCatMaybes (toParentReq widgetId <$> Seq.fromList mergeReqs)-  evts = RaiseEvent <$> Seq.fromList (visibleEvts ++ enabledEvts) -  tmpResult = WidgetResult newRoot (tmpReqs <> extraReqs <> evts)-  reducedResult = toParentResult comp newState wenv styledComp tmpResult+  tmpResult = WidgetResult newRoot (RenderOnce <| tmpReqs <> extraReqs <> evts)+  reducedResult+    | useNewRoot = toParentResult comp newState wenv styledComp tmpResult+    | otherwise = resultNode oldComp   !newResult = handleWidgetIdChange oldComp reducedResult  -- | Dispose@@ -634,7 +712,9 @@       Just evt -> Just $ handleMsgEvent comp state wenv widgetComp evt       Nothing -> case cast arg of         Just (CompMsgUpdate msg) -> handleMsgUpdate comp state wenv widgetComp <$> cast msg-        _ -> traceShow ("Failed match on Composite handleEvent", typeOf arg) Nothing+        Nothing -> case cast arg of+          Just req -> handleDelayedRequest comp state wenv widgetComp req+          _ -> traceShow ("Failed match on Composite handleMessage", typeOf arg) Nothing   | otherwise = fmap processEvent result where       processEvent = toParentResult comp state wenv widgetComp       cmpWidget = _cpsRoot ^. L.widget@@ -715,12 +795,16 @@   -> WidgetNode sp ep   -> Renderer   -> IO ()-compositeRender comp state wenv widgetComp renderer = action where-  CompositeState{..} = state-  widget = _cpsRoot ^. L.widget-  !model = getCompositeModel state-  !cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model-  !action = widgetRender widget cwenv _cpsRoot renderer+compositeRender comp state wenv widgetComp renderer =+  drawStyledAction renderer viewport style $ \_ ->+    widgetRender widget cwenv _cpsRoot renderer+  where+    CompositeState{..} = state+    widget = _cpsRoot ^. L.widget+    viewport = widgetComp ^. L.info . L.viewport+    style = currentStyle wenv widgetComp+    !model = getCompositeModel state+    !cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model  handleMsgEvent   :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, CompParentModel sp)@@ -782,19 +866,42 @@   -> EventResponse s e sp ep   -> Maybe (WidgetRequest sp ep) evtResponseToRequest widgetComp widgetKeys response = case response of-  Model newModel -> Just $ sendTo widgetComp (CompMsgUpdate $ const newModel)-  Event event -> Just $ sendTo widgetComp event+  Model newModel -> Just $ sendMsgTo widgetComp (CompMsgUpdate $ const newModel)+  Event event -> Just $ sendMsgTo widgetComp event   Report report -> Just (RaiseEvent report)   Request req -> toParentReq widgetId req   RequestParent req -> Just req-  Message key msg -> (`sendTo` msg) <$> M.lookup key widgetKeys+  SetFocusOnKey key -> Just $ sendMsgTo widgetComp (CompMsgSetFocus key)+  MoveFocusFromKey key dir -> Just $ sendMsgTo widgetComp (CompMsgMoveFocus key dir)+  Message key msg -> Just $ sendMsgTo widgetComp (CompMsgMessage key msg)   Task task -> Just $ RunTask widgetId path task   Producer producer -> Just $ RunProducer widgetId path producer   where-    sendTo node msg = SendMessage (node ^. L.info . L.widgetId) msg     widgetId = widgetComp ^. L.info . L.widgetId     path = widgetComp ^. L.info . L.path +handleDelayedRequest+  :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, CompParentModel sp)+  => Composite s e sp ep+  -> CompositeState s e+  -> WidgetEnv sp ep+  -> WidgetNode sp ep+  -> CompMsgDelayedRequest+  -> Maybe (WidgetResult sp ep)+handleDelayedRequest comp state wenv node req = result where+    widgetKeys = _cpsWidgetKeyMap state+    newReq = case req of+      CompMsgSetFocus key -> setFocus <$> lookupNode widgetKeys "SetFocusOnKey" key+      CompMsgMoveFocus (Just key) dir -> moveFocusFrom key dir+      CompMsgMoveFocus _ dir -> Just $ MoveFocus Nothing dir+      CompMsgMessage key msg -> (`sendMsgTo` msg) <$> lookupNode widgetKeys "Message" key+    result = resultReqs node . (: []) <$> newReq++    setFocus node = SetFocus (node ^. L.info . L.widgetId)+    moveFocusFrom key dir = mwid >> Just (MoveFocus mwid dir) where+      mnode = lookupNode widgetKeys "MoveFocusFromKey" key+      mwid = (^. L.info . L.widgetId) <$> mnode+ mergeChild   :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, CompParentModel sp)   => Composite s e sp ep@@ -890,7 +997,7 @@   _weOs = _weOs wenv,   _weDpr = _weDpr wenv,   _weFontManager = _weFontManager wenv,-  _weFindByPath = _weFindByPath wenv,+  _weFindBranchByPath = _weFindBranchByPath wenv,   _weMainButton = _weMainButton wenv,   _weContextButton = _weContextButton wenv,   _weTheme = _weTheme wenv,@@ -926,3 +1033,11 @@     & L.info . L.path .~ newPath     & L.info . L.visible .~ (cVisible && pVisible)     & L.info . L.enabled .~ (cEnabled && pEnabled)++lookupNode :: WidgetKeyMap s e -> String -> WidgetKey -> Maybe (WidgetNode s e)+lookupNode widgetKeys desc key = case M.lookup key widgetKeys of+  Nothing -> trace ("Key " ++ show key ++ " not found for " ++ desc) Nothing+  res -> res++sendMsgTo :: Typeable i => WidgetNode s e -> i -> WidgetRequest sp ep+sendMsgTo node msg = SendMessage (node ^. L.info . L.widgetId) msg

@@ -99,6 +99,32 @@   -> StyleState        -- ^ The active style for the node.  {-|+Returns an updated version of the Container instance. Currently only used+during merge. Not needed in general, except for widgets that modify offset+or layout direction.++An example can be found in "Monomer.Widgets.Containers.Scroll".++Note:++Some widgets, scroll for example, provide offset/layout direction to the+Container instance; this information is passed down to children widgets in all+the lifecycle methods. During merge a problem arises: the new node has not yet+processed the old state and, since it is the Container whose merge function is+being invoked, it is not able to provide the correct offset/layout direction.+It is also not possible to directly extract this information from the old node,+because we have a Widget instance and not its Container instance. This function+provides a workaround for this.++This is a hacky solution; a more flexible dispatcher for Composite could avoid it.+-}+type ContainerCreateContainerFromModel s e a+  = WidgetEnv s e            -- ^ The widget environment.+  -> WidgetNode s e          -- ^ The widget node.+  -> a                       -- ^ The previous model.+  -> Maybe (Container s e a) -- ^ An updated Container instance.++{-| Updates the widget environment before passing it down to children. This function is called during the execution of all the widget functions. Useful for restricting viewport or modifying other kind of contextual information.@@ -353,6 +379,8 @@   containerUseScissor :: Bool,   -- | Returns the base style for this type of widget.   containerGetBaseStyle :: ContainerGetBaseStyle s e,+  -- | Returns an updated version of the Container instance.+  containerCreateContainerFromModel :: ContainerCreateContainerFromModel s e a,   -- | Returns the current style, depending on the status of the widget.   containerGetCurrentStyle :: ContainerGetCurrentStyle s e,   -- | Updates the widget environment before passing it down to children.@@ -403,6 +431,7 @@     containerUseScissor = False,     containerGetBaseStyle = defaultGetBaseStyle,     containerGetCurrentStyle = defaultGetCurrentStyle,+    containerCreateContainerFromModel = defaultCreateContainerFromModel,     containerUpdateCWenv = defaultUpdateCWenv,     containerInit = defaultInit,     containerInitPost = defaultInitPost,@@ -461,6 +490,9 @@ defaultGetCurrentStyle :: ContainerGetCurrentStyle s e defaultGetCurrentStyle wenv node = currentStyle wenv node +defaultCreateContainerFromModel :: ContainerCreateContainerFromModel s e a+defaultCreateContainerFromModel wenv node state = Nothing+ defaultUpdateCWenv :: ContainerUpdateCWenvHandler s e defaultUpdateCWenv wenv node cnode cidx = wenv @@ -571,7 +603,8 @@   -> WidgetResult s e mergeWrapper container wenv newNode oldNode = newResult where   getBaseStyle = containerGetBaseStyle container-  updateCWenv = getUpdateCWenv container+  createContainerFromModel = containerCreateContainerFromModel container+   mergeRequiredHandler = containerMergeChildrenReq container   mergeHandler = containerMerge container   mergePostHandler = containerMergePost container@@ -582,8 +615,14 @@     Nothing -> True    styledNode = initNodeStyle getBaseStyle wenv newNode++  -- Check if an updated container can be used for offset/layout direction.+  pNode = pResult ^. L.node+  updateCWenv = case useState oldState >>= createContainerFromModel wenv pNode of+    Just newContainer -> getUpdateCWenv newContainer+    _ -> getUpdateCWenv container   cWenvHelper idx child = cwenv where-    cwenv = updateCWenv wenv (pResult ^. L.node) child idx+    cwenv = updateCWenv wenv pNode child idx    pResult = mergeParent mergeHandler wenv styledNode oldNode oldState   cResult = mergeChildren cWenvHelper wenv newNode oldNode pResult

@@ -43,13 +43,12 @@ ) where  import Control.Applicative ((<|>))-import Control.Lens ((&), (^.), (.~), (%~), at)+import Control.Lens ((&), (^.), (^..), (.~), (%~), _1, at, folded) import Control.Lens.TH (abbreviatedFields, makeLensesWith) import Data.Bifunctor (first) import Data.Char (chr, isAscii, isPrint, ord) import Data.Default import Data.List (foldl')-import Data.Maybe import Data.Set (Set) import Data.Text (Text) @@ -91,6 +90,7 @@   }  data KeyStroke = KeyStroke {+  _kstKsText :: Text,   _kstKsC :: Bool,   _kstKsCtrl :: Bool,   _kstKsCmd :: Bool,@@ -101,6 +101,7 @@  instance Default KeyStroke where   def = KeyStroke {+    _kstKsText = "",     _kstKsC = False,     _kstKsCtrl = False,     _kstKsCmd = False,@@ -109,7 +110,12 @@     _kstKsKeys = Set.empty   } +newtype KeyStrokeState e = KeyStrokeState {+  _kssLatest :: [(KeyStroke, e)]+} deriving (Eq, Show)+ makeLensesWith abbreviatedFields ''KeyStroke+makeLensesWith abbreviatedFields ''KeyStrokeState  -- | Creates a keystroke container with a single node as child. keystroke :: WidgetEvent e => [(Text, e)] -> WidgetNode s e -> WidgetNode s e@@ -125,29 +131,53 @@ keystroke_ bindings configs managed = makeNode widget managed where   config = mconcat configs   newBindings = fmap (first textToStroke) bindings-  widget = makeKeystroke newBindings config+  state = KeyStrokeState []+  widget = makeKeystroke newBindings config state  makeNode :: Widget s e -> WidgetNode s e -> WidgetNode s e makeNode widget managedWidget = defaultWidgetNode "keystroke" widget   & L.info . L.focusable .~ False   & L.children .~ Seq.singleton managedWidget -makeKeystroke :: WidgetEvent e => [(KeyStroke, e)] -> KeystrokeCfg -> Widget s e-makeKeystroke bindings config = widget where-  widget = createContainer () def {+makeKeystroke+  :: WidgetEvent e+  => [(KeyStroke, e)]+  -> KeystrokeCfg+  -> KeyStrokeState e+  -> Widget s e+makeKeystroke bindings config state = widget where+  widget = createContainer state def {+    containerMerge = merge,     containerHandleEvent = handleEvent   } +  merge wenv node oldNode oldState = resultNode newNode where+    newNode = node+      & L.widget .~ makeKeystroke bindings config oldState+   handleEvent wenv node target evt = case evt of     KeyAction mod code KeyPressed -> Just result where-      ignoreChildren = Just True == _kscIgnoreChildren config       newWenv = wenv & L.inputStatus %~ removeMods-      evts = snd <$> filter (keyStrokeActive newWenv code . fst) bindings+      matches = filter (keyStrokeActive newWenv code . fst) bindings+      newState = KeyStrokeState matches+      newNode = node+        & L.widget .~ makeKeystroke bindings config newState+      evts = snd <$> matches       reqs         | ignoreChildren && not (null evts) = [IgnoreChildrenEvents]         | otherwise = []-      result = resultReqsEvts node reqs evts+      result = resultReqsEvts newNode reqs evts+    TextInput t+      | ignoreChildren && ignorePrevious t -> Just result where+        previousMatch t = t `elem` _kssLatest state ^.. folded . _1 . ksText+        ignorePrevious t = isTextValidCode t && previousMatch t+        newState = KeyStrokeState []+        newNode = node+          & L.widget .~ makeKeystroke bindings config newState+        result = resultReqs newNode [IgnoreChildrenEvents]     _ -> Nothing+    where+      ignoreChildren = Just True == _kscIgnoreChildren config  keyStrokeActive :: WidgetEnv s e -> KeyCode -> KeyStroke -> Bool keyStrokeActive wenv code ks = currValid && allPressed && validMods where@@ -173,6 +203,7 @@ textToStroke text = ks where   parts = T.split (=='-') text   ks = foldl' partToStroke def parts+    & ksText .~ text  partToStroke :: KeyStroke -> Text -> KeyStroke partToStroke ks "A" = ks & ksAlt .~ True@@ -212,11 +243,15 @@ partToStroke ks "F12" = ks & ksKeys %~ Set.insert keyF12 -- Other keys (numbers, letters, points, etc) partToStroke ks txt-  | isValid = ks & ksKeys %~ Set.insert (KeyCode (ord txtHead))+  | isTextValidCode txt = ks & ksKeys %~ Set.insert (KeyCode (ord txtHead))   | otherwise = ks   where-    isValid = T.length txt == 1 && isAscii txtHead && isPrint txtHead     txtHead = T.index txt 0++isTextValidCode :: Text -> Bool+isTextValidCode txt = validLen && isAscii txtHead && isPrint txtHead where+  validLen = T.length txt == 1+  txtHead = T.index txt 0  removeMods :: InputStatus -> InputStatus removeMods status = status

@@ -344,12 +344,13 @@  makeScroll :: ScrollCfg s e -> ScrollState -> Widget s e makeScroll config state = widget where-  widget = createContainer state def {+  container = def {     containerChildrenOffset = Just offset,     containerChildrenScissor = Just (_sstScissor state),     containerLayoutDirection = layoutDirection,     containerGetBaseStyle = getBaseStyle,     containerGetCurrentStyle = scrollCurrentStyle,+    containerCreateContainerFromModel = createContainerFromModel,     containerUpdateCWenv = updateCWenv,     containerInit = init,     containerMerge = merge,@@ -360,6 +361,7 @@     containerResize = resize,     containerRenderAfter = renderAfter   }+  widget = createContainer state container    ScrollState dragging dx dy _ _ _ = state   Size childWidth childHeight = _sstChildSize state@@ -385,6 +387,12 @@         & L.info . L.style .~ parentStyle         & L.children . ix 0 . L.info . L.style .~ childStyle       | otherwise = node++  createContainerFromModel wenv node state = Just newContainer where+    offset = Point (_sstDeltaX state) (_sstDeltaX state)+    newContainer = container {+      containerChildrenOffset = Just offset+    }    -- This is overriden to account for space used by scroll bars   updateCWenv wenv node cnode cidx = newWenv where

@@ -23,6 +23,7 @@   -- * Configuration   ZStackCfg,   onlyTopActive,+  onlyTopActive_,   -- * Constructors   zstack,   zstack_@@ -65,10 +66,13 @@ instance Monoid ZStackCfg where   mempty = def +-- | Makes the top visible node the only node that may receive events.+onlyTopActive :: ZStackCfg+onlyTopActive = onlyTopActive_ True+ -- | Whether the top visible node is the only node that may receive events.---   Defaults to True.-onlyTopActive :: Bool -> ZStackCfg-onlyTopActive active = def {+onlyTopActive_ :: Bool -> ZStackCfg+onlyTopActive_ active = def {   _zscOnlyTopActive = Just active } 

@@ -492,7 +492,7 @@       | isJust wheelHandler -> Just result where         handlerRes = fromJust wheelHandler state point move dir         (newText, newPos, newSel) = handlerRes-        reqs = [RenderOnce]+        reqs = [RenderOnce, IgnoreParentEvents]         result = genInputResult wenv node True newText newPos newSel reqs      -- Handle keyboard shortcuts and possible cursor changes

@@ -10,6 +10,9 @@ text, which can be added with a label in the desired position (usually with hstack). Alternatively, "Monomer.Widgets.Singles.LabeledCheckbox" provides this functionality out of the box.++'Monomer.Widgets.Singles.ToggleButton' provides similar functionality but with+the look of a regular button. -} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-}

@@ -12,7 +12,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE Strict #-}-{-# LANGUAGE TemplateHaskell #-}  module Monomer.Widgets.Singles.ColorPicker (   -- * Configuration@@ -194,12 +193,12 @@     ] `styleBasic` [width 32]    compRow lensCol evt lbl minV maxV = hstack [-      label lbl `styleBasic` [width 48],-      spacer_ [width 2],+      label lbl,+      spacer_ [width 5],       hslider_ lensCol minV maxV [onChange evt, onFocus PickerFocus,         onBlur PickerBlur]         `styleBasic` [paddingV 5],-      spacer_ [width 2],+      spacer_ [width 5],       numericField_ lensCol [minValue minV, maxValue maxV, onChange evt,         onFocus PickerFocus, onBlur PickerBlur]         `styleBasic` [width 40, padding 0, textRight]@@ -210,15 +209,15 @@    mainTree = hstack_ [sizeReqUpdater clearExtra] [       vstack [-        colorRow L.r "Red",+        colorRow L.r "R",         spacer_ [width 2],-        colorRow L.g "Green",+        colorRow L.g "G",         spacer_ [width 2],-        colorRow L.b "Blue",+        colorRow L.b "B",         spacer_ [width 2] `nodeVisible` showAlpha,-        alphaRow L.a "Alpha" `nodeVisible` showAlpha+        alphaRow L.a "A" `nodeVisible` showAlpha       ],-      spacer_ [width 2],+      spacer_ [width 5],       box_ [alignTop] colorSample `styleBasic` [flexHeight 50]     ] `styleBasic` [padding 0] 

@@ -320,7 +320,8 @@       tmpPos = pos + round (wy * wheelRate)       newPos = clamp 0 maxPos tmpPos       newVal = valueFromPos minVal dragRate newPos-      result = addReqsEvts (resultReqs node [RenderOnce]) newVal+      reqs = [RenderOnce, IgnoreParentEvents]+      result = addReqsEvts (resultReqs node reqs) newVal     _ -> Nothing     where       theme = currentTheme wenv node

@@ -0,0 +1,346 @@+{-|+Module      : Monomer.Widgets.Singles.OptionButton+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Option button widget, used for choosing one value from a fixed set. Each+instance of optionButton will be associated with a single value.++Its behavior is equivalent to 'Monomer.Widgets.Singles.Radio' and+'Monomer.Widgets.Singles.LabeledRadio', with a different visual representation.++This widget, and the associated 'ToggleButton', uses two separate styles for the+On and Off states which can be modified individually for the theme. If you use+any of the the standard style functions (styleBasic, styleHover, etc) in an+optionButton/toggleButton these changes will apply to both On and Off states,+except for the color related styles. The reason for this is that, in general,+you will want to use the same font and padding for both states, but colors will+usually differ. For changing the colors of the Off state you can use+'optionButtonOffStyle', that receives a 'Style' instance. The values set here+are higher priority than any inherited style from the theme or node text style.++'Style' instances can be created this way:++@+newStyle :: Style = def+  `styleBasic` [textSize 20]+  `styleHover` [textColor white]+@+-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StrictData #-}++module Monomer.Widgets.Singles.OptionButton (+  -- * Configuration+  OptionButtonCfg,+  optionButtonOffStyle,+  -- * Constructors+  optionButton,+  optionButton_,+  optionButtonV,+  optionButtonV_,+  optionButtonD_,+  -- * Internal+  makeOptionButton+) where++import Control.Applicative ((<|>))+import Control.Lens (ALens', Lens', (&), (^.), (^?), (.~), (?~), _Just)+import Control.Monad+import Data.Default+import Data.Maybe+import Data.Text (Text)++import qualified Data.Sequence as Seq++import Monomer.Widgets.Container+import Monomer.Widgets.Singles.Label++import qualified Monomer.Lens as L++{-|+Configuration options for optionButton:++- 'ignoreTheme': whether to load default style from theme or start empty.+- 'optionButtonOffStyle': style to use when the option is not active.+- 'trimSpaces': whether to remove leading/trailing spaces in the caption.+- '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.+- '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.+- 'onFocus': event to raise when focus is received.+- 'onFocusReq': 'WidgetRequest' to generate when focus is received.+- 'onBlur': event to raise when focus is lost.+- 'onBlurReq': 'WidgetRequest' to generate when focus is lost.+- 'onChange': event to raise when the value changes/is clicked.+- 'onChangeReq': 'WidgetRequest' to generate when the value changes/is clicked.+-}+data OptionButtonCfg s e a = OptionButtonCfg {+  _obcIgnoreTheme :: Maybe Bool,+  _obcOffStyle :: Maybe Style,+  _obcLabelCfg :: LabelCfg s e,+  _obcOnFocusReq :: [Path -> WidgetRequest s e],+  _obcOnBlurReq :: [Path -> WidgetRequest s e],+  _obcOnChangeReq :: [a -> WidgetRequest s e]+}++instance Default (OptionButtonCfg s e a) where+  def = OptionButtonCfg {+    _obcIgnoreTheme = Nothing,+    _obcOffStyle = Nothing,+    _obcLabelCfg = def,+    _obcOnFocusReq = [],+    _obcOnBlurReq = [],+    _obcOnChangeReq = []+  }++instance Semigroup (OptionButtonCfg s e a) where+  (<>) t1 t2 = OptionButtonCfg {+    _obcIgnoreTheme = _obcIgnoreTheme t2 <|> _obcIgnoreTheme t1,+    _obcOffStyle = _obcOffStyle t1 <> _obcOffStyle t2,+    _obcLabelCfg = _obcLabelCfg t1 <> _obcLabelCfg t2,+    _obcOnFocusReq = _obcOnFocusReq t1 <> _obcOnFocusReq t2,+    _obcOnBlurReq = _obcOnBlurReq t1 <> _obcOnBlurReq t2,+    _obcOnChangeReq = _obcOnChangeReq t1 <> _obcOnChangeReq t2+  }++instance Monoid (OptionButtonCfg s e a) where+  mempty = def++instance CmbIgnoreTheme (OptionButtonCfg s e a) where+  ignoreTheme_ ignore = def {+    _obcIgnoreTheme = Just ignore+  }++instance CmbTrimSpaces (OptionButtonCfg s e a) where+  trimSpaces_ trim = def {+    _obcLabelCfg = trimSpaces_ trim+  }++instance CmbEllipsis (OptionButtonCfg s e a) where+  ellipsis_ ellipsis = def {+    _obcLabelCfg = ellipsis_ ellipsis+  }++instance CmbMultiline (OptionButtonCfg s e a) where+  multiline_ multi = def {+    _obcLabelCfg = multiline_ multi+  }++instance CmbMaxLines (OptionButtonCfg s e a) where+  maxLines count = def {+    _obcLabelCfg = maxLines count+  }++instance CmbResizeFactor (OptionButtonCfg s e a) where+  resizeFactor s = def {+    _obcLabelCfg = resizeFactor s+  }++instance CmbResizeFactorDim (OptionButtonCfg s e a) where+  resizeFactorW w = def {+    _obcLabelCfg = resizeFactorW w+  }+  resizeFactorH h = def {+    _obcLabelCfg = resizeFactorH h+  }++instance WidgetEvent e => CmbOnFocus (OptionButtonCfg s e a) e Path where+  onFocus fn = def {+    _obcOnFocusReq = [RaiseEvent . fn]+  }++instance CmbOnFocusReq (OptionButtonCfg s e a) s e Path where+  onFocusReq req = def {+    _obcOnFocusReq = [req]+  }++instance WidgetEvent e => CmbOnBlur (OptionButtonCfg s e a) e Path where+  onBlur fn = def {+    _obcOnBlurReq = [RaiseEvent . fn]+  }++instance CmbOnBlurReq (OptionButtonCfg s e a) s e Path where+  onBlurReq req = def {+    _obcOnBlurReq = [req]+  }++instance WidgetEvent e => CmbOnChange (OptionButtonCfg s e a) a e where+  onChange fn = def {+    _obcOnChangeReq = [RaiseEvent . fn]+  }++instance CmbOnChangeReq (OptionButtonCfg s e a) s e a where+  onChangeReq req = def {+    _obcOnChangeReq = [req]+  }++-- | Sets the style for the Off state of the option button.+optionButtonOffStyle :: Style -> OptionButtonCfg s e a+optionButtonOffStyle style = def {+  _obcOffStyle = Just style+}++-- | Creates an optionButton using the given lens.+optionButton+  :: Eq a+  => Text+  -> a+  -> ALens' s a+  -> WidgetNode s e+optionButton caption option field = optionButton_ caption option field def++-- | Creates an optionButton using the given lens. Accepts config.+optionButton_+  :: Eq a+  => Text+  -> a+  -> ALens' s a+  -> [OptionButtonCfg s e a]+  -> WidgetNode s e+optionButton_ caption option field cfgs = newNode where+  newNode = optionButtonD_ caption option (WidgetLens field) cfgs++-- | Creates an optionButton using the given value and 'onChange' event handler.+optionButtonV+  :: (Eq a, WidgetEvent e)+  => Text+  -> a+  -> a+  -> (a -> e)+  -> WidgetNode s e+optionButtonV caption option value handler = newNode where+  newNode = optionButtonV_ caption option value handler def++-- | Creates an optionButton using the given value and 'onChange' event handler.+--   Accepts config.+optionButtonV_+  :: (Eq a, WidgetEvent e)+  => Text+  -> a+  -> a+  -> (a -> e)+  -> [OptionButtonCfg s e a]+  -> WidgetNode s e+optionButtonV_ caption option value handler configs = newNode where+  widgetData = WidgetValue value+  newConfigs = onChange handler : configs+  newNode = optionButtonD_ caption option widgetData newConfigs++-- | Creates an optionButton providing a 'WidgetData' instance and config.+optionButtonD_+  :: Eq a+  => Text+  -> a+  -> WidgetData s a+  -> [OptionButtonCfg s e a]+  -> WidgetNode s e+optionButtonD_ caption option widgetData configs = optionButtonNode where+  config = mconcat configs+  makeWithStyle = makeOptionButton L.optionBtnOnStyle L.optionBtnOffStyle+  widget = makeWithStyle widgetData caption (== option) (const option) config+  optionButtonNode = defaultWidgetNode "optionButton" widget+    & L.info . L.focusable .~ True++makeOptionButton+  :: Eq a+  => Lens' ThemeState StyleState+  -> Lens' ThemeState StyleState+  -> WidgetData s a+  -> Text+  -> (a -> Bool)+  -> (a -> a)+  -> OptionButtonCfg s e a+  -> Widget s e+makeOptionButton styleOn styleOff !field !caption !isSelVal !getNextVal !config = widget where+  widget = createContainer () def {+    containerAddStyleReq = False,+    containerDrawDecorations = False,+    containerUseScissor = True,+    containerInit = init,+    containerMerge = merge,+    containerHandleEvent = handleEvent,+    containerResize = resize+  }++  createChildNode wenv node = newNode where+    currValue = widgetDataGet (wenv ^. L.model) field+    isSelected = isSelVal currValue+    useBaseTheme = _obcIgnoreTheme config /= Just True++    baseOffStyle+      | useBaseTheme = Just (collectTheme wenv styleOff)+      | otherwise = Nothing++    baseOnStyle+      | useBaseTheme = Just (collectTheme wenv styleOn)+      | otherwise = Nothing++    nodeStyle = node ^. L.info . L.style+    colorlessStyle = mapStyleStates resetColor nodeStyle+    customOffStyle = mergeBasicStyle <$> _obcOffStyle config++    labelNodeStyle+      | isSelected = fromJust (baseOnStyle <> Just nodeStyle)+      | otherwise = fromJust (baseOffStyle <> Just colorlessStyle <> customOffStyle)++    labelCfg = _obcLabelCfg config+    labelCurrStyle = labelCurrentStyle childOfFocusedStyle+    labelNode = label_ caption [ignoreTheme, labelCfg, labelCurrStyle]+      & L.info . L.style .~ labelNodeStyle++    !newNode = node+      & L.children .~ Seq.singleton labelNode++  init wenv node = result where+    result = resultNode (createChildNode wenv node)++  merge wenv node oldNode oldState = result where+    result = resultNode (createChildNode wenv node)++  handleEvent wenv node target evt = case evt of+    Focus prev -> handleFocusChange node prev (_obcOnFocusReq config)+    Blur next -> handleFocusChange node next (_obcOnBlurReq config)++    KeyAction mode code status+      | isSelectKey code && status == KeyPressed -> Just result+      where+        isSelectKey code = isKeyReturn code || isKeySpace code++    Click p _ _+      | isPointInNodeVp node p -> Just result++    ButtonAction p btn BtnPressed 1 -- Set focus on click+      | mainBtn btn && pointInVp p && not focused -> Just resultFocus++    _ -> Nothing+    where+      mainBtn btn = btn == wenv ^. L.mainButton+      focused = isNodeFocused wenv node+      pointInVp p = isPointInNodeVp node p++      currValue = widgetDataGet (wenv ^. L.model) field+      nextValue = getNextVal currValue+      setValueReq = widgetDataSet field nextValue+      reqs = setValueReq ++ fmap ($ nextValue) (_obcOnChangeReq config)+      result = resultReqs node reqs+      resultFocus = resultReqs node [SetFocus (node ^. L.info . L.widgetId)]++  resize wenv node viewport children = resized where+    assignedAreas = Seq.fromList [viewport]+    resized = (resultNode node, assignedAreas)++resetColor :: StyleState -> StyleState+resetColor st = st+  & L.bgColor .~ Nothing+  & L.fgColor .~ Nothing+  & L.text . _Just . L.fontColor .~ Nothing

@@ -11,6 +11,9 @@ which should be added as a label in the desired position (usually with hstack). Alternatively, 'Monomer.Widgets.Singles.LabeledRadio' provides this functionality out of the box.++'Monomer.Widgets.Singles.OptionButton' provides similar functionality but with+the look of a regular button. -} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-}

@@ -391,11 +391,12 @@      ButtonAction point btn BtnReleased clicks  -> resultFromPoint point [] -    WheelScroll _ (Point _ wy) wheelDirection -> resultFromPos newPos [] where+    WheelScroll _ (Point _ wy) wheelDirection -> resultFromPos newPos reqs where       wheelCfg = fromMaybe (theme ^. L.sliderWheelRate) (_slcWheelRate config)       wheelRate = fromRational wheelCfg       tmpPos = pos + round (wy * wheelRate)       newPos = clamp 0 maxPos tmpPos+      reqs = [IgnoreParentEvents]     _ -> Nothing     where       theme = currentTheme wenv node

@@ -0,0 +1,122 @@+{-|+Module      : Monomer.Widgets.Singles.ToggleButton+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Toggle button widget, used for boolean properties.++Its behavior is equivalent to 'Monomer.Widgets.Singles.Checkbox' and+'Monomer.Widgets.Singles.LabeledCheckbox', with a different visual+representation.++See 'OptionButton' for detailed notes.+-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StrictData #-}++module Monomer.Widgets.Singles.ToggleButton (+  -- * Configuration+  ToggleButtonCfg,+  toggleButtonOffStyle,+  -- * Constructors+  toggleButton,+  toggleButton_,+  toggleButtonV,+  toggleButtonV_,+  toggleButtonD_+) where++import Control.Applicative ((<|>))+import Control.Lens (ALens', (&), (^.), (^?), (.~), (?~), _Just)+import Data.Default+import Data.Text (Text)++import qualified Data.Sequence as Seq++import Monomer.Widgets.Single+import Monomer.Widgets.Singles.OptionButton++import qualified Monomer.Lens as L++{-|+Configuration options for toggleButton:++- 'ignoreTheme': whether to load default style from theme or start empty.+- 'toggleButtonOffStyle': style to use when the option is not active.+- 'trimSpaces': whether to remove leading/trailing spaces in the caption.+- '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.+- '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.+- 'onFocus': event to raise when focus is received.+- 'onFocusReq': 'WidgetRequest' to generate when focus is received.+- 'onBlur': event to raise when focus is lost.+- 'onBlurReq': 'WidgetRequest' to generate when focus is lost.+- 'onChange': event to raise when the value changes/is clicked.+- 'onChangeReq': 'WidgetRequest' to generate when the value changes/is clicked.+-}+type ToggleButtonCfg = OptionButtonCfg++-- | Sets the style for the Off state of the toggle button.+toggleButtonOffStyle :: Style -> ToggleButtonCfg s e a+toggleButtonOffStyle = optionButtonOffStyle++-- | Creates a toggleButton using the given lens.+toggleButton+  :: Text+  -> ALens' s Bool+  -> WidgetNode s e+toggleButton caption field = toggleButton_ caption field def++-- | Creates a toggleButton using the given lens. Accepts config.+toggleButton_+  :: Text+  -> ALens' s Bool+  -> [ToggleButtonCfg s e Bool]+  -> WidgetNode s e+toggleButton_ caption field cfgs = newNode where+  newNode = toggleButtonD_ caption (WidgetLens field) cfgs++-- | Creates a toggleButton using the given value and 'onChange' event handler.+toggleButtonV+  :: WidgetEvent e+  => Text+  -> Bool+  -> (Bool -> e)+  -> WidgetNode s e+toggleButtonV caption value handler = newNode where+  newNode = toggleButtonV_ caption value handler def++-- | Creates a toggleButton using the given value and 'onChange' event handler.+--   Accepts config.+toggleButtonV_+  :: WidgetEvent e+  => Text+  -> Bool+  -> (Bool -> e)+  -> [ToggleButtonCfg s e Bool]+  -> WidgetNode s e+toggleButtonV_ caption value handler configs = newNode where+  widgetData = WidgetValue value+  newConfigs = onChange handler : configs+  newNode = toggleButtonD_ caption widgetData newConfigs++-- | Creates a toggleButton providing a 'WidgetData' instance and config.+toggleButtonD_+  :: Text+  -> WidgetData s Bool+  -> [ToggleButtonCfg s e Bool]+  -> WidgetNode s e+toggleButtonD_ caption widgetData configs = toggleButtonNode where+  config = mconcat configs+  makeWithStyle = makeOptionButton L.toggleBtnOnStyle L.toggleBtnOffStyle+  widget = makeWithStyle widgetData caption id not config+  toggleButtonNode = defaultWidgetNode "toggleButton" widget+    & L.info . L.focusable .~ True

@@ -226,7 +226,8 @@   -> WidgetNode s e  -- ^ The embedded child node.   -> StyleState      -- ^ The currently active state. childOfFocusedStyle wenv cnode = newStyle where-  pinfo = fromMaybe def (wenv ^. L.findByPath $ parentPath cnode)+  branch = wenv ^. L.findBranchByPath $ parentPath cnode+  pinfo = fromMaybe def (Seq.lookup (length branch - 1) branch)   cstyle = cnode ^. L.info . L.style   enabled = cnode ^. L.info . L.enabled 

@@ -205,7 +205,8 @@ -- | Returns the WidgetId associated to the given path, if any. findWidgetIdFromPath :: WidgetEnv s e -> Path -> Maybe WidgetId findWidgetIdFromPath wenv path = mwni ^? _Just . L.widgetId where-  mwni = wenv ^. L.findByPath $ path+  branch = wenv ^. L.findBranchByPath $ path+  mwni = Seq.lookup (length branch - 1) branch  -- | Sends a message to the given node with a delay of n ms. delayedMessage :: Typeable i => WidgetNode s e -> i -> Int -> WidgetRequest s e

@@ -20,7 +20,9 @@ import Data.Maybe import Data.Text (Text) import Data.Sequence (Seq)-import System.IO.Unsafe+import System.Environment (lookupEnv)+import System.IO.Unsafe (unsafePerformIO)+import Test.Hspec (Expectation, pendingWith)  import qualified Data.ByteString as BS import qualified Data.Map.Strict as M@@ -161,7 +163,7 @@   _weOs = "Mac OS X",   _weDpr = 2,   _weFontManager = mockFontManager,-  _weFindByPath = const Nothing,+  _weFindBranchByPath = const Seq.empty,   _weMainButton = BtnLeft,   _weContextButton = BtnRight,   _weTheme = def,@@ -348,3 +350,15 @@   ny = fromIntegral (round y)   nw = fromIntegral (round w)   nh = fromIntegral (round h)++useVideoSubSystem :: IO Bool+useVideoSubSystem = do+  (== Just "1") <$> lookupEnv "USE_SDL_VIDEO_SUBSYSTEM"++testInVideoSubSystem :: Expectation -> Expectation+testInVideoSubSystem expectation = do+  useVideo <- useVideoSubSystem+  if useVideo then+    expectation+  else+    pendingWith "SDL Video sub system not initialized. Skipping."

@@ -376,8 +376,8 @@       -> MainEvt       -> [EventResponse MainModel MainEvt MainModel ()]     handleEvent wenv node model evt = [Request (SendMessage wid msg)] where-      wni = wenv ^. L.findByPath $ path-      wid = maybe def (^. L.widgetId) wni+      wnis = wenv ^. L.findBranchByPath $ path+      wid = maybe def (^. L.widgetId) (Seq.lookup (length wnis - 1) wnis)     buildUI wenv model = vstack [         button "Start" MainBtnClicked,         composite "child" child buildChild handleChild@@ -496,7 +496,7 @@   cmpLabels = composite "main" id buildLabels handleEvent   buildUI :: WidgetEnv TestModel () -> TestModel -> WidgetNode TestModel ()   buildUI wenv model = box_ [ignoreEmptyArea, expandContent] $-    zstack_ [onlyTopActive False] [+    zstack_ [onlyTopActive_ False] [       label "Background",       vgrid [           hgrid [ textField text1, label "2", label "3" ],

@@ -124,7 +124,7 @@   where     wenv = mockWenv ()     btn2 = button "Click 2" (BtnClick 2) `styleBasic` [height 10]-    ignoredNode = zstack_ [onlyTopActive False] [+    ignoredNode = zstack_ [onlyTopActive_ False] [         button "Click 1" (BtnClick 1),         box_ [ignoreEmptyArea_ True] btn2       ]@@ -141,7 +141,7 @@   where     wenv = mockWenv ()     centeredBtn = button "Click 2" (BtnClick 2) `styleBasic` [height 10]-    sunkNode = zstack_ [onlyTopActive False] [+    sunkNode = zstack_ [onlyTopActive_ False] [         button "Click 1" (BtnClick 1),         box_ [ignoreEmptyArea_ False] centeredBtn       ]

@@ -35,7 +35,9 @@ import qualified Monomer.Lens as L  data TestEvt-  = CtrlA+  = SingleO+  | TextFieldChanged Text+  | CtrlA   | CtrlSpace   | CtrlShiftSpace   | MultiKey Int@@ -83,13 +85,21 @@       evtKC keyD, evtKC keyE] `shouldBe` Seq.fromList [MultiKey 1, MultiKey 2]    it "should not ignore children events if not explicitly requested" $ do-    events1 [evtKG keyA, evtT "d"] `shouldBe` Seq.fromList [CtrlA]+    events1 [evtKG keyA, evtT "d"] `shouldBe` Seq.fromList [CtrlA, TextFieldChanged "d"]     model1 [evtKG keyA, evtT "d"] ^. textValue `shouldBe` "d"    it "should ignore children events if requested" $ do-    events2 [evtKG keyA, evtT "d"] `shouldBe` Seq.fromList [CtrlA]+    events2 [evtKG keyA, evtT "d"] `shouldBe` Seq.fromList [CtrlA, TextFieldChanged "abcd"]     model2 [evtKG keyA, evtT "d"] ^. textValue `shouldBe` "abcd" +  it "should not filter text events if not explicitly requested" $ do+    events1 [evtK keyO, evtT "o"] `shouldBe` Seq.fromList [SingleO, TextFieldChanged "abco"]+    model1 [evtK keyO, evtT "o"] ^. textValue `shouldBe` "abco"++  it "should filter text events if requested" $ do+    events2 [evtK keyO, evtT "o"] `shouldBe` Seq.fromList [SingleO]+    model2 [evtK keyO, evtT "o"] ^. textValue `shouldBe` "abc"+   where     wenv = mockWenv (TestModel "")     bindings = [@@ -105,8 +115,8 @@     kstNode = keystroke bindings (textField textValue)     events es = nodeHandleEventEvts wenv es kstNode     wenv2 = mockWenv (TestModel "abc")-    kstModel1 = keystroke [("C-a", CtrlA)] (textField textValue)-    kstModel2 = keystroke_ [("C-a", CtrlA)] [ignoreChildrenEvts] (textField textValue)+    kstModel1 = keystroke [("C-a", CtrlA), ("o", SingleO)] (textField_ textValue [onChange TextFieldChanged])+    kstModel2 = keystroke_ [("C-a", CtrlA), ("o", SingleO)] [ignoreChildrenEvts] (textField_ textValue [onChange TextFieldChanged])     model1 es = nodeHandleEventModel wenv2 es kstModel1     model2 es = nodeHandleEventModel wenv2 es kstModel2     events1 es = nodeHandleEventEvts wenv2 es kstModel1

@@ -90,7 +90,7 @@    where     wenv = mockWenv ()-    zstackNode = zstack_ [onlyTopActive False] [+    zstackNode = zstack_ [onlyTopActive_ False] [         button "Click 1" (BtnClick 1),         vstack [           button "Click 2" (BtnClick 2) `styleBasic` [height 10]@@ -123,7 +123,7 @@    where     wenv = mockWenvEvtUnit (TestModel "" "")-    zstackNode = zstack_ [onlyTopActive False] [+    zstackNode = zstack_ [onlyTopActive_ False] [         textField textValue1,         textField textValue2       ]

@@ -53,7 +53,7 @@ handleEvent :: Spec handleEvent = describe "handleEvent" $ do   it "should update the model" $-    model (Point 306 10) ^. color `shouldBe` rgb 127 0 0+    model (Point 285 10) ^. color `shouldBe` rgb 127 0 0    it "should generate an event when focus is received" $     events evtFocus `shouldBe` Seq.singleton (GotFocus emptyPath)@@ -70,7 +70,7 @@ handleEventV :: Spec handleEventV = describe "handleEventV" $ do   it "should generante a change event" $-    events (evtRelease (Point 453 30)) `shouldBe` Seq.singleton (ColorChanged (rgb 0 200 0))+    events (evtRelease (Point 440 30)) `shouldBe` Seq.singleton (ColorChanged (rgb 0 200 0))    it "should generate an event when focus is received" $     events evtFocus `shouldBe` Seq.singleton (GotFocus emptyPath)@@ -85,8 +85,8 @@  getSizeReq :: Spec getSizeReq = describe "getSizeReq" $ do-  it "should return width = Range 126 1126" $-    sizeReqW `shouldBe` rangeSize 126 1126 1+  it "should return width = Range 97 1097" $+    sizeReqW `shouldBe` rangeSize 97 1097 1    it "should return height = Fixed 64" $     sizeReqH `shouldBe` fixedSize 64

@@ -191,11 +191,17 @@     let steps = [WheelScroll p (Point 0 (-200)) WheelNormal]     evts steps `shouldBe` Seq.singleton (DialChanged (-200)) +  it "should generate IgnoreParentEvents when using the wheel" $ do+    let p = Point 320 240+    let steps = [WheelScroll p (Point 0 (-64)) WheelNormal]+    reqs steps `shouldSatisfy` (IgnoreParentEvents `elem`)+   where     wenv = mockWenv (TestModel 0)       & L.theme .~ darkTheme     dialNode = dialV_ 0 DialChanged (-500) 500 [wheelRate 1]     evts es = nodeHandleEventEvts wenv es dialNode+    reqs es = nodeHandleEventReqs wenv es dialNode  handleShiftFocus :: Spec handleShiftFocus = describe "handleShiftFocus" $ do

@@ -118,6 +118,11 @@     model steps3 ^. integralValue `shouldBe` 100     model steps4 ^. integralValue `shouldBe` 1501 +  it "should generate IgnoreParentEvents when using the wheel" $ do+    let p = Point 100 10+    let steps = [WheelScroll p (Point 0 (-64)) WheelNormal]+    reqs steps `shouldSatisfy` (IgnoreParentEvents `elem`)+   it "should generate an event when focus is received" $     events [evtFocus] `shouldBe` Seq.singleton (GotFocus emptyPath) @@ -133,6 +138,7 @@     model es = nodeHandleEventModel wenv (evtFocus : es) intNode     modelBasic es = nodeHandleEventModel wenv es basicIntNode     events es = nodeHandleEventEvts wenv es intNode+    reqs es = nodeHandleEventReqs wenv es intNode  handleEventValueIntegral :: Spec handleEventValueIntegral = describe "handleEventIntegral" $ do@@ -317,6 +323,11 @@     model steps3 ^. fractionalValue `shouldBe` Just 870     model steps4 ^. fractionalValue `shouldBe` Just 1501 +  it "should generate IgnoreParentEvents when using the wheel" $ do+    let p = Point 100 10+    let steps = [WheelScroll p (Point 0 (-64)) WheelNormal]+    reqs steps `shouldSatisfy` (IgnoreParentEvents `elem`)+   it "should generate an event when focus is received" $     events evtFocus `shouldBe` Seq.singleton (GotFocus emptyPath) @@ -332,6 +343,7 @@     model es = nodeHandleEventModel wenv es floatNode     modelBasic es = nodeHandleEventModel wenv es basicFractionalNode     events evt = nodeHandleEventEvts wenv [evt] floatNode+    reqs es = nodeHandleEventReqs wenv es floatNode  handleEventValueFractional :: Spec handleEventValueFractional = describe "handleEventValueFractional" $ do

@@ -0,0 +1,116 @@+{-|+Module      : Monomer.Widgets.Singles.OptionButtonSpec+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Unit tests for OptionButton widget.++This module is intentionally copied from RadioSpec, since the behavior should be+the same.+-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Monomer.Widgets.Singles.OptionButtonSpec (spec) where++import Control.Lens ((&), (^.), (.~))+import Control.Lens.TH (abbreviatedFields, makeLensesWith)+import Data.Default+import Data.Text (Text)+import Test.Hspec++import qualified Data.Sequence as Seq++import Monomer.Core+import Monomer.Core.Combinators+import Monomer.Event+import Monomer.TestEventUtil+import Monomer.TestUtil+import Monomer.Widgets.Singles.OptionButton++import qualified Monomer.Lens as L++data Fruit+  = Apple+  | Orange+  | Banana+  deriving (Eq, Show)++data FruitEvt+  = FruitSel Fruit+  | GotFocus Path+  | LostFocus Path+  deriving (Eq, Show)++newtype TestModel = TestModel {+  _tmFruit :: Fruit+} deriving (Eq)++makeLensesWith abbreviatedFields ''TestModel++spec :: Spec+spec = describe "OptionButton" $ do+  handleEvent+  handleEventValue+  getSizeReq++handleEvent :: Spec+handleEvent = describe "handleEvent" $ do+  it "should not update the model if not clicked" $+    clickModel (Point 3000 3000) orangeNode ^. fruit `shouldBe` Apple++  it "should update the model when clicked" $+    clickModel (Point 320 240) orangeNode ^. fruit `shouldBe` Orange++  it "should update the model when Enter/Space is pressed" $+    keyModel keyReturn bananaNode ^. fruit `shouldBe` Banana++  it "should generate an event when focus is received" $+    events evtFocus orangeNode `shouldBe` Seq.singleton (GotFocus emptyPath)++  it "should generate an event when focus is lost" $+    events evtBlur orangeNode `shouldBe` Seq.singleton (LostFocus emptyPath)++  where+    wenv = mockWenv (TestModel Apple)+    orangeNode = optionButton_ "Orange" Orange fruit [onFocus GotFocus, onBlur LostFocus]+    bananaNode :: WidgetNode TestModel FruitEvt+    bananaNode = optionButton "Banana" Banana fruit+    clickModel p node = nodeHandleEventModel wenv [evtClick p] node+    keyModel key node = nodeHandleEventModel wenv [KeyAction def key KeyPressed] node+    events evt node = nodeHandleEventEvts wenv [evt] node++handleEventValue :: Spec+handleEventValue = describe "handleEventValue" $ do+  it "should not generate an event if clicked outside" $+    clickModel (Point 3000 3000) orangeNode `shouldBe` Seq.empty++  it "should generate a user provided event when clicked" $+    clickModel (Point 320 240) orangeNode `shouldBe` Seq.singleton (FruitSel Orange)++  it "should generate a user provided event when Enter/Space is pressed" $+    keyModel keyReturn bananaNode `shouldBe` Seq.singleton (FruitSel Banana)++  where+    wenv = mockWenv (TestModel Apple)+    orangeNode = optionButtonV "Orange" Orange Apple FruitSel+    bananaNode = optionButtonV "Banana" Banana Apple FruitSel+    clickModel p node = nodeHandleEventEvts wenv [evtClick p] node+    keyModel key node = nodeHandleEventEvts wenv [KeyAction def key KeyPressed] node++getSizeReq :: Spec+getSizeReq = describe "getSizeReq" $ do+  it "should return width = Fixed 50" $+    sizeReqW `shouldBe` fixedSize 50++  it "should return height = Fixed 20" $+    sizeReqH `shouldBe` fixedSize 20++  where+    wenv = mockWenvEvtUnit (TestModel Apple)+    (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (optionButton "Apple" Apple fruit)

@@ -324,11 +324,17 @@     let steps = [WheelScroll p (Point 0 100) WheelNormal]     model steps ^. sliderVal `shouldBe` 300 +  it "should generate IgnoreParentEvents when using the wheel" $ do+    let p = Point 100 10+    let steps = [WheelScroll p (Point 0 (-64)) WheelNormal]+    reqs steps `shouldSatisfy` (IgnoreParentEvents `elem`)+   where     wenv = mockWenvEvtUnit (TestModel 200)       & L.theme .~ darkTheme     sliderNode = hslider_ sliderVal (-500) 500 [wheelRate 1]     model es = nodeHandleEventModel wenv es sliderNode+    reqs es = nodeHandleEventReqs wenv es sliderNode  handleWheelValV :: Spec handleWheelValV = describe "handleWheelValV" $ do

@@ -105,13 +105,17 @@   it "should copy and paste text around" $ do     let str = "This is some long text"     let steps = [evtT str, selWordL, selWordL, selCharL, evtKG keyC, moveWordL, moveWordL, moveCharL, evtKG keyV]-    model steps ^. textValue `shouldBe` "This long text is some long text" +    testInVideoSubSystem $+      model steps ^. textValue `shouldBe` "This long text is some long text"+   it "should cut and paste text around" $ do     let str = "This is long text"     let steps = [evtT str, selWordL, selCharL, evtKG keyX, moveWordL, moveWordL, moveCharL, evtKG keyV]-    model steps ^. textValue `shouldBe` "This text is long" +    testInVideoSubSystem $+      model steps ^. textValue `shouldBe` "This text is long"+   it "should generate an event when focus is received" $ do     events [evtFocus] `shouldBe` Seq.singleton (GotFocus emptyPath)     ctx [evtFocus] ^. L.renderSchedule `shouldSatisfy` (==1) . length@@ -173,7 +177,9 @@    it "should input 'abc123', move to beginning, select three letters, copy, move to end, paste" $ do     let steps = [evtT "abc123", evtKC keyHome, selCharR, selCharR, selCharR, evtKG keyC, evtK keyEnd, evtKG keyV]-    lastEvt steps `shouldBe` TextChanged "abc123abc"++    testInVideoSubSystem $+      lastEvt steps `shouldBe` TextChanged "abc123abc"    it "should input a-b-c-d on separate lines, then press Return" $ do     let steps = [evtT "a\nb\nc\nd", evtK keyReturn]

@@ -95,13 +95,17 @@   it "should copy and paste text around" $ do     let str = "This is some long text"     let steps = [evtT str, selWordL, selWordL, selCharL, evtKG keyC, moveWordL, moveWordL, moveCharL, evtKG keyV]-    model steps ^. textValue `shouldBe` "This long text is some long text" +    testInVideoSubSystem $+      model steps ^. textValue `shouldBe` "This long text is some long text"+   it "should cut and paste text around" $ do     let str = "This is long text"     let steps = [evtT str, selWordL, selCharL, evtKG keyX, moveWordL, moveWordL, moveCharL, evtKG keyV]-    model steps ^. textValue `shouldBe` "This text is long" +    testInVideoSubSystem $+      model steps ^. textValue `shouldBe` "This text is long"+   it "should generate an event when focus is received" $ do     events [evtFocus] `shouldBe` Seq.singleton (GotFocus emptyPath)     ctx [evtFocus] ^. L.renderSchedule `shouldSatisfy` (==1) . length@@ -158,7 +162,9 @@    it "should input 'abc123', move to beginning, select three letters, copy, move to end, paste" $ do     let steps = [evtT "abc123", evtKC keyHome, selCharR, selCharR, selCharR, evtKG keyC, evtK keyEnd, evtKG keyV]-    lastEvt steps `shouldBe` TextChanged "abc123abc"++    testInVideoSubSystem $+      lastEvt steps `shouldBe` TextChanged "abc123abc"    where     wenv = mockWenv (TestModel "")

@@ -0,0 +1,111 @@+{-|+Module      : Monomer.Widgets.Singles.ToggleButtonSpec+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Unit tests for ToggleButton widget.++This module is intentionally copied from ToggleButtonSpec, since the behavior+should be the same.+-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Monomer.Widgets.Singles.ToggleButtonSpec (spec) where++import Control.Lens ((&), (^.), (.~))+import Control.Lens.TH (abbreviatedFields, makeLensesWith)+import Data.Default+import Data.Text (Text)+import Test.Hspec++import qualified Data.Sequence as Seq++import Monomer.Core+import Monomer.Core.Combinators+import Monomer.Event+import Monomer.TestEventUtil+import Monomer.TestUtil+import Monomer.Widgets.Singles.ToggleButton++import qualified Monomer.Lens as L++data TestEvt+  = BoolSel Bool+  | GotFocus Path+  | LostFocus Path+  deriving (Eq, Show)++newtype TestModel = TestModel {+  _tmTestBool :: Bool+} deriving (Eq, Show)++makeLensesWith abbreviatedFields ''TestModel++spec :: Spec+spec = describe "ToggleButton" $ do+  handleEvent+  handleEventValue+  getSizeReq++handleEvent :: Spec+handleEvent = describe "handleEvent" $ do+  it "should not update the model if not clicked" $+    clickModel (Point 3000 3000) ^. testBool `shouldBe` False++  it "should update the model when clicked" $+    clickModel (Point 100 100) ^. testBool `shouldBe` True++  it "should update the model when Enter/Space is pressed" $+    keyModel keyReturn ^. testBool `shouldBe` True++  it "should generate an event when focus is received" $+    events evtFocus `shouldBe` Seq.singleton (GotFocus emptyPath)++  it "should generate an event when focus is lost" $+    events evtBlur `shouldBe` Seq.singleton (LostFocus emptyPath)++  where+    wenv = mockWenv (TestModel False)+    chkNode = toggleButton_ "Toggle" testBool [onFocus GotFocus, onBlur LostFocus]+    clickModel p = nodeHandleEventModel wenv [evtClick p] chkNode+    keyModel key = nodeHandleEventModel wenv [KeyAction def key KeyPressed] chkNode+    events evt = nodeHandleEventEvts wenv [evt] chkNode++handleEventValue :: Spec+handleEventValue = describe "handleEventValue" $ do+  it "should not generate an event if clicked outside" $+    clickModel (Point 3000 3000) chkNode `shouldBe` Seq.empty++  it "should generate a user provided event when clicked" $+    clickModel (Point 100 100) chkNode `shouldBe` Seq.singleton (BoolSel True)++  it "should generate a user provided event when clicked (True -> False)" $+    clickModel (Point 100 100) chkNodeT `shouldBe` Seq.singleton (BoolSel False)++  it "should generate a user provided event when Enter/Space is pressed" $+    keyModel keyReturn chkNode `shouldBe` Seq.singleton (BoolSel True)++  where+    wenv = mockWenv (TestModel False)+    chkNode = toggleButtonV "Toggle" False BoolSel+    chkNodeT = toggleButtonV "Toggle" True BoolSel+    clickModel p node = nodeHandleEventEvts wenv [evtClick p] node+    keyModel key node = nodeHandleEventEvts wenv [KeyAction def key KeyPressed] node++getSizeReq :: Spec+getSizeReq = describe "getSizeReq" $ do+  it "should return width = Fixed 60" $+    sizeReqW `shouldBe` fixedSize 60++  it "should return height = Fixed 20" $+    sizeReqH `shouldBe` fixedSize 20++  where+    wenv = mockWenvEvtUnit (TestModel False)+    (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (toggleButton "Toggle" testBool)

@@ -5,6 +5,8 @@ import qualified SDL import qualified SDL.Raw as Raw +import Monomer.TestUtil (useVideoSubSystem)+ import qualified Monomer.Common.CursorIconSpec as CursorIconSpec import qualified Monomer.Core.SizeReqSpec as SizeReqSpec import qualified Monomer.Graphics.UtilSpec as GraphicsUtilSpec@@ -41,6 +43,7 @@ import qualified Monomer.Widgets.Singles.LabeledRadioSpec as LabeledRadioSpec import qualified Monomer.Widgets.Singles.LabelSpec as LabelSpec import qualified Monomer.Widgets.Singles.NumericFieldSpec as NumericFieldSpec+import qualified Monomer.Widgets.Singles.OptionButtonSpec as OptionButtonSpec import qualified Monomer.Widgets.Singles.RadioSpec as RadioSpec import qualified Monomer.Widgets.Singles.SeparatorLineSpec as SeparatorLineSpec import qualified Monomer.Widgets.Singles.SliderSpec as SliderSpec@@ -48,6 +51,7 @@ import qualified Monomer.Widgets.Singles.TextFieldSpec as TextFieldSpec import qualified Monomer.Widgets.Singles.TextAreaSpec as TextAreaSpec import qualified Monomer.Widgets.Singles.TimeFieldSpec as TimeFieldSpec+import qualified Monomer.Widgets.Singles.ToggleButtonSpec as ToggleButtonSpec  import qualified Monomer.Widgets.Util.FocusSpec as FocusSpec import qualified Monomer.Widgets.Util.StyleSpec as StyleSpec@@ -55,14 +59,20 @@  main :: IO () main = do-  -- Initialize SDL-  SDL.initialize [SDL.InitVideo]-  -- Run tests-  hspec spec-  -- Shutdown SDL-  Raw.quitSubSystem Raw.SDL_INIT_VIDEO-  SDL.quit+  initVideo <- useVideoSubSystem +  if initVideo then do+    -- Initialize SDL+    SDL.initialize [SDL.InitVideo]+    -- Run tests+    hspec spec+    -- Shutdown SDL+    Raw.quitSubSystem Raw.SDL_INIT_VIDEO+    SDL.quit+  else do+    -- Run tests+    hspec spec+ spec :: Spec spec = do   common@@ -126,6 +136,7 @@   LabeledCheckboxSpec.spec   LabeledRadioSpec.spec   NumericFieldSpec.spec+  OptionButtonSpec.spec   RadioSpec.spec   SeparatorLineSpec.spec   SliderSpec.spec@@ -133,6 +144,7 @@   TextAreaSpec.spec   TextFieldSpec.spec   TimeFieldSpec.spec+  ToggleButtonSpec.spec  widgetsUtil :: Spec widgetsUtil = describe "Widgets Util" $ do