monomer 1.2.0.0 → 1.3.0.0

raw patch · 45 files changed

+783/−166 lines, 45 filesdep ~aesondep ~lensdep ~sdl2

Dependency ranges changed: aeson, lens, sdl2, text, time, wuss

Files

• ChangeLog.md +32/−0
• README.md +6/−1
• monomer.cabal +35/−35
• src/Monomer/Core/Combinators.hs +12/−0
• src/Monomer/Event/Core.hs +1/−0
• src/Monomer/Graphics/Text.hs +7/−4
• src/Monomer/Main/Core.hs +1/−1
• src/Monomer/Main/Platform.hs +3/−2
• src/Monomer/Widgets/Composite.hs +9/−4
• src/Monomer/Widgets/Container.hs +10/−2
• src/Monomer/Widgets/Containers/Base/LabeledItem.hs +14/−10
• src/Monomer/Widgets/Containers/Box.hs +2/−2
• src/Monomer/Widgets/Containers/Dropdown.hs +9/−9
• src/Monomer/Widgets/Containers/Grid.hs +27/−9
• src/Monomer/Widgets/Containers/Scroll.hs +85/−15
• src/Monomer/Widgets/Containers/SelectList.hs +9/−6
• src/Monomer/Widgets/Containers/Split.hs +4/−2
• src/Monomer/Widgets/Containers/Stack.hs +27/−9
• src/Monomer/Widgets/Singles/DateField.hs +3/−2
• src/Monomer/Widgets/Singles/Dial.hs +4/−2
• src/Monomer/Widgets/Singles/Image.hs +18/−6
• src/Monomer/Widgets/Singles/LabeledCheckbox.hs +14/−1
• src/Monomer/Widgets/Singles/LabeledRadio.hs +23/−6
• src/Monomer/Widgets/Singles/NumericField.hs +3/−1
• src/Monomer/Widgets/Singles/OptionButton.hs +15/−7
• src/Monomer/Widgets/Singles/Radio.hs +25/−7
• src/Monomer/Widgets/Singles/Slider.hs +5/−3
• src/Monomer/Widgets/Singles/TimeField.hs +3/−2
• src/Monomer/Widgets/Singles/ToggleButton.hs +1/−1
• src/Monomer/Widgets/Util/Drawing.hs +27/−4
• test/unit/Monomer/TestUtil.hs +62/−10
• test/unit/Monomer/Widgets/CompositeSpec.hs +30/−2
• test/unit/Monomer/Widgets/Containers/DropdownSpec.hs +11/−0
• test/unit/Monomer/Widgets/Containers/GridSpec.hs +42/−0
• test/unit/Monomer/Widgets/Containers/ScrollSpec.hs +60/−0
• test/unit/Monomer/Widgets/Containers/SelectListSpec.hs +11/−1
• test/unit/Monomer/Widgets/Containers/StackSpec.hs +42/−0
• test/unit/Monomer/Widgets/Singles/DateFieldSpec.hs +10/−0
• test/unit/Monomer/Widgets/Singles/DialSpec.hs +11/−0
• test/unit/Monomer/Widgets/Singles/LabeledRadioSpec.hs +10/−0
• test/unit/Monomer/Widgets/Singles/NumericFieldSpec.hs +20/−0
• test/unit/Monomer/Widgets/Singles/OptionButtonSpec.hs +10/−0
• test/unit/Monomer/Widgets/Singles/RadioSpec.hs +10/−0
• test/unit/Monomer/Widgets/Singles/SliderSpec.hs +10/−0
• test/unit/Monomer/Widgets/Singles/TimeFieldSpec.hs +10/−0

@@ -1,3 +1,35 @@+## 1.3.0.0++### Added++- Export `drawArrowUp` from `Drawing` module.+- The `image` widget now supports a `fitEither` option ([PR #56](https://github.com/fjvallarino/monomer/pull/56)). Thanks @Kyarigwo!+- The `scroll` widget now raises `onChange` events, providing the current `ScrollStatus` ([PR #51](https://github.com/fjvallarino/monomer/pull/51)).+- The `grid`, `stack`, `labeledCheckbox` and `labeledRadio` widgets now support a `childSpacing`/`childSpacing_` option+  ([PR #67](https://github.com/fjvallarino/monomer/pull/67)). Thanks @Dretch!++### Fixed++- Widgets that receive polymorphic types now append the handled type to their `WidgetType`. This+  is done to avoid issues if the handled type is later changed ([#46](https://github.com/fjvallarino/monomer/issues/46)).+- If the `WidgetType` of the root item in a `Composite` changes during `merge`, initialize the new widget instead+  of merging with the old one ([#50](https://github.com/fjvallarino/monomer/issues/50)).+- The arrow position in `dropdown` is now correct when a dropdown is taller than one line ([PR #55](https://github.com/fjvallarino/monomer/pull/55)). Thanks @Dretch!+- The middle button click is now handled by `convertEvents`, and in turn reported to widgets ([#63](https://github.com/fjvallarino/monomer/issues/63)).+- Add tolerance to width comparison in text clipping functions ([#54](https://github.com/fjvallarino/monomer/issues/54)).+- Call `pumpEvents` before `pollEvents`. The `pumpEvents` call is implied by `pollEvent`, but starting on+  SDL2 `2.0.20` it seems to be required to call it explicitly ([#66](https://github.com/fjvallarino/monomer/issues/66)). Thanks @JD95!++### Changed++- Relaxed upper bounds of dependencies for Stackage inclusion.++## 1.2.0.1++### Fixed++- The `scroll` and `split` widgets now avoid unexpected behaviour when visibility is toggled.+ ## 1.2.0.0  ### Added

@@ -77,6 +77,11 @@ If possible, keep them small and focused. If you are planning on making a large change, please submit an issue first so we can agree on a solution. +## Questions?++If you are not sure how something works or you have a usage question, feel free+to open an issue!+ ## License  This library is licensed under the [BSD-3 license](LICENSE).@@ -88,5 +93,5 @@  ## Acknowledgments -- Thanks to [Ghislaine Guerin](https://github.com/ghislaineguerin) for UX advise.+- Thanks to [Ghislaine Guerin](https://github.com/ghislaineguerin) for UX advice. - Thanks to [Mikko Mononen](https://github.com/memononen) for the amazing [nanovg](https://github.com/memononen/nanovg) library.

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           monomer-version:        1.2.0.0+version:        1.3.0.0 synopsis:       A GUI library for writing native Haskell applications. description:    Monomer is an easy to use, cross platform, GUI library for writing native                 Haskell applications.@@ -168,16 +168,16 @@     , extra >=1.6 && <1.9     , formatting >=6.0 && <8.0     , http-client >=0.6 && <0.9-    , lens >=4.16 && <5.1+    , lens >=4.16 && <6     , mtl >=2.1 && <2.3     , nanovg >=0.8 && <1.0     , process ==1.6.*     , safe ==0.3.*-    , sdl2 >=2.4.0 && <2.6+    , sdl2 >=2.5.0 && <2.6     , stm ==2.5.*-    , text ==1.2.*+    , text >=1.2 && <2.1     , text-show >=3.7 && <3.10-    , time >=1.8 && <1.13+    , time >=1.8 && <1.16     , transformers >=0.5 && <0.7     , unordered-containers >=0.2.8 && <0.3     , vector >=0.12 && <0.14@@ -203,7 +203,7 @@   build-depends:       JuicyPixels >=3.2.9 && <3.5     , OpenGL ==3.0.*-    , aeson >=1.4 && <2.1+    , aeson >=1.4 && <2.3     , async >=2.1 && <2.3     , attoparsec >=0.12 && <0.15     , base >=4.11 && <5@@ -215,17 +215,17 @@     , extra >=1.6 && <1.9     , formatting >=6.0 && <8.0     , http-client >=0.6 && <0.9-    , lens >=4.16 && <5.1+    , lens >=4.16 && <6     , monomer     , mtl >=2.1 && <2.3     , nanovg >=0.8 && <1.0     , process ==1.6.*     , safe ==0.3.*-    , sdl2 >=2.4.0 && <2.6+    , sdl2 >=2.5.0 && <2.6     , stm ==2.5.*-    , text ==1.2.*+    , text >=1.2 && <2.1     , text-show >=3.7 && <3.10-    , time >=1.8 && <1.13+    , time >=1.8 && <1.16     , transformers >=0.5 && <0.7     , unordered-containers >=0.2.8 && <0.3     , vector >=0.12 && <0.14@@ -258,18 +258,18 @@     , extra >=1.6 && <1.9     , formatting >=6.0 && <8.0     , http-client >=0.6 && <0.9-    , lens >=4.16 && <5.1+    , lens >=4.16 && <6     , monomer     , mtl >=2.1 && <2.3     , nanovg >=0.8 && <1.0     , process ==1.6.*     , random >=1.1 && <1.3     , safe ==0.3.*-    , sdl2 >=2.4.0 && <2.6+    , sdl2 >=2.5.0 && <2.6     , stm ==2.5.*-    , text ==1.2.*+    , text >=1.2 && <2.1     , text-show >=3.7 && <3.10-    , time >=1.8 && <1.13+    , time >=1.8 && <1.16     , transformers >=0.5 && <0.7     , unordered-containers >=0.2.8 && <0.3     , vector >=0.12 && <0.14@@ -301,18 +301,18 @@     , extra >=1.6 && <1.9     , formatting >=6.0 && <8.0     , http-client >=0.6 && <0.9-    , lens >=4.16 && <5.1+    , lens >=4.16 && <6     , monomer     , mtl >=2.1 && <2.3     , nanovg >=0.8 && <1.0     , process ==1.6.*     , random >=1.1 && <1.3     , safe ==0.3.*-    , sdl2 >=2.4.0 && <2.6+    , sdl2 >=2.5.0 && <2.6     , stm ==2.5.*-    , text ==1.2.*+    , text >=1.2 && <2.1     , text-show >=3.7 && <3.10-    , time >=1.8 && <1.13+    , time >=1.8 && <1.16     , transformers >=0.5 && <0.7     , unordered-containers >=0.2.8 && <0.3     , vector >=0.12 && <0.14@@ -333,7 +333,7 @@   build-depends:       JuicyPixels >=3.2.9 && <3.5     , OpenGL ==3.0.*-    , aeson >=1.4 && <2.1+    , aeson >=1.4 && <2.3     , async >=2.1 && <2.3     , attoparsec >=0.12 && <0.15     , base >=4.11 && <5@@ -345,24 +345,24 @@     , extra >=1.6 && <1.9     , formatting >=6.0 && <8.0     , http-client >=0.6 && <0.9-    , lens >=4.16 && <5.1+    , lens >=4.16 && <6     , monomer     , mtl >=2.1 && <2.3     , nanovg >=0.8 && <1.0     , process ==1.6.*     , safe ==0.3.*     , scientific ==0.3.*-    , sdl2 >=2.4.0 && <2.6+    , sdl2 >=2.5.0 && <2.6     , stm ==2.5.*-    , text ==1.2.*+    , text >=1.2 && <2.1     , text-show >=3.7 && <3.10-    , time >=1.8 && <1.13+    , time >=1.8 && <1.16     , transformers >=0.5 && <0.7     , unordered-containers >=0.2.8 && <0.3     , vector >=0.12 && <0.14     , websockets ==0.12.*     , wreq >=0.5.2 && <0.6-    , wuss ==1.1.*+    , wuss >=1.1 && <2.3   default-language: Haskell2010  executable todo@@ -389,17 +389,17 @@     , extra >=1.6 && <1.9     , formatting >=6.0 && <8.0     , http-client >=0.6 && <0.9-    , lens >=4.16 && <5.1+    , lens >=4.16 && <6     , monomer     , mtl >=2.1 && <2.3     , nanovg >=0.8 && <1.0     , process ==1.6.*     , safe ==0.3.*-    , sdl2 >=2.4.0 && <2.6+    , sdl2 >=2.5.0 && <2.6     , stm ==2.5.*-    , text ==1.2.*+    , text >=1.2 && <2.1     , text-show >=3.7 && <3.10-    , time >=1.8 && <1.13+    , time >=1.8 && <1.16     , transformers >=0.5 && <0.7     , unordered-containers >=0.2.8 && <0.3     , vector >=0.12 && <0.14@@ -437,16 +437,16 @@     , extra >=1.6 && <1.9     , formatting >=6.0 && <8.0     , http-client >=0.6 && <0.9-    , lens >=4.16 && <5.1+    , lens >=4.16 && <6     , monomer     , mtl >=2.1 && <2.3     , nanovg >=0.8 && <1.0     , process ==1.6.*     , random >=1.1 && <1.3     , safe ==0.3.*-    , sdl2 >=2.4.0 && <2.6+    , sdl2 >=2.5.0 && <2.6     , stm ==2.5.*-    , text ==1.2.*+    , text >=1.2 && <2.1     , text-show >=3.7 && <3.10     , time >=1.8 && <1.13     , transformers >=0.5 && <0.7@@ -528,18 +528,18 @@     , formatting >=6.0 && <8.0     , hspec >=2.4 && <3.0     , http-client >=0.6 && <0.9-    , lens >=4.16 && <5.1+    , lens >=4.16 && <6     , monomer     , mtl >=2.1 && <2.3     , nanovg >=0.8 && <1.0     , process ==1.6.*     , safe ==0.3.*-    , sdl2 >=2.4.0 && <2.6+    , sdl2 >=2.5.0 && <2.6     , silently ==1.2.*     , stm ==2.5.*-    , text ==1.2.*+    , text >=1.2 && <2.1     , text-show >=3.7 && <3.10-    , time >=1.8 && <1.13+    , time >=1.8 && <1.16     , transformers >=0.5 && <0.7     , unordered-containers >=0.2.8 && <0.3     , vector >=0.12 && <0.14

@@ -265,6 +265,10 @@ class CmbFitHeight t where   fitHeight :: t +-- | Either fitWidth or fitHeight such that image does not overflow viewport+class CmbFitEither t where+  fitEither :: t+ -- | Applies nearest filtering when stretching an image. class CmbImageNearest t where   imageNearest :: t@@ -694,3 +698,11 @@ -- | Set radius for the bottom right corner. class CmbRadiusBR t where   radiusBR :: Double -> t++-- | Set the spacing between the children of the container.+class CmbChildSpacing t where+  -- | Set the spacing to the default amount (may vary by container).+  childSpacing :: t+  childSpacing = childSpacing_ 10+  -- | Set the spacing to the specified amount.+  childSpacing_ :: Double -> t

@@ -85,6 +85,7 @@     button = case SDL.mouseButtonEventButton eventData of       SDL.ButtonLeft -> Just BtnLeft       SDL.ButtonRight -> Just BtnRight+      SDL.ButtonMiddle -> Just BtnMiddle       _ -> Nothing      action = case SDL.mouseButtonEventMotion eventData of

@@ -328,7 +328,7 @@   targetW = width - tw    dropHelper (idx, w) g-    | _glpW g + w <= dw = (idx + 1, _glpW g + w)+    | isSafeLE (_glpW g + w) dw = (idx + 1, _glpW g + w)     | otherwise = (idx, w)   (dropChars, _) = foldl' dropHelper (0, targetW) (Seq.reverse _tlGlyphs) @@ -359,11 +359,11 @@   fontSpcH = styleFontSpaceH style    takeHelper (idx, w) g-    | _glpW g + w <= width = (idx + 1, _glpW g + w)+    | isSafeLE (_glpW g + w) width = (idx + 1, _glpW g + w)     | otherwise = (idx, w)    (takeChars, _) = foldl' takeHelper (0, 0) _tlGlyphs-  validGlyphs = Seq.takeWhileL (\g -> _glpXMax g <= width) _tlGlyphs+  validGlyphs = Seq.takeWhileL (\g -> isSafeLE (_glpXMax g) width) _tlGlyphs   newText     | trim == KeepSpaces = T.take (length validGlyphs) _tlText     | otherwise = T.dropWhileEnd (== ' ') $ T.take (length validGlyphs) _tlText@@ -395,7 +395,7 @@   -> (Seq GlyphPos, Seq GlyphGroup) fitExtraGroups Empty _ _ _ = (Empty, Empty) fitExtraGroups (g :<| gs) !width !prevGMax !keepTailSpaces-  | gW + wDiff <= width || keepSpace = (g <> newFit, newRest)+  | isSafeLE (gW + wDiff) width || keepSpace = (g <> newFit, newRest)   | otherwise = (Empty, g :<| gs)   where     gW = getGlyphsWidth g@@ -444,3 +444,6 @@  isSpace :: Char -> Bool isSpace = (== ' ')++isSafeLE :: Double -> Double -> Bool+isSafeLE width target = width <= target || abs (target - width) < 0.001

@@ -220,7 +220,7 @@   let MainLoopArgs{..} = loopArgs    startTicks <- fmap fromIntegral SDL.ticks-  events <- SDL.pollEvents+  events <- SDL.pumpEvents >> SDL.pollEvents    windowSize <- use L.windowSize   dpr <- use L.dpr

@@ -23,6 +23,7 @@ ) where  import Control.Monad (void)+import Control.Monad.Extra (whenJust) import Control.Monad.State import Data.Maybe import Data.Text (Text)@@ -90,8 +91,8 @@         | platform `elem` ["Windows", "Linux"] = (scaleFactor, 1 / scaleFactor)         | otherwise = (scaleFactor * contentRatio, 1 / scaleFactor) -- macOS -  when (isJust (_apcWindowTitle config)) $-    SDL.windowTitle window $= fromJust (_apcWindowTitle config)+  whenJust (_apcWindowTitle config) $ \title ->+    SDL.windowTitle window $= title    when windowFullscreen $     SDL.setWindowMode window SDL.FullscreenDesktop

@@ -528,8 +528,8 @@   -- The same model is provided as old since nothing else is available, but   -- mergeRequired may be using data from a closure   modelChanged = _cmpMergeRequired comp (fromJust oldModel) model-  visibleChg = oldComp ^. L.info . L.visible /= newComp ^. L.info . L.visible-  enabledChg = oldComp ^. L.info . L.enabled /= newComp ^. L.info . L.enabled+  visibleChg = nodeVisibleChanged oldComp newComp+  enabledChg = nodeEnabledChanged oldComp newComp   flagsChanged = visibleChg || enabledChg   themeChanged = wenv ^. L.themeChanged   mergeRequired@@ -914,10 +914,14 @@ mergeChild comp state wenv newModel widgetRoot widgetComp = newResult where   CompositeState{..} = state   cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap newModel+  widgetId = _cpsRoot ^. L.info . L.widgetId   builtRoot = cascadeCtx wenv widgetComp (_cmpUiBuilder comp cwenv newModel)-      & L.info . L.widgetId .~ _cpsRoot ^. L.info . L.widgetId+      & L.info . L.widgetId .~ widgetId   builtWidget = builtRoot ^. L.widget-  mergedResult = widgetMerge builtWidget cwenv builtRoot widgetRoot+  initRequired = not (nodeMatches widgetRoot builtRoot)+  mergedResult+    | initRequired = widgetInit builtWidget cwenv builtRoot+    | otherwise = widgetMerge builtWidget cwenv builtRoot widgetRoot   !mergedState = state {     _cpsModel = Just newModel,     _cpsRoot = mergedResult ^. L.node,@@ -926,6 +930,7 @@   !result = toParentResult comp mergedState wenv widgetComp mergedResult   !newReqs = widgetDataSet (_cmpWidgetData comp) newModel     ++ fmap ($ newModel) (_cmpOnChangeReq comp)+    ++ [ResizeWidgets widgetId | initRequired]   !newResult = result     & L.requests <>~ Seq.fromList newReqs 

@@ -317,11 +317,19 @@   -> (SizeReq, SizeReq)    -- ^ The horizontal and vertical requirements.  {-|-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.+Assigns space to children according to the Container's logic, returning a 'Seq'+of 'Rect's in the same order of the child widgets. If the container has a single+child it is not generally necessary to override this function. A new version of+the Container may be returned if state needs to be updated.  Examples can be found in "Monomer.Widgets.Containers.Grid" and "Monomer.Widgets.Containers.Stack".++Note: if the Container's state depends on the current size, visibility should be+considered; since invisible nodes receive zero space, it may affect calculations+and cause unexpected behavior when the widget is made visible again. Examples+can be found in "Monomer.Widgets.Containers.Scroll" and+"Monomer.Widgets.Containers.Split". -} type ContainerResizeHandler s e   = WidgetEnv s e                  -- ^ The widget environment.

@@ -26,7 +26,7 @@ import qualified Data.Sequence as Seq  import Monomer.Core-import Monomer.Core.Combinators+import Monomer.Core.Combinators as Cmb  import Monomer.Widgets.Container import Monomer.Widgets.Containers.Stack@@ -43,22 +43,24 @@   :: WidgetEvent e   => WidgetType   -> RectSide+  -> Maybe Double   -> Text   -> LabelCfg s e   -> WidgetNode s e   -> WidgetNode s e-labeledItem wtype textSide caption labelCfg itemNode = labeledNode where-  widget = makeLabeledItem textSide caption labelCfg itemNode+labeledItem wtype textSide childSpacing caption labelCfg itemNode = labeledNode where+  widget = makeLabeledItem textSide childSpacing caption labelCfg itemNode   labeledNode = defaultWidgetNode wtype widget  makeLabeledItem   :: WidgetEvent e   => RectSide+  -> Maybe Double   -> Text   -> LabelCfg s e   -> WidgetNode s e   -> Widget s e-makeLabeledItem textSide caption labelCfg itemNode = widget where+makeLabeledItem textSide childSpacing caption labelCfg itemNode = widget where   widget = createContainer () def {     containerInit = init,     containerMerge = merge,@@ -83,10 +85,12 @@       & L.info . L.style <>~ itemStyle      childNode-      | textSide == SideLeft = hstack [ labelNode, spacer, styledNode ]-      | textSide == SideRight = hstack [ styledNode, spacer, labelNode ]-      | textSide == SideTop = vstack [ labelNode, spacer, styledNode ]-      | otherwise = vstack [ styledNode, spacer, labelNode ]+      | textSide == SideLeft = hstack_ stackCfg [ labelNode, styledNode ]+      | textSide == SideRight = hstack_ stackCfg [ styledNode, labelNode ]+      | textSide == SideTop = vstack_ stackCfg [ labelNode, styledNode ]+      | otherwise = vstack_ stackCfg [ styledNode, labelNode ]+    stackCfg =+      [maybe Cmb.childSpacing Cmb.childSpacing_ childSpacing]     newNode = node       & L.children .~ Seq.singleton childNode @@ -110,8 +114,8 @@     where       labelIdx         | textSide `elem` [SideLeft, SideTop] = 0-        | otherwise = 2-      targetIdx = 2 - labelIdx+        | otherwise = 1+      targetIdx = 1 - labelIdx       newPath = Seq.take (length target - 1) target |> targetIdx       labelNode = node ^. L.children . ix 0 . L.children ^?! ix labelIdx       targetNode = node ^. L.children . ix 0 . L.children ^?! ix targetIdx

@@ -397,8 +397,8 @@     contentArea = fromMaybe def (removeOuterBounds style viewport)     Rect cx cy cw ch = contentArea -    contentW = snd $ assignStackAreas True contentArea children-    contentH = snd $ assignStackAreas False contentArea children+    contentW = snd $ assignStackAreas True contentArea 0 children+    contentH = snd $ assignStackAreas False contentArea 0 children      raChild = Rect cx cy (min cw contentW) (min ch contentH)     ah = fromMaybe ACenter (_boxAlignH config)

@@ -18,6 +18,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StrictData #-}  module Monomer.Widgets.Containers.Dropdown (@@ -40,8 +41,9 @@ import Data.Maybe import Data.Sequence (Seq(..), (<|), (|>)) import Data.Text (Text)-import Data.Typeable (cast)+import Data.Typeable (Typeable, Proxy, cast, typeRep) import GHC.Generics+import TextShow  import qualified Data.Sequence as Seq @@ -223,22 +225,21 @@  -- | Creates a dropdown providing a WidgetData instance and config. dropdownD_-  :: (WidgetModel s, WidgetEvent e, Traversable t, DropdownItem a)+  :: forall s e t a . (WidgetModel s, WidgetEvent e, Traversable t, DropdownItem a)   => WidgetData s a         -- ^ The 'WidgetData' to retrieve the value from.   -> t a                    -- ^ The list of selectable items.   -> (a -> WidgetNode s e)  -- ^ Function to create the header (always visible).   -> (a -> WidgetNode s e)  -- ^ Function to create the list (collapsable).   -> [DropdownCfg s e a]    -- ^ The config options.   -> WidgetNode s e         -- ^ The created dropdown.-dropdownD_ widgetData items makeMain makeRow configs = makeNode widget where+dropdownD_ widgetData items makeMain makeRow configs = newNode where   config = mconcat configs   newState = DropdownState False def   newItems = foldl' (|>) Empty items+  wtype = WidgetType ("dropdown-" <> showt (typeRep (undefined :: Proxy a)))   widget = makeDropdown widgetData newItems makeMain makeRow config newState--makeNode :: Widget s e -> WidgetNode s e-makeNode widget = defaultWidgetNode "dropdown" widget-  & L.info . L.focusable .~ True+  newNode = defaultWidgetNode wtype widget+    & L.info . L.focusable .~ True  makeDropdown   :: (WidgetModel s, WidgetEvent e, DropdownItem a)@@ -505,8 +506,7 @@       Rect x y w h = contentArea       size = style ^. L.text . non def . L.fontSize . non def       arrowW = unFontSize size / 2-      dh = (h - arrowW) / 2-      arrowRect = Rect (x + w - dh * 2) (y + dh * 1.25) arrowW (arrowW / 2)+      arrowRect = Rect (x + w - arrowW) (y + h / 2 - arrowW / 3) arrowW (arrowW / 2)    renderOverlay renderer wenv overlayNode = renderAction where     widget = overlayNode ^. L.widget

@@ -24,7 +24,7 @@ ) where  import Control.Applicative ((<|>))-import Control.Lens ((&), (^.), (.~))+import Control.Lens ((&), (^.), (.~), (%~)) import Data.Default import Data.List (foldl') import Data.Maybe@@ -40,25 +40,34 @@ {-| Configuration options for grid: +- 'childSpacing': spacing between the child widgets. - 'sizeReqUpdater': allows modifying the 'SizeReq' generated by the grid. -}-newtype GridCfg = GridCfg {+data GridCfg = GridCfg {+  _grcChildSpacing :: Maybe Double,   _grcSizeReqUpdater :: [SizeReqUpdater] }  instance Default GridCfg where   def = GridCfg {+    _grcChildSpacing = Nothing,     _grcSizeReqUpdater = []   }  instance Semigroup GridCfg where   (<>) s1 s2 = GridCfg {+    _grcChildSpacing = _grcChildSpacing s2 <|> _grcChildSpacing s1,     _grcSizeReqUpdater = _grcSizeReqUpdater s1 <> _grcSizeReqUpdater s2   }  instance Monoid GridCfg where   mempty = def +instance CmbChildSpacing GridCfg where+  childSpacing_ spacing = def {+    _grcChildSpacing = Just spacing+  }+ instance CmbSizeReqUpdater GridCfg where   sizeReqUpdater updater = def {     _grcSizeReqUpdater = [updater]@@ -95,6 +104,7 @@   }    isVertical = not isHorizontal+  childSpacing = fromMaybe 0 (_grcChildSpacing config)    getSizeReq wenv node children = newSizeReq where     sizeReqFns = _grcSizeReqUpdater config@@ -105,12 +115,13 @@    getDimSizeReq mainAxis accesor vchildren     | Seq.null vreqs = fixedSize 0-    | mainAxis = foldl1 sizeReqMergeSum (Seq.replicate nreqs maxSize)+    | mainAxis = foldl1 sizeReqMergeSum (Seq.replicate nreqs maxSize) & L.fixed %~ (+ totalSpacing)     | otherwise = maxSize     where       vreqs = accesor <$> vchildren       nreqs = Seq.length vreqs       ~maxSize = foldl1 sizeReqMergeMax vreqs+      totalSpacing = fromIntegral (nreqs - 1) * childSpacing    resize wenv node viewport children = resized where     style = currentStyle wenv node@@ -118,18 +129,25 @@     Rect l t w h = contentArea     vchildren = Seq.filter (_wniVisible . _wnInfo) children +    totalSpacingW = fromIntegral (max 0 (cols - 1)) * childSpacing+    totalSpacingH = fromIntegral (max 0 (rows - 1)) * childSpacing+     cols = if isHorizontal then length vchildren else 1     rows = if isHorizontal then 1 else length vchildren -    cw = if cols > 0 then w / fromIntegral cols else 0-    ch = if rows > 0 then h / fromIntegral rows else 0+    cw = if cols > 0 then (w - totalSpacingW) / fromIntegral cols else 0+    ch = if rows > 0 then (h - totalSpacingH) / fromIntegral rows else 0      cx i-      | rows > 0 = l + fromIntegral (i `div` rows) * cw-      | otherwise = 0+      | rows == 0 = 0+      | isHorizontal = l + fromIntegral i * cw + spacingOffset i+      | otherwise = l     cy i-      | cols > 0 = t + fromIntegral (i `div` cols) * ch-      | otherwise = 0+      | cols == 0 = 0+      | isVertical = t + fromIntegral i * ch + spacingOffset i+      | otherwise = t+    spacingOffset i =+      fromIntegral i * childSpacing      foldHelper (currAreas, index) child = (newAreas, newIndex) where       (newIndex, newViewport)

@@ -22,12 +22,12 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE StrictData #-}  module Monomer.Widgets.Containers.Scroll (   -- * Configuration   ScrollCfg,+  ScrollStatus(..),   ScrollMessage(..),   scrollOverlay,   scrollOverlay_,@@ -68,6 +68,23 @@   | ScrollBoth   deriving (Eq, Show) +data ScrollStatus = ScrollStatus {+  scrollDeltaX :: Double,+  scrollDeltaY :: Double,+  scrollRect :: Rect,+  scrollVpSize :: Size,+  scrollChildSize :: Size+} deriving (Eq, Show)++instance Default ScrollStatus where+  def = ScrollStatus {+    scrollDeltaX = 0,+    scrollDeltaY = 0,+    scrollRect = def,+    scrollVpSize = def,+    scrollChildSize = def+  }+ data ActiveBar   = HBar   | VBar@@ -76,6 +93,12 @@ {-| Configuration options for scroll: +- 'scrollOverlay': whether scroll bar should be on top of content or by the+  side.+- 'scrollInvisible': shortcut for setting invisible style. Useful with scroll+  overlay, since it allows scrolling without taking up space or hiding content.+- 'scrollFollowFocus': whether to auto scroll when focusing a non visible item.+- 'scrollStyle': the base style of the scroll bar. - 'wheelRate': rate at which wheel movement causes scrolling. - 'barColor': the color of the bar (container of the thumb). - 'barHoverColor': the color of the bar when mouse is on top.@@ -84,12 +107,8 @@ - 'thumbHoverColor': the color of the thumb when mouse is on top. - 'thumbWidth': the width of the thumb. - 'thumbRadius': the radius of the corners of the thumb.-- 'scrollOverlay': whether scroll bar should be on top of content or by the-  side.-- 'scrollInvisible': shortcut for setting invisible style. Useful with scroll-  overlay, since it allows scrolling without taking up space or hiding content.-- 'scrollFollowFocus': whether to auto scroll when focusing a non visible item.-- 'scrollStyle': the base style of the scroll bar.+- 'onChange': event to raise when the viewport changes.+- 'onChangeReq': 'WidgetRequest' to generate when the viewport changes. -} data ScrollCfg s e = ScrollCfg {   _scScrollType :: Maybe ScrollType,@@ -104,7 +123,8 @@   _scStyle :: Maybe (ALens' ThemeState StyleState),   _scBarWidth :: Maybe Double,   _scThumbWidth :: Maybe Double,-  _scThumbRadius :: Maybe Double+  _scThumbRadius :: Maybe Double,+  _scOnChangeReq :: [ScrollStatus -> WidgetRequest s e] }  instance Default (ScrollCfg s e) where@@ -121,7 +141,8 @@     _scStyle = Nothing,     _scBarWidth = Nothing,     _scThumbWidth = Nothing,-    _scThumbRadius = Nothing+    _scThumbRadius = Nothing,+    _scOnChangeReq = []   }  instance Semigroup (ScrollCfg s e) where@@ -138,7 +159,8 @@     _scStyle = _scStyle t2 <|> _scStyle t1,     _scBarWidth = _scBarWidth t2 <|> _scBarWidth t1,     _scThumbWidth = _scThumbWidth t2 <|> _scThumbWidth t1,-    _scThumbRadius = _scThumbRadius t2 <|> _scThumbRadius t1+    _scThumbRadius = _scThumbRadius t2 <|> _scThumbRadius t1,+    _scOnChangeReq = _scOnChangeReq t2 <|> _scOnChangeReq t1   }  instance Monoid (ScrollCfg s e) where@@ -185,6 +207,16 @@     _scThumbRadius = Just r   } +instance WidgetEvent e => CmbOnChange (ScrollCfg s e) ScrollStatus e where+  onChange fn = def {+    _scOnChangeReq = [RaiseEvent . fn]+  }++instance CmbOnChangeReq (ScrollCfg s e) s e ScrollStatus where+  onChangeReq req = def {+    _scOnChangeReq = [req]+  }+ -- | Scroll bars will be displayed on top of the content. scrollOverlay :: ScrollCfg s e scrollOverlay = scrollOverlay_ True@@ -559,6 +591,7 @@     rect = moveRect offset targetRect     Rect rx ry rw rh = rect     Rect cx cy _ _ = contentArea+    childVp = Rect cx cy maxVpW maxVpH      diffL = cx - rx     diffR = cx + maxVpW - (rx + rw)@@ -566,11 +599,11 @@     diffB = cy + maxVpH - (ry + rh)      stepX-      | rectInRectH rect contentArea = dx+      | rectInRectH rect childVp = dx       | abs diffL <= abs diffR = diffL + dx       | otherwise = diffR + dx     stepY-      | rectInRectV rect contentArea = dy+      | rectInRectV rect childVp = dy       | abs diffT <= abs diffB = diffT + dy       | otherwise = diffB + dy @@ -579,7 +612,7 @@       _sstDeltaY = scrollAxisV stepY     }     result-      | rectInRect rect contentArea = Nothing+      | rectInRect rect childVp = Nothing       | otherwise = Just $ rebuildWidget wenv node newState    scrollReset wenv node = result where@@ -613,9 +646,14 @@     }    rebuildWidget wenv node newState = result where+    updateReqs+      | childPosChanged state newState = scrollInfoReqs node config newState+      | otherwise = []+     newNode = node       & L.widget .~ makeScroll config newState     result = resultNode newNode+      & L.requests .~ Seq.fromList updateReqs    getSizeReq :: ContainerGetSizeReqHandler s e   getSizeReq wenv node children = sizeReq where@@ -676,10 +714,21 @@       _sstChildSize = Size areaW areaH,       _sstScissor = scissor     }-    newNode = resultNode $ node+    newNode = node       & L.widget .~ makeScroll config newState-    result = (newNode, Seq.singleton cViewport)+      -- For scrollInfoReqs only, since parent will set viewport later+      & L.info . L.viewport .~ viewport +    updateReqs+      | childPosChanged state newState = scrollInfoReqs newNode config newState+      | otherwise = []+    visibleResult = resultNode newNode+      & L.requests .~ Seq.fromList updateReqs++    result+      | node ^. L.info . L.visible = (visibleResult, Seq.singleton cViewport)+      | otherwise = (resultNode node, Seq.singleton cViewport)+   renderAfter wenv node renderer = do     when hScrollRequired $       drawRect renderer hScrollRect barColorH Nothing@@ -729,6 +778,27 @@       thumbColorV         | vMouseInThumb || draggingV = thumbHCol         | otherwise = thumbBCol++childPosChanged :: ScrollState -> ScrollState -> Bool+childPosChanged state newState = _sstVpSize state /= _sstVpSize newState+  || _sstChildSize state /= _sstChildSize newState+  || _sstDeltaX state /= _sstDeltaX newState+  || _sstDeltaY state /= _sstDeltaY newState++scrollInfoReqs+  :: WidgetNode s e+  -> ScrollCfg s e+  -> ScrollState+  -> [WidgetRequest s e]+scrollInfoReqs node config state = reqs where+  info = ScrollStatus {+    scrollDeltaX = _sstDeltaX state,+    scrollDeltaY = _sstDeltaY state,+    scrollRect = node ^. L.info . L.viewport,+    scrollVpSize = _sstVpSize state,+    scrollChildSize = _sstChildSize state+  }+  reqs = fmap ($ info) (_scOnChangeReq config)  scrollCurrentStyle :: WidgetEnv s e -> WidgetNode s e -> StyleState scrollCurrentStyle wenv node

@@ -15,6 +15,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Monomer.Widgets.Containers.SelectList (   -- * Configuration@@ -38,7 +39,8 @@ import Data.Maybe import Data.Sequence (Seq(..), (<|), (|>)) import Data.Text (Text)-import Data.Typeable (Typeable, cast)+import Data.Typeable (Typeable, Proxy, cast, typeRep)+import TextShow  import qualified Data.Map as Map import qualified Data.Sequence as Seq@@ -235,21 +237,22 @@  -- | Creates a dropdown providing a 'WidgetData' instance and config. selectListD_-  :: (WidgetModel s, WidgetEvent e, Traversable t, SelectListItem a)+  :: 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.   -> SelectListMakeRow s e a  -- ^ Function to create the list items.   -> [SelectListCfg s e a]  -- ^ The config options.   -> WidgetNode s e         -- ^ The created dropdown.-selectListD_ widgetData items makeRow configs = makeNode widget where+selectListD_ widgetData items makeRow configs = makeNode wtype widget where   config = mconcat configs   newItems = foldl' (|>) Empty items   newState = SelectListState newItems (-1) 0+  wtype = WidgetType ("selectList-" <> showt (typeRep (undefined :: Proxy a)))   widget = makeSelectList widgetData newItems makeRow config newState -makeNode :: Widget s e -> WidgetNode s e-makeNode widget = scroll_ [scrollStyle L.selectListStyle] childNode where-  childNode = defaultWidgetNode "selectList" widget+makeNode :: WidgetType -> Widget s e -> WidgetNode s e+makeNode wtype widget = scroll_ [scrollStyle L.selectListStyle] childNode where+  childNode = defaultWidgetNode wtype widget     & L.info . L.focusable .~ True  makeSelectList

@@ -270,7 +270,7 @@     style = currentStyle wenv node     contentArea = fromMaybe def (removeOuterBounds style viewport)     Rect rx ry rw rh = contentArea-    (areas, newSize) = assignStackAreas isHorizontal contentArea children+    (areas, newSize) = assignStackAreas isHorizontal contentArea 0 children     oldHandlePos = _spsHandlePos state      sizeReq1 = sizeReq $ Seq.index children 0@@ -320,7 +320,9 @@       & L.node . L.widget .~ makeSplit isHorizontal config newState       & L.requests .~ Seq.fromList (requestPos ++ reqOnChange)     newVps = Seq.fromList [rect1, rect2]-    resized = (result, newVps)+    resized+      | node ^. L.info . L.visible = (result, newVps)+      | otherwise = (resultNode node, newVps)    getValidHandlePos maxDim vp handleXY children = addPoint origin newPoint where     Rect rx ry _ _ = vp

@@ -26,7 +26,7 @@ ) where  import Control.Applicative ((<|>))-import Control.Lens ((&), (^.), (.~))+import Control.Lens ((&), (^.), (.~), (%~)) import Data.Default import Data.Foldable (toList) import Data.List (foldl')@@ -43,24 +43,28 @@ {-| Configuration options for stack: +- 'childSpacing': spacing between the child widgets. - 'ignoreEmptyArea': when the widgets do not use all the available space,   ignoring the unassigned space allows for mouse events to pass through. This is   useful in zstack layers. - 'sizeReqUpdater': allows modifying the 'SizeReq' generated by the stack. -} data StackCfg = StackCfg {+  _stcChildSpacing :: Maybe Double,   _stcIgnoreEmptyArea :: Maybe Bool,   _stcSizeReqUpdater :: [SizeReqUpdater] }  instance Default StackCfg where   def = StackCfg {+    _stcChildSpacing = Nothing,     _stcIgnoreEmptyArea = Nothing,     _stcSizeReqUpdater = []   }  instance Semigroup StackCfg where   (<>) s1 s2 = StackCfg {+    _stcChildSpacing = _stcChildSpacing s2 <|> _stcChildSpacing s1,     _stcIgnoreEmptyArea = _stcIgnoreEmptyArea s2 <|> _stcIgnoreEmptyArea s1,     _stcSizeReqUpdater = _stcSizeReqUpdater s1 <> _stcSizeReqUpdater s2   }@@ -68,6 +72,11 @@ instance Monoid StackCfg where   mempty = def +instance CmbChildSpacing StackCfg where+  childSpacing_ spacing = def {+    _stcChildSpacing = Just spacing+  }+ instance CmbIgnoreEmptyArea StackCfg where   ignoreEmptyArea_ ignore = def {     _stcIgnoreEmptyArea = Just ignore@@ -120,6 +129,7 @@    isVertical = not isHorizontal   ignoreEmptyArea = fromMaybe False (_stcIgnoreEmptyArea config)+  childSpacing = fromMaybe 0 (_stcChildSpacing config)    getSizeReq wenv node children = newSizeReq where     sizeReqFns = _stcSizeReqUpdater config@@ -130,15 +140,16 @@    getDimSizeReq mainAxis accesor vchildren     | Seq.null vreqs = fixedSize 0-    | mainAxis = foldl1 sizeReqMergeSum vreqs+    | mainAxis = foldl1 sizeReqMergeSum vreqs & L.fixed %~ (+ totalSpacing)     | otherwise = foldl1 sizeReqMergeMax vreqs     where       vreqs = accesor <$> vchildren+      totalSpacing = fromIntegral (Seq.length vchildren - 1) * childSpacing    resize wenv node viewport children = resized where     style = currentStyle wenv node     contentArea = fromMaybe def (removeOuterBounds style viewport)-    (newVps, newDim) = assignStackAreas isHorizontal contentArea children+    (newVps, newDim) = assignStackAreas isHorizontal contentArea childSpacing children     newCa       | isHorizontal = contentArea & L.w .~ newDim       | otherwise = contentArea & L.h .~ newDim@@ -153,9 +164,10 @@ assignStackAreas   :: Bool                 -- ^ True if horizontal, False for vertical.   -> Rect                 -- ^ The available space to assign.+  -> Double               -- ^ The spacing between adjacent children.   -> Seq (WidgetNode s e) -- ^ The widgets that will be assigned space.   -> (Seq Rect, Double)   -- ^ The assigned areas and used space in main axis.-assignStackAreas isHorizontal contentArea children = result where+assignStackAreas isHorizontal contentArea childSpacing children = result where   Rect x y w h = contentArea   mainSize = if isHorizontal then w else h   mainStart = if isHorizontal then x else y@@ -173,9 +185,12 @@     newExtraFac = cExtraFac + sizeReqExtra req * sizeReqFactor req     newStep = (newFixed, newFlex, newFlexFac, newExtraFac) +  visibleSpacings = max 0 (Seq.length vchildren - 1)+  totalSpacing = fromIntegral visibleSpacings * childSpacing+   (fixed, flex, flexFac, extraFac) = foldl' sumSizes def reqs-  flexAvail = min flex (mainSize - fixed)-  extraAvail = max 0 (mainSize - fixed - flexAvail)+  flexAvail = min flex (mainSize - fixed - totalSpacing)+  extraAvail = max 0 (mainSize - fixed - totalSpacing - flexAvail)    -- flexCoeff can only be negative   flexCoeff@@ -185,12 +200,15 @@     | extraAvail > 0 && extraFac > 0 = extraAvail / extraFac     | otherwise = 0 -  foldHelper (accum, offset) child = (newAccum, newOffset) where+  foldHelper (accum, offset, vIndex) child = (newAccum, newOffset, newVIndex) where     newRect = resizeChild isHorizontal contentArea flexCoeff extraCoeff offset child     newAccum = accum |> newRect-    newOffset = offset + rectSelector newRect+    newOffset = offset + rectSelector newRect + spacing+    newVIndex = vIndex + if visible then 1 else 0+    spacing = if vIndex < Seq.length vchildren - 1 && visible then childSpacing else 0+    visible = _wniVisible (_wnInfo child) -  (areas, usedDim) = foldl' foldHelper (Seq.empty, mainStart) children+  (areas, usedDim, _) = foldl' foldHelper (Seq.empty, mainStart, 0) children   result = (areas, usedDim - mainStart)  resizeChild :: Bool -> Rect -> Factor -> Factor -> Double -> WidgetNode s e -> Rect

@@ -20,7 +20,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE UndecidableInstances #-}  module Monomer.Widgets.Singles.DateField (@@ -49,6 +48,7 @@ import Data.Text (Text) import Data.Time import Data.Typeable (Typeable, typeOf)+import TextShow  import qualified Data.Attoparsec.Text as A import qualified Data.Text as T@@ -395,7 +395,8 @@     _ifcOnBlurReq = _dfcOnBlurReq config,     _ifcOnChangeReq = _dfcOnChangeReq config   }-  newNode = inputField_ "dateField" inputConfig+  wtype = WidgetType ("dateField-" <> showt (typeOf initialValue))+  newNode = inputField_ wtype inputConfig  handleWheel   :: FormattableDate a

@@ -37,8 +37,9 @@ import Data.Default import Data.Maybe import Data.Text (Text)-import Data.Typeable (Typeable)+import Data.Typeable (Typeable, typeOf) import GHC.Generics+import TextShow  import qualified Data.Sequence as Seq @@ -212,8 +213,9 @@ dialD_ widgetData minVal maxVal configs = dialNode where   config = mconcat configs   state = DialState 0 0+  wtype = WidgetType ("dial-" <> showt (typeOf minVal))   widget = makeDial widgetData minVal maxVal config state-  dialNode = defaultWidgetNode "dial" widget+  dialNode = defaultWidgetNode wtype widget     & L.info . L.focusable .~ True  makeDial

@@ -69,6 +69,7 @@   | FitFill   | FitWidth   | FitHeight+  | FitEither   deriving (Eq, Show)  -- | Posible errors when loading an image.@@ -174,6 +175,11 @@     _imcFit = Just FitHeight   } +instance CmbFitEither (ImageCfg e) where+  fitEither  = def {+    _imcFit = Just FitEither+  }+ instance CmbTransparency (ImageCfg e) where   transparency alpha = def {     _imcTransparency = Just alpha@@ -423,16 +429,22 @@ fitImage viewport imageSize imgFlags imgFit alignH alignV = case imgFit of   FitNone -> alignImg iw ih   FitFill -> alignImg w h-  FitWidth-    | ImageRepeatY `elem` imgFlags -> alignImg w ih-    | otherwise -> alignImg w (w * ih / iw)-  FitHeight-    | ImageRepeatX `elem` imgFlags -> alignImg iw h-    | otherwise -> alignImg (h * iw / ih) h+  FitWidth -> fitWidth+  FitHeight -> fitHeight+  FitEither+    | w * ih > h * iw -> fitHeight+    | otherwise -> fitWidth   where     Rect x y w h = viewport     Size iw ih = imageSize     alignImg nw nh = alignInRect viewport (Rect x y nw nh) alignH alignV+    fitWidth+      | ImageRepeatY `elem` imgFlags = alignImg w ih+      | otherwise = alignImg w (w * ih / iw)+    fitHeight+      | ImageRepeatX `elem` imgFlags = alignImg iw h+      | otherwise = alignImg (h * iw / ih) h+  handleImageLoad :: ImageCfg e -> WidgetEnv s e -> Text -> IO ImageMessage handleImageLoad config wenv path = do

@@ -43,6 +43,10 @@ {-| Configuration options for labeledCheckbox: +- General++    - 'childSpacing': the spacing between the checkbox and the text.+ - Text related      - 'textLeft': places the label to the left of the checkbox.@@ -70,6 +74,7 @@ -} data LabeledCheckboxCfg s e = LabeledCheckboxCfg {   _lchTextSide :: Maybe RectSide,+  _lchChildSpacing :: Maybe Double,   _lchLabelCfg :: LabelCfg s e,   _lchCheckboxCfg :: CheckboxCfg s e }@@ -77,6 +82,7 @@ instance Default (LabeledCheckboxCfg s e) where   def = LabeledCheckboxCfg {     _lchTextSide = Nothing,+    _lchChildSpacing = Nothing,     _lchLabelCfg = def,     _lchCheckboxCfg = def   }@@ -84,6 +90,7 @@ instance Semigroup (LabeledCheckboxCfg s e) where   (<>) t1 t2 = LabeledCheckboxCfg {     _lchTextSide = _lchTextSide t2 <|> _lchTextSide t1,+    _lchChildSpacing = _lchChildSpacing t2 <|> _lchChildSpacing t1,     _lchLabelCfg = _lchLabelCfg t1 <> _lchLabelCfg t2,     _lchCheckboxCfg = _lchCheckboxCfg t1 <> _lchCheckboxCfg t2   }@@ -91,6 +98,11 @@ instance Monoid (LabeledCheckboxCfg s e) where   mempty = def +instance CmbChildSpacing (LabeledCheckboxCfg s e) where+  childSpacing_ spacing = def {+    _lchChildSpacing = Just spacing+  }+ instance CmbTextLeft (LabeledCheckboxCfg s e) where   textLeft_ False = def   textLeft_ True = def {@@ -240,6 +252,7 @@ labeledCheckboxD_ caption widgetData configs = newNode where   config = mconcat configs   labelSide = fromMaybe SideLeft (_lchTextSide config)+  childSpacing = _lchChildSpacing config   labelCfg = _lchLabelCfg config   widget = checkboxD_ widgetData [_lchCheckboxCfg config]-  newNode = labeledItem "labeledCheckbox" labelSide caption labelCfg widget+  newNode = labeledItem "labeledCheckbox" labelSide childSpacing caption labelCfg widget

@@ -10,6 +10,7 @@ clickable label. Each instance of the radio will be associated with a single value. -}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Strict #-}@@ -30,6 +31,8 @@ import Data.Default import Data.Maybe import Data.Text (Text)+import Data.Typeable (typeOf)+import TextShow  import qualified Data.Sequence as Seq @@ -43,6 +46,10 @@ {-| Configuration options for labeledRadio: +- General++    - 'childSpacing': the spacing between the radio and the text.+ - Text related      - 'textLeft': places the label to the left of the radio.@@ -70,6 +77,7 @@ -} data LabeledRadioCfg s e a = LabeledRadioCfg {   _lchTextSide :: Maybe RectSide,+  _lchChildSpacing :: Maybe Double,   _lchLabelCfg :: LabelCfg s e,   _lchRadioCfg :: RadioCfg s e a }@@ -77,6 +85,7 @@ instance Default (LabeledRadioCfg s e a) where   def = LabeledRadioCfg {     _lchTextSide = Nothing,+    _lchChildSpacing = Nothing,     _lchLabelCfg = def,     _lchRadioCfg = def   }@@ -84,6 +93,7 @@ instance Semigroup (LabeledRadioCfg s e a) where   (<>) t1 t2 = LabeledRadioCfg {     _lchTextSide = _lchTextSide t2 <|> _lchTextSide t1,+    _lchChildSpacing = _lchChildSpacing t2 <|> _lchChildSpacing t1,     _lchLabelCfg = _lchLabelCfg t1 <> _lchLabelCfg t2,     _lchRadioCfg = _lchRadioCfg t1 <> _lchRadioCfg t2   }@@ -91,6 +101,11 @@ instance Monoid (LabeledRadioCfg s e a) where   mempty = def +instance CmbChildSpacing (LabeledRadioCfg s e a) where+  childSpacing_ spacing = def {+    _lchChildSpacing = Just spacing+  }+ instance CmbTextLeft (LabeledRadioCfg s e a) where   textLeft_ False = def   textLeft_ True = def {@@ -185,7 +200,7 @@  -- | Creates a labeled radio using the given lens. labeledRadio-  :: (Eq a, WidgetEvent e)+  :: (RadioValue a, WidgetEvent e)   => Text   -> a   -> ALens' s a@@ -194,7 +209,7 @@  -- | Creates a labeled radio using the given lens. Accepts config. labeledRadio_-  :: (Eq a, WidgetEvent e)+  :: (RadioValue a, WidgetEvent e)   => Text   -> a   -> ALens' s a@@ -205,7 +220,7 @@  -- | Creates a labeled radio using the given value and 'onChange' event handler. labeledRadioV-  :: (Eq a, WidgetEvent e)+  :: (RadioValue a, WidgetEvent e)   => Text   -> a   -> a@@ -219,7 +234,7 @@ Accepts config. -} labeledRadioV_-  :: (Eq a, WidgetEvent e)+  :: (RadioValue a, WidgetEvent e)   => Text   -> a   -> a@@ -232,7 +247,7 @@  -- | Creates a labeled radio providing a 'WidgetData' instance and config. labeledRadioD_-  :: (Eq a, WidgetEvent e)+  :: (RadioValue a, WidgetEvent e)   => Text   -> a   -> WidgetData s a@@ -241,6 +256,8 @@ labeledRadioD_ caption option widgetData configs = newNode where   config = mconcat configs   labelSide = fromMaybe SideLeft (_lchTextSide config)+  childSpacing = _lchChildSpacing config   labelCfg = _lchLabelCfg config+  wtype = WidgetType ("labeledRadio-" <> showt (typeOf option))   widget = radioD_ option widgetData [_lchRadioCfg config]-  newNode = labeledItem "labeledRadio" labelSide caption labelCfg widget+  newNode = labeledItem wtype labelSide childSpacing caption labelCfg widget

@@ -42,6 +42,7 @@ import Data.Text (Text) import Data.Text.Read (signed, rational) import Data.Typeable (Typeable, typeOf)+import TextShow  import qualified Data.Attoparsec.Text as A import qualified Data.Text as T@@ -347,7 +348,8 @@     _ifcOnBlurReq = _nfcOnBlurReq config,     _ifcOnChangeReq = _nfcOnChangeReq config   }-  newNode = inputField_ "numericField" inputConfig+  wtype = WidgetType ("numericField-" <> showt (typeOf initialValue))+  newNode = inputField_ wtype inputConfig  handleWheel   :: FormattableNumber a

@@ -31,6 +31,7 @@ @ -} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -39,6 +40,7 @@  module Monomer.Widgets.Singles.OptionButton (   -- * Configuration+  OptionButtonValue,   OptionButtonCfg,   optionButtonOffStyle,   -- * Constructors@@ -57,6 +59,8 @@ import Data.Default import Data.Maybe import Data.Text (Text)+import Data.Typeable (Typeable, typeOf)+import TextShow  import qualified Data.Sequence as Seq @@ -65,6 +69,9 @@  import qualified Monomer.Lens as L +-- | Constraints for numeric types accepted by the optionButton widget.+type OptionButtonValue a = (Eq a, Typeable a)+ {-| Configuration options for optionButton: @@ -192,7 +199,7 @@  -- | Creates an optionButton using the given lens. optionButton-  :: Eq a+  :: OptionButtonValue a   => Text   -> a   -> ALens' s a@@ -201,7 +208,7 @@  -- | Creates an optionButton using the given lens. Accepts config. optionButton_-  :: Eq a+  :: OptionButtonValue a   => Text   -> a   -> ALens' s a@@ -212,7 +219,7 @@  -- | Creates an optionButton using the given value and 'onChange' event handler. optionButtonV-  :: (Eq a, WidgetEvent e)+  :: (OptionButtonValue a, WidgetEvent e)   => Text   -> a   -> a@@ -224,7 +231,7 @@ -- | Creates an optionButton using the given value and 'onChange' event handler. --   Accepts config. optionButtonV_-  :: (Eq a, WidgetEvent e)+  :: (OptionButtonValue a, WidgetEvent e)   => Text   -> a   -> a@@ -238,7 +245,7 @@  -- | Creates an optionButton providing a 'WidgetData' instance and config. optionButtonD_-  :: Eq a+  :: OptionButtonValue a   => Text   -> a   -> WidgetData s a@@ -247,12 +254,13 @@ optionButtonD_ caption option widgetData configs = optionButtonNode where   config = mconcat configs   makeWithStyle = makeOptionButton L.optionBtnOnStyle L.optionBtnOffStyle+  wtype = WidgetType ("optionButton-" <> showt (typeOf option))   widget = makeWithStyle widgetData caption (== option) (const option) config-  optionButtonNode = defaultWidgetNode "optionButton" widget+  optionButtonNode = defaultWidgetNode wtype widget     & L.info . L.focusable .~ True  makeOptionButton-  :: Eq a+  :: OptionButtonValue a   => Lens' ThemeState StyleState   -> Lens' ThemeState StyleState   -> WidgetData s a

@@ -16,12 +16,14 @@ the look of a regular button. -} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StrictData #-}  module Monomer.Widgets.Singles.Radio (   -- * Configuration+  RadioValue,   RadioCfg,   -- * Constructors   radio,@@ -37,11 +39,16 @@ import Data.Default import Data.Maybe import Data.Text (Text)+import Data.Typeable (Typeable, typeOf)+import TextShow  import Monomer.Widgets.Single  import qualified Monomer.Lens as L +-- | Constraints for numeric types accepted by the radio widget.+type RadioValue a = (Eq a, Typeable a)+ {-| Configuration options for radio: @@ -115,12 +122,12 @@   }  -- | Creates a radio using the given lens.-radio :: (Eq a, WidgetEvent e) => a -> ALens' s a -> WidgetNode s e+radio :: (RadioValue a, WidgetEvent e) => a -> ALens' s a -> WidgetNode s e radio option field = radio_ option field def  -- | Creates a radio using the given lens. Accepts config. radio_-  :: (Eq a, WidgetEvent e)+  :: (RadioValue a, WidgetEvent e)   => a   -> ALens' s a   -> [RadioCfg s e a]@@ -128,13 +135,18 @@ radio_ option field configs = radioD_ option (WidgetLens field) configs  -- | Creates a radio using the given value and 'onChange' event handler.-radioV :: (Eq a, WidgetEvent e) => a -> a -> (a -> e) -> WidgetNode s e+radioV+  :: (RadioValue a, WidgetEvent e)+  => a+  -> a+  -> (a -> e)+  -> WidgetNode s e radioV option value handler = radioV_ option value handler def  -- | Creates a radio using the given value and 'onChange' event handler. --   Accepts config. radioV_-  :: (Eq a, WidgetEvent e)+  :: (RadioValue a, WidgetEvent e)   => a   -> a   -> (a -> e)@@ -147,18 +159,24 @@  -- | Creates a radio providing a 'WidgetData' instance and config. radioD_-  :: (Eq a, WidgetEvent e)+  :: (RadioValue a, WidgetEvent e)   => a   -> WidgetData s a   -> [RadioCfg s e a]   -> WidgetNode s e radioD_ option widgetData configs = radioNode where   config = mconcat configs+  wtype = WidgetType ("radio-" <> showt (typeOf option))   widget = makeRadio widgetData option config-  radioNode = defaultWidgetNode "radio" widget+  radioNode = defaultWidgetNode wtype widget     & L.info . L.focusable .~ True -makeRadio :: (Eq a, WidgetEvent e) => WidgetData s a -> a -> RadioCfg s e a -> Widget s e+makeRadio+  :: (RadioValue a, WidgetEvent e)+  => WidgetData s a+  -> a+  -> RadioCfg s e a+  -> Widget s e makeRadio !field !option !config = widget where   widget = createSingle () def {     singleGetBaseStyle = getBaseStyle,

@@ -43,8 +43,9 @@ import Data.Default import Data.Maybe import Data.Text (Text)-import Data.Typeable (Typeable)+import Data.Typeable (Typeable, typeOf) import GHC.Generics+import TextShow  import qualified Data.Sequence as Seq @@ -53,7 +54,7 @@  import qualified Monomer.Lens as L --- | Constraints for numeric types accepted by slider.+-- | Constraints for numeric types accepted by the slider widget. type SliderValue a = (Eq a, Show a, Real a, FromFractional a, Typeable a)  {-|@@ -306,8 +307,9 @@ sliderD_ isHz widgetData minVal maxVal configs = sliderNode where   config = mconcat configs   state = SliderState 0 0+  wtype = WidgetType ("slider-" <> showt (typeOf minVal))   widget = makeSlider isHz widgetData minVal maxVal config state-  sliderNode = defaultWidgetNode "slider" widget+  sliderNode = defaultWidgetNode wtype widget     & L.info . L.focusable .~ True  makeSlider

@@ -20,7 +20,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE UndecidableInstances #-}  module Monomer.Widgets.Singles.TimeField (@@ -46,6 +45,7 @@ import Data.Text (Text) import Data.Time import Data.Typeable (Typeable, typeOf)+import TextShow  import qualified Data.Attoparsec.Text as A import qualified Data.Text as T@@ -372,7 +372,8 @@     _ifcOnBlurReq = _tfcOnBlurReq config,     _ifcOnChangeReq = _tfcOnChangeReq config   }-  newNode = inputField_ "timeField" inputConfig+  wtype = WidgetType ("timeField-" <> showt (typeOf initialValue))+  newNode = inputField_ wtype inputConfig  handleWheel   :: FormattableTime a

@@ -12,7 +12,7 @@ 'Monomer.Widgets.Singles.LabeledCheckbox', with a different visual representation. -See 'OptionButton' for detailed notes.+See 'Monomer.Widgets.Singles.OptionButton' for detailed notes. -} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-}

@@ -19,18 +19,20 @@   drawInRotation,   drawInAlpha,   drawTextLine,+  drawLine,   drawRect,   drawRectBorder,   drawArc,   drawArcBorder,   drawEllipse,   drawEllipseBorder,+  drawArrowUp,   drawArrowDown,   drawTimesX,   drawStyledAction,   drawStyledAction_,   drawRoundedRect,-  drawRectRoundedBorder+  drawRoundedRectBorder ) where  import Control.Applicative ((<|>))@@ -201,7 +203,7 @@ drawRectBorder renderer rect border Nothing =   drawRectSimpleBorder renderer rect border drawRectBorder renderer rect border (Just radius) =-  drawRectRoundedBorder renderer rect border radius+  drawRoundedRectBorder renderer rect border radius  -- | Draws a filled arc, delimited by a rect and within the given angles. drawArc@@ -277,6 +279,27 @@     contentRect = subtractFromRect rect w w w w     w = width / 2 +-- | Draws a triangular arrow pointing up, delimited by the given rect.+drawArrowUp+  :: Renderer      -- ^ The renderer.+  -> Rect          -- ^ The rect delimiting the arrow.+  -> Maybe Color   -- ^ The color. If Nothing, the arrow will not be drawn.+  -> IO ()         -- ^ The resulting action.+drawArrowUp renderer rect Nothing = return ()+drawArrowUp renderer rect (Just color) = do+  beginPath renderer+  setFillColor renderer color+  moveTo renderer p1+  renderLineTo renderer p2+  renderLineTo renderer p3+  renderLineTo renderer p1+  fill renderer+  where+    Rect x y w h = rect+    p1 = Point (x + w / 2) y+    p2 = Point (x + w) (y + h)+    p3 = Point x (y + h)+ -- | Draws a triangular arrow pointing down, delimited by the given rect. drawArrowDown   :: Renderer      -- ^ The renderer.@@ -451,8 +474,8 @@     (g1, g2) = cornerGradientPoints ocorner icorner  -- | Draws the border of a rounded rect. Borders' widths may not match.-drawRectRoundedBorder :: Renderer -> Rect -> Border -> Radius -> IO ()-drawRectRoundedBorder renderer rect border radius =+drawRoundedRectBorder :: Renderer -> Rect -> Border -> Radius -> IO ()+drawRoundedRectBorder renderer rect border radius =   let     Rect xl yt w h = rect     Border borL borR borT borB = border

@@ -40,6 +40,7 @@  data InitWidget   = WInit+  | WInitKeepFirst   | WNoInit   deriving (Eq, Show) @@ -217,17 +218,37 @@   -> WidgetNode s e   -> MonomerCtx s e nodeHandleEventCtx wenv evts node = ctx where-  ctx = snd $ nodeHandleEvents wenv WInit evts node+  ctx = nodeHandleEventCtx_ wenv WInit evts node +nodeHandleEventCtx_+  :: (Eq s)+  => WidgetEnv s e+  -> InitWidget+  -> [SystemEvent]+  -> WidgetNode s e+  -> MonomerCtx s e+nodeHandleEventCtx_ wenv init evts node = ctx where+  ctx = snd $ nodeHandleEvents wenv init evts node+ nodeHandleEventModel   :: (Eq s)   => WidgetEnv s e   -> [SystemEvent]   -> WidgetNode s e   -> s-nodeHandleEventModel wenv evts node = _weModel wenv2 where-  (wenv2, _, _) = fst $ nodeHandleEvents wenv WInit evts node+nodeHandleEventModel wenv evts node = model where+  model = nodeHandleEventModel_ wenv WInit evts node +nodeHandleEventModel_+  :: (Eq s)+  => WidgetEnv s e+  -> InitWidget+  -> [SystemEvent]+  -> WidgetNode s e+  -> s+nodeHandleEventModel_ wenv init evts node = _weModel wenv2 where+  (wenv2, _, _) = fst $ nodeHandleEvents wenv init evts node+ nodeHandleEventRoot   :: (Eq s)   => WidgetEnv s e@@ -235,8 +256,18 @@   -> WidgetNode s e   -> WidgetNode s e nodeHandleEventRoot wenv evts node = newRoot where-  (_, newRoot, _) = fst $ nodeHandleEvents wenv WInit evts node+  newRoot = nodeHandleEventRoot_ wenv WInit evts node +nodeHandleEventRoot_+  :: (Eq s)+  => WidgetEnv s e+  -> InitWidget+  -> [SystemEvent]+  -> WidgetNode s e+  -> WidgetNode s e+nodeHandleEventRoot_ wenv init evts node = newRoot where+  (_, newRoot, _) = fst $ nodeHandleEvents wenv init evts node+ nodeHandleEventReqs   :: (Eq s)   => WidgetEnv s e@@ -244,17 +275,37 @@   -> WidgetNode s e   -> Seq (WidgetRequest s e) nodeHandleEventReqs wenv evts node = reqs where-  (_, _, reqs) = fst $ nodeHandleEvents wenv WInit evts node+  reqs = nodeHandleEventReqs_ wenv WInit evts node +nodeHandleEventReqs_+  :: (Eq s)+  => WidgetEnv s e+  -> InitWidget+  -> [SystemEvent]+  -> WidgetNode s e+  -> Seq (WidgetRequest s e)+nodeHandleEventReqs_ wenv init evts node = reqs where+  (_, _, reqs) = fst $ nodeHandleEvents wenv init evts node+ nodeHandleEventEvts   :: (Eq s)   => WidgetEnv s e   -> [SystemEvent]   -> WidgetNode s e   -> Seq e-nodeHandleEventEvts wenv evts node = eventsFromReqs reqs where-  (_, _, reqs) = fst $ nodeHandleEvents wenv WInit evts node+nodeHandleEventEvts wenv evts node = newEvts where+  newEvts = nodeHandleEventEvts_ wenv WInit evts node +nodeHandleEventEvts_+  :: (Eq s)+  => WidgetEnv s e+  -> InitWidget+  -> [SystemEvent]+  -> WidgetNode s e+  -> Seq e+nodeHandleEventEvts_ wenv init evts node = eventsFromReqs reqs where+  (_, _, reqs) = fst $ nodeHandleEvents wenv init evts node+ nodeHandleEvents   :: (Eq s)   => WidgetEnv s e@@ -263,9 +314,10 @@   -> WidgetNode s e   -> (HandlerStep s e, MonomerCtx s e) nodeHandleEvents wenv init evts node = result where-  steps-    | init == WInit = tail $ nodeHandleEvents_ wenv init [evts] node-    | otherwise = nodeHandleEvents_ wenv init [evts] node+  steps = case init of+    WInit -> tail $ nodeHandleEvents_ wenv init [evts] node+    WInitKeepFirst -> nodeHandleEvents_ wenv WInit [evts] node+    _ -> nodeHandleEvents_ wenv init [evts] node   result = foldl1 stepper steps   stepper step1 step2 = result where     ((_, _, reqs1), _) = step1

@@ -140,17 +140,20 @@ handleEvent :: Spec handleEvent = describe "handleEvent" $ do   handleEventBasic+  handleEventNewRoot   handleEventChild   handleEventResize   handleEventLocalKey  handleEventBasic :: Spec handleEventBasic = describe "handleEventBasic" $ do-  it "should not generate an event if clicked outside" $+  it "should not generate an event if clicked outside" $ do     model [evtClick (Point 3000 3000)] ^. clicks `shouldBe` 0+    reqs [evtClick (Point 3000 3000)] `shouldBe` Seq.Empty -  it "should generate a user provided event when clicked" $+  it "should generate a user provided event when clicked" $ do     model [evtClick (Point 10 10)] ^. clicks `shouldBe` 1+    reqs [evtClick (Point 10 10)] `shouldSatisfy` (== 3) . length    where     wenv = mockWenv def@@ -166,6 +169,31 @@     buildUI wenv model = button "Click" MainBtnClicked     cmpNode = composite "main" id buildUI handleEvent     model es = nodeHandleEventModel wenv es cmpNode+    reqs es = nodeHandleEventReqs wenv es cmpNode++handleEventNewRoot :: Spec+handleEventNewRoot = describe "handleEventNewRoot" $ do+  it "should generate a resize request when the widgetType of the root widget changes" $ do+    reqs [evtClick (Point 10 10)] `shouldSatisfy` (== 4) . length+    reqs [evtClick (Point 10 10)] `shouldSatisfy` (== 1) . length . Seq.filter isResizeWidgets++  where+    wenv = mockWenv def+    handleEvent+      :: WidgetEnv MainModel MainEvt+      -> WidgetNode MainModel MainEvt+      -> MainModel+      -> MainEvt+      -> [EventResponse MainModel MainEvt MainModel MainEvt]+    handleEvent wenv node model evt = case evt of+      MainBtnClicked -> [Model (model & clicks %~ (+1))]+      _ -> []+    buildUI wenv model+      | even (model ^. clicks) = button "Click" MainBtnClicked+      | otherwise = label "Test"+    cmpNode = composite "main" id buildUI handleEvent+    model es = nodeHandleEventModel wenv es cmpNode+    reqs es = nodeHandleEventReqs wenv es cmpNode  handleEventChild :: Spec handleEventChild = describe "handleEventChild" $ do

@@ -67,6 +67,7 @@   handleEvent   handleEventValue   getSizeReq+  testWidgetType  handleEvent :: Spec handleEvent = describe "handleEvent" $ do@@ -164,3 +165,13 @@     labelItem l = label_ (showt l) [resizeFactorW 0.01]     ddNode = dropdown selectedItem testItems labelItem labelItem     (sizeReqW, sizeReqH) = nodeGetSizeReq wenv ddNode++testWidgetType :: Spec+testWidgetType = describe "testWidgetType" $ do+  it "should set the correct widgetType" $+    node ^. L.info . L.widgetType `shouldBe` "dropdown-TestItem"++  where+    labelItem l = label_ (showt l) []+    node :: WidgetNode TestModel TestEvt+    node = dropdown selectedItem testItems labelItem labelItem

@@ -24,6 +24,7 @@ import Monomer.TestUtil import Monomer.Widgets.Containers.Grid import Monomer.Widgets.Singles.Label+import Monomer.Widgets.Singles.Spacer  import qualified Monomer.Lens as L @@ -40,6 +41,7 @@   getSizeReqMixedH   getSizeReqMixedV   getSizeReqUpdater+  getSizeReqChildSpacing  getSizeReqEmpty :: Spec getSizeReqEmpty = describe "empty" $ do@@ -136,11 +138,33 @@     vgridNode = vgrid_ [sizeReqUpdater (fixedToMinW 2), sizeReqUpdater (fixedToMaxH 3)] [label "Label"]     (sizeReqW, sizeReqH) = nodeGetSizeReq wenv vgridNode +getSizeReqChildSpacing :: Spec+getSizeReqChildSpacing = describe "with childSpacing" $ do+  it "should not add spacing when empty" $+    testGridSizeReq [] `shouldBe` fixedSize 0++  it "should not add spacing when singleton" $+    testGridSizeReq [spacer3] `shouldBe` fixedSize 3++  it "should add spacing between children" $+    testGridSizeReq [spacer3, spacer3] `shouldBe` fixedSize 8+  +  it "should not add spacing between invisible children" $ do+    testGridSizeReq [spacer3, spacer3 `nodeVisible` False] `shouldBe` fixedSize 3+  +  where+    wenv = mockWenv ()+    spacer3 = spacer_ [width 3, resizeFactor 0]+    testGridSizeReq children = sizeReqH where+      (_sizeReqW, sizeReqH) = nodeGetSizeReq wenv vgridNode+      vgridNode = vgrid_ [childSpacing_ 2] children+ resize :: Spec resize = describe "resize" $ do   resizeEmpty   resizeItemsH   resizeItemsV+  resizeChildSpacing  resizeEmpty :: Spec resizeEmpty = describe "empty" $ do@@ -205,3 +229,21 @@     newNode = nodeInit wenv gridNode     viewport = newNode ^. L.info . L.viewport     childrenVp = (^. L.info . L.viewport) <$> newNode ^. L.children++resizeChildSpacing :: Spec+resizeChildSpacing = describe "with childSpacing" $ do++  it "should add spacing between children" $+    testGridChildLocations [spacer, spacer] `shouldBe`+      Seq.fromList [Rect 0 0 640 215, Rect 0 265 640 215]+  +  it "should not add spacing between invisible children" $+    testGridChildLocations [spacer, spacer `nodeVisible` False, spacer] `shouldBe`+      Seq.fromList [Rect 0 0 640 215, Rect 0 0 0 0, Rect 0 265 640 215]+  +  where+    wenv = mockWenv ()+    testGridChildLocations children = childLocations where+      vgridNode = vgrid_ [childSpacing_ 50] children+      newNode = nodeInit wenv vgridNode+      childLocations = roundRectUnits . _wniViewport . _wnInfo <$> newNode ^. L.children

@@ -13,6 +13,7 @@ import Control.Lens ((&), (^.), (^?), (^?!), (.~), _Just, ix) import Data.Default import Data.Text (Text)+import Data.Sequence (Seq(..)) import Test.Hspec  import qualified Data.Sequence as Seq@@ -38,6 +39,7 @@   | Button2   | Button3   | Button4+  | OnScrollChange ScrollStatus   deriving (Eq, Show)  spec :: Spec@@ -52,6 +54,7 @@   handleChildrenFocus   handleNestedWheel   handleMessageReset+  raiseOnChange  handleBarClick :: Spec handleBarClick = describe "handleBarClick" $ do@@ -180,6 +183,63 @@       ]) `nodeKey` "mainScroll"     cmpNode = composite "main" id buildUI handleEvent     events es = nodeHandleEventEvts wenv es cmpNode++raiseOnChange :: Spec+raiseOnChange = describe "raiseOnChange" $ do+  it "should raise the event on init" $ do+    let evts es = nodeHandleEventEvts_ wenv WInitKeepFirst es scrollNode+    let (OnScrollChange status) :<| Empty = evts []++    scrollDeltaX status `shouldBe` 0+    scrollDeltaY status `shouldBe` 0+    validateStatus status++  it "should raise the event when horizontal bar is clicked" $ do+    let (OnScrollChange status) :<| Empty = evts [evtPress midHBar]++    scrollDeltaX status `shouldBe` -648+    scrollDeltaY status `shouldBe` 0+    validateStatus status++  it "should raise the event when vertical bar is clicked" $ do+    let (OnScrollChange status) :<| Empty = evts [evtPress midVBar]++    scrollDeltaX status `shouldBe` 0+    scrollDeltaY status `shouldBe` -488+    validateStatus status++  it "should raise the event when wheel is scrolled" $ do+    let evtWheel = WheelScroll (Point 320 240) (Point 0 (-20)) WheelNormal+    let (OnScrollChange status) :<| Empty = evts [evtWheel]++    scrollDeltaX status `shouldBe` 0+    scrollDeltaY status `shouldBe` -200+    validateStatus status++  where+    validateStatus status = do+      scrollRect status `shouldBe` Rect 0 0 640 480+      scrollVpSize status `shouldBe` Size 632 472+      scrollChildSize status `shouldBe` Size 1280 960++    wenv = mockWenv ()+      & L.theme .~ darkTheme+      & L.windowSize .~ Size 640 480+    midHBar = Point 630 476+    midVBar = Point 636 470+    st = [width 640, height 480]+    stackNode = vstack [+        hstack [+          button "Button 1" Button1 `styleBasic` st,+          button "Button 2" Button2 `styleBasic` st+        ],+        hstack [+          button "Button 3" Button3 `styleBasic` st,+          button "Button 4" Button4 `styleBasic` st+        ]+      ]+    scrollNode = scroll_ [onChange OnScrollChange] stackNode+    evts es = nodeHandleEventEvts wenv es scrollNode  forwardStyle :: Spec forwardStyle = describe "forwardStyle" $ do

@@ -13,7 +13,7 @@  module Monomer.Widgets.Containers.SelectListSpec (spec) where -import Control.Lens ((&), (^.), (.~), _1)+import Control.Lens ((&), (^.), (^?!), (.~), _1, ix) import Control.Lens.TH (abbreviatedFields, makeLensesWith) import Data.Default import Data.Functor ((<&>))@@ -68,6 +68,7 @@   handleEvent   handleEventValue   getSizeReq+  testWidgetType  handleEvent :: Spec handleEvent = describe "handleEvent" $ do@@ -143,3 +144,12 @@     wenv = mockWenvEvtUnit (TestModel testItem0)     slNode = selectList selectedItem testItems (label . showt)     (sizeReqW, sizeReqH) = nodeGetSizeReq wenv slNode++testWidgetType :: Spec+testWidgetType = describe "testWidgetType" $ do+  it "should set the correct widgetType" $+    node ^?! L.children . ix 0 . L.info . L.widgetType `shouldBe` "selectList-TestItem"++  where+    node :: WidgetNode TestModel TestEvt+    node = selectList selectedItem testItems (label . showt)

@@ -39,6 +39,7 @@   getSizeReqEmpty   getSizeReqItems   getSizeReqUpdater+  getSizeReqChildSpacing  getSizeReqEmpty :: Spec getSizeReqEmpty = describe "empty" $ do@@ -92,6 +93,27 @@     (sizeReqW1, sizeReqH1) = nodeGetSizeReq wenv vstackNode1     (sizeReqW2, sizeReqH2) = nodeGetSizeReq wenv vstackNode2 +getSizeReqChildSpacing :: Spec+getSizeReqChildSpacing = describe "with childSpacing" $ do+  it "should not add spacing when empty" $+    testStackSizeReq [] `shouldBe` fixedSize 0++  it "should not add spacing when singleton" $+    testStackSizeReq [spacer3] `shouldBe` fixedSize 3++  it "should add spacing between children" $+    testStackSizeReq [spacer3, spacer3] `shouldBe` fixedSize 8+  +  it "should not add spacing between invisible children" $ do+    testStackSizeReq [spacer3, spacer3 `nodeVisible` False] `shouldBe` fixedSize 3+  +  where+    wenv = mockWenv ()+    spacer3 = spacer_ [width 3, resizeFactor 0]+    testStackSizeReq children = sizeReqH where+      (_sizeReqW, sizeReqH) = nodeGetSizeReq wenv vstackNode+      vstackNode = vstack_ [childSpacing_ 2] children+ resize :: Spec resize = describe "resize" $ do   resizeEmpty@@ -105,6 +127,7 @@   resizeNoSpaceV   resizeSpacerFlexH   resizeSpacerFixedH+  resizeChildSpacing  resizeEmpty :: Spec resizeEmpty = describe "empty" $ do@@ -365,3 +388,22 @@     newNode = nodeInit wenv hstackNode     viewport = newNode ^. L.info . L.viewport     childrenVp = roundRectUnits . _wniViewport . _wnInfo <$> newNode ^. L.children++resizeChildSpacing :: Spec+resizeChildSpacing = describe "with childSpacing" $ do++  it "should add spacing between children" $+    testStackChildLocations [spacer3, spacer3] `shouldBe`+      Seq.fromList [Rect 0 0 640 3, Rect 0 5 640 3]+  +  it "should not add spacing between invisible children" $+    testStackChildLocations [spacer3, spacer3 `nodeVisible` False, spacer3] `shouldBe`+      Seq.fromList [Rect 0 0 640 3, Rect 0 0 0 0, Rect 0 5 640 3]+  +  where+    wenv = mockWenv ()+    spacer3 = spacer_ [width 3, resizeFactor 0]+    testStackChildLocations children = childLocations where+      vstackNode = vstack_ [childSpacing_ 2] children+      newNode = nodeInit wenv vstackNode+      childLocations = roundRectUnits . _wniViewport . _wnInfo <$> newNode ^. L.children

@@ -74,6 +74,7 @@   handleEventMouseDragDate   handleShiftFocus   getSizeReqDate+  testWidgetType  handleEventDate :: Spec handleEventDate = describe "handleEventDate" $ do@@ -282,3 +283,12 @@     (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (dateField dateValue)     dateResize = dateField_ dateValue [resizeOnChange]     (sizeReqW2, sizeReqH2) = nodeGetSizeReq wenv dateResize++testWidgetType :: Spec+testWidgetType = describe "testWidgetType" $ do+  it "should set the correct widgetType" $+    node ^. L.info . L.widgetType `shouldBe` "dateField-Day"++  where+    node :: WidgetNode DateModel TestEvt+    node = dateField dateValue

@@ -12,6 +12,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}  module Monomer.Widgets.Singles.DialSpec (spec) where @@ -56,6 +57,7 @@   handleWheelVal   handleShiftFocus   getSizeReq+  testWidgetType  handleKeyboard :: Spec handleKeyboard = describe "handleKeyboard" $ do@@ -235,3 +237,12 @@     wenv = mockWenvEvtUnit (TestModel 0)       & L.theme .~ darkTheme     (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (dial dialVal 0 100)++testWidgetType :: Spec+testWidgetType = describe "testWidgetType" $ do+  it "should set the correct widgetType" $+    node ^. L.info . L.widgetType `shouldBe` "dial-Double"++  where+    node :: WidgetNode TestModel TestEvt+    node = dial dialVal 0 100

@@ -56,6 +56,7 @@   handleEvent   handleEventValue   getSizeReq+  testWidgetType  handleEvent :: Spec handleEvent = describe "handleEvent" $ do@@ -127,3 +128,12 @@     wenv = mockWenvEvtUnit (TestModel Apple)       & L.theme .~ darkTheme     (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (labeledRadio "Test" Apple fruit)++testWidgetType :: Spec+testWidgetType = describe "testWidgetType" $ do+  it "should set the correct widgetType" $+    node ^. L.info . L.widgetType `shouldBe` "labeledRadio-Fruit"++  where+    node :: WidgetNode TestModel FruitEvt+    node = labeledRadio "Test" Apple fruit

@@ -66,6 +66,7 @@   handleEventValueIntegral   handleEventMouseDragIntegral   getSizeReqIntegral+  testIntegralWidgetType  handleEventIntegral :: Spec handleEventIntegral = describe "handleEventIntegral" $ do@@ -259,6 +260,15 @@     numericResize = numericField_ integralValue [resizeOnChange]     (sizeReqW2, sizeReqH2) = nodeGetSizeReq wenv numericResize +testIntegralWidgetType :: Spec+testIntegralWidgetType = describe "testIntegralWidgetType" $ do+  it "should set the correct widgetType" $+    node ^. L.info . L.widgetType `shouldBe` "numericField-Int"++  where+    node :: WidgetNode IntegralModel TestEvt+    node = numericField integralValue+ -- ------------------------------ -- Fractional field -- ------------------------------@@ -269,6 +279,7 @@   handleEventMouseDragFractional   handleShiftFocusFractional   getSizeReqFractional+  testFractionalWidgetType  handleEventFractional :: Spec handleEventFractional = describe "handleEventFractional" $ do@@ -484,3 +495,12 @@     (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (numericField fractionalValue)     numericResize = numericField_ fractionalValue [resizeOnChange]     (sizeReqW2, sizeReqH2) = nodeGetSizeReq wenv numericResize++testFractionalWidgetType :: Spec+testFractionalWidgetType = describe "testFractionalWidgetType" $ do+  it "should set the correct widgetType" $+    node ^. L.info . L.widgetType `shouldBe` "numericField-Maybe Double"++  where+    node :: WidgetNode FractionalModel TestEvt+    node = numericField fractionalValue

@@ -58,6 +58,7 @@   handleEvent   handleEventValue   getSizeReq+  testWidgetType  handleEvent :: Spec handleEvent = describe "handleEvent" $ do@@ -114,3 +115,12 @@   where     wenv = mockWenvEvtUnit (TestModel Apple)     (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (optionButton "Apple" Apple fruit)++testWidgetType :: Spec+testWidgetType = describe "testWidgetType" $ do+  it "should set the correct widgetType" $+    node ^. L.info . L.widgetType `shouldBe` "optionButton-Fruit"++  where+    node :: WidgetNode TestModel FruitEvt+    node = optionButton "Test" Apple fruit

@@ -56,6 +56,7 @@   handleEvent   handleEventValue   getSizeReq+  testWidgetType  handleEvent :: Spec handleEvent = describe "handleEvent" $ do@@ -115,3 +116,12 @@     wenv = mockWenvEvtUnit (TestModel Apple)       & L.theme .~ darkTheme     (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (radio Apple fruit)++testWidgetType :: Spec+testWidgetType = describe "testWidgetType" $ do+  it "should set the correct widgetType" $+    node ^. L.info . L.widgetType `shouldBe` "radio-Fruit"++  where+    node :: WidgetNode TestModel FruitEvt+    node = radio Apple fruit

@@ -62,6 +62,7 @@   getSizeReqH   getSizeReqV   getSizeReqThumb+  testWidgetType  handleKeyboardH :: Spec handleKeyboardH = describe "handleKeyboardH" $ do@@ -405,3 +406,12 @@     wenv = mockWenvEvtUnit (TestModel 0)       & L.theme .~ darkTheme     (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (vslider_ sliderVal 0 100 [thumbVisible])++testWidgetType :: Spec+testWidgetType = describe "testWidgetType" $ do+  it "should set the correct widgetType" $+    node ^. L.info . L.widgetType `shouldBe` "slider-Double"++  where+    node :: WidgetNode TestModel TestEvt+    node = hslider sliderVal 0 100

@@ -74,6 +74,7 @@   handleEventMouseDragTime   handleShiftFocus   getSizeReqTime+  testWidgetType  handleEventTime :: Spec handleEventTime = describe "handleEventTime" $ do@@ -291,3 +292,12 @@     (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (timeField timeValue)     timeResize = timeField_ timeValue [resizeOnChange]     (sizeReqW2, sizeReqH2) = nodeGetSizeReq wenv timeResize++testWidgetType :: Spec+testWidgetType = describe "testWidgetType" $ do+  it "should set the correct widgetType" $+    node ^. L.info . L.widgetType `shouldBe` "timeField-TimeOfDay"++  where+    node :: WidgetNode TimeModel TestEvt+    node = timeField timeValue