diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/examples/books/Main.hs b/examples/books/Main.hs --- a/examples/books/Main.hs +++ b/examples/books/Main.hs @@ -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) diff --git a/examples/generative/Main.hs b/examples/generative/Main.hs --- a/examples/generative/Main.hs +++ b/examples/generative/Main.hs @@ -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 ] diff --git a/examples/ticker/Main.hs b/examples/ticker/Main.hs --- a/examples/ticker/Main.hs +++ b/examples/ticker/Main.hs @@ -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 -> [ diff --git a/examples/todo/Main.hs b/examples/todo/Main.hs --- a/examples/todo/Main.hs +++ b/examples/todo/Main.hs @@ -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, diff --git a/examples/tutorial/Tutorial03_LifeCycle.hs b/examples/tutorial/Tutorial03_LifeCycle.hs --- a/examples/tutorial/Tutorial03_LifeCycle.hs +++ b/examples/tutorial/Tutorial03_LifeCycle.hs @@ -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 diff --git a/monomer.cabal b/monomer.cabal --- a/monomer.cabal +++ b/monomer.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: monomer -version: 1.1.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 diff --git a/src/Monomer/Core/StyleUtil.hs b/src/Monomer/Core/StyleUtil.hs --- a/src/Monomer/Core/StyleUtil.hs +++ b/src/Monomer/Core/StyleUtil.hs @@ -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 diff --git a/src/Monomer/Core/Themes/BaseTheme.hs b/src/Monomer/Core/Themes/BaseTheme.hs --- a/src/Monomer/Core/Themes/BaseTheme.hs +++ b/src/Monomer/Core/Themes/BaseTheme.hs @@ -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) diff --git a/src/Monomer/Core/Themes/SampleThemes.hs b/src/Monomer/Core/Themes/SampleThemes.hs --- a/src/Monomer/Core/Themes/SampleThemes.hs +++ b/src/Monomer/Core/Themes/SampleThemes.hs @@ -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" diff --git a/src/Monomer/Core/Util.hs b/src/Monomer/Core/Util.hs --- a/src/Monomer/Core/Util.hs +++ b/src/Monomer/Core/Util.hs @@ -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 diff --git a/src/Monomer/Core/WidgetTypes.hs b/src/Monomer/Core/WidgetTypes.hs --- a/src/Monomer/Core/WidgetTypes.hs +++ b/src/Monomer/Core/WidgetTypes.hs @@ -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. diff --git a/src/Monomer/Graphics/Util.hs b/src/Monomer/Graphics/Util.hs --- a/src/Monomer/Graphics/Util.hs +++ b/src/Monomer/Graphics/Util.hs @@ -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 diff --git a/src/Monomer/Main/Core.hs b/src/Monomer/Main/Core.hs --- a/src/Monomer/Main/Core.hs +++ b/src/Monomer/Main/Core.hs @@ -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, diff --git a/src/Monomer/Main/Handlers.hs b/src/Monomer/Main/Handlers.hs --- a/src/Monomer/Main/Handlers.hs +++ b/src/Monomer/Main/Handlers.hs @@ -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 diff --git a/src/Monomer/Main/Platform.hs b/src/Monomer/Main/Platform.hs --- a/src/Monomer/Main/Platform.hs +++ b/src/Monomer/Main/Platform.hs @@ -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" diff --git a/src/Monomer/Main/Types.hs b/src/Monomer/Main/Types.hs --- a/src/Monomer/Main/Types.hs +++ b/src/Monomer/Main/Types.hs @@ -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 } diff --git a/src/Monomer/Main/UserUtil.hs b/src/Monomer/Main/UserUtil.hs --- a/src/Monomer/Main/UserUtil.hs +++ b/src/Monomer/Main/UserUtil.hs @@ -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 diff --git a/src/Monomer/Widgets.hs b/src/Monomer/Widgets.hs --- a/src/Monomer/Widgets.hs +++ b/src/Monomer/Widgets.hs @@ -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 diff --git a/src/Monomer/Widgets/Composite.hs b/src/Monomer/Widgets/Composite.hs --- a/src/Monomer/Widgets/Composite.hs +++ b/src/Monomer/Widgets/Composite.hs @@ -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 diff --git a/src/Monomer/Widgets/Container.hs b/src/Monomer/Widgets/Container.hs --- a/src/Monomer/Widgets/Container.hs +++ b/src/Monomer/Widgets/Container.hs @@ -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 diff --git a/src/Monomer/Widgets/Containers/Keystroke.hs b/src/Monomer/Widgets/Containers/Keystroke.hs --- a/src/Monomer/Widgets/Containers/Keystroke.hs +++ b/src/Monomer/Widgets/Containers/Keystroke.hs @@ -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 diff --git a/src/Monomer/Widgets/Containers/Scroll.hs b/src/Monomer/Widgets/Containers/Scroll.hs --- a/src/Monomer/Widgets/Containers/Scroll.hs +++ b/src/Monomer/Widgets/Containers/Scroll.hs @@ -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 diff --git a/src/Monomer/Widgets/Containers/ZStack.hs b/src/Monomer/Widgets/Containers/ZStack.hs --- a/src/Monomer/Widgets/Containers/ZStack.hs +++ b/src/Monomer/Widgets/Containers/ZStack.hs @@ -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 } diff --git a/src/Monomer/Widgets/Singles/Base/InputField.hs b/src/Monomer/Widgets/Singles/Base/InputField.hs --- a/src/Monomer/Widgets/Singles/Base/InputField.hs +++ b/src/Monomer/Widgets/Singles/Base/InputField.hs @@ -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 diff --git a/src/Monomer/Widgets/Singles/Checkbox.hs b/src/Monomer/Widgets/Singles/Checkbox.hs --- a/src/Monomer/Widgets/Singles/Checkbox.hs +++ b/src/Monomer/Widgets/Singles/Checkbox.hs @@ -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 #-} diff --git a/src/Monomer/Widgets/Singles/ColorPicker.hs b/src/Monomer/Widgets/Singles/ColorPicker.hs --- a/src/Monomer/Widgets/Singles/ColorPicker.hs +++ b/src/Monomer/Widgets/Singles/ColorPicker.hs @@ -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] diff --git a/src/Monomer/Widgets/Singles/Dial.hs b/src/Monomer/Widgets/Singles/Dial.hs --- a/src/Monomer/Widgets/Singles/Dial.hs +++ b/src/Monomer/Widgets/Singles/Dial.hs @@ -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 diff --git a/src/Monomer/Widgets/Singles/OptionButton.hs b/src/Monomer/Widgets/Singles/OptionButton.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/OptionButton.hs @@ -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 diff --git a/src/Monomer/Widgets/Singles/Radio.hs b/src/Monomer/Widgets/Singles/Radio.hs --- a/src/Monomer/Widgets/Singles/Radio.hs +++ b/src/Monomer/Widgets/Singles/Radio.hs @@ -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 #-} diff --git a/src/Monomer/Widgets/Singles/Slider.hs b/src/Monomer/Widgets/Singles/Slider.hs --- a/src/Monomer/Widgets/Singles/Slider.hs +++ b/src/Monomer/Widgets/Singles/Slider.hs @@ -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 diff --git a/src/Monomer/Widgets/Singles/ToggleButton.hs b/src/Monomer/Widgets/Singles/ToggleButton.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/ToggleButton.hs @@ -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 diff --git a/src/Monomer/Widgets/Util/Style.hs b/src/Monomer/Widgets/Util/Style.hs --- a/src/Monomer/Widgets/Util/Style.hs +++ b/src/Monomer/Widgets/Util/Style.hs @@ -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 diff --git a/src/Monomer/Widgets/Util/Widget.hs b/src/Monomer/Widgets/Util/Widget.hs --- a/src/Monomer/Widgets/Util/Widget.hs +++ b/src/Monomer/Widgets/Util/Widget.hs @@ -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 diff --git a/test/unit/Monomer/TestUtil.hs b/test/unit/Monomer/TestUtil.hs --- a/test/unit/Monomer/TestUtil.hs +++ b/test/unit/Monomer/TestUtil.hs @@ -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." diff --git a/test/unit/Monomer/Widgets/CompositeSpec.hs b/test/unit/Monomer/Widgets/CompositeSpec.hs --- a/test/unit/Monomer/Widgets/CompositeSpec.hs +++ b/test/unit/Monomer/Widgets/CompositeSpec.hs @@ -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" ], diff --git a/test/unit/Monomer/Widgets/Containers/BoxSpec.hs b/test/unit/Monomer/Widgets/Containers/BoxSpec.hs --- a/test/unit/Monomer/Widgets/Containers/BoxSpec.hs +++ b/test/unit/Monomer/Widgets/Containers/BoxSpec.hs @@ -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 ] diff --git a/test/unit/Monomer/Widgets/Containers/KeystrokeSpec.hs b/test/unit/Monomer/Widgets/Containers/KeystrokeSpec.hs --- a/test/unit/Monomer/Widgets/Containers/KeystrokeSpec.hs +++ b/test/unit/Monomer/Widgets/Containers/KeystrokeSpec.hs @@ -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 diff --git a/test/unit/Monomer/Widgets/Containers/ZStackSpec.hs b/test/unit/Monomer/Widgets/Containers/ZStackSpec.hs --- a/test/unit/Monomer/Widgets/Containers/ZStackSpec.hs +++ b/test/unit/Monomer/Widgets/Containers/ZStackSpec.hs @@ -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 ] diff --git a/test/unit/Monomer/Widgets/Singles/ColorPickerSpec.hs b/test/unit/Monomer/Widgets/Singles/ColorPickerSpec.hs --- a/test/unit/Monomer/Widgets/Singles/ColorPickerSpec.hs +++ b/test/unit/Monomer/Widgets/Singles/ColorPickerSpec.hs @@ -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 diff --git a/test/unit/Monomer/Widgets/Singles/DialSpec.hs b/test/unit/Monomer/Widgets/Singles/DialSpec.hs --- a/test/unit/Monomer/Widgets/Singles/DialSpec.hs +++ b/test/unit/Monomer/Widgets/Singles/DialSpec.hs @@ -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 diff --git a/test/unit/Monomer/Widgets/Singles/NumericFieldSpec.hs b/test/unit/Monomer/Widgets/Singles/NumericFieldSpec.hs --- a/test/unit/Monomer/Widgets/Singles/NumericFieldSpec.hs +++ b/test/unit/Monomer/Widgets/Singles/NumericFieldSpec.hs @@ -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 diff --git a/test/unit/Monomer/Widgets/Singles/OptionButtonSpec.hs b/test/unit/Monomer/Widgets/Singles/OptionButtonSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Singles/OptionButtonSpec.hs @@ -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) diff --git a/test/unit/Monomer/Widgets/Singles/SliderSpec.hs b/test/unit/Monomer/Widgets/Singles/SliderSpec.hs --- a/test/unit/Monomer/Widgets/Singles/SliderSpec.hs +++ b/test/unit/Monomer/Widgets/Singles/SliderSpec.hs @@ -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 diff --git a/test/unit/Monomer/Widgets/Singles/TextAreaSpec.hs b/test/unit/Monomer/Widgets/Singles/TextAreaSpec.hs --- a/test/unit/Monomer/Widgets/Singles/TextAreaSpec.hs +++ b/test/unit/Monomer/Widgets/Singles/TextAreaSpec.hs @@ -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] diff --git a/test/unit/Monomer/Widgets/Singles/TextFieldSpec.hs b/test/unit/Monomer/Widgets/Singles/TextFieldSpec.hs --- a/test/unit/Monomer/Widgets/Singles/TextFieldSpec.hs +++ b/test/unit/Monomer/Widgets/Singles/TextFieldSpec.hs @@ -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 "") diff --git a/test/unit/Monomer/Widgets/Singles/ToggleButtonSpec.hs b/test/unit/Monomer/Widgets/Singles/ToggleButtonSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Monomer/Widgets/Singles/ToggleButtonSpec.hs @@ -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) diff --git a/test/unit/Spec.hs b/test/unit/Spec.hs --- a/test/unit/Spec.hs +++ b/test/unit/Spec.hs @@ -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