diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,26 @@ +## 1.5.1.0 + +### Added + +- Add color popup widget ([PR #247](https://github.com/fjvallarino/monomer/pull/247)). +- Add responseIf and responseMaybe helpers ([PR #250](https://github.com/fjvallarino/monomer/pull/250)). + +### Fixed + +- Fix rendering artifacts ([PR #215](https://github.com/fjvallarino/monomer/pull/215)). +- Trigger ResizeWidgets when user defined size requests change ([PR #229](https://github.com/fjvallarino/monomer/pull/229)). +- Do not pass events to selectList's children when they are not visible ([PR #230](https://github.com/fjvallarino/monomer/pull/230)). +- Avoid infinite resize loop in multiline label ([PR #233](https://github.com/fjvallarino/monomer/pull/233)). +- [Several](https://github.com/fjvallarino/monomer/pull/222) [really](https://github.com/fjvallarino/monomer/pull/244) [nice](https://github.com/fjvallarino/monomer/pull/249) [documentation](https://github.com/fjvallarino/monomer/pull/253) [improvements](https://github.com/fjvallarino/monomer/pull/254). Thanks @Deltaspace0! +- Modify tests for selectList and dropdown ([PR #245](https://github.com/fjvallarino/monomer/pull/245)). Thanks @Deltaspace0! +- Fix animation widget raising onFinished event when it is no longer relevant ([PR #252](https://github.com/fjvallarino/monomer/pull/252)). Thanks @Deltaspace0! + +### Changed + +- Add "examples" flag to optionally build examples and tutorials ([PR #218](https://github.com/fjvallarino/monomer/pull/218)). +- Use pkg-config for glew linking ([PR #219](https://github.com/fjvallarino/monomer/pull/219)). +- Export dialD_ ([PR #246](https://github.com/fjvallarino/monomer/pull/246)). Thanks @Deltaspace0! + ## 1.5.0.0 ### Added diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,12 +3,12 @@

A cross-platform GUI library for Haskell

- Logo + Logo

- CI badge + CI badge made with Haskell @@ -85,6 +85,10 @@ - Stability and performance. - Mobile support. + +## Useful extensions + +- [Hagrid](https://github.com/Dretch/monomer-hagrid), a flexible datagrid widget. ## Contributing diff --git a/dev-test-app/Main.hs b/dev-test-app/Main.hs new file mode 100644 --- /dev/null +++ b/dev-test-app/Main.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import Control.Lens +import Data.Maybe +import Data.Text (Text) +import Monomer +import TextShow + +import qualified Monomer.Lens as L + +newtype AppModel = AppModel { + _clickCount :: Int +} deriving (Eq, Show) + +data AppEvent + = AppInit + | AppIncrease + deriving (Eq, Show) + +makeLenses 'AppModel + +buildUI + :: WidgetEnv AppModel AppEvent + -> AppModel + -> WidgetNode AppModel AppEvent +buildUI wenv model = widgetTree where + widgetTree = vstack [ + label "Hello world", + spacer, + hstack [ + label $ "Click count: " <> showt (model ^. clickCount), + spacer, + button "Increase count" AppIncrease + ] + ] `styleBasic` [padding 10] + +handleEvent + :: WidgetEnv AppModel AppEvent + -> WidgetNode AppModel AppEvent + -> AppModel + -> AppEvent + -> [AppEventResponse AppModel AppEvent] +handleEvent wenv node model evt = case evt of + AppInit -> [] + AppIncrease -> [Model (model & clickCount +~ 1)] + +main :: IO () +main = do + startApp model handleEvent buildUI config + where + config = [ + appWindowTitle "Dev test app", + appWindowIcon "./assets/images/icon.png", + appTheme darkTheme, + appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", + appInitEvent AppInit + ] + model = AppModel 0 diff --git a/examples/tutorial/Tutorial02_Styling.hs b/examples/tutorial/Tutorial02_Styling.hs --- a/examples/tutorial/Tutorial02_Styling.hs +++ b/examples/tutorial/Tutorial02_Styling.hs @@ -68,7 +68,8 @@ titleText "Font color", hstack [ labeledCheckbox "Show color picker " showPicker, - filler + filler, + colorPopup fontColor ] `styleBasic` [paddingT 10, paddingB 5], colorPicker fontColor `nodeVisible` (model ^. showPicker) 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.5.0.0 +version: 1.5.1.0 synopsis: A GUI library for writing native Haskell applications. description: Monomer is an easy to use, cross platform, GUI library for writing native Haskell applications. @@ -31,6 +31,10 @@ type: git location: https://github.com/fjvallarino/monomer +flag examples + manual: True + default: False + library exposed-modules: Monomer @@ -107,6 +111,7 @@ Monomer.Widgets.Singles.Button Monomer.Widgets.Singles.Checkbox Monomer.Widgets.Singles.ColorPicker + Monomer.Widgets.Singles.ColorPopup Monomer.Widgets.Singles.DateField Monomer.Widgets.Singles.Dial Monomer.Widgets.Singles.ExternalLink @@ -154,6 +159,8 @@ cbits/dpi.c cbits/fontmanager.c cbits/glew.c + pkgconfig-depends: + glew build-tools: c2hs build-depends: @@ -177,18 +184,18 @@ , sdl2 >=2.5.0 && <2.6 , stm ==2.5.* , text >=1.2 && <2.1 - , text-show >=3.7 && <3.10 + , text-show >=3.7 && <3.12 , time >=1.8 && <1.16 , transformers >=0.5 && <0.7 , vector >=0.12 && <0.14 , wreq >=0.5.2 && <0.6 + default-language: Haskell2010 if os(windows) extra-libraries: glew32 else extra-libraries: GLEW - default-language: Haskell2010 executable books main-is: Main.hs @@ -223,13 +230,55 @@ , sdl2 >=2.5.0 && <2.6 , stm ==2.5.* , text >=1.2 && <2.1 - , text-show >=3.7 && <3.10 + , text-show >=3.7 && <3.12 , time >=1.8 && <1.16 , transformers >=0.5 && <0.7 , vector >=0.12 && <0.14 , wreq >=0.5.2 && <0.6 default-language: Haskell2010 + if flag(examples) + buildable: True + else + buildable: False +executable dev-test-app + main-is: Main.hs + other-modules: + Paths_monomer + hs-source-dirs: + dev-test-app + default-extensions: + OverloadedStrings + ghc-options: -threaded + build-depends: + JuicyPixels >=3.2.9 && <3.5 + , OpenGLRaw ==3.3.* + , async >=2.1 && <2.3 + , attoparsec >=0.12 && <0.15 + , base >=4.11 && <5 + , bytestring >=0.10 && <0.12 + , bytestring-to-vector ==0.3.* + , containers >=0.5.11 && <0.7 + , data-default >=0.5 && <0.8 + , exceptions ==0.10.* + , extra >=1.6 && <1.9 + , formatting >=6.0 && <8.0 + , http-client >=0.6 && <0.9 + , lens >=4.16 && <6 + , monomer + , mtl >=2.1 && <2.3 + , nanovg >=0.8.1 && <1.0 + , process ==1.6.* + , sdl2 >=2.5.0 && <2.6 + , stm ==2.5.* + , text >=1.2 && <2.1 + , text-show >=3.7 && <3.12 + , time >=1.8 && <1.16 + , transformers >=0.5 && <0.7 + , vector >=0.12 && <0.14 + , wreq >=0.5.2 && <0.6 + default-language: Haskell2010 + executable generative main-is: Main.hs other-modules: @@ -265,12 +314,16 @@ , sdl2 >=2.5.0 && <2.6 , stm ==2.5.* , text >=1.2 && <2.1 - , text-show >=3.7 && <3.10 + , text-show >=3.7 && <3.12 , time >=1.8 && <1.16 , transformers >=0.5 && <0.7 , vector >=0.12 && <0.14 , wreq >=0.5.2 && <0.6 default-language: Haskell2010 + if flag(examples) + buildable: True + else + buildable: False executable opengl main-is: Main.hs @@ -305,12 +358,16 @@ , sdl2 >=2.5.0 && <2.6 , stm ==2.5.* , text >=1.2 && <2.1 - , text-show >=3.7 && <3.10 + , text-show >=3.7 && <3.12 , time >=1.8 && <1.16 , transformers >=0.5 && <0.7 , vector >=0.12 && <0.14 , wreq >=0.5.2 && <0.6 default-language: Haskell2010 + if flag(examples) + buildable: True + else + buildable: False executable ticker main-is: Main.hs @@ -346,7 +403,7 @@ , sdl2 >=2.5.0 && <2.6 , stm ==2.5.* , text >=1.2 && <2.1 - , text-show >=3.7 && <3.10 + , text-show >=3.7 && <3.12 , time >=1.8 && <1.16 , transformers >=0.5 && <0.7 , vector >=0.12 && <0.14 @@ -354,6 +411,10 @@ , wreq >=0.5.2 && <0.6 , wuss >=1.1 && <2.3 default-language: Haskell2010 + if flag(examples) + buildable: True + else + buildable: False executable todo main-is: Main.hs @@ -387,12 +448,16 @@ , sdl2 >=2.5.0 && <2.6 , stm ==2.5.* , text >=1.2 && <2.1 - , text-show >=3.7 && <3.10 + , text-show >=3.7 && <3.12 , time >=1.8 && <1.16 , transformers >=0.5 && <0.7 , vector >=0.12 && <0.14 , wreq >=0.5.2 && <0.6 default-language: Haskell2010 + if flag(examples) + buildable: True + else + buildable: False executable tutorial main-is: Main.hs @@ -434,12 +499,16 @@ , sdl2 >=2.5.0 && <2.6 , stm ==2.5.* , text >=1.2 && <2.1 - , text-show >=3.7 && <3.10 + , text-show >=3.7 && <3.12 , time >=1.8 && <1.16 , transformers >=0.5 && <0.7 , vector >=0.12 && <0.14 , wreq >=0.5.2 && <0.6 default-language: Haskell2010 + if flag(examples) + buildable: True + else + buildable: False test-suite monomer-test type: exitcode-stdio-1.0 @@ -523,7 +592,7 @@ , sdl2 >=2.5.0 && <2.6 , stm ==2.5.* , text >=1.2 && <2.1 - , text-show >=3.7 && <3.10 + , text-show >=3.7 && <3.12 , time >=1.8 && <1.16 , transformers >=0.5 && <0.7 , vector >=0.12 && <0.14 diff --git a/src/Monomer/Core/Combinators.hs b/src/Monomer/Core/Combinators.hs --- a/src/Monomer/Core/Combinators.hs +++ b/src/Monomer/Core/Combinators.hs @@ -6,7 +6,7 @@ Stability : experimental Portability : non-portable -Combinator typeclasses used for style and widget configutation. The reason for +Combinator typeclasses used for style and widget configuration. The reason for using typeclasses is for the ability to reuse names such as onClick. Boolean combinators in general have two versions: @@ -14,7 +14,7 @@ - combinatorName: uses the default value, normally True, and is derived from the combinator with _ suffix. - combinatorName_: receives a boolean parameter. This is the function that needs -to be overriden in widgets. +to be overridden in widgets. -} {-# LANGUAGE FunctionalDependencies #-} @@ -303,7 +303,7 @@ class CmbFitHeight t where fitHeight :: t --- | Either fitWidth or fitHeight such that image does not overflow viewport +-- | Either fitWidth or fitHeight such that image does not overflow viewport. class CmbFitEither t where fitEither :: t @@ -350,7 +350,7 @@ class CmbThumbRadius t where thumbRadius :: Double -> t --- | Whether the thumb is visible, for example in a scroll. +-- | Whether the thumb is visible, for example in a slider. class CmbThumbVisible t where thumbVisible :: t thumbVisible = thumbVisible_ True @@ -615,7 +615,7 @@ Basic style combinator, mainly used infix with widgets. Represents the default style of a widget. It serves as the base for all the -other style states when an attribute is not overriden. +other style states when an attribute is not overridden. -} class CmbStyleBasic t where -- | Merges the new basic style states with the existing ones. @@ -746,7 +746,7 @@ alignLeft = alignLeft_ True alignLeft_ :: Bool -> t --- | Align object to the center (not text). +-- | Align object to the horizontal center (not text). class CmbAlignCenter t where alignCenter :: t alignCenter = alignCenter_ True @@ -764,7 +764,7 @@ alignTop = alignTop_ True alignTop_ :: Bool -> t --- | Align object to the middle (not text). +-- | Align object to the vertical middle (not text). class CmbAlignMiddle t where alignMiddle :: t alignMiddle = alignMiddle_ True diff --git a/src/Monomer/Core/StyleTypes.hs b/src/Monomer/Core/StyleTypes.hs --- a/src/Monomer/Core/StyleTypes.hs +++ b/src/Monomer/Core/StyleTypes.hs @@ -77,7 +77,7 @@ - Focus-Hover: The widget has keyboard focus and mouse is on top. Without this state one of Hover or Focus would take precedence and it would not be possible to specify the desired behavior. -- Active: The mouse button is currently presed and the pointer is within the +- Active: The mouse button is currently pressed and the pointer is within the boundaries of the widget. - Disabled: The widget is disabled. -} 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 @@ -42,7 +42,9 @@ subtractBorder, subtractPadding, subtractBorderFromRadius, - mapStyleStates + mapStyleStates, + borderWidths, + radiusWidths ) where import Control.Lens @@ -276,7 +278,7 @@ (bl, br, bt, bb) = borderWidths border nRect = subtractFromRect rect bl br bt bb --- | Subbtracts padding from the given rect. +-- | Subtracts padding from the given rect. subtractPadding :: Rect -> Maybe Padding -> Maybe Rect subtractPadding rect Nothing = Just rect subtractPadding rect (Just (Padding l r t b)) = nRect where @@ -338,6 +340,14 @@ br = maybe 0 _bsWidth (_brdRight border) bt = maybe 0 _bsWidth (_brdTop border) bb = maybe 0 _bsWidth (_brdBottom border) + +radiusWidths :: Maybe Radius -> (Double, Double, Double, Double) +radiusWidths Nothing = (0, 0, 0, 0) +radiusWidths (Just radius) = (btl, btr, bbl, bbr) where + btl = maybe 0 _rcrWidth (_radTopLeft radius) + btr = maybe 0 _rcrWidth (_radTopRight radius) + bbl = maybe 0 _rcrWidth (_radBottomLeft radius) + bbr = maybe 0 _rcrWidth (_radBottomRight radius) mergeNodeStyleState :: Lens' Style (Maybe StyleState) diff --git a/src/Monomer/Core/ThemeTypes.hs b/src/Monomer/Core/ThemeTypes.hs --- a/src/Monomer/Core/ThemeTypes.hs +++ b/src/Monomer/Core/ThemeTypes.hs @@ -58,6 +58,7 @@ _thsShadowAlignV :: AlignV, _thsBtnStyle :: StyleState, _thsBtnMainStyle :: StyleState, + _thsColorPopupStyle :: StyleState, _thsCheckboxStyle :: StyleState, _thsCheckboxWidth :: Double, _thsDateFieldStyle :: StyleState, @@ -118,6 +119,7 @@ _thsShadowAlignV = ABottom, _thsBtnStyle = def, _thsBtnMainStyle = def, + _thsColorPopupStyle = def, _thsCheckboxStyle = def, _thsCheckboxWidth = 20, _thsDateFieldStyle = def, @@ -178,6 +180,7 @@ _thsShadowAlignV = _thsShadowAlignV t2, _thsBtnStyle = _thsBtnStyle t1 <> _thsBtnStyle t2, _thsBtnMainStyle = _thsBtnMainStyle t1 <> _thsBtnMainStyle t2, + _thsColorPopupStyle = _thsColorPopupStyle t1 <> _thsColorPopupStyle t2, _thsCheckboxStyle = _thsCheckboxStyle t1 <> _thsCheckboxStyle t2, _thsCheckboxWidth = _thsCheckboxWidth t2, _thsDateFieldStyle = _thsDateFieldStyle t1 <> _thsDateFieldStyle t2, 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 @@ -140,6 +140,11 @@ & L.fontSize ?~ FontSize 20 & L.fontSpaceV ?~ FontSpace 2 +colorPopupStyle :: BaseThemeColors -> StyleState +colorPopupStyle themeMod = popupStyle where + sectionBg = sectionColor themeMod + popupStyle = mconcat [width 400, padding 10, bgColor sectionBg, radius 4] + dialogMsgBodyFont :: BaseThemeColors -> TextStyle dialogMsgBodyFont themeMod = fontStyle where fontStyle = normalFont @@ -226,6 +231,7 @@ & L.shadowColor .~ shadow themeMod & L.btnStyle .~ btnStyle themeMod & L.btnMainStyle .~ btnMainStyle themeMod + & L.colorPopupStyle .~ colorPopupStyle themeMod & L.checkboxWidth .~ 20 & L.checkboxStyle . L.fgColor ?~ inputFgBasic themeMod & L.checkboxStyle . L.hlColor ?~ inputHlBasic themeMod 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 @@ -301,7 +301,7 @@ {-| Similar to RunTask, but can generate unlimited messages. This is useful for WebSockets and similar data sources. It receives a function that with which to -send messagess to the producer owner. +send messages to the producer owner. -} isRunProducer :: WidgetRequest s e -> Bool isRunProducer RunProducer{} = True 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 @@ -40,7 +40,7 @@ {-| Time expressed in milliseconds. Useful for representing the time of events, -length of intervals, start time of the application and ellapsed time since its +length of intervals, start time of the application and elapsed time since its start. It can be converted from/to other numeric types using the standard functions. @@ -313,7 +313,7 @@ _weDpr :: Double, -- | The timestamp in milliseconds when the application started. _weAppStartTs :: Millisecond, - -- | Provides helper funtions for calculating text size. + -- | Provides helper functions for calculating text size. _weFontManager :: FontManager, -- | Returns the node info, and its parents', given a path from root. _weFindBranchByPath :: Path -> Seq WidgetNodeInfo, @@ -329,10 +329,12 @@ _weWidgetShared :: MVar (Map Text WidgetShared), {-| The active map of WidgetKey -> WidgetNode, if any. This map is restricted to - to the parent "Monomer.Widgets.Composite". Do not use this map directly, rely - instead on the 'Monomer.Core.Util.widgetIdFromKey', - 'Monomer.Core.Util.nodeInfoFromKey' and 'Monomer.Core.Util.nodeInfoFromPath' - utility functions. + to the parent "Monomer.Widgets.Composite". + + It is recommended to not use this map directly, since `WidgetNodeInfo` may be + stale (path and widgetId are always valid). Because of this it is safer to use + the 'Monomer.Core.Util.widgetIdFromKey', 'Monomer.Core.Util.nodeInfoFromKey' + and 'Monomer.Core.Util.nodeInfoFromPath' utility functions. -} _weWidgetKeyMap :: WidgetKeyMap s e, -- | The currently hovered path, if any. diff --git a/src/Monomer/Event/Core.hs b/src/Monomer/Event/Core.hs --- a/src/Monomer/Event/Core.hs +++ b/src/Monomer/Event/Core.hs @@ -36,6 +36,7 @@ isActionEvent SDL.MouseButtonEvent{} = True isActionEvent SDL.MouseWheelEvent{} = True isActionEvent SDL.KeyboardEvent{} = True +isActionEvent SDL.TextEditingEvent{} = True isActionEvent SDL.TextInputEvent{} = True isActionEvent _ = False diff --git a/src/Monomer/Event/Types.hs b/src/Monomer/Event/Types.hs --- a/src/Monomer/Event/Types.hs +++ b/src/Monomer/Event/Types.hs @@ -110,7 +110,7 @@ -- the main mouse button has been pressed. | Leave Point -- | A drag action is active and the mouse is inside the current viewport. The - -- messsage can be used to decide if it applies to the current widget. This + -- message can be used to decide if it applies to the current widget. This -- event is not received by the widget which initiated the drag action, even -- if dragging over it. | Drag Point Path WidgetDragMsg diff --git a/src/Monomer/Event/Util.hs b/src/Monomer/Event/Util.hs --- a/src/Monomer/Event/Util.hs +++ b/src/Monomer/Event/Util.hs @@ -37,7 +37,7 @@ import Monomer.Event.Keyboard import Monomer.Event.Types --- | Checks if Winddows/Cmd key is pressed. +-- | Checks if Windows/Cmd key is pressed. isGUIPressed :: KeyMod -> Bool isGUIPressed mod = _kmLeftGUI mod || _kmRightGUI mod @@ -118,7 +118,7 @@ isOnDrop Drop{} = True isOnDrop _ = False --- | Appplies a provided function to test a KeyAction event +-- | Applies a provided function to test a KeyAction event checkKeyboard :: SystemEvent -> (KeyMod -> KeyCode -> KeyStatus -> Bool) -> Bool checkKeyboard (KeyAction mod code motion) testFn = testFn mod code motion checkKeyboard _ _ = False diff --git a/src/Monomer/Graphics/NanoVGRenderer.hs b/src/Monomer/Graphics/NanoVGRenderer.hs --- a/src/Monomer/Graphics/NanoVGRenderer.hs +++ b/src/Monomer/Graphics/NanoVGRenderer.hs @@ -217,7 +217,7 @@ setPathWinding winding = do VG.pathWinding c cwinding where - cwinding = if winding == CW then 0 else 1 + cwinding = if winding == CW then 2 else 1 -- Strokes stroke = diff --git a/src/Monomer/Graphics/Text.hs b/src/Monomer/Graphics/Text.hs --- a/src/Monomer/Graphics/Text.hs +++ b/src/Monomer/Graphics/Text.hs @@ -121,7 +121,7 @@ | ellipsisReq = addEllipsisToTextLine fontMgr style cw <$> firstLine | otherwise = clipTextLine fontMgr style trim cw <$> firstLine --- | Fits a single line of text to the given width, potencially spliting into +-- | Fits a single line of text to the given width, potentially splitting into -- several lines. fitTextToWidth :: FontManager -- ^ The fontManager. diff --git a/src/Monomer/Graphics/Types.hs b/src/Monomer/Graphics/Types.hs --- a/src/Monomer/Graphics/Types.hs +++ b/src/Monomer/Graphics/Types.hs @@ -172,7 +172,7 @@ | MultiLine deriving (Eq, Show, Generic) --- | Text flags for trimming or keeping sapces. +-- | Text flags for trimming or keeping spaces. data TextTrim = TrimSpaces | KeepSpaces diff --git a/src/Monomer/Lens.hs b/src/Monomer/Lens.hs --- a/src/Monomer/Lens.hs +++ b/src/Monomer/Lens.hs @@ -6,7 +6,7 @@ Stability : experimental Portability : non-portable -Module grouping all the diferent lens modules. Useful import to avoid duplicate +Module grouping all the different lens modules. Useful import to avoid duplicate instance errors. -} module Monomer.Lens ( 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 @@ -28,7 +28,8 @@ import Control.Monad.State import Control.Monad.STM (atomically) import Data.Default -import Data.Maybe +import Data.Either (isLeft) +import Data.Maybe (fromMaybe) import Data.Map (Map) import Data.List (foldl') import Data.Text (Text) @@ -114,7 +115,7 @@ let monomerCtx = initMonomerCtx window channel vpSize dpr epr model runStateT (runAppLoop window glCtx channel appWidget config) monomerCtx - detroySDLWindow window + destroySDLWindow window where config = mconcat configs compCfgs @@ -254,7 +255,7 @@ mainLoop window fontManager config loopArgs = do let MainLoopArgs{..} = loopArgs - startTs <- getEllapsedTimestampSince _mlAppStartTs + startTs <- getElapsedTimestampSince _mlAppStartTs events <- SDL.pumpEvents >> SDL.pollEvents windowSize <- use L.windowSize @@ -270,6 +271,7 @@ inputStatus <- use L.inputStatus mousePos <- liftIO $ getCurrentMousePos epr currWinSize <- liftIO $ getViewportSize window dpr + prevRenderNeeded <- use L.renderRequested let Size rw rh = windowSize let ts = startTs - _mlFrameStartTs @@ -331,6 +333,8 @@ | otherwise = Seq.Empty let baseStep = (wenv, _mlWidgetRoot, Seq.empty) + L.renderRequested .= False + (rqWenv, rqRoot, _) <- handleRequests baseReqs baseStep (wtWenv, wtRoot, _) <- handleWidgetTasks rqWenv rqRoot (seWenv, seRoot, _) <- handleSystemEvents wtWenv wtRoot baseSystemEvents @@ -341,18 +345,18 @@ handleResizeWidgets (seWenv, seRoot, Seq.empty) else return (seWenv, seRoot, Seq.empty) - endTs <- getEllapsedTimestampSince _mlAppStartTs + endTs <- getElapsedTimestampSince _mlAppStartTs -- Rendering renderCurrentReq <- checkRenderCurrent startTs _mlLatestRenderTs - - let renderEvent = any isActionEvent eventsPayload - let winRedrawEvt = windowResized || windowExposed - let renderNeeded = winRedrawEvt || renderEvent || renderCurrentReq + renderMethod <- use L.renderMethod - when renderNeeded $ do - renderMethod <- use L.renderMethod + let actionEvt = any isActionEvent eventsPayload + let renderResize = windowResized && (isLinux wenv || isLeft renderMethod) + let windowRenderEvt = renderResize || any isWindowRenderEvent eventsPayload + let renderNeeded = windowRenderEvt || actionEvt || renderCurrentReq + when (prevRenderNeeded || renderNeeded) $ case renderMethod of Right renderChan -> do liftIO . atomically $ writeTChan renderChan (MsgRender newWenv newRoot) @@ -361,9 +365,14 @@ liftIO $ renderWidgets window dpr renderer bgColor newWenv newRoot - -- Used in the next rendering cycle - L.renderRequested .= windowResized + {- + Used in the next rendering cycle. + Temporary workaround: when rendering is needed, make sure to render the next + frame too in order to avoid visual artifacts. + -} + L.renderRequested .= renderNeeded + let fps = realToFrac _mlMaxFps let frameLength = round (1000000 / fps) let remainingMs = endTs - startTs @@ -455,6 +464,7 @@ let newWenv = tmpWenv & L.fontManager .~ fontMgr let color = newWenv ^. L.theme . L.clearColor + renderWidgets window dpr renderer color newWenv newRoot return (RenderState dpr newWenv newRoot) handleRenderMsg window renderer fontMgr state (MsgResize _) = do @@ -564,12 +574,24 @@ isMouseEntered eventsPayload = not status where status = null [ e | e@SDL.WindowGainedMouseFocusEvent {} <- eventsPayload ] +isWindowRenderEvent :: SDL.EventPayload -> Bool +isWindowRenderEvent SDL.WindowShownEvent{} = True +isWindowRenderEvent SDL.WindowExposedEvent{} = True +isWindowRenderEvent SDL.WindowMovedEvent{} = True +isWindowRenderEvent SDL.WindowResizedEvent{} = True +isWindowRenderEvent SDL.WindowSizeChangedEvent{} = True +isWindowRenderEvent SDL.WindowMaximizedEvent{} = True +isWindowRenderEvent SDL.WindowRestoredEvent{} = True +isWindowRenderEvent SDL.WindowGainedMouseFocusEvent{} = True +isWindowRenderEvent SDL.WindowGainedKeyboardFocusEvent{} = True +isWindowRenderEvent _ = False + getCurrentTimestamp :: MonadIO m => m Millisecond getCurrentTimestamp = toMs <$> liftIO getCurrentTime where toMs = floor . (1e3 *) . nominalDiffTimeToSeconds . utcTimeToPOSIXSeconds -getEllapsedTimestampSince :: MonadIO m => Millisecond -> m Millisecond -getEllapsedTimestampSince start = do +getElapsedTimestampSince :: MonadIO m => Millisecond -> m Millisecond +getElapsedTimestampSince start = do ts <- getCurrentTimestamp return (ts - start) 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 @@ -281,7 +281,7 @@ resizeRequests <- use L.resizeRequests paths <- mapM getWidgetIdPath resizeRequests let parts = Set.fromDistinctAscList . drop 1 . toList . Seq.inits - let sets = fold (parts <$> paths) + let sets = foldMap parts paths return (`Set.member` sets) 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 @@ -13,7 +13,7 @@ module Monomer.Main.Platform ( defaultWindowSize, initSDLWindow, - detroySDLWindow, + destroySDLWindow, getCurrentMousePos, getDrawableSize, getWindowSize, @@ -171,8 +171,8 @@ "Failed to set window icon. Does the file exist?\n\t" ++ show err ++ "\n" -- | Destroys the provided window, shutdowns the video subsystem and SDL. -detroySDLWindow :: SDL.Window -> IO () -detroySDLWindow window = do +destroySDLWindow :: SDL.Window -> IO () +destroySDLWindow window = do SDL.destroyWindow window Raw.quitSubSystem Raw.SDL_INIT_VIDEO SDL.quit 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 @@ -80,7 +80,7 @@ } deriving (Eq, Show) {-| -Asychronous widget task. Results must be provided as user defined, Typeable, +Asynchronous widget task. Results must be provided as user defined, Typeable, types. Error handling should be done inside the task and reporting handled as part of the user type. -} 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 @@ -133,3 +133,31 @@ configMaybe :: Monoid a => Maybe b -> (b -> a) -> a configMaybe Nothing _ = mempty configMaybe (Just val) fn = fn val + +{-| +Returns the provided 'EventResponse' when True, otherwise returns a no-op. + +Useful for conditionally returning a response. + +@ +... +_ -> [Model newModel, responseIf isValid (SetFocusOnKey "widgetKey")] +@ +-} +responseIf :: Bool -> EventResponse s e sp ep -> EventResponse s e sp ep +responseIf True resp = resp +responseIf False _ = NoOpResponse + +{-| +Returns the provided 'EventResponse' when 'Just', otherwise returns a no-op. + +Useful for conditionally returning a response. + +@ +... +_ -> [Model newModel, responseMaybe maybeResp] +@ +-} +responseMaybe :: Maybe (EventResponse s e sp ep) -> EventResponse s e sp ep +responseMaybe (Just resp) = resp +responseMaybe Nothing = NoOpResponse diff --git a/src/Monomer/Widgets.hs b/src/Monomer/Widgets.hs --- a/src/Monomer/Widgets.hs +++ b/src/Monomer/Widgets.hs @@ -18,6 +18,7 @@ -- * Containers module Monomer.Widgets.Containers.Alert, module Monomer.Widgets.Containers.Box, + module Monomer.Widgets.Containers.BoxShadow, module Monomer.Widgets.Containers.Confirm, module Monomer.Widgets.Containers.Draggable, module Monomer.Widgets.Containers.Dropdown, @@ -36,6 +37,7 @@ module Monomer.Widgets.Singles.Button, module Monomer.Widgets.Singles.Checkbox, module Monomer.Widgets.Singles.ColorPicker, + module Monomer.Widgets.Singles.ColorPopup, module Monomer.Widgets.Singles.DateField, module Monomer.Widgets.Singles.Dial, module Monomer.Widgets.Singles.ExternalLink, @@ -65,6 +67,7 @@ import Monomer.Widgets.Containers.Alert import Monomer.Widgets.Containers.Box +import Monomer.Widgets.Containers.BoxShadow import Monomer.Widgets.Containers.Confirm import Monomer.Widgets.Containers.Draggable import Monomer.Widgets.Containers.Dropdown @@ -83,6 +86,7 @@ import Monomer.Widgets.Singles.Button import Monomer.Widgets.Singles.Checkbox import Monomer.Widgets.Singles.ColorPicker +import Monomer.Widgets.Singles.ColorPopup import Monomer.Widgets.Singles.DateField import Monomer.Widgets.Singles.Dial import Monomer.Widgets.Singles.ExternalLink diff --git a/src/Monomer/Widgets/Animation/Fade.hs b/src/Monomer/Widgets/Animation/Fade.hs --- a/src/Monomer/Widgets/Animation/Fade.hs +++ b/src/Monomer/Widgets/Animation/Fade.hs @@ -102,21 +102,35 @@ } -- | Animates a widget from not visible state to fully visible. -animFadeIn :: WidgetEvent e => WidgetNode s e -> WidgetNode s e +animFadeIn + :: WidgetEvent e + => WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created animation container. animFadeIn managed = animFadeIn_ def managed -- | Animates a widget from not visible state to fully visible. Accepts config. -animFadeIn_ :: WidgetEvent e => [FadeCfg e] -> WidgetNode s e -> WidgetNode s e +animFadeIn_ + :: WidgetEvent e + => [FadeCfg e] -- ^ The config options. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created animation container. animFadeIn_ configs managed = makeNode "animFadeIn" widget managed where config = mconcat configs widget = makeFade True config def -- | Animates a widget from visible state to not visible. -animFadeOut :: WidgetEvent e => WidgetNode s e -> WidgetNode s e +animFadeOut + :: WidgetEvent e + => WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created animation container. animFadeOut managed = animFadeOut_ def managed -- | Animates a widget from visible state to not visible. Accepts config. -animFadeOut_ :: WidgetEvent e => [FadeCfg e] -> WidgetNode s e -> WidgetNode s e +animFadeOut_ + :: WidgetEvent e + => [FadeCfg e] -- ^ The config options. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created animation container. animFadeOut_ configs managed = makeNode "animFadeOut" widget managed where config = mconcat configs widget = makeFade False config def @@ -143,7 +157,7 @@ period = 20 steps = fromIntegral $ duration `div` period - finishedReq node = delayedMessage node AnimationFinished duration + finishedReq node ts = delayedMessage node (AnimationFinished ts) duration renderReq wenv node = req where widgetId = node ^. L.info . L.widgetId req = RenderEvery widgetId period (Just steps) @@ -153,7 +167,7 @@ newNode = node & L.widget .~ makeFade isFadeIn config (FadeState True ts) result - | autoStart = resultReqs newNode [finishedReq node, renderReq wenv node] + | autoStart = resultReqs newNode [finishedReq node ts, renderReq wenv node] | otherwise = resultNode node merge wenv node oldNode oldState = resultNode newNode where @@ -167,16 +181,17 @@ widgetId = node ^. L.info . L.widgetId ts = wenv ^. L.timestamp startState = FadeState True ts - startReqs = [finishedReq node, renderReq wenv node] + startReqs = [finishedReq node ts, renderReq wenv node] newNode newState = node & L.widget .~ makeFade isFadeIn config newState result = case msg of AnimationStart -> resultReqs (newNode startState) startReqs AnimationStop -> resultReqs (newNode def) [RenderStop widgetId] - AnimationFinished - | _fdsRunning state -> resultEvts node (_fdcOnFinished config) + AnimationFinished ts' + | isRelevant -> resultEvts node (_fdcOnFinished config) | otherwise -> resultNode node + where isRelevant = _fdsRunning state && ts' == _fdsStartTs state render wenv node renderer = do saveContext renderer diff --git a/src/Monomer/Widgets/Animation/Slide.hs b/src/Monomer/Widgets/Animation/Slide.hs --- a/src/Monomer/Widgets/Animation/Slide.hs +++ b/src/Monomer/Widgets/Animation/Slide.hs @@ -21,15 +21,15 @@ module Monomer.Widgets.Animation.Slide ( -- * Configuration SlideCfg, + slideLeft, + slideRight, + slideTop, + slideBottom, -- * Constructors animSlideIn, animSlideIn_, animSlideOut, - animSlideOut_, - slideLeft, - slideRight, - slideTop, - slideBottom + animSlideOut_ ) where import Control.Applicative ((<|>)) @@ -132,23 +132,37 @@ } -- | Animates a widget from the left to fully visible. -animSlideIn :: WidgetEvent e => WidgetNode s e -> WidgetNode s e +animSlideIn + :: WidgetEvent e + => WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created animation container. animSlideIn managed = animSlideIn_ def managed -- | Animates a widget from the provided direction to fully visible (defaults -- to left). Accepts config. -animSlideIn_ :: WidgetEvent e => [SlideCfg e] -> WidgetNode s e -> WidgetNode s e +animSlideIn_ + :: WidgetEvent e + => [SlideCfg e] -- ^ The config options. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created animation container. animSlideIn_ configs managed = makeNode "animSlideIn" widget managed where config = mconcat configs widget = makeSlide True config def -- | Animates a widget to the left from visible to not visible. -animSlideOut :: WidgetEvent e => WidgetNode s e -> WidgetNode s e +animSlideOut + :: WidgetEvent e + => WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created animation container. animSlideOut managed = animSlideOut_ def managed -- | Animates a widget to the the provided direction from visible to not -- visible (defaults to left). Accepts config. -animSlideOut_ :: WidgetEvent e => [SlideCfg e] -> WidgetNode s e -> WidgetNode s e +animSlideOut_ + :: WidgetEvent e + => [SlideCfg e] -- ^ The config options. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created animation container. animSlideOut_ configs managed = makeNode "animSlideOut" widget managed where config = mconcat configs widget = makeSlide False config def @@ -176,7 +190,7 @@ period = 20 steps = fromIntegral $ duration `div` period - finishedReq node = delayedMessage node AnimationFinished duration + finishedReq node ts = delayedMessage node (AnimationFinished ts) duration renderReq wenv node = req where widgetId = node ^. L.info . L.widgetId req = RenderEvery widgetId period (Just steps) @@ -186,7 +200,7 @@ newNode = node & L.widget .~ makeSlide isSlideIn config (SlideState True ts) result - | autoStart = resultReqs newNode [finishedReq node, renderReq wenv node] + | autoStart = resultReqs newNode [finishedReq node ts, renderReq wenv node] | otherwise = resultNode node merge wenv node oldNode oldState = resultNode newNode where @@ -200,16 +214,17 @@ widgetId = node ^. L.info . L.widgetId ts = wenv ^. L.timestamp startState = SlideState True ts - startReqs = [finishedReq node, renderReq wenv node] + startReqs = [finishedReq node ts, renderReq wenv node] newNode newState = node & L.widget .~ makeSlide isSlideIn config newState result = case msg of AnimationStart -> resultReqs (newNode startState) startReqs AnimationStop -> resultReqs (newNode def) [RenderStop widgetId] - AnimationFinished - | _slsRunning state -> resultEvts node (_slcOnFinished config) + AnimationFinished ts' + | isRelevant -> resultEvts node (_slcOnFinished config) | otherwise -> resultNode node + where isRelevant = _slsRunning state && ts' == _slsStartTs state render wenv node renderer = do saveContext renderer diff --git a/src/Monomer/Widgets/Animation/Types.hs b/src/Monomer/Widgets/Animation/Types.hs --- a/src/Monomer/Widgets/Animation/Types.hs +++ b/src/Monomer/Widgets/Animation/Types.hs @@ -10,6 +10,8 @@ -} module Monomer.Widgets.Animation.Types where +import Monomer.Core.WidgetTypes (Millisecond) + -- | Message animation widgets usually support. Controls animation state. data AnimationMsg -- | Starts the animation from the beginning, even if it's running. @@ -20,5 +22,5 @@ Indicates the animation has finished. This is usually generated by the widget itself for clean up. -} - | AnimationFinished + | AnimationFinished Millisecond deriving (Eq, Show) 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 @@ -8,7 +8,7 @@ Composite widget. Main glue between all the other widgets, also acts as the main app widget. Composite allows to split an application into reusable parts without -the need to implement a lower level widget. It can comunicate with its parent +the need to implement a lower level widget. It can communicate with its parent component by reporting events. Requires two functions: @@ -207,6 +207,8 @@ producer crashes without sending a value, composite will not know about it. -} | Producer (ProducerHandler e) + -- | Does nothing. Useful with 'responseIf' and 'responseMaybe' helpers. + | NoOpResponse {-| Configuration options for composite: @@ -626,7 +628,9 @@ reducedResult | useNewRoot = toParentResult comp newState wenv styledComp tmpResult | otherwise = resultNode oldComp - !newResult = handleWidgetIdChange oldComp reducedResult + !newResult = reducedResult + & handleUserSizeReqChange wenv oldComp + & handleWidgetIdChange oldComp -- | Dispose compositeDispose @@ -940,6 +944,7 @@ Message key msg -> Just $ sendMsgTo widgetComp (CompMsgMessage key msg) Task task -> Just $ RunTask widgetId path task Producer producer -> Just $ RunProducer widgetId path producer + NoOpResponse -> Nothing where widgetId = widgetComp ^. L.info . L.widgetId path = widgetComp ^. L.info . L.path 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 @@ -237,7 +237,7 @@ Disposes the current node. Only used by widgets which allocate resources during /init/ or /merge/, and will usually involve requests to the runtime. -An example can be found "Monomer.Widgets.Containers.Dropdown". +An example can be found in "Monomer.Widgets.Containers.Dropdown". -} type ContainerDisposeHandler s e = WidgetEnv s e -- ^ The widget environment. @@ -259,7 +259,7 @@ Returns the currently hovered widget, if any. If the widget is rectangular and uses the full content area, there is not need to override this function. -An example can be found "Monomer.Widgets.Containers.Dropdown". +An example can be found in "Monomer.Widgets.Containers.Dropdown". -} type ContainerFindByPointHandler s e = WidgetEnv s e -- ^ The widget environment. @@ -353,7 +353,7 @@ {-| Renders the widget's content using the given Renderer. In general, this method -needs to be overriden. There are two render methods: one runs before children, +needs to be overridden. There are two render methods: one runs before children, the other one after. Examples can be found in "Monomer.Widgets.Containers.Draggable" and @@ -432,9 +432,9 @@ containerGetSizeReq :: ContainerGetSizeReqHandler s e, -- | Resizes the widget to the provided size. containerResize :: ContainerResizeHandler s e, - -- | Renders the widget's content. This runs before childrens' render. + -- | Renders the widget's content. This runs before children's render. containerRender :: ContainerRenderHandler s e, - -- | Renders the widget's content. This runs after childrens' render. + -- | Renders the widget's content. This runs after children's render. containerRenderAfter :: ContainerRenderHandler s e } @@ -662,11 +662,14 @@ Just (ost, st) -> mergePostHandler wenv mNode oldNode ost st mResult Nothing -> mResult - tmpResult - | isResizeAnyResult (Just postRes) = postRes - & L.node .~ updateSizeReq wenv (postRes ^. L.node) - | otherwise = postRes - newResult = handleWidgetIdChange oldNode tmpResult + tmpResult = postRes + & handleUserSizeReqChange wenv oldNode + & handleWidgetIdChange oldNode + + newResult + | isResizeAnyResult (Just tmpResult) = tmpResult + & L.node .~ updateSizeReq wenv (tmpResult ^. L.node) + | otherwise = tmpResult mergeParent :: WidgetModel a diff --git a/src/Monomer/Widgets/Containers/Alert.hs b/src/Monomer/Widgets/Containers/Alert.hs --- a/src/Monomer/Widgets/Containers/Alert.hs +++ b/src/Monomer/Widgets/Containers/Alert.hs @@ -104,16 +104,16 @@ :: (WidgetModel s, WidgetEvent e) => e -- ^ The event to raise when the dialog is closed. -> WidgetNode () e -- ^ The content to display in the dialog. - -> WidgetNode s e -- ^ The created dialog. + -> WidgetNode s e -- ^ The created dialog. alert evt dialogBody = alert_ evt def dialogBody -- | Creates an alert dialog with the provided content. Accepts config. alert_ :: (WidgetModel s, WidgetEvent e) => e -- ^ The event to raise when the dialog is closed. - -> [AlertCfg] -- ^ The config options for the dialog. + -> [AlertCfg] -- ^ The config options for the dialog. -> WidgetNode () e -- ^ The content to display in the dialog. - -> WidgetNode s e -- ^ The created dialog. + -> WidgetNode s e -- ^ The created dialog. alert_ evt configs dialogBody = newNode where config = mconcat configs createUI = buildUI (const dialogBody) evt config @@ -122,17 +122,17 @@ -- | Creates an alert dialog with a text message as content. alertMsg :: (WidgetModel s, WidgetEvent e) - => Text -- ^ The message to display. - -> e -- ^ The event to raise when the dialog is closed. + => Text -- ^ The message to display. + -> e -- ^ The event to raise when the dialog is closed. -> WidgetNode s e -- ^ The created dialog. alertMsg message evt = alertMsg_ message evt def -- | Creates an alert dialog with a text message as content. Accepts config. alertMsg_ :: (WidgetModel s, WidgetEvent e) - => Text -- ^ The message to display. - -> e -- ^ The event to raise when the dialog is closed. - -> [AlertCfg] -- ^ The config options for the dialog. + => Text -- ^ The message to display. + -> e -- ^ The event to raise when the dialog is closed. + -> [AlertCfg] -- ^ The config options for the dialog. -> WidgetNode s e -- ^ The created dialog. alertMsg_ message evt configs = newNode where config = mconcat configs diff --git a/src/Monomer/Widgets/Containers/Base/LabeledItem.hs b/src/Monomer/Widgets/Containers/Base/LabeledItem.hs --- a/src/Monomer/Widgets/Containers/Base/LabeledItem.hs +++ b/src/Monomer/Widgets/Containers/Base/LabeledItem.hs @@ -46,13 +46,13 @@ -} labeledItem :: WidgetEvent e - => WidgetType - -> RectSide - -> Maybe Double - -> Text - -> LabelCfg s e - -> WidgetNode s e - -> WidgetNode s e + => WidgetType -- ^ The 'WidgetType' of the provided widget. + -> RectSide -- ^ The side of the label. + -> Maybe Double -- ^ The child spacing. + -> Text -- ^ The caption. + -> LabelCfg s e -- ^ The config options. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created stack. labeledItem wtype textSide childSpacing caption labelCfg itemNode = labeledNode where widget = makeLabeledItem textSide childSpacing caption labelCfg itemNode labeledNode = defaultWidgetNode wtype widget diff --git a/src/Monomer/Widgets/Containers/Box.hs b/src/Monomer/Widgets/Containers/Box.hs --- a/src/Monomer/Widgets/Containers/Box.hs +++ b/src/Monomer/Widgets/Containers/Box.hs @@ -55,11 +55,11 @@ module Monomer.Widgets.Containers.Box ( -- * Configuration BoxCfg, + expandContent, + boxFilterEvent, -- * Constructors box, - box_, - expandContent, - boxFilterEvent + box_ ) where import Control.Applicative ((<|>)) @@ -94,12 +94,24 @@ - 'alignCenter': aligns the inner widget to the horizontal center. - 'alignRight': aligns the inner widget to the right. - 'alignTop': aligns the inner widget to the top. -- 'alignMiddle': aligns the inner widget to the left. +- 'alignMiddle': aligns the inner widget to the vertical middle. - 'alignBottom': aligns the inner widget to the bottom. +- '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. +- 'onEnter': on mouse enter event. +- 'onEnterReq': generates a WidgetRequest on mouse enter. +- 'onLeave': on mouse leave event. +- 'onLeaveReq': generates a WidgetRequest on mouse leave. - 'onClick': click event. - 'onClickReq': generates a WidgetRequest on click. - 'onClickEmpty': click event on empty area. - 'onClickEmptyReq': generates a WidgetRequest on click in empty area. +- 'onBtnPressed': on button pressed event. +- 'onBtnPressedReq': generates a WidgetRequest when button is pressed. +- 'onBtnReleased': on button released event. +- 'onBtnReleasedReq': generates a WidgetRequest when button is released. - 'expandContent': if the inner widget should use all the available space. To be able to use alignment options, this must be False (the default). - 'boxFilterEvent': allows filtering or modifying a 'SystemEvent'. @@ -314,15 +326,18 @@ } -- | Creates a box widget with a single node as child. -box :: (WidgetModel s, WidgetEvent e) => WidgetNode s e -> WidgetNode s e +box + :: (WidgetModel s, WidgetEvent e) + => WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created box container. box managed = box_ def managed -- | Creates a box widget with a single node as child. Accepts config. box_ :: (WidgetModel s, WidgetEvent e) - => [BoxCfg s e] - -> WidgetNode s e - -> WidgetNode s e + => [BoxCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created box container. box_ configs managed = makeNode (makeBox config state) managed where config = mconcat configs state = BoxState Nothing diff --git a/src/Monomer/Widgets/Containers/Confirm.hs b/src/Monomer/Widgets/Containers/Confirm.hs --- a/src/Monomer/Widgets/Containers/Confirm.hs +++ b/src/Monomer/Widgets/Containers/Confirm.hs @@ -72,7 +72,7 @@ - 'titleCaption': the title of the alert dialog. - 'acceptCaption': the caption of the accept button. -- 'closeCaption': the caption of the close button. +- 'cancelCaption': the caption of the cancel button. -} data ConfirmCfg = ConfirmCfg { _cfcTitle :: Maybe Text, @@ -132,7 +132,7 @@ confirm acceptEvt cancelEvt dialogBody = newNode where newNode = confirm_ acceptEvt cancelEvt def dialogBody --- | Creates an alert dialog with the provided content. Accepts config. +-- | Creates a confirm dialog with the provided content. Accepts config. confirm_ :: (WidgetModel s, WidgetEvent e) => e -- ^ The accept button event. @@ -146,7 +146,7 @@ compCfg = [compositeMergeReqs mergeReqs] newNode = compositeD_ "confirm" (WidgetValue ()) createUI handleEvent compCfg --- | Creates an alert dialog with a text message as content. +-- | Creates a confirm dialog with a text message as content. confirmMsg :: (WidgetModel s, WidgetEvent e) => Text -- ^ The message to display in the dialog. @@ -155,7 +155,7 @@ -> WidgetNode s e -- ^ The created dialog. confirmMsg msg acceptEvt cancelEvt = confirmMsg_ msg acceptEvt cancelEvt def --- | Creates an alert dialog with a text message as content. Accepts config. +-- | Creates a confirm dialog with a text message as content. Accepts config. confirmMsg_ :: (WidgetModel s, WidgetEvent e) => Text -- ^ The message to display in the dialog. diff --git a/src/Monomer/Widgets/Containers/Draggable.hs b/src/Monomer/Widgets/Containers/Draggable.hs --- a/src/Monomer/Widgets/Containers/Draggable.hs +++ b/src/Monomer/Widgets/Containers/Draggable.hs @@ -125,16 +125,20 @@ } -- | Creates a draggable container with a single node as child. -draggable :: DragMsg a => a -> WidgetNode s e -> WidgetNode s e +draggable + :: DragMsg a + => a -- ^ The identifying value. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created draggable container. draggable msg managed = draggable_ msg def managed -- | Creates a draggable container with a single node as child. Accepts config. draggable_ :: DragMsg a - => a - -> [DraggableCfg s e] - -> WidgetNode s e - -> WidgetNode s e + => a -- ^ The identifying value. + -> [DraggableCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created draggable container. draggable_ msg configs managed = makeNode widget managed where config = mconcat configs widget = makeDraggable msg config diff --git a/src/Monomer/Widgets/Containers/DropTarget.hs b/src/Monomer/Widgets/Containers/DropTarget.hs --- a/src/Monomer/Widgets/Containers/DropTarget.hs +++ b/src/Monomer/Widgets/Containers/DropTarget.hs @@ -78,17 +78,20 @@ -- | Creates a drop target container with a single node as child. dropTarget - :: (DragMsg a, WidgetEvent e) => (a -> e) -> WidgetNode s e -> WidgetNode s e + :: (DragMsg a, WidgetEvent e) + => (a -> e) -- ^ The event to raise on drop. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created drop target container. dropTarget dropEvt managed = dropTarget_ dropEvt def managed -- | Creates a drop target container with a single node as child. Accepts -- config. dropTarget_ :: (DragMsg a, WidgetEvent e) - => (a -> e) - -> [DropTargetCfg] - -> WidgetNode s e - -> WidgetNode s e + => (a -> e) -- ^ The event to raise on drop. + -> [DropTargetCfg] -- ^ The config options. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created drop target container. dropTarget_ dropEvt configs managed = makeNode widget managed where config = mconcat configs widget = makeDropTarget dropEvt config diff --git a/src/Monomer/Widgets/Containers/Grid.hs b/src/Monomer/Widgets/Containers/Grid.hs --- a/src/Monomer/Widgets/Containers/Grid.hs +++ b/src/Monomer/Widgets/Containers/Grid.hs @@ -88,22 +88,36 @@ } -- | Creates a grid of items with the same width. -hgrid :: Traversable t => t (WidgetNode s e) -> WidgetNode s e +hgrid + :: Traversable t + => t (WidgetNode s e) -- ^ The list of items. + -> WidgetNode s e -- ^ The created grid. hgrid children = hgrid_ def children -- | Creates a grid of items with the same width. Accepts config. -hgrid_ :: Traversable t => [GridCfg] -> t (WidgetNode s e) -> WidgetNode s e +hgrid_ + :: Traversable t + => [GridCfg] -- ^ The config options. + -> t (WidgetNode s e) -- ^ The list of items. + -> WidgetNode s e -- ^ The created grid. hgrid_ configs children = newNode where config = mconcat configs newNode = defaultWidgetNode "hgrid" (makeFixedGrid True config) & L.children .~ foldl' (|>) Empty children -- | Creates a grid of items with the same height. -vgrid :: Traversable t => t (WidgetNode s e) -> WidgetNode s e +vgrid + :: Traversable t + => t (WidgetNode s e) -- ^ The list of items. + -> WidgetNode s e -- ^ The created grid. vgrid children = vgrid_ def children -- | Creates a grid of items with the same height. Accepts config. -vgrid_ :: Traversable t => [GridCfg] -> t (WidgetNode s e) -> WidgetNode s e +vgrid_ + :: Traversable t + => [GridCfg] -- ^ The config options. + -> t (WidgetNode s e) -- ^ The list of items. + -> WidgetNode s e -- ^ The created grid. vgrid_ configs children = newNode where config = mconcat configs newNode = defaultWidgetNode "vgrid" (makeFixedGrid False config) @@ -127,12 +141,12 @@ newSizeReqH = getDimSizeReq isVertical (_wniSizeReqH . _wnInfo) vchildren newSizeReq = applyFnList sizeReqFns (newSizeReqW, newSizeReqH) - getDimSizeReq mainAxis accesor vchildren + getDimSizeReq mainAxis accessor vchildren | Seq.null vreqs = fixedSize 0 | mainAxis = foldl1 sizeReqMergeSum (Seq.replicate nreqs maxSize) & L.fixed %~ (+ totalSpacing) | otherwise = maxSize where - vreqs = accesor <$> vchildren + vreqs = accessor <$> vchildren nreqs = Seq.length vreqs ~maxSize = foldl1 sizeReqMergeMax vreqs totalSpacing = fromIntegral (nreqs - 1) * childSpacing 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 @@ -163,16 +163,20 @@ makeLensesWith abbreviatedFields ''KeyStrokeState -- | Creates a keystroke container with a single node as child. -keystroke :: WidgetEvent e => [(Text, e)] -> WidgetNode s e -> WidgetNode s e +keystroke + :: WidgetEvent e + => [(Text, e)] -- ^ The list of key combinations and events. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created keystroke container. keystroke bindings managed = keystroke_ bindings def managed -- | Creates a keystroke container with a single node as child. Accepts config, keystroke_ :: WidgetEvent e - => [(Text, e)] - -> [KeystrokeCfg] - -> WidgetNode s e - -> WidgetNode s e + => [(Text, e)] -- ^ The list of key combinations and events. + -> [KeystrokeCfg] -- ^ The config options. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created keystroke container. keystroke_ bindings configs managed = makeNode widget managed where config = mconcat configs newBindings = fmap (first textToStroke) bindings diff --git a/src/Monomer/Widgets/Containers/Popup.hs b/src/Monomer/Widgets/Containers/Popup.hs --- a/src/Monomer/Widgets/Containers/Popup.hs +++ b/src/Monomer/Widgets/Containers/Popup.hs @@ -11,7 +11,7 @@ In addition to the content that is displayed when open, a popup requires a boolean lens or value to indicate if the content should be visible. This flag -can be used to programatically open/close the popup. The popup can also be +can be used to programmatically open/close the popup. The popup can also be closed by clicking outside its content. In general, it is a good idea to set a background color to the top level content @@ -138,9 +138,9 @@ - 'popupDisableClose': do not close the popup when clicking outside the content. - 'alignLeft': left align relative to the widget location or main window. - 'alignRight': right align relative to the widget location or main window. -- 'alignCenter': center align relative to the widget location or main window. +- 'alignCenter': horizontal center align relative to the widget location or main window. - 'alignTop': top align relative to the widget location or main window. -- 'alignMiddle': middle align relative to the widget location or main window. +- 'alignMiddle': vertical middle align relative to the widget location or main window. - 'alignBottom': bottom align relative to the widget location or main window. - 'onChange': event to raise when the popup is opened/closed. - 'onChangeReq': 'WidgetRequest' to generate when the popup is opened/closed. @@ -246,7 +246,7 @@ _ppcAnchor = Just node } -{- +{-| Align the popup to the horizontal outer edges of the anchor. It only works with 'alignLeft' and 'alignRight', which need to be specified separately. @@ -267,7 +267,7 @@ _ppcAlignToOuterH = Just align } -{- +{-| Align the popup vertically to the outer edges of the anchor. It only works with 'alignTop' and 'alignBottom', which need to be specified separately. @@ -335,9 +335,9 @@ -- | Creates a popup with the given lens to determine its visibility. popup :: WidgetModel s - => ALens' s Bool - -> WidgetNode s e - -> WidgetNode s e + => ALens' s Bool -- ^ The lens into the model. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created popup. popup field content = popup_ field def content {-| @@ -345,10 +345,10 @@ -} popup_ :: WidgetModel s - => ALens' s Bool - -> [PopupCfg s e] - -> WidgetNode s e - -> WidgetNode s e + => ALens' s Bool -- ^ The lens into the model. + -> [PopupCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created popup. popup_ field configs content = newNode where newNode = popupD_ (WidgetLens field) configs content @@ -358,10 +358,10 @@ -} popupV :: (WidgetModel s, WidgetEvent e) - => Bool - -> (Bool -> e) - -> WidgetNode s e - -> WidgetNode s e + => Bool -- ^ The current value. + -> (Bool -> e) -- ^ The event to raise on change. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created popup. popupV value handler content = popupV_ value handler def content {-| @@ -370,11 +370,11 @@ -} popupV_ :: (WidgetModel s, WidgetEvent e) - => Bool - -> (Bool -> e) - -> [PopupCfg s e] - -> WidgetNode s e - -> WidgetNode s e + => Bool -- ^ The current value. + -> (Bool -> e) -- ^ The event to raise on change. + -> [PopupCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created popup. popupV_ value handler configs content = newNode where newConfigs = onChange handler : configs newNode = popupD_ (WidgetValue value) newConfigs content @@ -385,10 +385,10 @@ -} popupD_ :: WidgetModel s - => WidgetData s Bool - -> [PopupCfg s e] - -> WidgetNode s e - -> WidgetNode s e + => WidgetData s Bool -- ^ The 'WidgetData' to retrieve the value from. + -> [PopupCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created popup. popupD_ wdata configs content = makeNode widget anchor content where config = mconcat configs state = PopupState def (-1) 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 @@ -363,33 +363,48 @@ deriving (Eq, Show) -- | Creates a scroll node that may show both bars. -scroll :: WidgetNode s e -> WidgetNode s e +scroll + :: WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created scroll. scroll managedWidget = scroll_ def managedWidget -- | Creates a scroll node that may show both bars. Accepts config. -scroll_ :: [ScrollCfg s e] -> WidgetNode s e -> WidgetNode s e +scroll_ + :: [ScrollCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created scroll. scroll_ configs managed = makeNode (makeScroll config def) managed where config = mconcat configs -- | Creates a horizontal scroll node. Vertical space is equal to what the -- parent node assigns. -hscroll :: WidgetNode s e -> WidgetNode s e +hscroll + :: WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created scroll. hscroll managedWidget = hscroll_ def managedWidget -- | Creates a horizontal scroll node. Vertical space is equal to what the -- parent node assigns. Accepts config. -hscroll_ :: [ScrollCfg s e] -> WidgetNode s e -> WidgetNode s e +hscroll_ + :: [ScrollCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created scroll. hscroll_ configs managed = makeNode (makeScroll config def) managed where config = mconcat (scrollType ScrollH : configs) -- | Creates a vertical scroll node. Vertical space is equal to what the -- parent node assigns. -vscroll :: WidgetNode s e -> WidgetNode s e +vscroll + :: WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created scroll. vscroll managedWidget = vscroll_ def managedWidget -- | Creates a vertical scroll node. Vertical space is equal to what the -- parent node assigns. Accepts config. -vscroll_ :: [ScrollCfg s e] -> WidgetNode s e -> WidgetNode s e +vscroll_ + :: [ScrollCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created scroll. vscroll_ configs managed = makeNode (makeScroll config def) managed where config = mconcat (scrollType ScrollV : configs) @@ -450,7 +465,7 @@ containerChildrenOffset = Just offset } - -- This is overriden to account for space used by scroll bars + -- This is overridden to account for space used by scroll bars updateCWenv wenv node cnode cidx = newWenv where theme = currentTheme wenv node barW = fromMaybe (theme ^. L.scrollBarWidth) (_scBarWidth config) diff --git a/src/Monomer/Widgets/Containers/SelectList.hs b/src/Monomer/Widgets/Containers/SelectList.hs --- a/src/Monomer/Widgets/Containers/SelectList.hs +++ b/src/Monomer/Widgets/Containers/SelectList.hs @@ -208,31 +208,31 @@ -- | Creates a select list using the given lens. selectList :: (WidgetModel s, WidgetEvent e, Traversable t, SelectListItem a) - => ALens' s a -- ^ The lens into the model. - -> t a -- ^ The list of selectable items. + => ALens' s a -- ^ The lens into the model. + -> t a -- ^ The list of selectable items. -> SelectListMakeRow s e a -- ^ Function to create the list items. - -> WidgetNode s e -- ^ The created dropdown. + -> WidgetNode s e -- ^ The created dropdown. selectList field items makeRow = selectList_ field items makeRow def -- | Creates a select list using the given lens. Accepts config. selectList_ :: (WidgetModel s, WidgetEvent e, Traversable t, SelectListItem a) - => ALens' s a -- ^ The lens into the model. - -> t a -- ^ The list of selectable items. + => ALens' s a -- ^ The lens into the model. + -> t a -- ^ The list of selectable items. -> SelectListMakeRow s e a -- ^ Function to create the list items. - -> [SelectListCfg s e a] -- ^ The config options. - -> WidgetNode s e -- ^ The created dropdown. + -> [SelectListCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created dropdown. selectList_ field items makeRow configs = newNode where newNode = selectListD_ (WidgetLens field) items makeRow configs -- | Creates a select list using the given value and 'onChange' event handler. selectListV :: (WidgetModel s, WidgetEvent e, Traversable t, SelectListItem a) - => a -- ^ The event to raise on change. - -> (Int -> a -> e) -- ^ The list of selectable items. - -> t a -- ^ The list of selectable items. + => a -- ^ The current value. + -> (Int -> a -> e) -- ^ The event to raise on change. + -> t a -- ^ The list of selectable items. -> SelectListMakeRow s e a -- ^ Function to create the list items. - -> WidgetNode s e -- ^ The created dropdown. + -> WidgetNode s e -- ^ The created dropdown. selectListV value handler items makeRow = newNode where newNode = selectListV_ value handler items makeRow def @@ -240,12 +240,12 @@ -- Accepts config. selectListV_ :: (WidgetModel s, WidgetEvent e, Traversable t, SelectListItem a) - => a -- ^ The event to raise on change. - -> (Int -> a -> e) -- ^ The list of selectable items. - -> t a -- ^ The list of selectable items. + => a -- ^ The current value. + -> (Int -> a -> e) -- ^ The event to raise on change. + -> t a -- ^ The list of selectable items. -> SelectListMakeRow s e a -- ^ Function to create the list items. - -> [SelectListCfg s e a] -- ^ The config options. - -> WidgetNode s e -- ^ The created dropdown. + -> [SelectListCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created dropdown. selectListV_ value handler items makeRow configs = newNode where widgetData = WidgetValue value newConfigs = onChangeIdx handler : configs @@ -254,11 +254,11 @@ -- | Creates a dropdown providing a 'WidgetData' instance and config. selectListD_ :: forall s e t a . (WidgetModel s, WidgetEvent e, Traversable t, SelectListItem a) - => WidgetData s a -- ^ The 'WidgetData' to retrieve the value from. - -> t a -- ^ The list of selectable items. + => WidgetData s a -- ^ The 'WidgetData' to retrieve the value from. + -> t a -- ^ The list of selectable items. -> SelectListMakeRow s e a -- ^ Function to create the list items. - -> [SelectListCfg s e a] -- ^ The config options. - -> WidgetNode s e -- ^ The created dropdown. + -> [SelectListCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created dropdown. selectListD_ widgetData items makeRow configs = makeNode wtype widget where config = mconcat configs newItems = foldl' (|>) Empty items @@ -341,6 +341,12 @@ | btn == wenv ^. L.mainButton -> result where result = Just $ resultReqs node [SetFocus (node ^. L.info . L.widgetId)] + Click point _ _ + | outsideVp point -> Just ignoreEvtResult + + Move point + | outsideVp point -> Just ignoreEvtResult + Focus prev -> handleFocusChange node prev (_slcOnFocusReq config) Blur next -> result where @@ -362,6 +368,10 @@ resultSelected = Just $ selectItem wenv node (_hlIdx state) isSelectKey code = isKeyReturn code || isKeySpace code _ -> Nothing + + where + outsideVp point = not (pointInRect point (wenv ^. L.viewport)) + ignoreEvtResult = resultReqs node [IgnoreChildrenEvents] highlightNext wenv node = highlightItem wenv node nextIdx where tempIdx = _hlIdx state diff --git a/src/Monomer/Widgets/Containers/Split.hs b/src/Monomer/Widgets/Containers/Split.hs --- a/src/Monomer/Widgets/Containers/Split.hs +++ b/src/Monomer/Widgets/Containers/Split.hs @@ -64,7 +64,7 @@ - 'splitIgnoreChildResize': whether to ignore changes in size to its children (otherwise, the handle position may change because of this). - 'onChange': raises an event when the handle is moved. -- 'onChangeReq': generates a WidgetReqest when the handle is moved. +- 'onChangeReq': generates a WidgetRequest when the handle is moved. -} data SplitCfg s e = SplitCfg { _spcHandlePos :: Maybe (WidgetData s Double), @@ -135,25 +135,33 @@ } deriving (Eq, Show, Generic) -- | Creates a horizontal split between the two provided nodes. -hsplit :: WidgetEvent e => (WidgetNode s e, WidgetNode s e) -> WidgetNode s e +hsplit + :: WidgetEvent e + => (WidgetNode s e, WidgetNode s e) -- ^ The child nodes. + -> WidgetNode s e -- ^ The created split. hsplit nodes = hsplit_ def nodes -- | Creates a horizontal split between the two provided nodes. Accepts config. hsplit_ :: WidgetEvent e - => [SplitCfg s e] -> (WidgetNode s e, WidgetNode s e) -> WidgetNode s e + => [SplitCfg s e] -- ^ The config options. + -> (WidgetNode s e, WidgetNode s e) -- ^ The child nodes. + -> WidgetNode s e -- ^ The created split. hsplit_ configs nodes = split_ True nodes configs -- | Creates a vertical split between the two provided nodes. -vsplit :: WidgetEvent e => (WidgetNode s e, WidgetNode s e) -> WidgetNode s e +vsplit + :: WidgetEvent e + => (WidgetNode s e, WidgetNode s e) -- ^ The child nodes. + -> WidgetNode s e -- ^ The created split. vsplit nodes = vsplit_ def nodes -- | Creates a vertical split between the two provided nodes. Accepts config. vsplit_ :: WidgetEvent e - => [SplitCfg s e] - -> (WidgetNode s e, WidgetNode s e) - -> WidgetNode s e + => [SplitCfg s e] -- ^ The config options. + -> (WidgetNode s e, WidgetNode s e) -- ^ The child nodes. + -> WidgetNode s e -- ^ The created split. vsplit_ configs nodes = split_ False nodes configs split_ diff --git a/src/Monomer/Widgets/Containers/Stack.hs b/src/Monomer/Widgets/Containers/Stack.hs --- a/src/Monomer/Widgets/Containers/Stack.hs +++ b/src/Monomer/Widgets/Containers/Stack.hs @@ -113,30 +113,36 @@ } -- | Creates a horizontal stack. -hstack :: (Traversable t) => t (WidgetNode s e) -> WidgetNode s e +hstack + :: (Traversable t) + => t (WidgetNode s e) -- ^ The list of items. + -> WidgetNode s e -- ^ The created stack. hstack children = hstack_ def children -- | Creates a horizontal stack. Accepts config. hstack_ :: (Traversable t) - => [StackCfg] - -> t (WidgetNode s e) - -> WidgetNode s e + => [StackCfg] -- ^ The config options. + -> t (WidgetNode s e) -- ^ The list of items. + -> WidgetNode s e -- ^ The created stack. hstack_ configs children = newNode where config = mconcat configs newNode = defaultWidgetNode "hstack" (makeStack True config) & L.children .~ foldl' (|>) Empty children -- | Creates a vertical stack. -vstack :: (Traversable t) => t (WidgetNode s e) -> WidgetNode s e +vstack + :: (Traversable t) + => t (WidgetNode s e) -- ^ The list of items. + -> WidgetNode s e -- ^ The created stack. vstack children = vstack_ def children -- | Creates a vertical stack. Accepts config. vstack_ :: (Traversable t) - => [StackCfg] - -> t (WidgetNode s e) - -> WidgetNode s e + => [StackCfg] -- ^ The config options. + -> t (WidgetNode s e) -- ^ The list of items. + -> WidgetNode s e -- ^ The created stack. vstack_ configs children = newNode where config = mconcat configs newNode = defaultWidgetNode "vstack" (makeStack False config) @@ -163,12 +169,12 @@ newSizeReqH = getDimSizeReq isVertical (_wniSizeReqH . _wnInfo) vchildren newSizeReq = applyFnList sizeReqFns (newSizeReqW, newSizeReqH) - getDimSizeReq mainAxis accesor vchildren + getDimSizeReq mainAxis accessor vchildren | Seq.null vreqs = fixedSize 0 | mainAxis = foldl1 sizeReqMergeSum vreqs & L.fixed %~ (+ totalSpacing) | otherwise = foldl1 sizeReqMergeMax vreqs where - vreqs = accesor <$> vchildren + vreqs = accessor <$> vchildren totalSpacing = fromIntegral (Seq.length vchildren - 1) * childSpacing resize wenv node viewport children = resized where diff --git a/src/Monomer/Widgets/Containers/ThemeSwitch.hs b/src/Monomer/Widgets/Containers/ThemeSwitch.hs --- a/src/Monomer/Widgets/Containers/ThemeSwitch.hs +++ b/src/Monomer/Widgets/Containers/ThemeSwitch.hs @@ -91,11 +91,18 @@ } -- | Switches to a new theme starting from its child node. -themeSwitch :: Theme -> WidgetNode s e -> WidgetNode s e +themeSwitch + :: Theme -- ^ The new theme. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created themeSwitch container. themeSwitch theme managed = themeSwitch_ theme def managed -- | Switches to a new theme starting from its child node. Accepts config. -themeSwitch_ :: Theme -> [ThemeSwitchCfg] -> WidgetNode s e -> WidgetNode s e +themeSwitch_ + :: Theme -- ^ The new theme. + -> [ThemeSwitchCfg] -- ^ The config options. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created themeSwitch container. themeSwitch_ theme configs managed = makeNode widget managed where config = mconcat configs state = ThemeSwitchState Nothing False diff --git a/src/Monomer/Widgets/Containers/Tooltip.hs b/src/Monomer/Widgets/Containers/Tooltip.hs --- a/src/Monomer/Widgets/Containers/Tooltip.hs +++ b/src/Monomer/Widgets/Containers/Tooltip.hs @@ -7,7 +7,7 @@ Portability : non-portable Displays a text message above its child node when the pointer is on top and the -delay, if any, has ellapsed. +delay, if any, has elapsed. Tooltip styling is a bit unusual, since it is applied to the overlaid element. This means padding will not be shown for the contained child element, but only @@ -15,7 +15,7 @@ is needed, "Monomer.Widgets.Containers.Box" can be used to wrap it. @ -tooltip "Click the button" (buttom \"Accept\" AcceptAction) +tooltip "Click the button" (button \"Accept\" AcceptAction) \`styleBasic\` [textSize 16, bgColor steelBlue, paddingH 5, radius 5] @ -} @@ -109,11 +109,18 @@ } deriving (Eq, Show, Generic) -- | Creates a tooltip for the child widget. -tooltip :: Text -> WidgetNode s e -> WidgetNode s e +tooltip + :: Text -- ^ The text message. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created tooltip container. tooltip caption managed = tooltip_ caption def managed -- | Creates a tooltip for the child widget. Accepts config. -tooltip_ :: Text -> [TooltipCfg] -> WidgetNode s e -> WidgetNode s e +tooltip_ + :: Text -- ^ The text message. + -> [TooltipCfg] -- ^ The config options. + -> WidgetNode s e -- ^ The child node. + -> WidgetNode s e -- ^ The created tooltip container. tooltip_ caption configs managed = makeNode widget managed where config = mconcat configs state = TooltipState def maxBound @@ -183,7 +190,7 @@ _ -> Nothing - -- Padding/border is not removed. Styles are only considerer for the overlay + -- Padding/border is not removed. Styles are only considered for the overlay resize wenv node viewport children = resized where resized = (resultNode node, Seq.singleton viewport) @@ -234,5 +241,5 @@ ts = wenv ^. L.timestamp viewport = node ^. L.info . L.viewport inViewport = pointInRect lastPos viewport - delayEllapsed = ts - lastPosTs >= delay - displayed = inViewport && delayEllapsed + delayElapsed = ts - lastPosTs >= delay + displayed = inViewport && delayElapsed 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 @@ -90,15 +90,18 @@ } deriving (Eq, Show, Generic) -- | Creates a zstack container with the provided nodes. -zstack :: (Traversable t) => t (WidgetNode s e) -> WidgetNode s e +zstack + :: (Traversable t) + => t (WidgetNode s e) -- ^ The list of child nodes. + -> WidgetNode s e -- ^ The created zstack container. zstack children = zstack_ def children -- | Creates a zstack container with the provided nodes. Accepts config. zstack_ :: (Traversable t) - => [ZStackCfg] - -> t (WidgetNode s e) - -> WidgetNode s e + => [ZStackCfg] -- ^ The config options. + -> t (WidgetNode s e) -- ^ The list of child nodes. + -> WidgetNode s e -- ^ The created zstack container. zstack_ configs children = newNode where config = mconcat configs state = ZStackState M.empty 0 @@ -190,11 +193,11 @@ newSizeReqW = getDimSizeReq (_wniSizeReqW . _wnInfo) vchildren newSizeReqH = getDimSizeReq (_wniSizeReqH . _wnInfo) vchildren - getDimSizeReq accesor vchildren + getDimSizeReq accessor vchildren | Seq.null vreqs = fixedSize 0 | otherwise = foldl1 sizeReqMergeMax vreqs where - vreqs = accesor <$> vchildren + vreqs = accessor <$> vchildren resize wenv node viewport children = resized where style = currentStyle wenv node diff --git a/src/Monomer/Widgets/Single.hs b/src/Monomer/Widgets/Single.hs --- a/src/Monomer/Widgets/Single.hs +++ b/src/Monomer/Widgets/Single.hs @@ -125,7 +125,7 @@ Disposes the current node. Only used by widgets which allocate resources during /init/ or /merge/, and will usually involve requests to the runtime. -An example can be found "Monomer.Widgets.Singles.Image". +An example can be found in "Monomer.Widgets.Singles.Image". -} type SingleDisposeHandler s e = WidgetEnv s e -- ^ The widget environment. @@ -151,7 +151,7 @@ Returns the currently hovered widget, if any. If the widget is rectangular and uses the full content area, there is not need to override this function. -An example can be found "Monomer.Widgets.Singles.Radio". +An example can be found in "Monomer.Widgets.Singles.Radio". -} type SingleFindByPointHandler s e = WidgetEnv s e -- ^ The widget environment. @@ -182,8 +182,7 @@ the widget should take care of _casting_ to the correct type using "Data.Typeable.cast" -Examples can be found in "Monomer.Widgets.Singles.Button" and -"Monomer.Widgets.Singles.Slider". +An example can be found in "Monomer.Widgets.Singles.Image". -} type SingleMessageHandler s e = forall i . Typeable i @@ -209,7 +208,7 @@ {-| Resizes the widget to the provided size. If the widget state does not depend -on the viewport size, this function does not need to be overriden. +on the viewport size, this function does not need to be overridden. Examples can be found in "Monomer.Widgets.Singles.Label". -} @@ -221,7 +220,7 @@ {-| Renders the widget's content using the given Renderer. In general, this method -needs to be overriden. +needs to be overridden. Examples can be found in "Monomer.Widgets.Singles.Checkbox" and "Monomer.Widgets.Singles.Slider". @@ -369,7 +368,7 @@ nodeHandler wenv styledNode = case useState oldState of Just state -> mergeHandler wenv styledNode oldNode state _ -> resultNode styledNode - tmpResult = runNodeHandler single wenv newNode oldInfo nodeHandler + tmpResult = runNodeHandler single wenv newNode oldNode nodeHandler newResult = handleWidgetIdChange oldNode tmpResult runNodeHandler @@ -377,10 +376,11 @@ => Single s e a -> WidgetEnv s e -> WidgetNode s e - -> WidgetNodeInfo + -> WidgetNode s e -> (WidgetEnv s e -> WidgetNode s e -> WidgetResult s e) -> WidgetResult s e -runNodeHandler single wenv newNode oldInfo nodeHandler = newResult where +runNodeHandler single wenv newNode oldNode nodeHandler = newResult where + oldInfo = oldNode ^. L.info getBaseStyle = singleGetBaseStyle single tempNode = newNode & L.info . L.widgetId .~ oldInfo ^. L.widgetId @@ -390,6 +390,9 @@ styledNode = initNodeStyle getBaseStyle wenv tempNode tmpResult = nodeHandler wenv styledNode + & handleUserSizeReqChange wenv oldNode + & handleWidgetIdChange oldNode + newResult | isResizeAnyResult (Just tmpResult) = tmpResult & L.node .~ updateSizeReq wenv (tmpResult ^. L.node) 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 @@ -50,7 +50,7 @@ import qualified Monomer.Lens as L --- | Constaints for a value handled by input field. +-- | Constraints for a value handled by input field. type InputFieldValue a = (Eq a, Show a, Typeable a) {-| @@ -214,9 +214,9 @@ -- | Creates an instance of an input field, with customizations in config. inputField_ :: (InputFieldValue a, WidgetEvent e) - => WidgetType - -> InputFieldCfg s e a - -> WidgetNode s e + => WidgetType -- ^ The 'WidgetType' of an input field. + -> InputFieldCfg s e a -- ^ The config options. + -> WidgetNode s e -- ^ The created instance of an input field. inputField_ widgetType config = node where value = _ifcInitialValue config widget = makeInputField config (initialState value) diff --git a/src/Monomer/Widgets/Singles/Button.hs b/src/Monomer/Widgets/Singles/Button.hs --- a/src/Monomer/Widgets/Singles/Button.hs +++ b/src/Monomer/Widgets/Singles/Button.hs @@ -187,14 +187,23 @@ Creates a button with main styling. Useful to highlight an option, such as \"Accept\", when multiple buttons are available. -} -mainButton :: WidgetEvent e => Text -> e -> WidgetNode s e +mainButton + :: WidgetEvent e + => Text -- ^ The caption. + -> e -- ^ The event to raise on click. + -> WidgetNode s e -- ^ The created button. mainButton caption handler = button_ caption handler [mainConfig] {-| Creates a button with main styling. Useful to highlight an option, such as \"Accept\", when multiple buttons are available. Accepts config. -} -mainButton_ :: WidgetEvent e => Text -> e -> [ButtonCfg s e] -> WidgetNode s e +mainButton_ + :: WidgetEvent e + => Text -- ^ The caption. + -> e -- ^ The event to raise on click. + -> [ButtonCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created button. mainButton_ caption handler configs = button_ caption handler newConfigs where newConfigs = mainConfig : configs @@ -203,16 +212,29 @@ \"Accept\", when multiple buttons are available. Accepts config but does not require an event. See 'buttonD_'. -} -mainButtonD_ :: WidgetEvent e => Text -> [ButtonCfg s e] -> WidgetNode s e +mainButtonD_ + :: WidgetEvent e + => Text -- ^ The caption. + -> [ButtonCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created button. mainButtonD_ caption configs = buttonD_ caption newConfigs where newConfigs = mainConfig : configs -- | Creates a button with normal styling. -button :: WidgetEvent e => Text -> e -> WidgetNode s e +button + :: WidgetEvent e + => Text -- ^ The caption. + -> e -- ^ The event to raise on click. + -> WidgetNode s e -- ^ The created button. button caption handler = button_ caption handler def -- | Creates a button with normal styling. Accepts config. -button_ :: WidgetEvent e => Text -> e -> [ButtonCfg s e] -> WidgetNode s e +button_ + :: WidgetEvent e + => Text -- ^ The caption. + -> e -- ^ The event to raise on click. + -> [ButtonCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created button. button_ caption handler configs = buttonNode where buttonNode = buttonD_ caption (onClick handler : configs) @@ -226,7 +248,11 @@ Composite can be reached by sending a message ('SendMessage') to its 'WidgetId' using 'onClickReq'. -} -buttonD_ :: WidgetEvent e => Text -> [ButtonCfg s e] -> WidgetNode s e +buttonD_ + :: WidgetEvent e + => Text -- ^ The caption. + -> [ButtonCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created button. buttonD_ caption configs = buttonNode where config = mconcat configs widget = makeButton caption config 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 @@ -147,16 +147,26 @@ } -- | Creates a checkbox using the given lens. -checkbox :: WidgetEvent e => ALens' s Bool -> WidgetNode s e +checkbox + :: WidgetEvent e + => ALens' s Bool -- ^ The lens into the model. + -> WidgetNode s e -- ^ The created checkbox. checkbox field = checkbox_ field def -- | Creates a checkbox using the given lens. Accepts config. checkbox_ - :: WidgetEvent e => ALens' s Bool -> [CheckboxCfg s e] -> WidgetNode s e + :: WidgetEvent e + => ALens' s Bool -- ^ The lens into the model. + -> [CheckboxCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created checkbox. checkbox_ field config = checkboxD_ (WidgetLens field) config -- | Creates a checkbox using the given value and 'onChange' event handler. -checkboxV :: WidgetEvent e => Bool -> (Bool -> e) -> WidgetNode s e +checkboxV + :: WidgetEvent e + => Bool -- ^ The current value. + -> (Bool -> e) -- ^ The event to raise on change. + -> WidgetNode s e -- ^ The created checkbox. checkboxV value handler = checkboxV_ value handler def {-| @@ -164,13 +174,20 @@ config. -} checkboxV_ - :: WidgetEvent e => Bool -> (Bool -> e) -> [CheckboxCfg s e] -> WidgetNode s e + :: WidgetEvent e + => Bool -- ^ The current value. + -> (Bool -> e) -- ^ The event to raise on change. + -> [CheckboxCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created checkbox. checkboxV_ value handler config = checkboxD_ (WidgetValue value) newConfig where newConfig = onChange handler : config -- | Creates a checkbox providing a 'WidgetData' instance and config. checkboxD_ - :: WidgetEvent e => WidgetData s Bool -> [CheckboxCfg s e] -> WidgetNode s e + :: WidgetEvent e + => WidgetData s Bool -- ^ The 'WidgetData' to retrieve the value from. + -> [CheckboxCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created checkbox. checkboxD_ widgetData configs = checkboxNode where config = mconcat configs widget = makeCheckbox widgetData config 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 @@ -8,9 +8,18 @@ Color picker, displayed inside its parent container as a regular widget. +Shows sliders for the color components. + @ colorPicker colorLens @ + +Optionally shows a slider for the alpha channel. + +@ +colorPicker_ colorLens [showAlpha] +@ + -} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -138,25 +147,25 @@ -- | Creates a color picker using the given lens. colorPicker :: (WidgetModel s, WidgetEvent e) - => ALens' s Color - -> WidgetNode s e + => ALens' s Color -- ^ The lens into the model. + -> WidgetNode s e -- ^ The created color picker. colorPicker field = colorPicker_ field def -- | Creates a color picker using the given lens. Accepts config. colorPicker_ :: (WidgetModel s, WidgetEvent e) - => ALens' s Color - -> [ColorPickerCfg s e] - -> WidgetNode s e + => ALens' s Color -- ^ The lens into the model. + -> [ColorPickerCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created color picker. colorPicker_ field configs = colorPickerD_ wlens configs [] where wlens = WidgetLens field -- | Creates a color picker using the given value and 'onChange' event handler. colorPickerV :: (WidgetModel s, WidgetEvent e) - => Color - -> (Color -> e) - -> WidgetNode s e + => Color -- ^ The current value. + -> (Color -> e) -- ^ The event to raise on change. + -> WidgetNode s e -- ^ The created color picker. colorPickerV value handler = colorPickerV_ value handler def {-| @@ -165,10 +174,10 @@ -} colorPickerV_ :: (WidgetModel s, WidgetEvent e) - => Color - -> (Color -> e) - -> [ColorPickerCfg s e] - -> WidgetNode s e + => Color -- ^ The current value. + -> (Color -> e) -- ^ The event to raise on change. + -> [ColorPickerCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created color picker. colorPickerV_ value handler configs = colorPickerD_ wdata newCfgs [] where wdata = WidgetValue value newCfgs = onChange handler : configs @@ -177,9 +186,13 @@ colorPickerD_ :: (WidgetModel s, WidgetEvent e) => WidgetData s Color + -- ^ The 'WidgetData' to retrieve the value from. -> [ColorPickerCfg s e] + -- ^ The config options. -> [CompositeCfg Color ColorPickerEvt s e] + -- ^ The composite config options. -> WidgetNode s e + -- ^ The created color picker. colorPickerD_ wdata cfgs cmpCfgs = newNode where cfg = mconcat cfgs uiBuilder = buildUI cfg diff --git a/src/Monomer/Widgets/Singles/ColorPopup.hs b/src/Monomer/Widgets/Singles/ColorPopup.hs new file mode 100644 --- /dev/null +++ b/src/Monomer/Widgets/Singles/ColorPopup.hs @@ -0,0 +1,252 @@ +{-| +Module : Monomer.Widgets.Singles.ColorPopup +Copyright : (c) 2018 Francisco Vallarino +License : BSD-3-Clause (see the LICENSE file) +Maintainer : fjvallarino@gmail.com +Stability : experimental +Portability : non-portable + +Color popup, displayed inside its parent container as a colored square. When +clicked, it opens a color picker overlay. + +Shows sliders for the color components. + +@ +colorPopup colorLens +@ + +Optionally shows a slider for the alpha channel. + +@ +colorPopup_ colorLens [showAlpha] +@ +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.Singles.ColorPopup ( + -- * Constructors + colorPopup, + colorPopup_, + colorPopupV, + colorPopupV_ +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((&), (^.), (.~), (?~), ALens', abbreviatedFields, makeLensesWith, non) +import Data.Default +import Data.Text (Text) + +import Monomer.Core.Combinators +import Monomer.Graphics.Types + +import Monomer.Widgets.Composite +import Monomer.Widgets.Containers.BoxShadow +import Monomer.Widgets.Containers.Popup +import Monomer.Widgets.Containers.Stack +import Monomer.Widgets.Singles.ColorPicker +import Monomer.Widgets.Singles.ToggleButton + +import qualified Monomer.Lens as L + +type ColorPopupEnv = WidgetEnv ColorPopupModel ColorPopupEvt +type ColorPopupNode = WidgetNode ColorPopupModel ColorPopupEvt + +{-| +Configuration options for colorPopup: + +- 'showAlpha': whether to allow modifying the alpha channel or not. +- '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 any of the values changes. +- 'onChangeReq': 'WidgetRequest' to generate when any of the values changes. +-} +data ColorPopupCfg s e = ColorPopupCfg { + _cpcColorPickerCfg :: ColorPickerCfg ColorPopupModel ColorPopupEvt, + _cpcOnFocusReq :: [Path -> WidgetRequest s e], + _cpcOnBlurReq :: [Path -> WidgetRequest s e], + _cpcOnChangeReq :: [Color -> WidgetRequest s e] +} + +instance Default (ColorPopupCfg s e) where + def = ColorPopupCfg { + _cpcColorPickerCfg = def, + _cpcOnFocusReq = [], + _cpcOnBlurReq = [], + _cpcOnChangeReq = [] + } + +instance Semigroup (ColorPopupCfg s e) where + (<>) a1 a2 = def { + _cpcColorPickerCfg = _cpcColorPickerCfg a1 <> _cpcColorPickerCfg a2, + _cpcOnFocusReq = _cpcOnFocusReq a1 <> _cpcOnFocusReq a2, + _cpcOnBlurReq = _cpcOnBlurReq a1 <> _cpcOnBlurReq a2, + _cpcOnChangeReq = _cpcOnChangeReq a1 <> _cpcOnChangeReq a2 + } + +instance Monoid (ColorPopupCfg s e) where + mempty = def + +instance CmbShowAlpha (ColorPopupCfg s e) where + showAlpha_ show = def { + _cpcColorPickerCfg = showAlpha_ show + } + +instance WidgetEvent e => CmbOnFocus (ColorPopupCfg s e) e Path where + onFocus fn = def { + _cpcOnFocusReq = [RaiseEvent . fn] + } + +instance CmbOnFocusReq (ColorPopupCfg s e) s e Path where + onFocusReq req = def { + _cpcOnFocusReq = [req] + } + +instance WidgetEvent e => CmbOnBlur (ColorPopupCfg s e) e Path where + onBlur fn = def { + _cpcOnBlurReq = [RaiseEvent . fn] + } + +instance CmbOnBlurReq (ColorPopupCfg s e) s e Path where + onBlurReq req = def { + _cpcOnBlurReq = [req] + } + +instance WidgetEvent e => CmbOnChange (ColorPopupCfg s e) Color e where + onChange fn = def { + _cpcOnChangeReq = [RaiseEvent . fn] + } + +instance CmbOnChangeReq (ColorPopupCfg s e) s e Color where + onChangeReq req = def { + _cpcOnChangeReq = [req] + } + +data ColorPopupModel = ColorPopupModel { + _cpmPopupShowColor :: Bool, + _cpmPopupColor :: Color +} deriving (Eq, Show) + +data ColorPopupEvt + = ColorChanged Color + | PopupFocus Path + | PopupBlur Path + +instance Default ColorPopupModel where + def = ColorPopupModel { + _cpmPopupShowColor = False, + _cpmPopupColor = def + } + +makeLensesWith abbreviatedFields 'ColorPopupModel + +-- | Creates a colorPopup using the given lens. +colorPopup + :: (WidgetModel s, WidgetEvent e) + => ALens' s Color -- ^ The lens into the model. + -> WidgetNode s e -- ^ The created color popup. +colorPopup field = colorPopup_ field def + +-- | Creates a colorPopup using the given lens. Accepts config. +colorPopup_ + :: (WidgetModel s, WidgetEvent e) + => ALens' s Color -- ^ The lens into the model. + -> [ColorPopupCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created color popup. +colorPopup_ field configs = colorPopupD_ (WidgetLens field) configs + +-- | Creates a colorPopup using the given value and 'onChange' event handler. +colorPopupV + :: (WidgetModel s, WidgetEvent e) + => Color -- ^ The current value. + -> (Color -> e) -- ^ The event to raise on change. + -> WidgetNode s e -- ^ The created color popup. +colorPopupV value handler = colorPopupV_ value handler def + +-- | Creates a colorPopup using the given value and 'onChange' event handler. +-- Accepts config. +colorPopupV_ + :: (WidgetModel s, WidgetEvent e) + => Color -- ^ The current value. + -> (Color -> e) -- ^ The event to raise on change. + -> [ColorPopupCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created color popup. +colorPopupV_ value handler configs = newNode where + newConfigs = onChange handler : configs + newNode = colorPopupD_ (WidgetValue value) newConfigs + +-- | Creates a colorPopup providing a 'WidgetData' instance and config. +colorPopupD_ + :: (WidgetModel s, WidgetEvent e) + => WidgetData s Color -- ^ The 'WidgetData' to retrieve the value from. + -> [ColorPopupCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created color popup. +colorPopupD_ wdata configs = newNode where + config = mconcat configs + model = WidgetValue def + uiBuilder = buildUI config + eventHandler = handleEvent wdata config + mergeModel wenv parentModel oldModel newModel = oldModel + & popupColor .~ widgetDataGet parentModel wdata + compCfg = [compositeMergeModel mergeModel] + newNode = compositeD_ "colorPopup" model uiBuilder eventHandler compCfg + +buildUI + :: WidgetModel sp + => ColorPopupCfg sp ep + -> ColorPopupEnv + -> ColorPopupModel + -> ColorPopupNode +buildUI config wenv model = widgetTree where + containerStyle = collectTheme wenv L.colorPopupStyle + selColor = model ^. popupColor + + toggleStyle = mergeBasicStyle $ def + & L.basic . non def . L.sizeReqW ?~ width 30 + & L.basic . non def . L.sizeReqH ?~ height 30 + & L.basic . non def . L.bgColor ?~ selColor + & L.basic . non def . L.border ?~ border 1 selColor + + toggleCfg = [toggleButtonOffStyle toggleStyle] + toggle = toggleButton_ "" popupShowColor toggleCfg + & L.info . L.style .~ toggleStyle + + pickerCfg = _cpcColorPickerCfg config + picker = colorPicker_ popupColor [pickerCfg, onChange ColorChanged] + & L.info . L.style .~ containerStyle + + content = boxShadow picker + popupCfg = [popupAlignToOuterV, popupOffset (Point 0 10), alignBottom, alignLeft] + widgetTree = popup_ popupShowColor (popupAnchor toggle : popupCfg) content + +handleEvent + :: WidgetModel sp + => WidgetData sp Color + -> ColorPopupCfg sp ep + -> ColorPopupEnv + -> ColorPopupNode + -> ColorPopupModel + -> ColorPopupEvt + -> [EventResponse ColorPopupModel ColorPopupEvt sp ep] +handleEvent wdata cfg wenv node model evt = case evt of + PopupFocus prev + | not (isNodeParentOfPath node prev) -> reportFocus prev + PopupBlur next + | not (isNodeParentOfPath node next) -> reportBlur next + ColorChanged col -> reportChange col + _ -> [] + where + parentColor pm = widgetDataGet pm wdata + parentChanged pm = parentColor pm /= model ^. popupColor + + report reqs = RequestParent <$> reqs + reportFocus prev = report (($ prev) <$> _cpcOnFocusReq cfg) + reportBlur next = report (($ next) <$> _cpcOnBlurReq cfg) + reportChange col = report (wdataReqs ++ changeReqs) where + wdataReqs = widgetDataSet wdata col + changeReqs = ($ col) <$> _cpcOnChangeReq cfg diff --git a/src/Monomer/Widgets/Singles/DateField.hs b/src/Monomer/Widgets/Singles/DateField.hs --- a/src/Monomer/Widgets/Singles/DateField.hs +++ b/src/Monomer/Widgets/Singles/DateField.hs @@ -38,16 +38,16 @@ FormattableDate, DayConverter(..), DateTextConverter(..), + dateFormatDelimiter, + dateFormatDDMMYYYY, + dateFormatMMDDYYYY, + dateFormatYYYYMMDD, -- * Constructors dateField, dateField_, dateFieldV, dateFieldV_, - dateFieldD_, - dateFormatDelimiter, - dateFormatDDMMYYYY, - dateFormatMMDDYYYY, - dateFormatYYYYMMDD + dateFieldD_ ) where import Control.Applicative ((<|>)) @@ -145,6 +145,8 @@ {-| Configuration options for dateField: +- 'caretWidth': the width of the caret. +- 'caretMs': the blink period of the caret. - 'validInput': field indicating if the current input is valid. Useful to show warnings in the UI, or disable buttons if needed. - 'resizeOnChange': Whether input causes 'ResizeWidgets' requests. @@ -339,32 +341,35 @@ -- | Creates a date field using the given lens. dateField :: (FormattableDate a, WidgetEvent e) - => ALens' s a -> WidgetNode s e + => ALens' s a -- ^ The lens into the model. + -> WidgetNode s e -- ^ The created date field. dateField field = dateField_ field def -- | Creates a date field using the given lens. Accepts config. dateField_ :: (FormattableDate a, WidgetEvent e) - => ALens' s a - -> [DateFieldCfg s e a] - -> WidgetNode s e + => ALens' s a -- ^ The lens into the model. + -> [DateFieldCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created date field. dateField_ field configs = widget where widget = dateFieldD_ (WidgetLens field) configs -- | Creates a date field using the given value and 'onChange' event handler. dateFieldV :: (FormattableDate a, WidgetEvent e) - => a -> (a -> e) -> WidgetNode s e + => a -- ^ The current value. + -> (a -> e) -- ^ The event to raise on change. + -> WidgetNode s e -- ^ The created date field. dateFieldV value handler = dateFieldV_ value handler def -- | Creates a date field using the given value and 'onChange' event handler. -- Accepts config. dateFieldV_ :: (FormattableDate a, WidgetEvent e) - => a - -> (a -> e) - -> [DateFieldCfg s e a] - -> WidgetNode s e + => a -- ^ The current value. + -> (a -> e) -- ^ The event to raise on change. + -> [DateFieldCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created date field. dateFieldV_ value handler configs = newNode where widgetData = WidgetValue value newConfigs = onChange handler : configs @@ -373,9 +378,9 @@ -- | Creates a date field providing a 'WidgetData' instance and config. dateFieldD_ :: (FormattableDate a, WidgetEvent e) - => WidgetData s a - -> [DateFieldCfg s e a] - -> WidgetNode s e + => WidgetData s a -- ^ The 'WidgetData' to retrieve the value from. + -> [DateFieldCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created date field. dateFieldD_ widgetData configs = newNode where config = mconcat configs format = fromMaybe defaultDateFormat (_dfcDateFormat config) 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 @@ -33,7 +33,8 @@ dial, dial_, dialV, - dialV_ + dialV_, + dialD_ ) where import Control.Applicative ((<|>)) @@ -154,10 +155,10 @@ -- | Creates a dial using the given lens, providing minimum and maximum values. dial :: (DialValue a, WidgetEvent e) - => ALens' s a - -> a - -> a - -> WidgetNode s e + => ALens' s a -- ^ The lens into the model. + -> a -- ^ Minimum value. + -> a -- ^ Maximum value. + -> WidgetNode s e -- ^ The created dial. dial field minVal maxVal = dial_ field minVal maxVal def {-| @@ -166,11 +167,11 @@ -} dial_ :: (DialValue a, WidgetEvent e) - => ALens' s a - -> a - -> a - -> [DialCfg s e a] - -> WidgetNode s e + => ALens' s a -- ^ The lens into the model. + -> a -- ^ Minimum value. + -> a -- ^ Maximum value. + -> [DialCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created dial. dial_ field minVal maxVal cfgs = dialD_ (WidgetLens field) minVal maxVal cfgs {-| @@ -179,11 +180,11 @@ -} dialV :: (DialValue a, WidgetEvent e) - => a - -> (a -> e) - -> a - -> a - -> WidgetNode s e + => a -- ^ The current value. + -> (a -> e) -- ^ The event to raise on change. + -> a -- ^ Minimum value. + -> a -- ^ Maximum value. + -> WidgetNode s e -- ^ The created dial. dialV value handler minVal maxVal = dialV_ value handler minVal maxVal def {-| @@ -193,12 +194,12 @@ -} dialV_ :: (DialValue a, WidgetEvent e) - => a - -> (a -> e) - -> a - -> a - -> [DialCfg s e a] - -> WidgetNode s e + => a -- ^ The current value. + -> (a -> e) -- ^ The event to raise on change. + -> a -- ^ Minimum value. + -> a -- ^ Maximum value. + -> [DialCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created dial. dialV_ value handler minVal maxVal configs = newNode where widgetData = WidgetValue value newConfigs = onChange handler : configs @@ -210,11 +211,11 @@ -} dialD_ :: (DialValue a, WidgetEvent e) - => WidgetData s a - -> a - -> a - -> [DialCfg s e a] - -> WidgetNode s e + => WidgetData s a -- ^ The 'WidgetData' to retrieve the value from. + -> a -- ^ Minimum value. + -> a -- ^ Maximum value. + -> [DialCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created dial. dialD_ widgetData minVal maxVal configs = dialNode where config = mconcat configs state = DialState 0 0 diff --git a/src/Monomer/Widgets/Singles/ExternalLink.hs b/src/Monomer/Widgets/Singles/ExternalLink.hs --- a/src/Monomer/Widgets/Singles/ExternalLink.hs +++ b/src/Monomer/Widgets/Singles/ExternalLink.hs @@ -137,12 +137,20 @@ } -- | Creates an external link with the given caption and url. -externalLink :: WidgetEvent e => Text -> Text -> WidgetNode s e +externalLink + :: WidgetEvent e + => Text -- ^ The caption. + -> Text -- ^ The url. + -> WidgetNode s e -- ^ The created external link. externalLink caption url = externalLink_ caption url def -- | Creates an external link with the given caption and url. Accepts config. externalLink_ - :: WidgetEvent e => Text -> Text -> [ExternalLinkCfg s e] -> WidgetNode s e + :: WidgetEvent e + => Text -- ^ The caption. + -> Text -- ^ The url. + -> [ExternalLinkCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created external link. externalLink_ caption url configs = externalLinkNode where config = mconcat configs widget = makeExternalLink caption url config diff --git a/src/Monomer/Widgets/Singles/Icon.hs b/src/Monomer/Widgets/Singles/Icon.hs --- a/src/Monomer/Widgets/Singles/Icon.hs +++ b/src/Monomer/Widgets/Singles/Icon.hs @@ -72,11 +72,16 @@ } -- | Creates an icon of the given type. -icon :: IconType -> WidgetNode s e +icon + :: IconType -- ^ The icon type. + -> WidgetNode s e -- ^ The created icon. icon iconType = icon_ iconType def -- | Creates an icon of the given type. Accepts config. -icon_ :: IconType -> [IconCfg] -> WidgetNode s e +icon_ + :: IconType -- ^ The icon type. + -> [IconCfg] -- ^ The config options. + -> WidgetNode s e -- ^ The created icon. icon_ iconType configs = defaultWidgetNode widgetType widget where iconName = T.pack $ show iconType widgetType = WidgetType ("i" <> T.tail iconName) diff --git a/src/Monomer/Widgets/Singles/Image.hs b/src/Monomer/Widgets/Singles/Image.hs --- a/src/Monomer/Widgets/Singles/Image.hs +++ b/src/Monomer/Widgets/Singles/Image.hs @@ -78,7 +78,7 @@ | FitEither deriving (Eq, Show) --- | Posible errors when loading an image. +-- | Possible errors when loading an image. data ImageLoadError = ImageLoadFailed String | ImageInvalid String @@ -92,16 +92,18 @@ - 'imageNearest': apply nearest filtering when stretching an image. - 'imageRepeatX': repeat the image across the x coordinate. - 'imageRepeatY': repeat the image across the y coordinate. -- 'fitNone': does not perform any streching if the size does not match viewport. +- 'fitNone': does not perform any stretching if the size does not match viewport. - 'fitFill': stretches the image to match the viewport. - 'fitWidth': stretches the image to match the viewport width. Maintains ratio. - 'fitHeight': stretches the image to match the viewport height. Maintains ratio. -- 'alignLeft': aligns left if extra space is available. -- 'alignRight': aligns right if extra space is available. -- 'alignCenter': aligns center if extra space is available. -- 'alignTop': aligns top if extra space is available. -- 'alignMiddle': aligns middle if extra space is available. -- 'alignBottom': aligns bottom if extra space is available. +- 'fitEither': stretches the image to match either the viewport width or height + such that image does not overflow viewport. Maintains ratio. +- 'alignLeft': aligns to the left if extra space is available. +- 'alignRight': aligns to the right if extra space is available. +- 'alignCenter': aligns to the horizontal center if extra space is available. +- 'alignTop': aligns to the top if extra space is available. +- 'alignMiddle': aligns to the vertical middle if extra space is available. +- 'alignBottom': aligns to the bottom if extra space is available. -} data ImageCfg e = ImageCfg { _imcLoadError :: [ImageLoadError -> e], @@ -256,11 +258,18 @@ | ImageFailed ImageLoadError -- | Creates an image with the given local path or url. -image :: WidgetEvent e => Text -> WidgetNode s e +image + :: WidgetEvent e + => Text -- ^ The local path or url. + -> WidgetNode s e -- ^ The created image widget. image path = image_ path def -- | Creates an image with the given local path or url. Accepts config. -image_ :: WidgetEvent e => Text -> [ImageCfg e] -> WidgetNode s e +image_ + :: WidgetEvent e + => Text -- ^ The local path or url. + -> [ImageCfg e] -- ^ The configuration of the image. + -> WidgetNode s e -- ^ The created image widget. image_ path configs = defaultWidgetNode "image" widget where config = mconcat configs source = ImagePath path diff --git a/src/Monomer/Widgets/Singles/Label.hs b/src/Monomer/Widgets/Singles/Label.hs --- a/src/Monomer/Widgets/Singles/Label.hs +++ b/src/Monomer/Widgets/Singles/Label.hs @@ -26,8 +26,8 @@ module Monomer.Widgets.Singles.Label ( -- * Configuration LabelCfg, - -- * Constructors labelCurrentStyle, + -- * Constructors label, label_, labelS, @@ -154,26 +154,38 @@ _lstStyle :: StyleState, _lstTextRect :: Rect, _lstTextLines :: Seq TextLine, - _lstPrevResize :: (Millisecond, Bool) + _lstResizeStep :: (Millisecond, Bool) } deriving (Eq, Show, Generic) -- | Creates a label using the provided 'Text'. -label :: Text -> WidgetNode s e +label + :: Text -- ^ The caption. + -> WidgetNode s e -- ^ The created label. label caption = label_ caption def -- | Creates a label using the provided 'Text'. Accepts config. -label_ :: Text -> [LabelCfg s e] -> WidgetNode s e +label_ + :: Text -- ^ The caption. + -> [LabelCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created label. label_ caption configs = defaultWidgetNode "label" widget where config = mconcat configs state = LabelState caption def def Seq.Empty (0, False) widget = makeLabel config state -- | Creates a label using the 'Show' instance of the type. -labelS :: Show a => a -> WidgetNode s e +labelS + :: Show a + => a -- ^ The value with a 'Show' instance. + -> WidgetNode s e -- ^ The created label. labelS caption = labelS_ caption def -- | Creates a label using the 'Show' instance of the type. Accepts config. -labelS_ :: Show a => a -> [LabelCfg s e] -> WidgetNode s e +labelS_ + :: Show a + => a -- ^ The value with a 'Show' instance. + -> [LabelCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created label. labelS_ caption configs = label_ (T.pack . show $ caption) configs makeLabel :: LabelCfg s e -> LabelState -> Widget s e @@ -201,7 +213,7 @@ | otherwise = SingleLine maxLines = _lscTextMaxLines config labelCurrentStyle = fromMaybe currentStyle (_lscCurrentStyle config) - LabelState caption textStyle textRect textLines prevResize = state + LabelState caption textStyle textRect textLines resizeStep = state getBaseStyle wenv node | ignoreTheme = Nothing @@ -216,11 +228,12 @@ & L.widget .~ makeLabel config newState merge wenv newNode oldNode oldState = result where + LabelState prevCaption prevStyle prevRect prevLines prevResize = oldState + (tsResized, alreadyResized) = prevResize + widgetId = newNode ^. L.info . L.widgetId style = labelCurrentStyle wenv newNode - prevStyle = _lstStyle oldState - - captionChanged = _lstCaption oldState /= caption + captionChanged = prevCaption /= caption styleChanged = prevStyle ^. L.text /= style ^. L.text || prevStyle ^. L.padding /= style ^. L.padding || prevStyle ^. L.border /= style ^. L.border @@ -231,11 +244,13 @@ -- This is used in resize to know if glyphs have to be recalculated newRect | changeReq = def - | otherwise = _lstTextRect oldState - newState = oldState { + | otherwise = prevRect + newState = LabelState { _lstCaption = caption, _lstStyle = style, - _lstTextRect = newRect + _lstTextRect = newRect, + _lstTextLines = prevLines, + _lstResizeStep = (tsResized, alreadyResized && not captionChanged) } reqs = [ ResizeWidgets widgetId | changeReq ] @@ -246,7 +261,7 @@ getSizeReq wenv node = (sizeW, sizeH) where ts = wenv ^. L.timestamp caption = _lstCaption state - prevResize = _lstPrevResize state + prevResize = _lstResizeStep state style = labelCurrentStyle wenv node cw = getContentArea node style ^. L.w @@ -286,18 +301,20 @@ = fitTextToSize fontMgr style overflow mode trim maxLines size caption newTextLines = alignTextLines style alignRect fittedLines - (prevTs, prevStep) = prevResize - needsSndResize = mode == MultiLine && (prevTs /= ts || not prevStep) + rectEq = textRect == crect + (tsResized, alreadyResized) = resizeStep + resizeAgain = mode == MultiLine && (tsResized /= ts || not alreadyResized) + isResized = (alreadyResized && rectEq) || (resizeAgain && tsResized == ts) newState = state { _lstStyle = style, _lstTextRect = crect, _lstTextLines = newTextLines, - _lstPrevResize = (ts, needsSndResize && prevTs == ts) + _lstResizeStep = (ts, isResized) } newNode = node & L.widget .~ makeLabel config newState - result = resultReqs newNode [ResizeWidgets widgetId | needsSndResize] + result = resultReqs newNode [ResizeWidgets widgetId | resizeAgain] render wenv node renderer = do drawInScissor renderer True scissorVp $ diff --git a/src/Monomer/Widgets/Singles/LabeledCheckbox.hs b/src/Monomer/Widgets/Singles/LabeledCheckbox.hs --- a/src/Monomer/Widgets/Singles/LabeledCheckbox.hs +++ b/src/Monomer/Widgets/Singles/LabeledCheckbox.hs @@ -213,16 +213,20 @@ } -- | Creates a labeled checkbox using the given lens. -labeledCheckbox :: WidgetEvent e => Text -> ALens' s Bool -> WidgetNode s e +labeledCheckbox + :: WidgetEvent e + => Text -- ^ The caption. + -> ALens' s Bool -- ^ The lens into the model. + -> WidgetNode s e -- ^ The created labeled checkbox. labeledCheckbox caption field = labeledCheckbox_ caption field def -- | Creates a labeled checkbox using the given lens. Accepts config. labeledCheckbox_ :: WidgetEvent e - => Text - -> ALens' s Bool - -> [LabeledCheckboxCfg s e] - -> WidgetNode s e + => Text -- ^ The caption. + -> ALens' s Bool -- ^ The lens into the model. + -> [LabeledCheckboxCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created labeled checkbox. labeledCheckbox_ caption field config = newNode where newNode = labeledCheckboxD_ caption (WidgetLens field) config @@ -230,10 +234,10 @@ -- handler. labeledCheckboxV :: WidgetEvent e - => Text - -> Bool - -> (Bool -> e) - -> WidgetNode s e + => Text -- ^ The caption. + -> Bool -- ^ The current value. + -> (Bool -> e) -- ^ The event to raise on change. + -> WidgetNode s e -- ^ The created labeled checkbox. labeledCheckboxV caption value handler = newNode where newNode = labeledCheckboxV_ caption value handler def @@ -243,11 +247,11 @@ -} labeledCheckboxV_ :: WidgetEvent e - => Text - -> Bool - -> (Bool -> e) - -> [LabeledCheckboxCfg s e] - -> WidgetNode s e + => Text -- ^ The caption. + -> Bool -- ^ The current value. + -> (Bool -> e) -- ^ The event to raise on change. + -> [LabeledCheckboxCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created labeled checkbox. labeledCheckboxV_ caption value handler config = newNode where newConfig = onChange handler : config newNode = labeledCheckboxD_ caption (WidgetValue value) newConfig @@ -255,10 +259,10 @@ -- | Creates a labeled checkbox providing a 'WidgetData' instance and config. labeledCheckboxD_ :: WidgetEvent e - => Text - -> WidgetData s Bool - -> [LabeledCheckboxCfg s e] - -> WidgetNode s e + => Text -- ^ The caption. + -> WidgetData s Bool -- ^ The 'WidgetData' to retrieve the value from. + -> [LabeledCheckboxCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created labeled checkbox. labeledCheckboxD_ caption widgetData configs = newNode where config = mconcat configs labelSide = fromMaybe SideLeft (_lchTextSide config) diff --git a/src/Monomer/Widgets/Singles/LabeledRadio.hs b/src/Monomer/Widgets/Singles/LabeledRadio.hs --- a/src/Monomer/Widgets/Singles/LabeledRadio.hs +++ b/src/Monomer/Widgets/Singles/LabeledRadio.hs @@ -211,31 +211,31 @@ -- | Creates a labeled radio using the given lens. labeledRadio :: (RadioValue a, WidgetEvent e) - => Text - -> a - -> ALens' s a - -> WidgetNode s e + => Text -- ^ The caption. + -> a -- ^ The option value. + -> ALens' s a -- ^ The lens into the model. + -> WidgetNode s e -- ^ The created labeled radio. labeledRadio caption option field = labeledRadio_ caption option field def -- | Creates a labeled radio using the given lens. Accepts config. labeledRadio_ :: (RadioValue a, WidgetEvent e) - => Text - -> a - -> ALens' s a - -> [LabeledRadioCfg s e a] - -> WidgetNode s e + => Text -- ^ The caption. + -> a -- ^ The option value. + -> ALens' s a -- ^ The lens into the model. + -> [LabeledRadioCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created labeled radio. labeledRadio_ caption option field config = newNode where newNode = labeledRadioD_ caption option (WidgetLens field) config -- | Creates a labeled radio using the given value and 'onChange' event handler. labeledRadioV :: (RadioValue a, WidgetEvent e) - => Text - -> a - -> a - -> (a -> e) - -> WidgetNode s e + => Text -- ^ The caption. + -> a -- ^ The option value. + -> a -- ^ The current value. + -> (a -> e) -- ^ The event to raise on change. + -> WidgetNode s e -- ^ The created labeled radio. labeledRadioV caption option value handler = newNode where newNode = labeledRadioV_ caption option value handler def @@ -245,12 +245,12 @@ -} labeledRadioV_ :: (RadioValue a, WidgetEvent e) - => Text - -> a - -> a - -> (a -> e) - -> [LabeledRadioCfg s e a] - -> WidgetNode s e + => Text -- ^ The caption. + -> a -- ^ The option value. + -> a -- ^ The current value. + -> (a -> e) -- ^ The event to raise on change. + -> [LabeledRadioCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created labeled radio. labeledRadioV_ caption option value handler config = newNode where newConfig = onChange handler : config newNode = labeledRadioD_ caption option (WidgetValue value) newConfig @@ -258,11 +258,11 @@ -- | Creates a labeled radio providing a 'WidgetData' instance and config. labeledRadioD_ :: (RadioValue a, WidgetEvent e) - => Text - -> a - -> WidgetData s a - -> [LabeledRadioCfg s e a] - -> WidgetNode s e + => Text -- ^ The caption. + -> a -- ^ The option value. + -> WidgetData s a -- ^ The 'WidgetData' to retrieve the value from. + -> [LabeledRadioCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created labeled radio. labeledRadioD_ caption option widgetData configs = newNode where config = mconcat configs labelSide = fromMaybe SideLeft (_lchTextSide config) diff --git a/src/Monomer/Widgets/Singles/NumericField.hs b/src/Monomer/Widgets/Singles/NumericField.hs --- a/src/Monomer/Widgets/Singles/NumericField.hs +++ b/src/Monomer/Widgets/Singles/NumericField.hs @@ -117,6 +117,8 @@ {-| Configuration options for numericField: +- 'caretWidth': the width of the caret. +- 'caretMs': the blink period of the caret. - 'validInput': field indicating if the current input is valid. Useful to show warnings in the UI, or disable buttons if needed. - 'resizeOnChange': Whether input causes ResizeWidgets requests. @@ -287,32 +289,35 @@ -- | Creates a numeric field using the given lens. numericField :: (FormattableNumber a, WidgetEvent e) - => ALens' s a -> WidgetNode s e + => ALens' s a -- ^ The lens into the model. + -> WidgetNode s e -- ^ The created numeric field. numericField field = numericField_ field def -- | Creates a numeric field using the given lens. Accepts config. numericField_ :: (FormattableNumber a, WidgetEvent e) - => ALens' s a - -> [NumericFieldCfg s e a] - -> WidgetNode s e + => ALens' s a -- ^ The lens into the model. + -> [NumericFieldCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created numeric field. numericField_ field configs = widget where widget = numericFieldD_ (WidgetLens field) configs -- | Creates a numeric field using the given value and 'onChange' event handler. numericFieldV :: (FormattableNumber a, WidgetEvent e) - => a -> (a -> e) -> WidgetNode s e + => a -- ^ The current value. + -> (a -> e) -- ^ The event to raise on change. + -> WidgetNode s e -- ^ The created numeric field. numericFieldV value handler = numericFieldV_ value handler def -- | Creates a numeric field using the given value and 'onChange' event handler. -- Accepts config. numericFieldV_ :: (FormattableNumber a, WidgetEvent e) - => a - -> (a -> e) - -> [NumericFieldCfg s e a] - -> WidgetNode s e + => a -- ^ The current value. + -> (a -> e) -- ^ The event to raise on change. + -> [NumericFieldCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created numeric field. numericFieldV_ value handler configs = newNode where widgetData = WidgetValue value newConfigs = onChange handler : configs @@ -321,9 +326,9 @@ -- | Creates a numeric field providing a 'WidgetData' instance and config. numericFieldD_ :: forall s e a . (FormattableNumber a, WidgetEvent e) - => WidgetData s a - -> [NumericFieldCfg s e a] - -> WidgetNode s e + => WidgetData s a -- ^ The 'WidgetData' to retrieve the value from. + -> [NumericFieldCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created numeric field. numericFieldD_ widgetData configs = newNode where config = mconcat configs minVal = _nfcMinValue config diff --git a/src/Monomer/Widgets/Singles/OptionButton.hs b/src/Monomer/Widgets/Singles/OptionButton.hs --- a/src/Monomer/Widgets/Singles/OptionButton.hs +++ b/src/Monomer/Widgets/Singles/OptionButton.hs @@ -220,31 +220,31 @@ -- | Creates an optionButton using the given lens. optionButton :: OptionButtonValue a - => Text - -> a - -> ALens' s a - -> WidgetNode s e + => Text -- ^ The caption. + -> a -- ^ The option value. + -> ALens' s a -- ^ The lens into the model. + -> WidgetNode s e -- ^ The created option button. optionButton caption option field = optionButton_ caption option field def -- | Creates an optionButton using the given lens. Accepts config. optionButton_ :: OptionButtonValue a - => Text - -> a - -> ALens' s a - -> [OptionButtonCfg s e a] - -> WidgetNode s e + => Text -- ^ The caption. + -> a -- ^ The option value. + -> ALens' s a -- ^ The lens into the model. + -> [OptionButtonCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created option button. 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 :: (OptionButtonValue a, WidgetEvent e) - => Text - -> a - -> a - -> (a -> e) - -> WidgetNode s e + => Text -- ^ The caption. + -> a -- ^ The option value. + -> a -- ^ The current value. + -> (a -> e) -- ^ The event to raise on change. + -> WidgetNode s e -- ^ The created option button. optionButtonV caption option value handler = newNode where newNode = optionButtonV_ caption option value handler def @@ -252,12 +252,12 @@ -- Accepts config. optionButtonV_ :: (OptionButtonValue a, WidgetEvent e) - => Text - -> a - -> a - -> (a -> e) - -> [OptionButtonCfg s e a] - -> WidgetNode s e + => Text -- ^ The caption. + -> a -- ^ The option value. + -> a -- ^ The current value. + -> (a -> e) -- ^ The event to raise on change. + -> [OptionButtonCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created option button. optionButtonV_ caption option value handler configs = newNode where widgetData = WidgetValue value newConfigs = onChange handler : configs @@ -266,11 +266,11 @@ -- | Creates an optionButton providing a 'WidgetData' instance and config. optionButtonD_ :: OptionButtonValue a - => Text - -> a - -> WidgetData s a - -> [OptionButtonCfg s e a] - -> WidgetNode s e + => Text -- ^ The caption. + -> a -- ^ The option value. + -> WidgetData s a -- ^ The 'WidgetData' to retrieve the value from. + -> [OptionButtonCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created option button. optionButtonD_ caption option widgetData configs = optionButtonNode where config = mconcat configs makeWithStyle = makeOptionButton L.optionBtnOnStyle L.optionBtnOffStyle @@ -285,14 +285,14 @@ -} makeOptionButton :: OptionButtonValue a - => Lens' ThemeState StyleState - -> Lens' ThemeState StyleState - -> WidgetData s a - -> Text - -> (a -> Bool) - -> (a -> a) - -> OptionButtonCfg s e a - -> Widget s e + => Lens' ThemeState StyleState -- ^ The on style lens. + -> Lens' ThemeState StyleState -- ^ The off style lens. + -> WidgetData s a -- ^ The 'WidgetData' to retrieve the value from. + -> Text -- ^ The caption. + -> (a -> Bool) -- ^ Set the on or off state depending on the value. + -> (a -> a) -- ^ How to change the value on click. + -> OptionButtonCfg s e a -- ^ The config. + -> Widget s e -- ^ The created widget. makeOptionButton styleOn styleOff !field !caption !isSelVal !getNextVal !config = widget where widget = createContainer () def { containerAddStyleReq = False, 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 @@ -142,36 +142,40 @@ } -- | Creates a radio using the given lens. -radio :: (RadioValue a, WidgetEvent e) => a -> ALens' s a -> WidgetNode s e +radio + :: (RadioValue a, WidgetEvent e) + => a -- ^ The option value. + -> ALens' s a -- ^ The lens into the model. + -> WidgetNode s e -- ^ The created radio. radio option field = radio_ option field def -- | Creates a radio using the given lens. Accepts config. radio_ :: (RadioValue a, WidgetEvent e) - => a - -> ALens' s a - -> [RadioCfg s e a] - -> WidgetNode s e + => a -- ^ The option value. + -> ALens' s a -- ^ The lens into the model. + -> [RadioCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created radio. radio_ option field configs = radioD_ option (WidgetLens field) configs -- | Creates a radio using the given value and 'onChange' event handler. radioV :: (RadioValue a, WidgetEvent e) - => a - -> a - -> (a -> e) - -> WidgetNode s e + => a -- ^ The option value. + -> a -- ^ The current value. + -> (a -> e) -- ^ The event to raise on change. + -> WidgetNode s e -- ^ The created radio. radioV option value handler = radioV_ option value handler def -- | Creates a radio using the given value and 'onChange' event handler. -- Accepts config. radioV_ :: (RadioValue a, WidgetEvent e) - => a - -> a - -> (a -> e) - -> [RadioCfg s e a] - -> WidgetNode s e + => a -- ^ The option value. + -> a -- ^ The current value. + -> (a -> e) -- ^ The event to raise on change. + -> [RadioCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created radio. radioV_ option value handler configs = newNode where widgetData = WidgetValue value newConfigs = onChange handler : configs @@ -180,10 +184,10 @@ -- | Creates a radio providing a 'WidgetData' instance and config. radioD_ :: (RadioValue a, WidgetEvent e) - => a - -> WidgetData s a - -> [RadioCfg s e a] - -> WidgetNode s e + => a -- ^ The option value. + -> WidgetData s a -- ^ The 'WidgetData' to retrieve the value from. + -> [RadioCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created radio. radioD_ option widgetData configs = radioNode where config = mconcat configs wtype = WidgetType ("radio-" <> showt (typeOf option)) diff --git a/src/Monomer/Widgets/Singles/SeparatorLine.hs b/src/Monomer/Widgets/Singles/SeparatorLine.hs --- a/src/Monomer/Widgets/Singles/SeparatorLine.hs +++ b/src/Monomer/Widgets/Singles/SeparatorLine.hs @@ -8,7 +8,7 @@ SeparatorLine is used for adding a separator line between two widgets. It adapts to the active layout direction, creating a vertical line on a horizontal layout -and viceversa. +and vice versa. @ hstack [ 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 @@ -190,10 +190,10 @@ -} hslider :: (SliderValue a, WidgetEvent e) - => ALens' s a - -> a - -> a - -> WidgetNode s e + => ALens' s a -- ^ The lens into the model. + -> a -- ^ Minimum value. + -> a -- ^ Maximum value. + -> WidgetNode s e -- ^ The created slider. hslider field minVal maxVal = hslider_ field minVal maxVal def {-| @@ -202,11 +202,11 @@ -} hslider_ :: (SliderValue a, WidgetEvent e) - => ALens' s a - -> a - -> a - -> [SliderCfg s e a] - -> WidgetNode s e + => ALens' s a -- ^ The lens into the model. + -> a -- ^ Minimum value. + -> a -- ^ Maximum value. + -> [SliderCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created slider. hslider_ field minVal maxVal cfg = sliderD_ True wlens minVal maxVal cfg where wlens = WidgetLens field @@ -216,10 +216,10 @@ -} vslider :: (SliderValue a, WidgetEvent e) - => ALens' s a - -> a - -> a - -> WidgetNode s e + => ALens' s a -- ^ The lens into the model. + -> a -- ^ Minimum value. + -> a -- ^ Maximum value. + -> WidgetNode s e -- ^ The created slider. vslider field minVal maxVal = vslider_ field minVal maxVal def {-| @@ -228,11 +228,11 @@ -} vslider_ :: (SliderValue a, WidgetEvent e) - => ALens' s a - -> a - -> a - -> [SliderCfg s e a] - -> WidgetNode s e + => ALens' s a -- ^ The lens into the model. + -> a -- ^ Minimum value. + -> a -- ^ Maximum value. + -> [SliderCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created slider. vslider_ field minVal maxVal cfg = sliderD_ False wlens minVal maxVal cfg where wlens = WidgetLens field @@ -242,11 +242,11 @@ -} hsliderV :: (SliderValue a, WidgetEvent e) - => a - -> (a -> e) - -> a - -> a - -> WidgetNode s e + => a -- ^ The current value. + -> (a -> e) -- ^ The event to raise on change. + -> a -- ^ Minimum value. + -> a -- ^ Maximum value. + -> WidgetNode s e -- ^ The created slider. hsliderV value handler minVal maxVal = hsliderV_ value handler minVal maxVal def {-| @@ -255,12 +255,12 @@ -} hsliderV_ :: (SliderValue a, WidgetEvent e) - => a - -> (a -> e) - -> a - -> a - -> [SliderCfg s e a] - -> WidgetNode s e + => a -- ^ The current value. + -> (a -> e) -- ^ The event to raise on change. + -> a -- ^ Minimum value. + -> a -- ^ Maximum value. + -> [SliderCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created slider. hsliderV_ value handler minVal maxVal configs = newNode where widgetData = WidgetValue value newConfigs = onChange handler : configs @@ -272,11 +272,11 @@ -} vsliderV :: (SliderValue a, WidgetEvent e) - => a - -> (a -> e) - -> a - -> a - -> WidgetNode s e + => a -- ^ The current value. + -> (a -> e) -- ^ The event to raise on change. + -> a -- ^ Minimum value. + -> a -- ^ Maximum value. + -> WidgetNode s e -- ^ The created slider. vsliderV value handler minVal maxVal = vsliderV_ value handler minVal maxVal def {-| @@ -285,12 +285,12 @@ -} vsliderV_ :: (SliderValue a, WidgetEvent e) - => a - -> (a -> e) - -> a - -> a - -> [SliderCfg s e a] - -> WidgetNode s e + => a -- ^ The current value. + -> (a -> e) -- ^ The event to raise on change. + -> a -- ^ Minimum value. + -> a -- ^ Maximum value. + -> [SliderCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created slider. vsliderV_ value handler minVal maxVal configs = newNode where widgetData = WidgetValue value newConfigs = onChange handler : configs @@ -302,12 +302,12 @@ -} sliderD_ :: (SliderValue a, WidgetEvent e) - => Bool - -> WidgetData s a - -> a - -> a - -> [SliderCfg s e a] - -> WidgetNode s e + => Bool -- ^ True if horizontal, False if vertical + -> WidgetData s a -- ^ The 'WidgetData' to retrieve the value from. + -> a -- ^ Minimum value. + -> a -- ^ Maximum value. + -> [SliderCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created slider. sliderD_ isHz widgetData minVal maxVal configs = sliderNode where config = mconcat configs state = SliderState 0 0 diff --git a/src/Monomer/Widgets/Singles/TextArea.hs b/src/Monomer/Widgets/Singles/TextArea.hs --- a/src/Monomer/Widgets/Singles/TextArea.hs +++ b/src/Monomer/Widgets/Singles/TextArea.hs @@ -67,6 +67,8 @@ {-| Configuration options for textArea: +- 'caretWidth': the width of the caret. +- 'caretMs': the blink period of the caret. - 'maxLength': the maximum length of input text. - 'maxLines': the maximum number of lines of input text. - 'acceptTab': whether to handle tab and convert it to spaces (cancelling change @@ -221,23 +223,37 @@ } -- | Creates a text area using the given lens. -textArea :: WidgetEvent e => ALens' s Text -> WidgetNode s e +textArea + :: WidgetEvent e + => ALens' s Text -- ^ The lens into the model. + -> WidgetNode s e -- ^ The created text area. textArea field = textArea_ field def -- | Creates a text area using the given lens. Accepts config. textArea_ - :: WidgetEvent e => ALens' s Text -> [TextAreaCfg s e] -> WidgetNode s e + :: WidgetEvent e + => ALens' s Text -- ^ The lens into the model. + -> [TextAreaCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created text area. textArea_ field configs = textAreaD_ wdata configs where wdata = WidgetLens field -- | Creates a text area using the given value and 'onChange' event handler. -textAreaV :: WidgetEvent e => Text -> (Text -> e) -> WidgetNode s e +textAreaV + :: WidgetEvent e + => Text -- ^ The current value. + -> (Text -> e) -- ^ The event to raise on change. + -> WidgetNode s e -- ^ The created text area. textAreaV value handler = textAreaV_ value handler def -- | Creates a text area using the given value and 'onChange' event handler. -- Accepts config. textAreaV_ - :: WidgetEvent e => Text -> (Text -> e) -> [TextAreaCfg s e] -> WidgetNode s e + :: WidgetEvent e + => Text -- ^ The current value. + -> (Text -> e) -- ^ The event to raise on change. + -> [TextAreaCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created text area. textAreaV_ value handler configs = textAreaD_ wdata newConfig where wdata = WidgetValue value newConfig = onChange handler : configs @@ -245,9 +261,9 @@ -- | Creates a text area providing a 'WidgetData' instance and config. textAreaD_ :: WidgetEvent e - => WidgetData s Text - -> [TextAreaCfg s e] - -> WidgetNode s e + => WidgetData s Text -- ^ The 'WidgetData' to retrieve the value from. + -> [TextAreaCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created text area. textAreaD_ wdata configs = scrollNode where config = mconcat configs widget = makeTextArea wdata config def diff --git a/src/Monomer/Widgets/Singles/TextDropdown.hs b/src/Monomer/Widgets/Singles/TextDropdown.hs --- a/src/Monomer/Widgets/Singles/TextDropdown.hs +++ b/src/Monomer/Widgets/Singles/TextDropdown.hs @@ -20,7 +20,7 @@ {-# LANGUAGE Strict #-} module Monomer.Widgets.Singles.TextDropdown ( - -- * Configuratiom + -- * Configuration TextDropdownItem, -- * Constructors textDropdown, @@ -47,14 +47,14 @@ type TextDropdownItem a = DropdownItem a {-| -Creates a text dropdown using the given lens. The type must be have a 'TextShow' +Creates a text dropdown using the given lens. The type must have a 'TextShow' instance. -} textDropdown :: (WidgetModel s, WidgetEvent e, Traversable t, TextDropdownItem a, TextShow a) - => ALens' s a - -> t a - -> WidgetNode s e + => ALens' s a -- ^ The lens into the model. + -> t a -- ^ The list of items. + -> WidgetNode s e -- ^ The created text dropdown. textDropdown field items = newNode where newNode = textDropdown_ field items showt def @@ -64,24 +64,23 @@ -} textDropdown_ :: (WidgetModel s, WidgetEvent e, Traversable t, TextDropdownItem a) - => ALens' s a - -> t a - -> (a -> Text) - -> [DropdownCfg s e a] - -> WidgetNode s e + => ALens' s a -- ^ The lens into the model. + -> t a -- ^ The list of items. + -> (a -> Text) -- ^ The function for converting to Text. + -> [DropdownCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created text dropdown. textDropdown_ field items toText configs = newNode where newNode = textDropdownD_ (WidgetLens field) items toText configs {-| Creates a text dropdown using the given value and 'onChange' event handler. -Takes a function for converting the type to Text. -} textDropdownV :: (WidgetModel s, WidgetEvent e, Traversable t, TextDropdownItem a, TextShow a) - => a - -> (a -> e) - -> t a - -> WidgetNode s e + => a -- ^ The current value. + -> (a -> e) -- ^ The event to raise on change. + -> t a -- ^ The list of items. + -> WidgetNode s e -- ^ The created text dropdown. textDropdownV value handler items = newNode where newNode = textDropdownV_ value handler items showt def @@ -91,12 +90,12 @@ -} textDropdownV_ :: (WidgetModel s, WidgetEvent e, Traversable t, TextDropdownItem a) - => a - -> (a -> e) - -> t a - -> (a -> Text) - -> [DropdownCfg s e a] - -> WidgetNode s e + => a -- ^ The current value. + -> (a -> e) -- ^ The event to raise on change. + -> t a -- ^ The list of items. + -> (a -> Text) -- ^ The function for converting to Text. + -> [DropdownCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created text dropdown. textDropdownV_ value handler items toText configs = newNode where widgetData = WidgetValue value newConfigs = onChange handler : configs @@ -108,65 +107,65 @@ -} textDropdownD_ :: (WidgetModel s, WidgetEvent e, Traversable t, TextDropdownItem a) - => WidgetData s a - -> t a - -> (a -> Text) - -> [DropdownCfg s e a] - -> WidgetNode s e + => WidgetData s a -- ^ The 'WidgetData' to retrieve the value from. + -> t a -- ^ The list of items. + -> (a -> Text) -- ^ The function for converting to Text. + -> [DropdownCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created text dropdown. textDropdownD_ widgetData items toText configs = newNode where makeMain t = label_ (toText t) [resizeFactorW 0.01] makeRow t = label_ (toText t) [resizeFactorW 0.01] newNode = dropdownD_ widgetData items makeMain makeRow configs {-| -Creates a text dropdown using the given lens. The type must be have a 'Show' +Creates a text dropdown using the given lens. The type must have a 'Show' instance. -} textDropdownS :: (WidgetModel s, WidgetEvent e, Traversable t, TextDropdownItem a, Show a) - => ALens' s a - -> t a - -> WidgetNode s e + => ALens' s a -- ^ The lens into the model. + -> t a -- ^ The list of items. + -> WidgetNode s e -- ^ The created text dropdown. textDropdownS field items = newNode where newNode = textDropdownS_ field items def {-| -Creates a text dropdown using the given lens. The type must be have a 'Show' +Creates a text dropdown using the given lens. The type must have a 'Show' instance. Accepts config. -} textDropdownS_ :: (WidgetModel s, WidgetEvent e, Traversable t, TextDropdownItem a, Show a) - => ALens' s a - -> t a - -> [DropdownCfg s e a] - -> WidgetNode s e + => ALens' s a -- ^ The lens into the model. + -> t a -- ^ The list of items. + -> [DropdownCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created text dropdown. textDropdownS_ field items configs = newNode where newNode = textDropdownDS_ (WidgetLens field) items configs {-| Creates a text dropdown using the given value and 'onChange' event handler. The -type must be have a 'Show' instance. +type must have a 'Show' instance. -} textDropdownSV :: (WidgetModel s, WidgetEvent e, Traversable t, TextDropdownItem a, Show a) - => a - -> (a -> e) - -> t a - -> WidgetNode s e + => a -- ^ The current value. + -> (a -> e) -- ^ The event to raise on change. + -> t a -- ^ The list of items. + -> WidgetNode s e -- ^ The created text dropdown. textDropdownSV value handler items = newNode where newNode = textDropdownSV_ value handler items def {-| Creates a text dropdown using the given value and 'onChange' event handler. The -type must be have a 'Show' instance. Accepts config. +type must have a 'Show' instance. Accepts config. -} textDropdownSV_ :: (WidgetModel s, WidgetEvent e, Traversable t, TextDropdownItem a, Show a) - => a - -> (a -> e) - -> t a - -> [DropdownCfg s e a] - -> WidgetNode s e + => a -- ^ The current value. + -> (a -> e) -- ^ The event to raise on change. + -> t a -- ^ The list of items. + -> [DropdownCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created text dropdown. textDropdownSV_ value handler items configs = newNode where widgetData = WidgetValue value newConfigs = onChange handler : configs @@ -174,14 +173,14 @@ {-| Creates a text dropdown providing a 'WidgetData' instance and config. The -type must be have a 'Show' instance. +type must have a 'Show' instance. -} textDropdownDS_ :: (WidgetModel s, WidgetEvent e, Traversable t, TextDropdownItem a, Show a) - => WidgetData s a - -> t a - -> [DropdownCfg s e a] - -> WidgetNode s e + => WidgetData s a -- ^ The 'WidgetData' to retrieve the value from. + -> t a -- ^ The list of items. + -> [DropdownCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created text dropdown. textDropdownDS_ widgetData items configs = newNode where toText = pack . show makeMain t = label_ (toText t) [resizeFactorW 0.01] diff --git a/src/Monomer/Widgets/Singles/TextField.hs b/src/Monomer/Widgets/Singles/TextField.hs --- a/src/Monomer/Widgets/Singles/TextField.hs +++ b/src/Monomer/Widgets/Singles/TextField.hs @@ -55,6 +55,9 @@ {-| Configuration options for textField: +- 'caretWidth': the width of the caret. +- 'caretMs': the blink period of the caret. +- 'placeholder': the placeholder to use when main value is empty. - 'validInput': field indicating if the current input is valid. Useful to show warnings in the UI, or disable buttons if needed. - 'resizeOnChange': Whether input causes ResizeWidgets requests. @@ -205,29 +208,46 @@ } -- | Creates a text field using the given lens. -textField :: WidgetEvent e => ALens' s Text -> WidgetNode s e +textField + :: WidgetEvent e + => ALens' s Text -- ^ The lens into the model. + -> WidgetNode s e -- ^ The created text field. textField field = textField_ field def -- | Creates a text field using the given lens. Accepts config. textField_ - :: WidgetEvent e => ALens' s Text -> [TextFieldCfg s e] -> WidgetNode s e + :: WidgetEvent e + => ALens' s Text -- ^ The lens into the model. + -> [TextFieldCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created text field. textField_ field configs = textFieldD_ (WidgetLens field) configs -- | Creates a text field using the given value and 'onChange' event handler. -textFieldV :: WidgetEvent e => Text -> (Text -> e) -> WidgetNode s e +textFieldV + :: WidgetEvent e + => Text -- ^ The current value. + -> (Text -> e) -- ^ The event to raise on change. + -> WidgetNode s e -- ^ The created text field. textFieldV value handler = textFieldV_ value handler def -- | Creates a text field using the given value and 'onChange' event handler. -- Accepts config. textFieldV_ - :: WidgetEvent e => Text -> (Text -> e) -> [TextFieldCfg s e] -> WidgetNode s e + :: WidgetEvent e + => Text -- ^ The current value. + -> (Text -> e) -- ^ The event to raise on change. + -> [TextFieldCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created text field. textFieldV_ value handler configs = textFieldD_ widgetData newConfig where widgetData = WidgetValue value newConfig = onChange handler : configs -- | Creates a text field providing a 'WidgetData' instance and config. textFieldD_ - :: WidgetEvent e => WidgetData s Text -> [TextFieldCfg s e] -> WidgetNode s e + :: WidgetEvent e + => WidgetData s Text -- ^ The 'WidgetData' to retrieve the value from. + -> [TextFieldCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created text field. textFieldD_ widgetData configs = inputField where config = mconcat configs fromText = textToText (_tfcMaxLength config) diff --git a/src/Monomer/Widgets/Singles/TimeField.hs b/src/Monomer/Widgets/Singles/TimeField.hs --- a/src/Monomer/Widgets/Singles/TimeField.hs +++ b/src/Monomer/Widgets/Singles/TimeField.hs @@ -37,14 +37,14 @@ TimeFieldFormat, TimeOfDayConverter(..), TimeTextConverter(..), + timeFormatHHMM, + timeFormatHHMMSS, -- * Constructors timeField, timeField_, timeFieldV, timeFieldV_, - timeFieldD_, - timeFormatHHMM, - timeFormatHHMMSS + timeFieldD_ ) where import Control.Applicative ((<|>)) @@ -141,6 +141,8 @@ {-| Configuration options for timeField: +- 'caretWidth': the width of the caret. +- 'caretMs': the blink period of the caret. - 'validInput': field indicating if the current input is valid. Useful to show warnings in the UI, or disable buttons if needed. - 'resizeOnChange': Whether input causes ResizeWidgets requests. @@ -318,32 +320,35 @@ -- | Creates a time field using the given lens. timeField :: (FormattableTime a, WidgetEvent e) - => ALens' s a -> WidgetNode s e + => ALens' s a -- ^ The lens into the model. + -> WidgetNode s e -- ^ The created time field. timeField field = timeField_ field def -- | Creates a time field using the given lens. Accepts config. timeField_ :: (FormattableTime a, WidgetEvent e) - => ALens' s a - -> [TimeFieldCfg s e a] - -> WidgetNode s e + => ALens' s a -- ^ The lens into the model. + -> [TimeFieldCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created time field. timeField_ field configs = widget where widget = timeFieldD_ (WidgetLens field) configs -- | Creates a time field using the given value and 'onChange' event handler. timeFieldV :: (FormattableTime a, WidgetEvent e) - => a -> (a -> e) -> WidgetNode s e + => a -- ^ The current value. + -> (a -> e) -- ^ The event to raise on change. + -> WidgetNode s e -- ^ The created time field. timeFieldV value handler = timeFieldV_ value handler def -- | Creates a time field using the given value and 'onChange' event handler. -- Accepts config. timeFieldV_ :: (FormattableTime a, WidgetEvent e) - => a - -> (a -> e) - -> [TimeFieldCfg s e a] - -> WidgetNode s e + => a -- ^ The current value. + -> (a -> e) -- ^ The event to raise on change. + -> [TimeFieldCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created time field. timeFieldV_ value handler configs = newNode where widgetData = WidgetValue value newConfigs = onChange handler : configs @@ -352,9 +357,9 @@ -- | Creates a time field providing a 'WidgetData' instance and config. timeFieldD_ :: (FormattableTime a, WidgetEvent e) - => WidgetData s a - -> [TimeFieldCfg s e a] - -> WidgetNode s e + => WidgetData s a -- ^ The 'WidgetData' to retrieve the value from. + -> [TimeFieldCfg s e a] -- ^ The config options. + -> WidgetNode s e -- ^ The created time field. timeFieldD_ widgetData configs = newNode where config = mconcat configs format = fromMaybe defaultTimeFormat (_tfcTimeFormat config) diff --git a/src/Monomer/Widgets/Singles/ToggleButton.hs b/src/Monomer/Widgets/Singles/ToggleButton.hs --- a/src/Monomer/Widgets/Singles/ToggleButton.hs +++ b/src/Monomer/Widgets/Singles/ToggleButton.hs @@ -75,27 +75,27 @@ -- | Creates a toggleButton using the given lens. toggleButton - :: Text - -> ALens' s Bool - -> WidgetNode s e + :: Text -- ^ The caption. + -> ALens' s Bool -- ^ The lens into the model. + -> WidgetNode s e -- ^ The created toggle button. toggleButton caption field = toggleButton_ caption field def -- | Creates a toggleButton using the given lens. Accepts config. toggleButton_ - :: Text - -> ALens' s Bool - -> [ToggleButtonCfg s e] - -> WidgetNode s e + :: Text -- ^ The caption. + -> ALens' s Bool -- ^ The lens into the model. + -> [ToggleButtonCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created toggle button. 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 + => Text -- ^ The caption. + -> Bool -- ^ The current value. + -> (Bool -> e) -- ^ The event to raise on change. + -> WidgetNode s e -- ^ The created toggle button. toggleButtonV caption value handler = newNode where newNode = toggleButtonV_ caption value handler def @@ -103,11 +103,11 @@ -- Accepts config. toggleButtonV_ :: WidgetEvent e - => Text - -> Bool - -> (Bool -> e) - -> [ToggleButtonCfg s e] - -> WidgetNode s e + => Text -- ^ The caption. + -> Bool -- ^ The current value. + -> (Bool -> e) -- ^ The event to raise on change. + -> [ToggleButtonCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created toggle button. toggleButtonV_ caption value handler configs = newNode where widgetData = WidgetValue value newConfigs = onChange handler : configs @@ -115,10 +115,10 @@ -- | Creates a toggleButton providing a 'WidgetData' instance and config. toggleButtonD_ - :: Text - -> WidgetData s Bool - -> [ToggleButtonCfg s e] - -> WidgetNode s e + :: Text -- ^ The caption. + -> WidgetData s Bool -- ^ The 'WidgetData' to retrieve the value from. + -> [ToggleButtonCfg s e] -- ^ The config options. + -> WidgetNode s e -- ^ The created toggle button. toggleButtonD_ caption widgetData configs = toggleButtonNode where config = mconcat configs makeWithStyle = makeOptionButton L.toggleBtnOnStyle L.toggleBtnOffStyle diff --git a/src/Monomer/Widgets/Util/Drawing.hs b/src/Monomer/Widgets/Util/Drawing.hs --- a/src/Monomer/Widgets/Util/Drawing.hs +++ b/src/Monomer/Widgets/Util/Drawing.hs @@ -22,6 +22,7 @@ drawLine, drawRect, drawRectBorder, + drawRectBoxGradient, drawTriangle, drawTriangleBorder, drawArc, @@ -206,6 +207,23 @@ drawRectSimpleBorder renderer rect border drawRectBorder renderer rect border (Just radius) = drawRoundedRectBorder renderer rect border radius + +-- | Draws a box gradient rect with the given radius, inner and outer colors. +drawRectBoxGradient + :: Renderer -- ^ The renderer. + -> Rect -- ^ The rectangle to be drawn. + -> Double -- ^ The radius width. + -> Double -- ^ The feather size. + -> Color -- ^ The inner color. + -> Color -- ^ The outer color. + -> IO () -- ^ The resulting action. +drawRectBoxGradient renderer rect rad feather inner outer = do + beginPath renderer + renderRoundedRect renderer rect rad rad rad rad + setFillBoxGradient renderer rect rad feather inner outer + fill renderer + where + Rect rx ry rw rh = rect {-| Draws a filled triangle with the given color. diff --git a/src/Monomer/Widgets/Util/Hover.hs b/src/Monomer/Widgets/Util/Hover.hs --- a/src/Monomer/Widgets/Util/Hover.hs +++ b/src/Monomer/Widgets/Util/Hover.hs @@ -49,11 +49,11 @@ isPointInNodeEllipse :: WidgetNode s e -> Point -> Bool isPointInNodeEllipse node p = pointInEllipse p (node ^. L.info . L.viewport) --- | Checks if the main button is pressed and pointer inside the vieport. +-- | Checks if the main button is pressed and pointer inside the viewport. isNodeActive :: WidgetEnv s e -> WidgetNode s e -> Bool isNodeActive wenv node = isNodeInfoActive False wenv (node ^. L.info) --- | Checks if the main button is pressed inside the vieport. +-- | Checks if the main button is pressed inside the viewport. isNodePressed :: WidgetEnv s e -> WidgetNode s e -> Bool isNodePressed wenv node = isNodeInfoPressed False wenv (node ^. L.info) 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 @@ -24,11 +24,12 @@ initNodeStyle, mergeBasicStyle, handleStyleChange, + handleUserSizeReqChange, childOfFocusedStyle ) where import Control.Applicative ((<|>)) -import Control.Lens (Lens', (&), (^.), (^?), (.~), (?~), (<>~), _Just, _1, non) +import Control.Lens hiding ((<|), (|>)) import Data.Bits (xor) import Data.Default @@ -212,6 +213,27 @@ newResult | doCursor = handleCursorChange wenv target evt style node tmpResult | otherwise = tmpResult + +{-| +Checks if the user set size requests changed between the old and new versions of +the node. Useful during merge to trigger a widget resize. +-} +handleUserSizeReqChange + :: WidgetEnv s e + -> WidgetNode s e + -> WidgetResult s e + -> WidgetResult s e +handleUserSizeReqChange wenv oldNode result = newResult where + newNode = result ^. L.node + newWidgetId = newNode ^. L.info . L.widgetId + + (oldStyle, newStyle) = (currentStyle wenv oldNode, currentStyle wenv newNode) + changedW = oldStyle ^. L.sizeReqW /= newStyle ^. L.sizeReqW + changedH = oldStyle ^. L.sizeReqH /= newStyle ^. L.sizeReqH + newResult + | changedW || changedH = result + & L.requests %~ (|> ResizeWidgets newWidgetId) + | otherwise = result {-| Replacement of currentStyle for child widgets embedded in a focusable parent. It diff --git a/src/Monomer/Widgets/Util/Types.hs b/src/Monomer/Widgets/Util/Types.hs --- a/src/Monomer/Widgets/Util/Types.hs +++ b/src/Monomer/Widgets/Util/Types.hs @@ -42,7 +42,7 @@ Configuration for style related functions. It allows to override how each of the states (hovered, focused and active) is defined for a given widget type. -A usage example can be found in "Monomer.Widgets.Radio". +A usage example can be found in "Monomer.Widgets.Singles.Radio". -} data CurrentStyleCfg s e = CurrentStyleCfg { _ascIsHovered :: IsHovered s e, diff --git a/test/unit/Monomer/Widgets/Animation/FadeSpec.hs b/test/unit/Monomer/Widgets/Animation/FadeSpec.hs --- a/test/unit/Monomer/Widgets/Animation/FadeSpec.hs +++ b/test/unit/Monomer/Widgets/Animation/FadeSpec.hs @@ -73,7 +73,7 @@ evts AnimationStop `shouldBe` Seq.empty it "should generate an event if AnimationFinished is received" $ - evts AnimationFinished `shouldBe` Seq.singleton OnTestFinished + evts (AnimationFinished 0) `shouldBe` Seq.singleton OnTestFinished where wenv = mockWenv () diff --git a/test/unit/Monomer/Widgets/Animation/SlideSpec.hs b/test/unit/Monomer/Widgets/Animation/SlideSpec.hs --- a/test/unit/Monomer/Widgets/Animation/SlideSpec.hs +++ b/test/unit/Monomer/Widgets/Animation/SlideSpec.hs @@ -73,7 +73,7 @@ evts AnimationStop `shouldBe` Seq.empty it "should generate an event if AnimationFinished is received" $ - evts AnimationFinished `shouldBe` Seq.singleton OnTestFinished + evts (AnimationFinished 0) `shouldBe` Seq.singleton OnTestFinished where wenv = mockWenv () 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 @@ -20,6 +20,7 @@ import Control.Lens.TH (abbreviatedFields, makeLensesWith) import Data.Default import Data.Foldable (toList) +import Data.List (find) import Data.Maybe import Data.Text (Text) import Data.Typeable (Typeable, cast) @@ -42,6 +43,7 @@ import Monomer.Widgets.Singles.Button import Monomer.Widgets.Singles.Checkbox import Monomer.Widgets.Singles.Label +import Monomer.Widgets.Singles.Spacer import Monomer.Widgets.Singles.TextField import Monomer.Widgets.Util.Widget @@ -139,6 +141,7 @@ findByPoint findByPath findNextFocus + mergeUserResize getSizeReq resize @@ -614,6 +617,39 @@ hgrid [ label "7", label "8", cmpLabels ] ] ] + +mergeUserResize :: Spec +mergeUserResize = describe "merge resize" $ do + it "should not generate a request if user size did not change" $ do + let result = mergeSizeReq [] [] + find isResizeWidgets (result ^. L.requests) `shouldBe` Nothing + + it "should generate a ResizeWidgets request if user size changed" $ do + let result = mergeSizeReq [width 100] [] + find isResizeWidgets (result ^. L.requests) `shouldNotBe` Nothing + + it "should generate a ResizeWidgets request if user size changed" $ do + let result = mergeSizeReq [width 100] [width 200] + find isResizeWidgets (result ^. L.requests) `shouldNotBe` Nothing + + where + wenv = mockWenv def + handleEvent + :: WidgetEnv MainModel MainEvt + -> WidgetNode MainModel MainEvt + -> MainModel + -> MainEvt + -> [EventResponse MainModel MainEvt MainModel MainEvt] + handleEvent wenv node model evt = [] + buildUI wenv model = spacer + oldNode = composite "main" id buildUI handleEvent + newNode = composite_ "main" id buildUI handleEvent [mergeRequired (const . const . const True)] + mergeSizeReq oldStyle newStyle = result where + oldNode2 = nodeInit wenv $ + oldNode `styleBasic` oldStyle + newNode2 = newNode + `styleBasic` newStyle + result = widgetMerge (newNode2 ^. L.widget) wenv newNode2 oldNode2 getSizeReq :: Spec getSizeReq = describe "getSizeReq" $ do diff --git a/test/unit/Monomer/Widgets/ContainerSpec.hs b/test/unit/Monomer/Widgets/ContainerSpec.hs --- a/test/unit/Monomer/Widgets/ContainerSpec.hs +++ b/test/unit/Monomer/Widgets/ContainerSpec.hs @@ -19,6 +19,7 @@ import Control.Lens ((&), (^.), (^?), (.~), (%~), ix) import Control.Lens.TH (abbreviatedFields, makeLensesWith) import Data.Default +import Data.List (find) import Data.Text (Text) import Test.Hspec @@ -46,8 +47,34 @@ -- This uses Stack for testing, since Container is a template and not a real container spec :: Spec -spec = describe "Container" +spec = describe "Container" $ do + mergeUserResize handleEvent + +mergeUserResize :: Spec +mergeUserResize = describe "merge resize" $ do + it "should not generate a request if user size did not change" $ do + let result = mergeSizeReq [] [] + find isResizeWidgets (result ^. L.requests) `shouldBe` Nothing + + it "should generate a ResizeWidgets request if user size changed" $ do + let result = mergeSizeReq [width 100] [] + find isResizeWidgets (result ^. L.requests) `shouldNotBe` Nothing + + it "should generate a ResizeWidgets request if user size changed" $ do + let result = mergeSizeReq [width 100] [width 200] + find isResizeWidgets (result ^. L.requests) `shouldNotBe` Nothing + + where + wenv = mockWenvEvtUnit (TestModel "" "") + oldNode = vstack [] + newNode = vstack [] + mergeSizeReq oldStyle newStyle = result where + oldNode2 = nodeInit wenv $ + oldNode `styleBasic` oldStyle + newNode2 = newNode + `styleBasic` newStyle + result = widgetMerge (newNode2 ^. L.widget) wenv newNode2 oldNode2 handleEvent :: Spec handleEvent = describe "handleEvent" $ do diff --git a/test/unit/Monomer/Widgets/Containers/DropdownSpec.hs b/test/unit/Monomer/Widgets/Containers/DropdownSpec.hs --- a/test/unit/Monomer/Widgets/Containers/DropdownSpec.hs +++ b/test/unit/Monomer/Widgets/Containers/DropdownSpec.hs @@ -76,6 +76,9 @@ it "should not update the model if not clicked" $ model [evtClick (Point 3000 3000)] ^. selectedItem `shouldBe` testItem0 + it "should not update the model if clicked outside the list" $ + model [evtClick mainP, evtClick (Point 300 500)] ^. selectedItem `shouldBe` testItem0 + it "should update the model when clicked" $ do let itemP = Point 50 90 model [evtClick mainP, evtClick itemP] ^. selectedItem `shouldBe` testItem3 diff --git a/test/unit/Monomer/Widgets/Containers/SelectListSpec.hs b/test/unit/Monomer/Widgets/Containers/SelectListSpec.hs --- a/test/unit/Monomer/Widgets/Containers/SelectListSpec.hs +++ b/test/unit/Monomer/Widgets/Containers/SelectListSpec.hs @@ -72,8 +72,8 @@ handleEvent :: Spec handleEvent = describe "handleEvent" $ do - it "should not update the model if not clicked" $ - clickModel (Point 3000 3000) ^. selectedItem `shouldBe` testItem0 + it "should not update the model if clicked outside the list" $ + clickModel (Point 300 500) ^. selectedItem `shouldBe` testItem0 it "should update the model when clicked" $ clickModel (Point 100 70) ^. selectedItem `shouldBe` testItem3 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 @@ -69,7 +69,7 @@ handleEventV :: Spec handleEventV = describe "handleEventV" $ do - it "should generante a change event" $ + it "should generate a change event" $ events (evtRelease (Point 440 30)) `shouldBe` Seq.singleton (ColorChanged (rgb 0 200 0)) it "should generate an event when focus is received" $ diff --git a/test/unit/Monomer/Widgets/Singles/DateFieldSpec.hs b/test/unit/Monomer/Widgets/Singles/DateFieldSpec.hs --- a/test/unit/Monomer/Widgets/Singles/DateFieldSpec.hs +++ b/test/unit/Monomer/Widgets/Singles/DateFieldSpec.hs @@ -198,7 +198,7 @@ let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] model steps ^. dateValue `shouldBe` minDate - it "should drag upwnwards 10000 pixels, staying at maxDate (the maximum)" $ do + it "should drag upwards 2000 pixels, staying at maxDate (the maximum)" $ do let selStart = Point 50 50 let selEnd = Point 50 (-1950) let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] 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 @@ -194,7 +194,7 @@ let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] model steps ^. integralValue `shouldBe` -500 - it "should drag upwnwards 1000 pixels, staying at 500 (the maximum)" $ do + it "should drag upwards 1000 pixels, staying at 500 (the maximum)" $ do let selStart = Point 50 50 let selEnd = Point 50 (-950) let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] diff --git a/test/unit/Monomer/Widgets/Singles/TimeFieldSpec.hs b/test/unit/Monomer/Widgets/Singles/TimeFieldSpec.hs --- a/test/unit/Monomer/Widgets/Singles/TimeFieldSpec.hs +++ b/test/unit/Monomer/Widgets/Singles/TimeFieldSpec.hs @@ -198,7 +198,7 @@ let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd] model steps ^. timeValue `shouldBe` minTime - it "should drag upwnwards 10000 pixels, staying at maxTime (the maximum)" $ do + it "should drag upwards 2000 pixels, staying at maxTime (the maximum)" $ do let selStart = Point 50 50 let selEnd = Point 50 (-1950) let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd]