monomer 1.4.1.0 → 1.5.0.0

raw patch · 54 files changed

+1751/−189 lines, 54 filesdep ~nanovgdep ~text-show

Dependency ranges changed: nanovg, text-show

Files

• ChangeLog.md +25/−0
• README.md +22/−11
• cbits/fontmanager.c +5/−0
• cbits/fontmanager.h +2/−0
• examples/books/Main.hs +15/−14
• examples/generative/Main.hs +1/−1
• examples/opengl/Main.hs +1/−1
• examples/ticker/Main.hs +1/−1
• examples/todo/Main.hs +21/−8
• examples/todo/TodoTypes.hs +3/−0
• examples/tutorial/Tutorial01_Basics.hs +1/−1
• examples/tutorial/Tutorial02_Styling.hs +1/−1
• examples/tutorial/Tutorial03_LifeCycle.hs +1/−1
• examples/tutorial/Tutorial04_Tasks.hs +1/−1
• examples/tutorial/Tutorial05_Producers.hs +1/−1
• examples/tutorial/Tutorial06_Composite.hs +1/−1
• examples/tutorial/Tutorial07_CustomWidget.hs +1/−1
• examples/tutorial/Tutorial08_Themes.hs +1/−1
• monomer.cabal +13/−9
• src/Monomer/Core/ThemeTypes.hs +10/−0
• src/Monomer/Core/Themes/BaseTheme.hs +2/−0
• src/Monomer/Core/Themes/SampleThemes.hs +2/−0
• src/Monomer/Core/Util.hs +8/−0
• src/Monomer/Graphics/FFI.chs +25/−2
• src/Monomer/Graphics/FontManager.hs +12/−5
• src/Monomer/Graphics/NanoVGRenderer.hs +29/−5
• src/Monomer/Graphics/Types.hs +20/−5
• src/Monomer/Helper.hs +23/−1
• src/Monomer/Main/Core.hs +7/−5
• src/Monomer/Main/Handlers.hs +5/−5
• src/Monomer/Main/Platform.hs +55/−23
• src/Monomer/Main/Types.hs +41/−9
• src/Monomer/Main/UserUtil.hs +79/−0
• src/Monomer/Main/WidgetTask.hs +2/−2
• src/Monomer/Widgets.hs +2/−0
• src/Monomer/Widgets/Composite.hs +13/−6
• src/Monomer/Widgets/Container.hs +39/−19
• src/Monomer/Widgets/Containers/Alert.hs +6/−2
• src/Monomer/Widgets/Containers/BoxShadow.hs +187/−0
• src/Monomer/Widgets/Containers/Confirm.hs +2/−1
• src/Monomer/Widgets/Containers/Dropdown.hs +25/−2
• src/Monomer/Widgets/Containers/Popup.hs +688/−0
• src/Monomer/Widgets/Containers/SelectList.hs +17/−7
• src/Monomer/Widgets/Containers/Tooltip.hs +8/−0
• src/Monomer/Widgets/Single.hs +5/−3
• src/Monomer/Widgets/Singles/Label.hs +14/−15
• src/Monomer/Widgets/Util/Focus.hs +6/−0
• src/Monomer/Widgets/Util/Hover.hs +3/−2
• test/unit/Monomer/TestUtil.hs +20/−5
• test/unit/Monomer/Widgets/CompositeSpec.hs +9/−11
• test/unit/Monomer/Widgets/Containers/BoxShadowSpec.hs +65/−0
• test/unit/Monomer/Widgets/Containers/ConfirmSpec.hs +1/−1
• test/unit/Monomer/Widgets/Containers/PopupSpec.hs +200/−0
• test/unit/Spec.hs +4/−0

@@ -1,3 +1,28 @@+## 1.5.0.0++### Added++- Do not disable screensaver unless explicitly requested; add configuration flag ([PR #189](https://github.com/fjvallarino/monomer/pull/189)).+- Conditional helpers for lists of widgets, styles and configuration options ([PR #185](https://github.com/fjvallarino/monomer/pull/185)).+- Popup widget ([PR #191](https://github.com/fjvallarino/monomer/pull/191)).+- Loading fonts from memory ([PR #199](https://github.com/fjvallarino/monomer/pull/199)). Thanks @klausweiss!+- BoxShadow component ([PR #205](https://github.com/fjvallarino/monomer/pull/205)). Thanks @Dretch!++### Fixed++- Issue in `selectList`, which would ignore `WidgetRequest`s made by child widgets ([PR #157](https://github.com/fjvallarino/monomer/pull/157)).+- Compatibility with GHC 9.2.2 ([PR #162](https://github.com/fjvallarino/monomer/pull/162)). Thanks @Dretch!+- Consider padding, border and sizeReqs in addition to textStyle when checking if resize is needed for label ([PR #169](https://github.com/fjvallarino/monomer/pull/169)).+- Hide tooltip when a button action is detected on its child widget ([PR #170](https://github.com/fjvallarino/monomer/pull/170)).+- Fix Composite's onDispose event handler ([PR #176](https://github.com/fjvallarino/monomer/pull/176)).+- Catch exception when trying to write to stderr and try stdout instead ([PR #190](https://github.com/fjvallarino/monomer/pull/190)).++### Changed++- Do not exit application if icon image is missing or fails to load ([PR #171](https://github.com/fjvallarino/monomer/pull/171)).+- Use stderr for diagnostic and error messages ([PR #172](https://github.com/fjvallarino/monomer/pull/172)).+- Allow using any file type for the application icon ([PR #186](https://github.com/fjvallarino/monomer/pull/186)).+ ## 1.4.1.0  ### Added

@@ -1,15 +1,31 @@-# Monomer+<h1 align="center">Monomer</h1> +<h3 align="center">A cross-platform GUI library for Haskell</h3>++<p align="center">+  <img src="assets/images/monomer-logo.svg" height=250 width=250 alt="Logo" />+</p>++<p align="center">+  <a href="https://github.com/fjvallarino/monomer/actions">+    <img src="https://img.shields.io/github/workflow/status/fjvallarino/monomer/Build" alt="CI badge" />+  </a>+  <a href="https://haskell.org">+    <img src="https://img.shields.io/badge/Made%20in-Haskell-%235e5086?logo=haskell&style=flat-square" alt="made with Haskell"/>+  </a>+  <a href="https://haskell.org">+    <img src="https://img.shields.io/github/license/fjvallarino/monomer?color=111%09193%0965%09" alt="BSD-3-Clause"/>+  </a>+</p>++<br/>+ An easy to use, cross platform, GUI library for writing native Haskell applications. -It provides a framework similar to the Elm Architecture, allowing the creation+Monomer provides a framework similar to the Elm Architecture, allowing the creation of GUIs using an extensible set of widgets with pure Haskell. -## Screenshot--![Project's screenshot](assets/images/monomer-readme.png)- ## Objectives  - Be easy to learn and use.@@ -76,11 +92,6 @@  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 

@@ -53,6 +53,11 @@ 	return fonsAddFont(ctx->fs, name, filename, 0); } +int fmCreateFontMem(FMcontext* ctx, const char* name, unsigned char* data, int dataSize)+{+	return fonsAddFontMem(ctx->fs, name, data, dataSize, 1, 0);+}+ void fmSetScale(FMcontext* ctx, float scale) { 	ctx->scale = scale; }

@@ -39,6 +39,8 @@  int fmCreateFont(FMcontext* ctx, const char* name, const char* filename); +int fmCreateFontMem(FMcontext* ctx, const char* name, unsigned char* data, int dataSize);+ void fmSetScale(FMcontext* ctx, float scale);  void fmFontFace(FMcontext* ctx, const char* font);

@@ -75,19 +75,20 @@   shortLabel value = label value `styleBasic` [textFont "Medium", textTop]   longLabel value = label_ value [multiline, ellipsis, trimSpaces] -  content = hstack . concat $ [[-    vstack [-      longLabel (b ^. title)-        `styleBasic` [textSize 20, textFont "Medium"],-      spacer,-      longLabel (T.intercalate ", " (b ^. authors))-        `styleBasic` [textSize 16],-      spacer,-      label publishYear-        `styleBasic` [textSize 14]-    ]],-    [filler | hasCover],-    [bookImage (b ^. cover) "M" `styleBasic` [width 200] | hasCover]+  content = hstack [+      vstack_ [childSpacing] [+        longLabel (b ^. title)+          `styleBasic` [textSize 20, textFont "Medium"],+        longLabel (T.intercalate ", " (b ^. authors))+          `styleBasic` [textSize 16],+        label publishYear+          `styleBasic` [textSize 14]+      ],+      widgetIf hasCover $ hstack [+        filler,+        bookImage (b ^. cover) "M"+          `styleBasic` [width 200]+      ]     ]  buildUI@@ -190,7 +191,7 @@   where     config = [       appWindowTitle "Book search",-      appWindowIcon "./assets/images/icon.bmp",+      appWindowIcon "./assets/images/icon.png",       appTheme customDarkTheme,       appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf",       appFontDef "Medium" "./assets/fonts/Roboto-Medium.ttf",

@@ -112,7 +112,7 @@     model = GenerativeModel CirclesGrid False def def     config = [       appWindowTitle "Generative",-      appWindowIcon "./assets/images/icon.bmp",+      appWindowIcon "./assets/images/icon.png",       appTheme darkTheme,       appFontDef "Remix" "./assets/fonts/remixicon.ttf",       appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf",

@@ -94,7 +94,7 @@   where     config = [       appWindowTitle "OpenGL",-      appWindowIcon "./assets/images/icon.bmp",+      appWindowIcon "./assets/images/icon.png",       appTheme darkTheme,       appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf",       appInitEvent AppInit

@@ -243,7 +243,7 @@   where     config = [       appWindowTitle "Ticker",-      appWindowIcon "./assets/images/icon.bmp",+      appWindowIcon "./assets/images/icon.png",       appTheme customDarkTheme,       appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf",       appFontDef "Remix" "./assets/fonts/remixicon.ttf",

@@ -68,7 +68,7 @@       rowButton remixEdit2Line (TodoEdit idx t),       spacer,       rowButton remixDeleteBinLine (TodoDeleteBegin idx t)-    ] `styleBasic` (paddingV 15 : [borderB 1 rowSepColor | not isLast])+    ] `styleBasic` [ paddingV 15, styleIf (not isLast) $ borderB 1 rowSepColor ]    animRow = animFadeOut_ [onFinished (TodoDelete idx t)] todoInfo @@ -119,7 +119,9 @@ buildUI :: TodoWenv -> TodoModel -> TodoNode buildUI wenv model = widgetTree where   sectionBg = wenv ^. L.theme . L.sectionColor-  isEditing = model ^. action /= TodoNone+  isEditing+    | TodoEditing _ <- model ^. action = True+    | otherwise = False    countLabel = label caption `styleBasic` styles where     caption = "Tasks (" <> showt (length $ model ^. todos) <> ")"@@ -142,6 +144,12 @@         filler       ] `styleBasic` [bgColor (grayDark & L.a .~ 0.5)] +  confirmDeleteLayer = case model ^.action of+    TodoConfirmingDelete idx todo -> [popup] where+      popup = confirmMsg msg (TodoConfirmDelete idx todo) TodoCancelDelete+      msg = "Are you sure you want to delete '" <> (todo ^. description) <> "' ?"+    _ -> []+   mainLayer = vstack [       countLabel,       scroll_ [] (todoList `styleBasic` [padding 20, paddingT 5]),@@ -150,10 +158,10 @@         `styleBasic` [bgColor sectionBg, padding 20]     ] -  widgetTree = zstack [+  widgetTree = zstack ([       mainLayer,       editLayer `nodeVisible` isEditing-    ]+    ] <> confirmDeleteLayer)  handleEvent   :: TodoWenv@@ -190,12 +198,17 @@     SetFocusOnKey "todoNew"]    TodoDeleteBegin idx todo -> [+    Model (model & action .~ TodoConfirmingDelete idx todo)]++  TodoConfirmDelete idx todo -> [+    Model (model & action .~ TodoNone),     Message (WidgetKey (todoRowKey todo)) AnimationStart] +  TodoCancelDelete -> [+    Model (model & action .~ TodoNone)]+     TodoDelete idx todo -> [-    Model $ model-      & action .~ TodoNone-      & todos .~ remove idx (model ^. todos),+    Model $ model & todos .~ remove idx (model ^. todos),     SetFocusOnKey "todoNew"]    TodoCancel -> [@@ -245,7 +258,7 @@   where     config = [       appWindowTitle "Todo list",-      appWindowIcon "./assets/images/icon.bmp",+      appWindowIcon "./assets/images/icon.png",       appTheme customDarkTheme,       appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf",       appFontDef "Medium" "./assets/fonts/Roboto-Medium.ttf",

@@ -49,6 +49,7 @@   = TodoNone   | TodoAdding   | TodoEditing Int+  | TodoConfirmingDelete Int Todo   deriving (Eq, Show)  data TodoModel = TodoModel {@@ -63,6 +64,8 @@   | TodoAdd   | TodoEdit Int Todo   | TodoSave Int+  | TodoConfirmDelete Int Todo+  | TodoCancelDelete   | TodoDeleteBegin Int Todo   | TodoDelete Int Todo   | TodoShowEdit

@@ -62,7 +62,7 @@   where     config = [       appWindowTitle "Tutorial 01 - Basics",-      appWindowIcon "./assets/images/icon.bmp",+      appWindowIcon "./assets/images/icon.png",       appTheme darkTheme,       appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf",       appInitEvent AppInit

@@ -106,7 +106,7 @@   where     config = [       appWindowTitle "Tutorial 02 - Styling",-      appWindowIcon "./assets/images/icon.bmp",+      appWindowIcon "./assets/images/icon.png",       appTheme darkTheme,       appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf",       appFontDef "Medium" "./assets/fonts/Roboto-Medium.ttf",

@@ -102,7 +102,7 @@   where     config = [       appWindowTitle "Tutorial 03 - Merging",-      appWindowIcon "./assets/images/icon.bmp",+      appWindowIcon "./assets/images/icon.png",       appTheme darkTheme,       appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf",       appInitEvent AppInit

@@ -87,7 +87,7 @@   where     config = [       appWindowTitle "Tutorial 04 - Tasks",-      appWindowIcon "./assets/images/icon.bmp",+      appWindowIcon "./assets/images/icon.png",       appTheme darkTheme,       appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf",       appFontDef "Bold" "./assets/fonts/Roboto-Bold.ttf"

@@ -80,7 +80,7 @@   where     config = [       appWindowTitle "Tutorial 05 - Producers",-      appWindowIcon "./assets/images/icon.bmp",+      appWindowIcon "./assets/images/icon.png",       appTheme darkTheme,       appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf",       appFontDef "Bold" "./assets/fonts/Roboto-Bold.ttf",

@@ -150,7 +150,7 @@   where     config = [       appWindowTitle "Tutorial 06 - Composite",-      appWindowIcon "./assets/images/icon.bmp",+      appWindowIcon "./assets/images/icon.png",       appTheme darkTheme,       appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf",       appInitEvent AppInit

@@ -168,7 +168,7 @@   where     config = [       appWindowTitle "Tutorial 07 - Custom Widget",-      appWindowIcon "./assets/images/icon.bmp",+      appWindowIcon "./assets/images/icon.png",       appTheme darkTheme,       appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf"       ]

@@ -115,7 +115,7 @@   where     config = [       appWindowTitle "Tutorial 08 - Themes",-      appWindowIcon "./assets/images/icon.bmp",+      appWindowIcon "./assets/images/icon.png",       appTheme darkTheme,       appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf",       appInitEvent AppInit

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           monomer-version:        1.4.1.0+version:        1.5.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.@@ -87,12 +87,14 @@       Monomer.Widgets.Containers.Alert       Monomer.Widgets.Containers.Base.LabeledItem       Monomer.Widgets.Containers.Box+      Monomer.Widgets.Containers.BoxShadow       Monomer.Widgets.Containers.Confirm       Monomer.Widgets.Containers.Draggable       Monomer.Widgets.Containers.Dropdown       Monomer.Widgets.Containers.DropTarget       Monomer.Widgets.Containers.Grid       Monomer.Widgets.Containers.Keystroke+      Monomer.Widgets.Containers.Popup       Monomer.Widgets.Containers.Scroll       Monomer.Widgets.Containers.SelectList       Monomer.Widgets.Containers.Split@@ -170,7 +172,7 @@     , http-client >=0.6 && <0.9     , lens >=4.16 && <6     , mtl >=2.1 && <2.3-    , nanovg >=0.8 && <1.0+    , nanovg >=0.8.1 && <1.0     , process ==1.6.*     , sdl2 >=2.5.0 && <2.6     , stm ==2.5.*@@ -216,7 +218,7 @@     , lens >=4.16 && <6     , monomer     , mtl >=2.1 && <2.3-    , nanovg >=0.8 && <1.0+    , nanovg >=0.8.1 && <1.0     , process ==1.6.*     , sdl2 >=2.5.0 && <2.6     , stm ==2.5.*@@ -257,7 +259,7 @@     , lens >=4.16 && <6     , monomer     , mtl >=2.1 && <2.3-    , nanovg >=0.8 && <1.0+    , nanovg >=0.8.1 && <1.0     , process ==1.6.*     , random >=1.1 && <1.3     , sdl2 >=2.5.0 && <2.6@@ -297,7 +299,7 @@     , lens >=4.16 && <6     , monomer     , mtl >=2.1 && <2.3-    , nanovg >=0.8 && <1.0+    , nanovg >=0.8.1 && <1.0     , process ==1.6.*     , random >=1.1 && <1.3     , sdl2 >=2.5.0 && <2.6@@ -339,7 +341,7 @@     , lens >=4.16 && <6     , monomer     , mtl >=2.1 && <2.3-    , nanovg >=0.8 && <1.0+    , nanovg >=0.8.1 && <1.0     , process ==1.6.*     , sdl2 >=2.5.0 && <2.6     , stm ==2.5.*@@ -380,7 +382,7 @@     , lens >=4.16 && <6     , monomer     , mtl >=2.1 && <2.3-    , nanovg >=0.8 && <1.0+    , nanovg >=0.8.1 && <1.0     , process ==1.6.*     , sdl2 >=2.5.0 && <2.6     , stm ==2.5.*@@ -426,7 +428,7 @@     , lens >=4.16 && <6     , monomer     , mtl >=2.1 && <2.3-    , nanovg >=0.8 && <1.0+    , nanovg >=0.8.1 && <1.0     , process ==1.6.*     , random >=1.1 && <1.3     , sdl2 >=2.5.0 && <2.6@@ -453,12 +455,14 @@       Monomer.Widgets.Animation.SlideSpec       Monomer.Widgets.CompositeSpec       Monomer.Widgets.Containers.AlertSpec+      Monomer.Widgets.Containers.BoxShadowSpec       Monomer.Widgets.Containers.BoxSpec       Monomer.Widgets.Containers.ConfirmSpec       Monomer.Widgets.Containers.DragDropSpec       Monomer.Widgets.Containers.DropdownSpec       Monomer.Widgets.Containers.GridSpec       Monomer.Widgets.Containers.KeystrokeSpec+      Monomer.Widgets.Containers.PopupSpec       Monomer.Widgets.Containers.ScrollSpec       Monomer.Widgets.Containers.SelectListSpec       Monomer.Widgets.Containers.SplitSpec@@ -514,7 +518,7 @@     , lens >=4.16 && <6     , monomer     , mtl >=2.1 && <2.3-    , nanovg >=0.8 && <1.0+    , nanovg >=0.8.1 && <1.0     , process ==1.6.*     , sdl2 >=2.5.0 && <2.6     , stm ==2.5.*

@@ -22,6 +22,7 @@ import Monomer.Core.StyleTypes import Monomer.Graphics.ColorTable import Monomer.Graphics.Types+import Monomer.Graphics.Util  -- | Theme configuration for each state, plus clear/base color. data Theme = Theme {@@ -52,6 +53,9 @@ -- | Default theme settings for each widget. data ThemeState = ThemeState {   _thsEmptyOverlayStyle :: StyleState,+  _thsShadowColor :: Color,+  _thsShadowAlignH :: AlignH,+  _thsShadowAlignV :: AlignV,   _thsBtnStyle :: StyleState,   _thsBtnMainStyle :: StyleState,   _thsCheckboxStyle :: StyleState,@@ -109,6 +113,9 @@ instance Default ThemeState where   def = ThemeState {     _thsEmptyOverlayStyle = def,+    _thsShadowColor = darkGray { _colorA = 0.2 },+    _thsShadowAlignH = ACenter,+    _thsShadowAlignV = ABottom,     _thsBtnStyle = def,     _thsBtnMainStyle = def,     _thsCheckboxStyle = def,@@ -166,6 +173,9 @@ instance Semigroup ThemeState where   (<>) t1 t2 = ThemeState {     _thsEmptyOverlayStyle = _thsEmptyOverlayStyle t1 <> _thsEmptyOverlayStyle t2,+    _thsShadowColor = _thsShadowColor t2,+    _thsShadowAlignH = _thsShadowAlignH t2,+    _thsShadowAlignV = _thsShadowAlignV t2,     _thsBtnStyle = _thsBtnStyle t1 <> _thsBtnStyle t2,     _thsBtnMainStyle = _thsBtnMainStyle t1 <> _thsBtnMainStyle t2,     _thsCheckboxStyle = _thsCheckboxStyle t1 <> _thsCheckboxStyle t2,

@@ -65,6 +65,7 @@   dialogText :: Color,   dialogTitleText :: Color,   emptyOverlay :: Color,+  shadow :: Color,   externalLinkBasic :: Color,   externalLinkHover :: Color,   externalLinkFocus :: Color,@@ -222,6 +223,7 @@ baseBasic themeMod = def   & L.emptyOverlayStyle .~ bgColor (emptyOverlay themeMod)   & L.emptyOverlayStyle . L.padding ?~ padding 8+  & L.shadowColor .~ shadow themeMod   & L.btnStyle .~ btnStyle themeMod   & L.btnMainStyle .~ btnMainStyle themeMod   & L.checkboxWidth .~ 20

@@ -56,6 +56,7 @@   dialogText = black,   dialogTitleText = black,   emptyOverlay = gray07 & L.a .~ 0.8,+  shadow = gray00 & L.a .~ 0.2,    externalLinkBasic = blue07,   externalLinkHover = blue08,@@ -155,6 +156,7 @@   dialogText = white,   dialogTitleText = white,   emptyOverlay = gray05 & L.a .~ 0.8,+  shadow = gray00 & L.a .~ 0.33,    externalLinkBasic = blue07,   externalLinkHover = blue08,

@@ -329,9 +329,17 @@ isResizeAnyResult :: Maybe (WidgetResult s e) -> Bool isResizeAnyResult res = isResizeResult res || isResizeImmediateResult res +-- | Checks if the platform is Linux+isLinux :: WidgetEnv s e -> Bool+isLinux wenv = _weOs wenv == "Linux"+ -- | Checks if the platform is macOS isMacOS :: WidgetEnv s e -> Bool isMacOS wenv = _weOs wenv == "Mac OS X"++-- | Checks if the platform is Windows+isWindows :: WidgetEnv s e -> Bool+isWindows wenv = _weOs wenv == "Windows"  {-| Returns the current time in milliseconds. Adds appStartTs and timestamp fields

@@ -17,8 +17,8 @@  module Monomer.Graphics.FFI where -import Control.Monad (forM)-import Data.ByteString (useAsCString)+import Control.Monad (forM, (>=>))+import Data.ByteString (useAsCStringLen, useAsCString, ByteString) import Data.Text (Text) import Data.Text.Foreign (withCStringLen) import Data.Sequence (Seq)@@ -118,6 +118,27 @@ withNull :: (Ptr a -> b) -> b withNull f = f nullPtr +-- | Same as CStringLen, but for strings of unsigned char* array type.+type CUStringLen = (Ptr CUChar, CInt)++-- | Same as 'useAsCStringLen', but works with unsigned char* arrays.+useAsCUStringLen :: ByteString -> (CUStringLen -> IO a) -> IO a+useAsCUStringLen bs f = useAsCStringLen bs (\(ptr, len) -> f (castPtr ptr, fromIntegral len))++-- | Same as 'useAsCUStringLen', but copies the underlying memory, leaving freeing it to the C code.+allocCUStringLen :: ByteString -> (CUStringLen -> IO a) -> IO a+allocCUStringLen bs f = useAsCUStringLen bs (copyCUStringLenMemory >=> f)++-- | Copy memory under given pointer to a new address.+-- The allocated memory is not garbage-collected and needs to be freed manually later.+copyCUStringLenMemory :: CUStringLen -> IO CUStringLen+copyCUStringLenMemory (from, len) =+  let intLen = fromIntegral len+  in do+    to <- mallocBytes intLen+    copyBytes to from intLen+    return (to, len)+ -- Common {# pointer *FMcontext as FMContext newtype #} deriving instance Storable FMContext@@ -125,6 +146,8 @@ {# fun unsafe fmInit {`Double'} -> `FMContext' #}  {# fun unsafe fmCreateFont {`FMContext', withCString*`Text', withCString*`Text'} -> `Int' #}++{# fun unsafe fmCreateFontMem {`FMContext', withCString*`Text', allocCUStringLen*`ByteString'&} -> `Int' #}  {# fun unsafe fmSetScale {`FMContext', `Double'} -> `()' #} 

@@ -16,6 +16,7 @@ ) where  import Control.Monad (foldM, when)+import Control.Lens ((^.))  import Data.Default import Data.Sequence (Seq)@@ -28,6 +29,8 @@ import Monomer.Common.BasicTypes import Monomer.Graphics.FFI import Monomer.Graphics.Types+import Monomer.Helper (putStrLnErr)+import Monomer.Graphics.Lens (fontName, fontPath, fontBytes)  -- | Creates a font manager instance. makeFontManager@@ -40,7 +43,7 @@   validFonts <- foldM (loadFont ctx) [] fonts    when (null validFonts) $-    putStrLn "Could not find any valid fonts. Text size calculations will fail."+    putStrLnErr "Could not find any valid fonts. Text size calculations will fail."    return $ newManager ctx @@ -100,11 +103,15 @@       }  loadFont :: FMContext -> [Text] -> FontDef -> IO [Text]-loadFont ctx fonts (FontDef name path) = do-  res <- fmCreateFont ctx name path+loadFont ctx fonts fontDef = do+  res <- createFont fontDef   if res >= 0-    then return $ path : fonts-    else putStrLn ("Failed to load font: " ++ T.unpack name) >> return fonts+    then return $ name : fonts+    else putStrLnErr ("Failed to load font: " ++ T.unpack name) >> return fonts+  where+    name = fontDef ^. fontName+    createFont FontDefFile{} = fmCreateFont ctx name (fontDef ^. fontPath)+    createFont FontDefMem{} = fmCreateFontMem ctx name (fontDef ^. fontBytes)  setFont :: FMContext -> Double -> Font -> FontSize -> FontSpace -> IO () setFont ctx scale (Font name) (FontSize size) (FontSpace spaceH) = do

@@ -42,6 +42,7 @@  import Monomer.Common import Monomer.Graphics.Types+import Monomer.Helper (putStrLnErr)  import qualified Monomer.Common.Lens as L import qualified Monomer.Graphics.Lens as L@@ -99,7 +100,7 @@   validFonts <- foldM (loadFont c) Set.empty fonts    when (null validFonts) $-    putStrLn "Could not find any valid fonts. Text will fail to be displayed."+    putStrLnErr "Could not find any valid fonts. Text will fail to be displayed."    envRef <- newIORef $ Env {     overlays = Seq.empty,@@ -236,6 +237,10 @@     gradient <- makeRadialGradient c dpr p1 rad1 rad2 color1 color2     VG.strokePaint c gradient +  setStrokeBoxGradient rect rad feather color1 color2 = do+    gradient <- makeBoxGradient c dpr rect rad feather color1 color2+    VG.strokePaint c gradient+   setStrokeImagePattern name topLeft size angle alpha = do     env <- readIORef envRef @@ -258,6 +263,10 @@     gradient <- makeRadialGradient c dpr p1 rad1 rad2 color1 color2     VG.fillPaint c gradient +  setFillBoxGradient rect rad feather color1 color2 = do+    gradient <- makeBoxGradient c dpr rect rad feather color1 color2+    VG.fillPaint c gradient+   setFillImagePattern name topLeft size angle alpha = do     env <- readIORef envRef @@ -352,11 +361,15 @@     req = ImageReq name def Nothing ImageDelete []  loadFont :: VG.Context -> Set Text -> FontDef -> IO (Set Text)-loadFont c fonts (FontDef name path) = do-  res <- VG.createFont c name (VG.FileName path)+loadFont c fonts fontDef = do+  res <- createFont fontDef   case res of     Just{} -> return $ Set.insert name fonts-    _ -> putStrLn ("Failed to load font: " ++ T.unpack name) >> return fonts+    _ -> putStrLnErr ("Failed to load font: " ++ T.unpack name) >> return fonts+  where+    name = fontDef ^. L.fontName+    createFont FontDefFile{} = VG.createFont c name (VG.FileName $ fontDef ^. L.fontPath)+    createFont FontDefMem{} = VG.createFontMem c name (fontDef ^. L.fontBytes)  setFont   :: VG.Context@@ -398,6 +411,17 @@     col1 = colorToPaint color1     col2 = colorToPaint color2 +makeBoxGradient+  :: VG.Context -> Double -> Rect -> Double -> Double -> Color -> Color -> IO VG.Paint+makeBoxGradient c dpr rect rad feather color1 color2 =+  VG.boxGradient c cx cy cw ch crad cfeather col1 col2+  where+    CRect cx cy cw ch = rectToCRect rect dpr+    crad = realToFrac $ rad * dpr+    cfeather = realToFrac $ feather * dpr+    col1 = colorToPaint color1+    col2 = colorToPaint color2+ makeImagePattern   :: VG.Context -> Double -> Image -> Point -> Size -> Double -> Double -> IO VG.Paint makeImagePattern c dpr image topLeft size angle alpha = do@@ -483,7 +507,7 @@  clearImagesMap :: VG.Context -> ImagesMap -> IO () clearImagesMap c imagesMap = do-  putStrLn "Clearing images map"+  putStrLnErr "Clearing images map"   forM_ (M.elems imagesMap) $ \image ->     VG.deleteImage c (_imNvImage image) 

@@ -45,11 +45,16 @@ instance Default Color where   def = Color 255 255 255 1.0 --- | The definition of a font.-data FontDef = FontDef {-  _fntName :: !Text,  -- ^ The logic name. Will be used when defining styles.-  _fntPath :: !Text   -- ^ The path in the filesystem.-} deriving (Eq, Show, Generic)+data FontDef+  = FontDefFile+    { _fntFontName :: !Text  -- ^ The logic name. Will be used when defining styles.+    , _fntFontPath :: !Text  -- ^ The path in the filesystem.+    }+  | FontDefMem+    { _fntFontName :: !Text         -- ^ The logic name. Will be used when defining styles.+    , _fntFontBytes :: !ByteString  -- ^ The bytes of the loaded font.+    }+  deriving (Eq, Show, Generic)  -- | The name of a loaded font. newtype Font@@ -333,6 +338,11 @@   -}   setStrokeRadialGradient :: Point -> Double -> Double -> Color -> Color -> IO (),   {-|+  Sets a box gradient stroke with box area, corner radius, feather, inner and+  outer Color+  -}+  setStrokeBoxGradient :: Rect -> Double -> Double -> Color -> Color -> IO (),+  {-|   Sets an image pattern stroke, with top given by Point, size of a single image   given by size, rotation and alpha.   -}@@ -348,6 +358,11 @@   inner and outer Color.   -}   setFillRadialGradient :: Point -> Double -> Double -> Color -> Color -> IO (),+  {-|+  Sets a box gradient fill with box area, corner radius, feather, inner and+  outer Color+  -}+  setFillBoxGradient :: Rect -> Double -> Double -> Color -> Color -> IO (),   {-|   Sets an image pattern fill, with top given by Point, size of a single image   given by size, rotation and alpha.

@@ -16,6 +16,7 @@ import Control.Exception (SomeException, catch) import Control.Monad.IO.Class (MonadIO) import Data.Sequence (Seq(..))+import System.IO (hPutStrLn, stderr)  import qualified Data.Sequence as Seq @@ -56,7 +57,23 @@ applyFnList :: [a -> a] -> a -> a applyFnList fns initial = foldl (flip ($)) initial fns --- | Returns the maximum value of a given floating type.+{-|+Returns the minimum value of a given floating type.++Copied from: https://hackage.haskell.org/package/numeric-limits+-}+minNumericValue :: (RealFloat a) => a+minNumericValue = x where+  n = floatDigits x+  b = floatRadix x+  (l, _) = floatRange x+  x = encodeFloat (b^n - 1) (l - n - 1)++{-|+Returns the maximum value of a given floating type.++Copied from: https://hackage.haskell.org/package/numeric-limits+-} maxNumericValue :: (RealFloat a) => a maxNumericValue = x where   n = floatDigits x@@ -76,3 +93,8 @@ headMay :: [a] -> Maybe a headMay [] = Nothing headMay (x : _) = Just x++putStrLnErr :: String -> IO ()+putStrLnErr msg = catchAny+  (hPutStrLn stderr msg)+  (const $ putStrLn msg)

@@ -50,7 +50,7 @@ import Monomer.Main.Util import Monomer.Main.WidgetTask import Monomer.Graphics-import Monomer.Helper (catchAny)+import Monomer.Helper (catchAny, putStrLnErr) import Monomer.Widgets.Composite  import qualified Monomer.Lens as L@@ -200,8 +200,8 @@        case setupRes of         RenderSetupMakeCurrentFailed msg -> do-          liftIO . putStrLn $ "Setup of the rendering thread failed: " ++ msg-          liftIO . putStrLn $ "Falling back to rendering in the main thread. "+          liftIO . putStrLnErr $ "Setup of the rendering thread failed: " ++ msg+          liftIO . putStrLnErr $ "Falling back to rendering in the main thread. "             ++ "The content may not be updated while resizing the window."            makeMainThreadRenderer@@ -221,7 +221,9 @@   case setupRes of     RenderSetupMulti -> do       liftIO . atomically $ writeTChan channel (MsgInit newWenv newRoot)-      liftIO $ watchWindowResize channel++      unless (isLinux newWenv) $+        liftIO $ watchWindowResize channel     _ -> return ()    let loopArgs = MainLoopArgs {@@ -283,7 +285,7 @@   let baseSystemEvents = convertEvents convertCfg mousePos eventsPayload  --  when newSecond $---    liftIO . putStrLn $ "Frames: " ++ show _mlFrameCount+--    liftIO . putStrLnErr $ "Frames: " ++ show _mlFrameCount    when quit $     L.exitApplication .= True

@@ -52,7 +52,7 @@ import Monomer.Core import Monomer.Event import Monomer.Graphics-import Monomer.Helper (headMay, seqStartsWith)+import Monomer.Helper (headMay, putStrLnErr, seqStartsWith) import Monomer.Main.Types import Monomer.Main.Util @@ -436,7 +436,7 @@   cursor <- Map.lookup icon <$> use L.cursorIcons    when (isNothing cursor) $-    liftIO . putStrLn $ "Invalid handleSetCursorIcon: " ++ show icon+    liftIO . putStrLnErr $ "Invalid handleSetCursorIcon: " ++ show icon    forM_ cursor SDLE.setCursor @@ -601,7 +601,6 @@   -> HandlerStep s e   -> m (HandlerStep s e) handleRaiseEvent message step = do-  --liftIO . putStrLn $ message ++ show (typeOf message)   return step   where     message = "Invalid state. RaiseEvent reached main handler. Type: "@@ -753,6 +752,7 @@     -- Hover changes need to be handled here too     mainPress <- use L.mainBtnPress     draggedMsg <- getDraggedMsgInfo+    overlay <- getOverlayPath      when (btn == mainBtn) $       L.mainBtnPress .= Nothing@@ -762,7 +762,7 @@     let pressed = fmap fst mainPress     let isPressed = btn == mainBtn && target == pressed     let clickEvt = [(Click point btn clicks, pressed) | isPressed || clicks > 1]-    let releasedEvt = [(evt, pressed <|> target)]+    let releasedEvt = [(evt, pressed <|> target <|> overlay)]     let dropEvts = case draggedMsg of           Just (path, msg) -> [(Drop point path msg, target) | not isPressed]           _ -> []@@ -891,7 +891,7 @@   let sdlCursor = cursorPair >>= (`Map.lookup` cursorIcons) . snd    when (isNothing sdlCursor && isJust cursorPair) $-    liftIO. putStrLn $ "Invalid restoreCursorOnWindowEnter: " ++ show cursorPair+    liftIO. putStrLnErr $ "Invalid restoreCursorOnWindowEnter: " ++ show cursorPair    when (not prevInside && currInside && isJust sdlCursor) $ do     SDLE.setCursor (fromJust sdlCursor)

@@ -28,12 +28,15 @@ import Control.Monad.State import Data.Maybe import Data.Text (Text)+import Data.Word import Foreign (alloca, peek) import Foreign.C (peekCString, withCString) import Foreign.C.Types import SDL (($=)) +import qualified Codec.Picture as P import qualified Data.Text as T+import qualified Data.Vector.Storable as V import qualified Foreign.C.String as STR import qualified SDL import qualified SDL.Input.Mouse as Mouse@@ -43,10 +46,8 @@ import qualified SDL.Video.Renderer as SVR  import Monomer.Common-import Monomer.Core.StyleTypes+import Monomer.Helper (catchAny, putStrLnErr) import Monomer.Main.Types-import Monomer.Event.Types-import Monomer.Widgets.Composite  foreign import ccall unsafe "initGlew" glewInit :: IO CInt foreign import ccall unsafe "initDpiAwareness" initDpiAwareness :: IO CInt@@ -59,12 +60,18 @@ initSDLWindow :: AppConfig e -> IO (SDL.Window, Double, Double, SDL.GLContext) initSDLWindow config = do   SDL.initialize [SDL.InitVideo]++  setDisableCompositorHint disableCompositingFlag++  if disableScreensaverFlag+    then Raw.disableScreenSaver+    else Raw.enableScreenSaver+   SDL.HintRenderScaleQuality $= SDL.ScaleLinear-  setDisableCompositorHint compositingFlag+  renderQuality <- SDL.get SDL.HintRenderScaleQuality -  do renderQuality <- SDL.get SDL.HintRenderScaleQuality-     when (renderQuality /= SDL.ScaleLinear) $-       putStrLn "Warning: Linear texture filtering not enabled!"+  when (renderQuality /= SDL.ScaleLinear) $+    putStrLnErr "Warning: Linear texture filtering not enabled!"    platform <- getPlatform   initDpiAwareness@@ -112,7 +119,7 @@    err <- SRE.getError   err <- STR.peekCString err-  putStrLn err+  putStrLnErr err    ctxRender <- SDL.glCreateContext window @@ -131,9 +138,12 @@       SDL.glProfile = SDL.Core SDL.Normal 3 2,       SDL.glMultisampleSamples = 1     }-    compositingFlag = fromMaybe False (_apcDisableCompositing config)-    userScaleFactor = fromMaybe 1 (_apcScaleFactor config)++    disableCompositingFlag = _apcDisableCompositing config == Just True+    disableScreensaverFlag = _apcDisableScreensaver config == Just True     disableAutoScale = _apcDisableAutoScale config == Just True+    userScaleFactor = fromMaybe 1 (_apcScaleFactor config)+     (baseW, baseH) = case _apcWindowState config of       Just (MainWindowNormal size) -> size       _ -> defaultWindowSize@@ -148,18 +158,21 @@  setWindowIcon :: SDL.Window -> AppConfig e -> IO () setWindowIcon (SIT.Window winPtr) config =-  forM_ (_apcWindowIcon config) $ \iconPath -> do-    iconSurface <- SVR.loadBMP (T.unpack iconPath)-    let SVR.Surface iconSurfacePtr _ = iconSurface-    finally-      -- Note: this can use the high-level setWindowIcon once it is available (https://github.com/haskell-game/sdl2/pull/243)-      (Raw.setWindowIcon winPtr iconSurfacePtr)-      (SVR.freeSurface iconSurface)+  forM_ (_apcWindowIcon config) $ \iconPath ->+    flip catchAny handleException $ do+      iconSurface <- loadImgToSurface (T.unpack iconPath)+      let SVR.Surface iconSurfacePtr _ = iconSurface+      finally+        -- Note: this can use the high-level setWindowIcon once it is available (https://github.com/haskell-game/sdl2/pull/243)+        (Raw.setWindowIcon winPtr iconSurfacePtr)+        (SVR.freeSurface iconSurface)+  where+    handleException err = putStrLnErr $+      "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-  putStrLn "About to destroyWindow"   SDL.destroyWindow window   Raw.quitSubSystem Raw.SDL_INIT_VIDEO   SDL.quit@@ -243,9 +256,28 @@   return (hdpi / 96)  setDisableCompositorHint :: Bool -> IO ()-setDisableCompositorHint disable = void $-  withCString "SDL_VIDEO_X11_NET_WM_BYPASS_COMPOSITOR" $ \cHintNameStr ->-    withCString disableStr $ \cDisableStr ->-      Raw.setHint cHintNameStr cDisableStr+setDisableCompositorHint disable =+  setBooleanHintSDL "SDL_VIDEO_X11_NET_WM_BYPASS_COMPOSITOR" disable++setBooleanHintSDL :: String -> Bool -> IO ()+setBooleanHintSDL flagName value = void $+  withCString flagName $ \cHintNameStr ->+    withCString valueStr $ \cValueStr ->+      Raw.setHint cHintNameStr cValueStr   where-    disableStr = if disable then "1" else "0"+    valueStr = if value then "1" else "0"++readImageRGBA8 :: FilePath -> IO (P.Image P.PixelRGBA8)+readImageRGBA8 path = P.readImage path+  >>= either fail (return . P.convertRGBA8)++loadImgToSurface :: FilePath -> IO SDL.Surface+loadImgToSurface path = do+  rgba8 <- readImageRGBA8 path+  imgData <- V.thaw (P.imageData rgba8)++  let width = fromIntegral $ P.imageWidth rgba8+      height = fromIntegral $ P.imageHeight rgba8+      imgSize = SDL.V2 width height++  SDL.createRGBSurfaceFrom imgData imgSize (4 * width) SDL.ABGR8888

@@ -41,6 +41,7 @@ import Monomer.Core.WidgetTypes import Monomer.Event.Types import Monomer.Graphics.Types+import Data.ByteString (ByteString)  -- | Main Monomer monad. type MonomerM s e m = (Eq s, MonadState (MonomerCtx s e) m, MonadCatch m, MonadIO m)@@ -205,7 +206,9 @@   -- | Whether wheel/trackpad vertical movement should be inverted.   _apcInvertWheelY :: Maybe Bool,   -- | Whether compositing should be disabled. Defaults to False.-  _apcDisableCompositing :: Maybe Bool+  _apcDisableCompositing :: Maybe Bool,+  -- | Whether the screensaver should be disabled. Defaults to False.+  _apcDisableScreensaver :: Maybe Bool }  instance Default (AppConfig e) where@@ -229,7 +232,8 @@     _apcContextButton = Nothing,     _apcInvertWheelX = Nothing,     _apcInvertWheelY = Nothing,-    _apcDisableCompositing = Nothing+    _apcDisableCompositing = Nothing,+    _apcDisableScreensaver = Nothing   }  instance Semigroup (AppConfig e) where@@ -253,7 +257,8 @@     _apcContextButton = _apcContextButton a2 <|> _apcContextButton a1,     _apcInvertWheelX = _apcInvertWheelX a2 <|> _apcInvertWheelX a1,     _apcInvertWheelY = _apcInvertWheelY a2 <|> _apcInvertWheelY a1,-    _apcDisableCompositing = _apcDisableCompositing a2 <|> _apcDisableCompositing a1+    _apcDisableCompositing = _apcDisableCompositing a2 <|> _apcDisableCompositing a1,+    _apcDisableScreensaver = _apcDisableScreensaver a2 <|> _apcDisableScreensaver a1   }  instance Monoid (AppConfig e) where@@ -378,14 +383,29 @@ }  {-|-Available fonts to the application. An empty list will make it impossible to-render text.+Available fonts to the application, loaded from the specified path. +Specifying no fonts will make it impossible to render text. -} appFontDef :: Text -> Text -> AppConfig e appFontDef name path = def {-  _apcFonts = [ FontDef name path ]+  _apcFonts = [ FontDefFile name path ] } +{-|+Available fonts to the application, loaded from the bytes in memory. +Specifying no fonts will make it impossible to render text.++One use case for this function is to embed fonts in the application, without the need to distribute the font files.+The [file-embed](https://hackage.haskell.org/package/file-embed-0.0.15.0/docs/Data-FileEmbed.html) library can be used for this.+@+appFontDefMemory "memoryFont" $(embedFile "dirName/fileName")+@+-}+appFontDefMem :: Text -> ByteString -> AppConfig e+appFontDefMem name bytes = def {+  _apcFonts = [ FontDefMem name bytes ]+}+ -- | Initial theme. appTheme :: Theme -> AppConfig e appTheme t = def {@@ -450,11 +470,23 @@ Whether compositing should be disabled. Linux only, ignored in other platforms. Defaults to False. -Desktop applications should leave compositing as is, since disabling it may+Desktop applications should leave compositing as is since disabling it may cause visual glitches in other programs. When creating games or fullscreen applications, disabling compositing may improve performance. -} appDisableCompositing :: Bool -> AppConfig e-appDisableCompositing invert = def {-  _apcDisableCompositing = Just invert+appDisableCompositing disable = def {+  _apcDisableCompositing = Just disable+}++{-|+Whether the screensaver should be disabled. Defaults to False.++Desktop applications should leave the screensaver as is since disabling it also+affects power saving features, including turning off the screen. When creating+games or fullscreen applications, disabling the screensaver may make sense.+-}+appDisableScreensaver :: Bool -> AppConfig e+appDisableScreensaver disable = def {+  _apcDisableScreensaver = Just disable }

@@ -20,6 +20,7 @@ import Data.Text (Text)  import Monomer.Widgets.Composite+import Monomer.Widgets.Singles.Spacer  import qualified Monomer.Core.Lens as L import qualified Monomer.Main.Lens as L@@ -54,3 +55,81 @@ -- | Generates a response that cancels a request to exit the application cancelExitApplication :: EventResponse s e sp ep cancelExitApplication = Request (ExitApplication False)++{-|+Returns the provided widget when True, otherwise returns an invisible+placeholder.++Useful for conditionally adding a widget to a list.++@+vstack [+  label \"Label 1\",+  widgetIf isValid (label \"Label 2\")+]+@+-}+widgetIf :: Bool -> WidgetNode s e -> WidgetNode s e+widgetIf True node = node+widgetIf False _ = spacer `nodeVisible` False++{-|+Returns the result of applying the function when the provided value is Just,+otherwise returns an invisible placeholder.++Useful for conditionally adding a widget to a list.+-}+widgetMaybe :: Maybe a -> (a -> WidgetNode s e) -> WidgetNode s e+widgetMaybe Nothing _ = spacer `nodeVisible` False+widgetMaybe (Just val) fn = fn val++{-|+Returns the provided style when True, otherwise returns the empty style.++Useful for conditionally setting a style.++@+label \"Test\"+  \`styleBasic\` [+    textFont \"Medium\",+    styleIf invalidUser (textColor red)+  ]+@+-}+styleIf :: Bool -> StyleState -> StyleState+styleIf True state = state+styleIf False _ = mempty++{-|+Returns the result of applying the function when the provided value is Just,+otherwise returns the empty style.++Useful for conditionally setting a style.+-}+styleMaybe :: Maybe a -> (a -> StyleState) -> StyleState+styleMaybe Nothing _ = mempty+styleMaybe (Just state) fn = fn state++{-|+Returns the provided configuration value when True, otherwise returns the+default ('mempty') configuration value.++Useful for conditionally setting a configuration value.++@+label_ \"Test\" [textFont \"Medium\", configIf showAll multiline]+@+-}+configIf :: Monoid a => Bool -> a -> a+configIf True val = val+configIf False _ = mempty++{-|+Returns the result of applying the function when the provided value is Just,+otherwise returns the default ('mempty') configuration value.++Useful for conditionally setting a configuration value.+-}+configMaybe :: Monoid a => Maybe b -> (b -> a) -> a+configMaybe Nothing _ = mempty+configMaybe (Just val) fn = fn val

@@ -28,7 +28,7 @@ import qualified Data.Sequence as Seq  import Monomer.Core-import Monomer.Helper (collectJustM)+import Monomer.Helper (collectJustM, putStrLnErr) import Monomer.Main.Handlers import Monomer.Main.Lens import Monomer.Main.Util@@ -90,7 +90,7 @@   -> Either SomeException i   -> m (HandlerStep s e) processTaskResult wenv widgetRoot _ (Left ex) = do-  liftIO . putStrLn $ "Error processing Widget task result: " ++ show ex+  liftIO . putStrLnErr $ "Error processing Widget task result: " ++ show ex   return (wenv, widgetRoot, Seq.empty) processTaskResult wenv widgetRoot widgetId (Right taskResult)   = processTaskEvent wenv widgetRoot widgetId taskResult

@@ -24,6 +24,7 @@   module Monomer.Widgets.Containers.DropTarget,   module Monomer.Widgets.Containers.Grid,   module Monomer.Widgets.Containers.Keystroke,+  module Monomer.Widgets.Containers.Popup,   module Monomer.Widgets.Containers.Scroll,   module Monomer.Widgets.Containers.SelectList,   module Monomer.Widgets.Containers.Split,@@ -70,6 +71,7 @@ import Monomer.Widgets.Containers.DropTarget import Monomer.Widgets.Containers.Grid import Monomer.Widgets.Containers.Keystroke+import Monomer.Widgets.Containers.Popup import Monomer.Widgets.Containers.Scroll import Monomer.Widgets.Containers.SelectList import Monomer.Widgets.Containers.Split

@@ -68,8 +68,8 @@ import Control.Applicative ((<|>)) import Control.Exception (AssertionFailed(..), throw) import Control.Lens (ALens', (&), (^.), (^?), (.~), (%~), (<>~), at, ix, non)+import Control.Monad (when) import Data.Default-import Data.Either import Data.List (foldl') import Data.Map.Strict (Map) import Data.Maybe@@ -642,12 +642,18 @@   model = getCompositeModel state   cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model   widget = _cpsRoot ^. L.widget+  widgetId = widgetComp ^. L.info . L.widgetId -  WidgetResult _ reqs = widgetDispose widget cwenv _cpsRoot+  handleReq (RaiseEvent evt) = reqs where+    WidgetResult _ reqs = handleMsgEvent comp state wenv widgetComp evt+  handleReq req = maybe Seq.empty Seq.singleton (toParentReq widgetId req) -  disposeReqs = Seq.fromList (_cmpOnDisposeReq comp)-  tempResult = WidgetResult _cpsRoot (reqs <> disposeReqs)+  parentReqs = mconcat (handleReq <$> _cmpOnDisposeReq comp)++  WidgetResult _ childReqs = widgetDispose widget cwenv _cpsRoot+  tempResult = WidgetResult _cpsRoot childReqs   result = toParentResult comp state wenv widgetComp tempResult+    & L.requests %~ (parentReqs <>)  compositeGetInstanceTree   :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, CompParentModel sp)@@ -853,8 +859,9 @@   -> Renderer   -> IO () compositeRender comp state wenv widgetComp renderer =-  drawStyledAction renderer viewport style $ \_ ->-    widgetRender widget cwenv _cpsRoot renderer+  when (isWidgetVisible wenv widgetComp) $+    drawStyledAction renderer viewport style $ \_ ->+      widgetRender widget cwenv _cpsRoot renderer   where     CompositeState{..} = state     widget = _cpsRoot ^. L.widget

@@ -144,6 +144,12 @@ internal state needs to use model/environment information, generate user events or make requests to the runtime. +During init, a widget can return an arbitrary list of child widgets as part of+its result, even replacing those provided by the user. For this reason, child+widgets are initialized after this init function is complete. In case you need+to retrieve the 'WidgetId' of a child widget, you should use 'containerInitPost'+instead.+ An example can be found in "Monomer.Widgets.Containers.SelectList".  Most of the current containers serve layout purposes and don't need a custom@@ -191,6 +197,12 @@ In general, you want to at least keep the previous state unless the widget is stateless or only consumes model/environment information. +During merge, a widget can return an arbitrary list of child widgets as part of+its result, even replacing those provided by the user. For this reason, new+child widgets are initialized after this merge function is complete. In case you+need to retrieve the 'WidgetId' of a child widget, you should use+'containerMergePost' instead.+ Examples can be found in "Monomer.Widgets.Containers.Fade" and "Monomer.Widgets.Containers.Tooltip". On the other hand, "Monomer.Widgets.Containers.Grid" does not need to override merge since it's@@ -624,20 +636,21 @@     Nothing -> True    styledNode = initNodeStyle getBaseStyle wenv newNode+  pResult = mergeParent mergeHandler wenv styledNode oldNode oldState+  pNode = pResult ^. L.node    -- Check if an updated container can be used for offset/layout direction.-  pNode = pResult ^. L.node   updateCWenv = case useState oldState >>= createContainerFromModel wenv pNode of     Just newContainer -> getUpdateCWenv newContainer     _ -> getUpdateCWenv container+   cWenvHelper idx child = cwenv where     cwenv = updateCWenv wenv pNode child idx -  pResult = mergeParent mergeHandler wenv styledNode oldNode oldState-  cResult = mergeChildren cWenvHelper wenv newNode oldNode pResult+  cResult = mergeChildren cWenvHelper wenv pNode oldNode pResult   vResult = mergeChildrenCheckVisible oldNode cResult -  flagsChanged = nodeFlagsChanged oldNode newNode+  flagsChanged = nodeFlagsChanged oldNode pNode   themeChanged = wenv ^. L.themeChanged   mResult     | mergeRequired || flagsChanged || themeChanged = vResult@@ -647,7 +660,7 @@   mState = widgetGetState (mNode ^. L.widget) wenv mNode   postRes = case (,) <$> useState oldState <*> useState mState of     Just (ost, st) -> mergePostHandler wenv mNode oldNode ost st mResult-    Nothing -> resultNode (mResult ^. L.node)+    Nothing -> mResult    tmpResult     | isResizeAnyResult (Just postRes) = postRes@@ -698,6 +711,7 @@   mergedReqs = foldMap _wrRequests mergedResults   removedReqs = foldMap _wrRequests removedResults   mergedNode = pNode & L.children .~ mergedChildren+   newReqs = pReqs <> mergedReqs <> removedReqs   !newResult = WidgetResult mergedNode newReqs @@ -717,10 +731,16 @@     _ -> widgetDispose (child ^. L.widget) wenv child   !removed = fmap dispose oldIts   !res = (Empty, removed)+ mergeChildSeq updateCWenv wenv oldKeys newKeys newNode Empty newIts = res where-  init (idx, !child) = widgetInit (child ^. L.widget) wenv child+  init (idx, !child) = newWidget where+    newWidgetId = child ^. L.info . L.widgetId+    newWidget = widgetInit (child ^. L.widget) wenv child+      & L.requests %~ (|> ResizeWidgets newWidgetId)+   !merged = fmap init newIts   !res = (merged, Empty)+ mergeChildSeq updateCWenv wenv oldKeys newKeys newNode oldIts newIts = res where   (_, !oldChild) :<| oldChildren = oldIts   (!newIdx, !newChild) :<| newChildren = newIts@@ -1147,24 +1167,24 @@   -> Renderer   -> IO () renderWrapper container wenv !node !renderer =-  drawInScissor renderer useScissor viewport $-    drawStyledAction_ renderer drawDecorations viewport style $ \_ -> do-      renderBefore wenv node renderer+  when (isWidgetVisible wenv node) $+    drawInScissor renderer useScissor viewport $+      drawStyledAction_ renderer drawDecorations viewport style $ \_ -> do+        renderBefore wenv node renderer -      drawInScissor renderer useChildrenScissor childrenScissorRect $ do-        when (isJust offset) $ do-          saveContext renderer-          setTranslation renderer (fromJust offset)+        drawInScissor renderer useChildrenScissor childrenScissorRect $ do+          when (isJust offset) $ do+            saveContext renderer+            setTranslation renderer (fromJust offset) -        forM_ pairs $ \(idx, child) ->-          when (isWidgetVisible (cwenv child idx) child) $+          forM_ pairs $ \(idx, child) ->             widgetRender (child ^. L.widget) (cwenv child idx) child renderer -        when (isJust offset) $-          restoreContext renderer+          when (isJust offset) $+            restoreContext renderer -      -- Outside children scissor-      renderAfter wenv node renderer+        -- Outside children scissor+        renderAfter wenv node renderer   where     style = containerGetCurrentStyle container wenv node     updateCWenv = getUpdateCWenv container

@@ -40,16 +40,20 @@ ) where  import Control.Applicative ((<|>))-import Control.Lens ((&), (.~))+import Control.Lens ((&), (.~), (%~)) import Data.Default import Data.Maybe import Data.Text (Text) +import qualified Data.Sequence as Seq+ import Monomer.Core import Monomer.Core.Combinators  import Monomer.Widgets.Composite+import Monomer.Widgets.Container import Monomer.Widgets.Containers.Box+import Monomer.Widgets.Containers.BoxShadow import Monomer.Widgets.Containers.Keystroke import Monomer.Widgets.Containers.Stack import Monomer.Widgets.Singles.Button@@ -165,7 +169,7 @@       box_ [alignRight] dismissButton         & L.info . L.style .~ collectTheme wenv L.dialogButtonsStyle     ] & L.info . L.style .~ collectTheme wenv L.dialogFrameStyle-  alertBox = box_ [onClickEmpty cancelEvt] alertTree+  alertBox = box_ [onClickEmpty cancelEvt] (boxShadow alertTree)     & L.info . L.style .~ emptyOverlay   mainTree = keystroke [("Esc", cancelEvt)] alertBox 

@@ -0,0 +1,187 @@+{-|+Module      : Monomer.Widgets.Containers.BoxShadow+Copyright   : (c) 2022 Gareth Smith, Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++A rectangular drop-shadow. Normally used around alert boxes to give the illusion+they are floating above the widgets underneath them.+-}+{-# LANGUAGE Strict #-}++module Monomer.Widgets.Containers.BoxShadow (+  -- * Configuration+  BoxShadowCfg,+  -- * Constructors+  boxShadow,+  boxShadow_+) where++import Control.Applicative ((<|>))+import Control.Lens ((&), (.~), (^.))+import Data.Default+import Data.Maybe++import qualified Data.Sequence as Seq++import Monomer.Core+import Monomer.Core.Combinators++import Monomer.Widgets.Container++import qualified Monomer.Lens as L++{-|+Configuration options for boxShadow:++- 'radius': the radius of the corners of the shadow.+- 'alignLeft': aligns the shadow to the left.+- 'alignCenter': aligns the shadow to the horizontal center.+- 'alignRight': aligns the shadow to the right.+- 'alignTop': aligns the shadow to the top.+- 'alignMiddle': aligns the shadow to the vertical middle.+- 'alignBottom': aligns the shadow to the bottom.+-}+data BoxShadowCfg = BoxShadowCfg {+  _bscRadius :: Maybe Double,+  _bscAlignH :: Maybe AlignH,+  _bscAlignV :: Maybe AlignV+}++instance Default BoxShadowCfg where+  def = BoxShadowCfg {+    _bscRadius = Nothing,+    _bscAlignH = Nothing,+    _bscAlignV = Nothing+  }++instance Semigroup BoxShadowCfg where+  (<>) c1 c2 = BoxShadowCfg {+    _bscRadius = _bscRadius c1 <|> _bscRadius c2,+    _bscAlignH = _bscAlignH c1 <|> _bscAlignH c2,+    _bscAlignV = _bscAlignV c1 <|> _bscAlignV c2+  }++instance Monoid BoxShadowCfg where+  mempty = def++instance CmbRadius BoxShadowCfg where+  radius r = def {+    _bscRadius = Just r+  }++instance CmbAlignLeft BoxShadowCfg where+  alignLeft_ False = def+  alignLeft_ True = def {+    _bscAlignH = Just ALeft+  }++instance CmbAlignCenter BoxShadowCfg where+  alignCenter_ False = def+  alignCenter_ True = def {+    _bscAlignH = Just ACenter+  }++instance CmbAlignRight BoxShadowCfg where+  alignRight_ False = def+  alignRight_ True = def {+    _bscAlignH = Just ARight+  }++instance CmbAlignTop BoxShadowCfg where+  alignTop_ False = def+  alignTop_ True = def {+    _bscAlignV = Just ATop+  }++instance CmbAlignMiddle BoxShadowCfg where+  alignMiddle_ False = def+  alignMiddle_ True = def {+    _bscAlignV = Just AMiddle+  }++instance CmbAlignBottom BoxShadowCfg where+  alignBottom_ False = def+  alignBottom_ True = def {+    _bscAlignV = Just ABottom+  }++-- | Creates a boxShadow around the provided content.+boxShadow+  :: WidgetNode s e  -- ^ The content to display inside the boxShadow.+  -> WidgetNode s e  -- ^ The created boxShadow.+boxShadow = boxShadow_ def++-- | Creates a boxShadow around the provided content. Accepts config.+boxShadow_+  :: [BoxShadowCfg]  -- ^ The config options for the boxShadow.+  -> WidgetNode s e  -- ^ The content to display inside the boxShadow.+  -> WidgetNode s e  -- ^ The created boxShadow.+boxShadow_ config child =+  defaultWidgetNode "boxShadow" (boxShadowWidget (mconcat config))+   & L.children .~ Seq.singleton child++boxShadowWidget :: BoxShadowCfg -> Widget s e+boxShadowWidget config = widget where+  widget = createContainer () def {+    containerGetSizeReq = getSizeReq,+    containerResize = resize,+    containerRender = render+  }++  shadowRadius = fromMaybe 8 (_bscRadius config)+  shadowDiameter = shadowRadius * 2++  getSizeReq wenv node children = (sizeReqW, sizeReqH) where+    sizeReqW = maybe (fixedSize 0) (addFixed shadowDiameter . _wniSizeReqW . _wnInfo) vchild+    sizeReqH = maybe (fixedSize 0) (addFixed shadowDiameter. _wniSizeReqH . _wnInfo) vchild+    vchildren = Seq.filter (_wniVisible . _wnInfo) children+    vchild = Seq.lookup 0 vchildren++  resize wenv node viewport children = (resultNode node, fmap assignArea children) where+    style = currentStyle wenv node+    contentArea = fromMaybe def (removeOuterBounds style viewport)+    +    assignArea child+      | visible = moveRect childOffset (subtractShadow contentArea)+      | otherwise = def+      where+        visible = (_wniVisible . _wnInfo) child+    +    childOffset = Point offsetX offsetY where+      theme = currentTheme wenv node+      shadowAlignH = fromMaybe (theme ^. L.shadowAlignH) (_bscAlignH config)+      shadowAlignV = fromMaybe (theme ^. L.shadowAlignV) (_bscAlignV config)+      offset = shadowRadius / 4+      offsetX = case shadowAlignH of+        ALeft -> offset+        ACenter -> 0+        ARight -> -offset+      offsetY = case shadowAlignV of+        ATop -> offset+        AMiddle -> 0+        ABottom -> -offset+  +  render wenv node renderer = do+    beginPath renderer+    setFillBoxGradient renderer (subtractShadow vp) shadowRadius shadowDiameter shadowColor transparent+    renderRect renderer vp+    fill renderer+    where+      style = currentStyle wenv node+      vp = getContentArea node style+      shadowColor = wenv ^. L.theme . L.basic . L.shadowColor+      transparent = rgba 0 0 0 0+  +  subtractShadow (Rect l t w h) = Rect l' t' w' h' where+    (l', w') = subtractDim l w+    (t', h') = subtractDim t h+    subtractDim pos size+      | size > shadowDiameter = (pos + shadowRadius, size - shadowDiameter)+      | otherwise = (pos + size / 2, 0)++addFixed :: Double -> SizeReq -> SizeReq+addFixed f sReq =+  sReq { _szrFixed = _szrFixed sReq + f }

@@ -57,6 +57,7 @@  import Monomer.Widgets.Composite import Monomer.Widgets.Containers.Box+import Monomer.Widgets.Containers.BoxShadow import Monomer.Widgets.Containers.Keystroke import Monomer.Widgets.Containers.Stack import Monomer.Widgets.Singles.Button@@ -213,7 +214,7 @@       box_ [alignRight] buttons         & L.info . L.style <>~ collectTheme wenv L.dialogButtonsStyle     ] & L.info . L.style .~ collectTheme wenv L.dialogFrameStyle-  confirmBox = box_ [onClickEmpty cancelEvt] confirmTree+  confirmBox = box_ [onClickEmpty cancelEvt] (boxShadow confirmTree)     & L.info . L.style .~ emptyOverlay   mainTree = keystroke [("Esc", cancelEvt)] confirmBox 

@@ -22,6 +22,11 @@  customDropdown = dropdown userLens usernames makeSelected makeRow @++Note: the content of the dropdown list will only be updated when the provided+items change, based on their 'Eq' instance. In case data external to the items+is used for building the row nodes, 'mergeRequired' may be needed to avoid stale+content. -} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-}@@ -84,11 +89,17 @@ - 'maxHeight': maximum height of the list when dropdown is expanded. - 'itemBasicStyle': 'Style' of an item in the list when not selected. - 'itemSelectedStyle': 'Style' of the selected item in the list.+- 'mergeRequired': whether merging the items in the list is required. Useful+  when the content displayed depends on external data, since changes to data+  outside the provided list cannot be detected. In general it is recommended to+  only depend on data contained in the list itself, making sure the 'Eq'+  instance of the item type is correct. -} data DropdownCfg s e a = DropdownCfg {   _ddcMaxHeight :: Maybe Double,   _ddcItemStyle :: Maybe Style,   _ddcItemSelectedStyle :: Maybe Style,+  _ddcMergeRequired :: Maybe (WidgetEnv s e -> Seq a -> Seq a -> Bool),   _ddcOnFocusReq :: [Path -> WidgetRequest s e],   _ddcOnBlurReq :: [Path -> WidgetRequest s e],   _ddcOnChangeReq :: [a -> WidgetRequest s e],@@ -100,6 +111,7 @@     _ddcMaxHeight = Nothing,     _ddcItemStyle = Nothing,     _ddcItemSelectedStyle = Nothing,+    _ddcMergeRequired = Nothing,     _ddcOnFocusReq = [],     _ddcOnBlurReq = [],     _ddcOnChangeReq = [],@@ -111,6 +123,7 @@     _ddcMaxHeight = _ddcMaxHeight t2 <|> _ddcMaxHeight t1,     _ddcItemStyle = _ddcItemStyle t2 <|> _ddcItemStyle t1,     _ddcItemSelectedStyle = _ddcItemSelectedStyle t2 <|> _ddcItemSelectedStyle t1,+    _ddcMergeRequired = _ddcMergeRequired t2 <|> _ddcMergeRequired t1,     _ddcOnFocusReq = _ddcOnFocusReq t1 <> _ddcOnFocusReq t2,     _ddcOnBlurReq = _ddcOnBlurReq t1 <> _ddcOnBlurReq t2,     _ddcOnChangeReq = _ddcOnChangeReq t1 <> _ddcOnChangeReq t2,@@ -175,6 +188,11 @@     _ddcItemSelectedStyle = Just style   } +instance CmbMergeRequired (DropdownCfg s e a) (WidgetEnv s e) (Seq a) where+  mergeRequired fn = def {+    _ddcMergeRequired = Just fn+  }+ data DropdownState = DropdownState {   _ddsOpen :: Bool,   _ddsOffset :: Point@@ -254,7 +272,7 @@     & L.info . L.focusable .~ True  makeDropdown-  :: (WidgetModel s, WidgetEvent e, DropdownItem a)+  :: forall s e a. (WidgetModel s, WidgetEvent e, DropdownItem a)   => WidgetData s a   -> Seq a   -> (a -> WidgetNode s e)@@ -420,9 +438,11 @@       & L.widget .~ makeDropdown widgetData items makeMain makeRow config newState     requests = [ResetOverlay slWid, SetFocus widgetId] +  scrollListInfo :: WidgetNode s e -> (WidgetId, Path)   scrollListInfo node = (scrollInfo ^. L.widgetId, scrollInfo ^. L.path) where     scrollInfo = node ^?! L.children . ix listIdx . L.info +  selectListInfo :: WidgetNode s e -> (WidgetId, Path)   selectListInfo node = (listInfo ^. L.widgetId, listInfo ^. L.path) where     listInfo = node ^?! L.children . ix listIdx . L.children . ix 0 . L.info @@ -540,12 +560,15 @@   itemStyle = fromJust (Just normalTheme <> _ddcItemStyle config)   itemSelStyle = fromJust (Just selectedTheme <> _ddcItemSelectedStyle config) +  mergeReqFn = maybe def mergeRequired (_ddcMergeRequired config)+   slConfig = [       selectOnBlur,       onBlurReq (const $ SendMessage widgetId OnListBlur),       onChangeIdxReq (\idx it -> SendMessage widgetId (OnChangeMessage idx it)),       itemBasicStyle itemStyle,-      itemSelectedStyle itemSelStyle+      itemSelectedStyle itemSelStyle,+      mergeReqFn     ]   slStyle = collectTheme wenv L.dropdownListStyle   selectListNode = selectListD_ value items makeRow slConfig

@@ -0,0 +1,688 @@+{-|+Module      : Monomer.Widgets.Containers.Popup+Copyright   : (c) 2018 Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Popup widget, used to display content overlaid on top of the active widget tree.+When the popup is open, events will not reach the widgets below it.++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+closed by clicking outside its content.++In general, it is a good idea to set a background color to the top level content+widget, since by default most widgets have a transparent background; this is+true in particular for containers.++@+popup visiblePopup $  -- visiblePopup is a lens to a Bool field in the model+  label "This will appear on top of the widget tree"+    `styleBasic` [bgColor gray, padding 10]+@++By default the popup will be open at the top-left location the widget would be+if it was directly embedded in the widget tree. One common pattern is having a+popup open when clicking a button, and the expectation is it will open below the+button. This can be achieved with:++@+vstack [+  button "Open" OpenPopup,+  popup visiblePopup (label "Content")+]+@++The popup's content can be aligned relative to the location of the popup widget+in the widget tree:++@+popup_ visiblePopup [alignTop, alignCenter] $+  label "This will appear on top of the widget tree, aligned to the top-center"+    `styleBasic` [bgColor gray, padding 10]+@++Alternatively, aligning relative to the application's window is possible. This+can be useful for displaying notifications:++@+popup_ visiblePopup [popupAlignToWindow, alignTop, alignCenter] $+  label "This will appear centered at the top of the main window"+    `styleBasic` [bgColor gray, padding 10]+@++It's possible to add an offset to the location of the popup, and also combine it+with alignment options:++@+cfgs = [popupAlignToWindow, alignTop, alignCenter, popupOffset (Point 0 5)]++popup_ visiblePopup cfgs $+  label "This will appear centered almost at the top of the main window"+    `styleBasic` [bgColor gray, padding 10]+@++Alternatively, a widget can be provided as an anchor. This is not too different+than the previous examples but opens up more alignment options, since the+popup's content can now be aligned relative to the outer side of the edges of+the anchor widget.++@+anchor = toggleButton "Show popup" visiblePopup+cfgs = [popupAnchor anchor, popupAlignToOuterV, alignTop, alignCenter]++popup_ visiblePopup cfgs $+  label "The bottom of the content will be aligned to the top of the anchor"+    `styleBasic` [bgColor gray, padding 10]+@++For an example of popup's use, check 'Monomer.Widgets.Singles.ColorPopup'.++Note: style settings will be ignored by this widget. The content and anchor need+to be styled independently.+-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Strict #-}++module Monomer.Widgets.Containers.Popup (+  -- * Configuration+  PopupCfg,+  popupAnchor,+  popupAlignToOuterH,+  popupAlignToOuterH_,+  popupAlignToOuterV,+  popupAlignToOuterV_,+  popupAlignToWindow,+  popupAlignToWindow_,+  popupOffset,+  popupOpenAtCursor,+  popupOpenAtCursor_,+  popupDisableClose,+  popupDisableClose_,++  -- * Constructors+  popup,+  popup_,+  popupV,+  popupV_,+  popupD_+) where++import Control.Applicative ((<|>))+import Control.Lens -- ((&), (^.), (^?!), (.~), ALens', ix)+import Control.Monad (when)+import Data.Default+import Data.Maybe++import qualified Data.Sequence as Seq++import Monomer.Widgets.Container+import Monomer.Widgets.Singles.Spacer++import qualified Monomer.Lens as L++{-|+Configuration options for popup:++- 'popupAnchor': a widget to be used as a reference for positioning the popup.+- 'popupAlignToOuter': align the popup to the anchor's outer borders.+- 'popupAlignToWindow': align the popup to the application's window.+- 'popupOffset': offset to add to the default location of the popup.+- 'popupOpenAtCursor': whether to open the content at the cursor position.+- '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.+- 'alignTop': top align relative to the widget location or main window.+- 'alignMiddle': 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.+-}+data PopupCfg s e = PopupCfg {+  _ppcAnchor :: Maybe (WidgetNode s e),+  _ppcAlignToOuterH :: Maybe Bool,+  _ppcAlignToOuterV :: Maybe Bool,+  _ppcAlignToWindow :: Maybe Bool,+  _ppcAlignH :: Maybe AlignH,+  _ppcAlignV :: Maybe AlignV,+  _ppcOffset :: Maybe Point,+  _ppcOpenAtCursor :: Maybe Bool,+  _ppcDisableClose :: Maybe Bool,+  _ppcOnChangeReq :: [Bool -> WidgetRequest s e]+}++instance Default (PopupCfg s e) where+  def = PopupCfg {+    _ppcAnchor = Nothing,+    _ppcAlignToOuterH = Nothing,+    _ppcAlignToOuterV = Nothing,+    _ppcAlignToWindow = Nothing,+    _ppcAlignH = Nothing,+    _ppcAlignV = Nothing,+    _ppcOffset = Nothing,+    _ppcOpenAtCursor = Nothing,+    _ppcDisableClose = Nothing,+    _ppcOnChangeReq = []+  }++instance Semigroup (PopupCfg s e) where+  (<>) t1 t2 = PopupCfg {+    _ppcAnchor = _ppcAnchor t2 <|> _ppcAnchor t1,+    _ppcAlignToOuterH = _ppcAlignToOuterH t2 <|> _ppcAlignToOuterH t1,+    _ppcAlignToOuterV = _ppcAlignToOuterV t2 <|> _ppcAlignToOuterV t1,+    _ppcAlignToWindow = _ppcAlignToWindow t2 <|> _ppcAlignToWindow t1,+    _ppcAlignH = _ppcAlignH t2 <|> _ppcAlignH t1,+    _ppcAlignV = _ppcAlignV t2 <|> _ppcAlignV t1,+    _ppcOffset = _ppcOffset t2 <|> _ppcOffset t1,+    _ppcOpenAtCursor = _ppcOpenAtCursor t2 <|> _ppcOpenAtCursor t1,+    _ppcDisableClose = _ppcDisableClose t2 <|> _ppcDisableClose t1,+    _ppcOnChangeReq = _ppcOnChangeReq t1 <> _ppcOnChangeReq t2+  }++instance Monoid (PopupCfg s e) where+  mempty = def++instance CmbAlignLeft (PopupCfg s e) where+  alignLeft_ False = def+  alignLeft_ True = def {+    _ppcAlignH = Just ALeft+  }++instance CmbAlignCenter (PopupCfg s e) where+  alignCenter_ False = def+  alignCenter_ True = def {+    _ppcAlignH = Just ACenter+  }++instance CmbAlignRight (PopupCfg s e) where+  alignRight_ False = def+  alignRight_ True = def {+    _ppcAlignH = Just ARight+  }++instance CmbAlignTop (PopupCfg s e) where+  alignTop_ False = def+  alignTop_ True = def {+    _ppcAlignV = Just ATop+  }++instance CmbAlignMiddle (PopupCfg s e) where+  alignMiddle_ False = def+  alignMiddle_ True = def {+    _ppcAlignV = Just AMiddle+  }++instance CmbAlignBottom (PopupCfg s e) where+  alignBottom_ False = def+  alignBottom_ True = def {+    _ppcAlignV = Just ABottom+  }++instance WidgetEvent e => CmbOnChange (PopupCfg s e) Bool e where+  onChange fn = def {+    _ppcOnChangeReq = [RaiseEvent . fn]+  }++instance CmbOnChangeReq (PopupCfg s e) s e Bool where+  onChangeReq req = def {+    _ppcOnChangeReq = [req]+  }++{-|+Sets the widget that will be used as the anchor for the popup. In general, this+anchor will also act as the trigger to open the popup (e.g. a button). When the+popup is open, the anchor will be used to position the content, taking scroll+and window size into consideration.+-}+popupAnchor :: WidgetNode s e -> PopupCfg s e+popupAnchor node = def {+  _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.++This option only works when 'popupAnchor' is set.+-}+popupAlignToOuterH :: PopupCfg s e+popupAlignToOuterH = popupAlignToOuterH_ True++{-|+Sets whether to align the popup to the horizontal outer edges of the anchor. It+only works with 'alignLeft' and 'alignRight', which need to be specified+separately.++This option only works when 'popupAnchor' is set.+-}+popupAlignToOuterH_ :: Bool -> PopupCfg s e+popupAlignToOuterH_ align = def {+  _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.++This option only works when 'popupAnchor' is set.+-}+popupAlignToOuterV :: PopupCfg s e+popupAlignToOuterV = popupAlignToOuterV_ True++{-|+Sets whether to align the popup vertically to the outer edges of the anchor. It+only works with 'alignTop' and 'alignBottom', which need to be specified+separately.++This option only works when 'popupAnchor' is set.+-}+popupAlignToOuterV_ :: Bool -> PopupCfg s e+popupAlignToOuterV_ align = def {+  _ppcAlignToOuterV = Just align+}++-- | Alignment will be relative to the application's main window.+popupAlignToWindow :: PopupCfg s e+popupAlignToWindow = popupAlignToWindow_ True++-- | Sets whether alignment will be relative to the application's main window.+popupAlignToWindow_ :: Bool -> PopupCfg s e+popupAlignToWindow_ align = def {+  _ppcAlignToWindow = Just align+}++{-|+Offset to be applied to the location of the popup. It is applied after alignment+options but before adjusting for screen boundaries.+-}+popupOffset :: Point -> PopupCfg s e+popupOffset point = def {+  _ppcOffset = Just point+}++-- | The popup will open at the current cursor position.+popupOpenAtCursor :: PopupCfg s e+popupOpenAtCursor = popupOpenAtCursor_ True++-- | Sets whether the popup will open at the current cursor position.+popupOpenAtCursor_ :: Bool -> PopupCfg s e+popupOpenAtCursor_ open = def {+  _ppcOpenAtCursor = Just open+}++-- | Clicking outside the popup's content will not close it.+popupDisableClose :: PopupCfg s e+popupDisableClose = popupDisableClose_ True++-- | Sets whether clicking outside the popup's content will not close it.+popupDisableClose_ :: Bool -> PopupCfg s e+popupDisableClose_ close = def {+  _ppcDisableClose = Just close+}++data PopupState = PopupState {+  _ppsClickPos :: Point,+  _ppsReleaseMs :: Millisecond+} deriving (Eq, Show)++-- | Creates a popup with the given lens to determine its visibility.+popup+  :: WidgetModel s+  => ALens' s Bool+  -> WidgetNode s e+  -> WidgetNode s e+popup field content = popup_ field def content++{-|+Creates a popup with the given lens to determine its visibility. Accepts config.+-}+popup_+  :: WidgetModel s+  => ALens' s Bool+  -> [PopupCfg s e]+  -> WidgetNode s e+  -> WidgetNode s e+popup_ field configs content = newNode where+  newNode = popupD_ (WidgetLens field) configs content++{-|+Creates a popup using the given value to determine its visibility and 'onChange'+event handler.+-}+popupV+  :: (WidgetModel s, WidgetEvent e)+  => Bool+  -> (Bool -> e)+  -> WidgetNode s e+  -> WidgetNode s e+popupV value handler content = popupV_ value handler def content++{-|+Creates a popup using the given value to determine its visibility and 'onChange'+event handler. Accepts config.+-}+popupV_+  :: (WidgetModel s, WidgetEvent e)+  => Bool+  -> (Bool -> e)+  -> [PopupCfg s e]+  -> WidgetNode s e+  -> WidgetNode s e+popupV_ value handler configs content = newNode where+  newConfigs = onChange handler : configs+  newNode = popupD_ (WidgetValue value) newConfigs content++{-|+Creates a popup providing a 'WidgetData' instance to determine its visibility+and config.+-}+popupD_+  :: WidgetModel s+  => WidgetData s Bool+  -> [PopupCfg s e]+  -> WidgetNode s e+  -> WidgetNode s e+popupD_ wdata configs content = makeNode widget anchor content where+  config = mconcat configs+  state = PopupState def (-1)+  widget = makePopup wdata config state++  anchor = case _ppcAnchor config of+    Just node -> node+    Nothing -> spacer+      `styleBasic` [maxWidth 0.01, maxHeight 0.01]++makeNode :: Widget s e -> WidgetNode s e -> WidgetNode s e -> WidgetNode s e+makeNode widget anchor content = defaultWidgetNode "popup" widget+  & L.info . L.focusable .~ False+  & L.children .~ Seq.fromList [anchor, content]++anchorIdx :: Int+anchorIdx = 0++contentIdx :: Int+contentIdx = 1++makePopup+  :: forall s e . WidgetModel s+  => WidgetData s Bool+  -> PopupCfg s e+  -> PopupState+  -> Widget s e+makePopup field config state = widget where+  container = def {+    containerAddStyleReq = False,+    containerInitPost = initPost,+    containerMergePost = mergePost,+    containerHandleEvent = handleEvent,+    containerGetSizeReq = getSizeReq,+    containerResize = resize+  }+  baseWidget = createContainer state container+  widget = baseWidget {+    widgetRender = render+  }++  initPost wenv node newState result = newResult where+    newResult = checkPopup field config newState wenv result++  mergePost wenv node oldNode oldState newState result = newResult where+    newResult = checkPopup field config oldState wenv result++  handleEvent wenv node target evt = case evt of+    KeyAction mod code KeyPressed+      | isCloseable && isKeyEscape code -> Just closeResult++    ButtonAction point button BtnReleased clicks+      | isCloseable && not (insidePopup point) -> Just closeResult++    Click point button clicks+      | isCloseable && not (insidePopup point) -> Just closeResult++    {-+    This check is needed because the anchor is inside the overlay, and otherwise+    it would receive events when the popup is open.+    -}+    _+      | (isVisible && not isContentTarget) || matchMs -> Just ignoreResult+      | otherwise -> Nothing++    where+      path = node ^. L.info . L.path++      disableClose = _ppcDisableClose config == Just True+      matchMs = _ppsReleaseMs state == wenv ^. L.timestamp++      isVisible = widgetDataGet (wenv ^. L.model) field+      isContentTarget = isPathParent (path |> contentIdx) target+      isCloseable = isVisible && not disableClose++      content = Seq.index (node ^. L.children) contentIdx+      cviewport = content ^. L.info . L.viewport+      insidePopup point = pointInRect point cviewport++      closeResult = closePopup field config state wenv node+      ignoreResult = resultReqs node [IgnoreChildrenEvents]++  getSizeReq :: ContainerGetSizeReqHandler s e+  getSizeReq wenv node children = (newReqW, newReqH) where+    anchor = Seq.index children anchorIdx+    newReqW = anchor ^. L.info . L.sizeReqW+    newReqH = anchor ^. L.info . L.sizeReqH++  resize :: ContainerResizeHandler s e+  resize wenv node viewport children = resized where+    Size ww wh = wenv ^. L.windowSize+    Rect px py pw ph = viewport+    Point sx sy = subPoint (_ppsClickPos state) (wenv ^. L.offset)+    Point ox oy = fromMaybe def (_ppcOffset config)++    alignOuterH = _ppcAlignToOuterH config == Just True+    alignOuterV = _ppcAlignToOuterV config == Just True+    alignWin = _ppcAlignToWindow config == Just True+    alignH = _ppcAlignH config+    alignV = _ppcAlignV config+    openAtCursor = _ppcOpenAtCursor config == Just True++    content = Seq.index children contentIdx+    cw = sizeReqMaxBounded (content ^. L.info . L.sizeReqW)+    ch = sizeReqMaxBounded (content ^. L.info . L.sizeReqH)++    (alignL, alignR) = (alignH == Just ALeft, alignH == Just ARight)+    (alignT, alignB) = (alignV == Just ATop, alignV == Just ABottom)+    (alignC, alignM) = (alignH == Just ACenter, alignV == Just AMiddle)++    Rect ax ay aw ah+      | alignWin = Rect 0 0 ww wh+      | otherwise = viewport++    (atx, arx)+      | alignOuterH = (ax - cw + ox, ax + aw + ox)+      | otherwise = (ax + ox, ax + aw - cw + ox)+    (aty, aby)+      | alignOuterV = (ay - ch + oy, ay + ah + oy)+      | otherwise = (ay + oy, ay + ah - ch + oy)++    Point olx oty = calcWindowOffset wenv config (Rect atx aty cw ch)+    Point orx oby = calcWindowOffset wenv config (Rect arx aby cw ch)++    fits offset = abs offset < 0.01 || alignWin+    (fitL, fitR) = (fits olx, fits orx)+    (fitT, fitB) = (fits oty, fits oby)++    cx+      | openAtCursor = sx+      | alignC = ax + (aw - cw) / 2+      | alignL && (fitL || not fitR) || alignR && fitL && not fitR = atx - ox+      | alignR && (fitR || not fitL) || alignL && fitR && not fitL = arx - ox+      | otherwise = ax++    cy+      | openAtCursor = sy+      | alignM = ay + (ah - ch) / 2+      | alignT && (fitT || not fitB) || alignB && fitT && not fitB = aty - oy+      | alignB && (fitB || not fitT) || alignT && fitB && not fitT = aby - oy+      | otherwise = ay++    tmpArea = Rect (cx + ox) (cy + oy) cw ch+    winOffset = calcWindowOffset wenv config tmpArea+    carea = moveRect winOffset tmpArea++    assignedAreas = Seq.fromList [viewport, carea]+    resized = (resultNode node, assignedAreas)++  render wenv node renderer = do+    widgetRender (anchor ^. L.widget) awenv anchor renderer++    when isVisible $+      createOverlay renderer $+        drawInTranslation renderer scrollOffset $ do+          widgetRender (content ^. L.widget) cwenv content renderer+    where+      isVisible = widgetDataGet (wenv ^. L.model) field++      alignWin = _ppcAlignToWindow config == Just True+      scrollOffset+        | alignWin = def+        | otherwise = wenv ^. L.offset++      anchor = Seq.index (node ^. L.children) anchorIdx+      anchorVp = anchor ^. L.info . L.viewport+      content = Seq.index (node ^. L.children) contentIdx+      contentVp = content ^. L.info . L.viewport++      -- Hacky solution to avoid the anchor acting as if it were top-level.+      updateOverlay overlay+        | isVisible = Just (content ^. L.info . L.path)+        | otherwise = overlay+      -- Update viewports to avoid clipping/scissoring issues.+      awenv = updateWenvOffset container wenv node anchorVp+        & L.viewport .~ anchorVp+        & L.overlayPath %~ updateOverlay+      cwenv = updateWenvOffset container wenv node contentVp+        & L.viewport .~ contentVp++calcWindowOffset :: WidgetEnv s e -> PopupCfg s e -> Rect -> Point+calcWindowOffset wenv config viewport = Point offsetX offsetY where+  alignWin = _ppcAlignToWindow config == Just True++  Size winW winH = wenv ^. L.windowSize+  Rect cx cy cw ch+    | alignWin = viewport+    | otherwise = moveRect (wenv ^. L.offset) viewport++  offsetX+    | cx < 0 = -cx+    | cx + cw > winW = winW - cx - cw+    | otherwise = 0+  offsetY+    | cy < 0 = -cy+    | cy + ch > winH = winH - cy - ch+    | otherwise = 0++checkPopup+  :: WidgetModel s+  => WidgetData s Bool+  -> PopupCfg s e+  -> PopupState+  -> WidgetEnv s e+  -> WidgetResult s e+  -> WidgetResult s e+checkPopup field config state wenv result = newResult where+  node = result ^. L.node+  shouldDisplay = widgetDataGet (wenv ^. L.model) field+  isOverlay = isNodeInOverlay wenv node++  (newNode, newReqs)+    | shouldDisplay && not isOverlay = showPopup field config state wenv node+    | not shouldDisplay && isOverlay = hidePopup config node+    | otherwise = (node & L.widget .~ makePopup field config state, [])++  newResult = result+    & L.node . L.widget .~ newNode ^. L.widget+    & L.requests <>~ Seq.fromList newReqs++showPopup+  :: WidgetModel s+  => WidgetData s Bool+  -> PopupCfg s e+  -> PopupState+  -> WidgetEnv s e+  -> WidgetNode s e+  -> (WidgetNode s e, [WidgetRequest s e])+showPopup field config state wenv node = (newNode, newReqs) where+  widgetId = node ^. L.info . L.widgetId+  path = node ^. L.info . L.path+  mousePos = wenv ^. L.inputStatus . L.mousePos++  anchor = Seq.index (node ^. L.children) anchorIdx+  awidgetId = anchor ^. L.info . L.widgetId++  onChangeReqs = fmap ($ True) (_ppcOnChangeReq config)+  showReqs = [+      ResizeWidgets widgetId,+      SetOverlay widgetId path,+      MoveFocus (Just awidgetId) FocusFwd+    ]++  newState = state {+    _ppsClickPos = mousePos+  }+  newNode = node+    & L.widget .~ makePopup field config newState+  newReqs = mconcat [showReqs, onChangeReqs]++hidePopup+  :: PopupCfg s e -> WidgetNode s e -> (WidgetNode s e, [WidgetRequest s e])+hidePopup config node = (node, onChangeReqs <> hideReqs) where+  widgetId = node ^. L.info . L.widgetId++  content = Seq.index (node ^. L.children) contentIdx+  cwidgetId = content ^. L.info . L.widgetId++  onChangeReqs = fmap ($ False) (_ppcOnChangeReq config)+  hideReqs = [+      ResetOverlay widgetId,+      MoveFocus (Just cwidgetId) FocusBwd+    ]++closePopup+  :: WidgetModel s+  => WidgetData s Bool+  -> PopupCfg s e+  -> PopupState+  -> WidgetEnv s e+  -> WidgetNode s e+  -> WidgetResult s e+closePopup field config state wenv node = result where+  widgetId = node ^. L.info . L.widgetId+  toggleShow = widgetDataSet field False+  isOverlay = isNodeInOverlay wenv node++  content = Seq.index (node ^. L.children) contentIdx+  cwidgetId = content ^. L.info . L.widgetId++  onChangeReqs+    | isOverlay = fmap ($ False) (_ppcOnChangeReq config)+    | otherwise = []+  closeReqs = [+      IgnoreChildrenEvents,+      ResetOverlay widgetId,+      MoveFocus (Just cwidgetId) FocusBwd+    ]++  newState = state {+    _ppsReleaseMs = wenv ^. L.timestamp+  }+  newNode = node+    & L.widget .~ makePopup field config newState++  reqs = mconcat [closeReqs, toggleShow, onChangeReqs]+  result = resultReqs newNode reqs

@@ -18,6 +18,11 @@  customSelect = selectList userLens usernames makeRow @++Note: the content of the list will only be updated when the provided items+change, based on their 'Eq' instance. In case data external to the items is used+for building the row nodes, 'mergeRequired' may be needed to avoid stale+content. -} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-}@@ -54,7 +59,6 @@ import qualified Data.Map as Map import qualified Data.Sequence as Seq -import Monomer.Graphics.Lens import Monomer.Widgets.Container import Monomer.Widgets.Containers.Box import Monomer.Widgets.Containers.Scroll@@ -85,8 +89,11 @@   navigating away from the widget with tab key. - 'itemBasicStyle': style of an item in the list when not selected. - 'itemSelectedStyle': style of the selected item in the list.-- 'mergeRequired': whether merging children is required. Useful when select list-  is part of another widget such as dropdown.+- 'mergeRequired': whether merging children is required. Useful when the content+  displayed depends on external data, since changes to data outside the provided+  list cannot be detected. In general it is recommended to only depend on data+  contained in the list itself, making sure the 'Eq' instance of the item type+  is correct. -} data SelectListCfg s e a = SelectListCfg {   _slcSelectOnBlur :: Maybe Bool,@@ -518,10 +525,12 @@ updateResultStyle wenv config result oldState newState = newResult where   slIdx = _slIdx newState   hlIdx = _hlIdx newState-  tmpNode = result ^. L.node-  (newNode, reqs) = updateStyles wenv config oldState tmpNode slIdx hlIdx-  newResult = resultReqs newNode reqs+  WidgetResult prevNode prevReqs = result +  (newNode, reqs) = updateStyles wenv config oldState prevNode slIdx hlIdx+  newResult = resultNode newNode+    & L.requests .~ prevReqs <> Seq.fromList reqs+ makeItemsList   :: (WidgetModel s, WidgetEvent e, Eq a)   => WidgetEnv s e@@ -539,5 +548,6 @@     clickCfg = onClickReq $ SendMessage widgetId (SelectListClickItem idx)     itemCfg = [expandContent, clickCfg]     content = makeRow item-    newItem = box_ itemCfg (content & L.info . L.style .~ normalStyle)+      & L.info . L.style .~ normalStyle+    newItem = box_ itemCfg content   itemsList = vstack $ Seq.mapWithIndex makeItem items

@@ -149,6 +149,14 @@     result = resultNode newNode    handleEvent wenv node target evt = case evt of+    ButtonAction{} -> Just $ resultReqs newNode [RenderOnce] where+      newState = state {+        _ttsLastPos = Point (-1) (-1),+        _ttsLastPosTs = maxBound+      }+      newNode = node+        & L.widget .~ makeTooltip caption config newState+     Leave point -> Just $ resultReqs newNode [RenderOnce] where       newState = state {         _ttsLastPos = Point (-1) (-1),

@@ -41,6 +41,7 @@  import Control.Exception (AssertionFailed(..), throw) import Control.Lens ((&), (^.), (^?), (.~), (%~), _Just)+import Control.Monad (when) import Data.Default import Data.Maybe import Data.Sequence (Seq(..), (|>))@@ -600,9 +601,10 @@   -> Renderer   -> IO () renderWrapper single wenv node renderer =-  drawInScissor renderer useScissor viewport $-    drawStyledAction_ renderer drawDecorations viewport style $ \_ ->-      handler wenv node renderer+  when (isWidgetVisible wenv node) $+    drawInScissor renderer useScissor viewport $+      drawStyledAction_ renderer drawDecorations viewport style $ \_ ->+        handler wenv node renderer   where     handler = singleRender single     drawDecorations = singleDrawDecorations single

@@ -151,7 +151,7 @@  data LabelState = LabelState {   _lstCaption :: Text,-  _lstTextStyle :: Maybe TextStyle,+  _lstStyle :: StyleState,   _lstTextRect :: Rect,   _lstTextLines :: Seq TextLine,   _lstPrevResize :: (Millisecond, Bool)@@ -165,7 +165,7 @@ label_ :: Text -> [LabelCfg s e] -> WidgetNode s e label_ caption configs = defaultWidgetNode "label" widget where   config = mconcat configs-  state = LabelState caption Nothing def Seq.Empty (0, False)+  state = LabelState caption def def Seq.Empty (0, False)   widget = makeLabel config state  -- | Creates a label using the 'Show' instance of the type.@@ -210,7 +210,7 @@   init wenv node = resultNode newNode where     style = labelCurrentStyle wenv node     newState = state {-      _lstTextStyle = style ^. L.text+      _lstStyle = style     }     newNode = node       & L.widget .~ makeLabel config newState@@ -218,10 +218,15 @@   merge wenv newNode oldNode oldState = result where     widgetId = newNode ^. L.info . L.widgetId     style = labelCurrentStyle wenv newNode-    newTextStyle = style ^. L.text+    prevStyle = _lstStyle oldState      captionChanged = _lstCaption oldState /= caption-    styleChanged = _lstTextStyle oldState /= newTextStyle+    styleChanged = prevStyle ^. L.text /= style ^. L.text+      || prevStyle ^. L.padding /= style ^. L.padding+      || prevStyle ^. L.border /= style ^. L.border+      || prevStyle ^. L.sizeReqH /= style ^. L.sizeReqH+      || prevStyle ^. L.sizeReqW /= style ^. L.sizeReqW+     changeReq = captionChanged || styleChanged     -- This is used in resize to know if glyphs have to be recalculated     newRect@@ -229,8 +234,8 @@       | otherwise = _lstTextRect oldState     newState = oldState {       _lstCaption = caption,-      _lstTextRect = newRect,-      _lstTextStyle = newTextStyle+      _lstStyle = style,+      _lstTextRect = newRect     }      reqs = [ ResizeWidgets widgetId | changeReq ]@@ -271,7 +276,6 @@     widgetId = newNode ^. L.info . L.widgetId     style = labelCurrentStyle wenv node     crect = fromMaybe def (removeOuterBounds style viewport)-    newTextStyle = style ^. L.text      Rect px py pw ph = textRect     Rect _ _ cw ch = crect@@ -282,18 +286,13 @@       = fitTextToSize fontMgr style overflow mode trim maxLines size caption     newTextLines = alignTextLines style alignRect fittedLines -    newGlyphsReq = pw /= cw || ph /= ch || textStyle /= newTextStyle-    newLines-      | not newGlyphsReq = textLines-      | otherwise = newTextLines-     (prevTs, prevStep) = prevResize     needsSndResize = mode == MultiLine && (prevTs /= ts || not prevStep)      newState = state {-      _lstTextStyle = newTextStyle,+      _lstStyle = style,       _lstTextRect = crect,-      _lstTextLines = newLines,+      _lstTextLines = newTextLines,       _lstPrevResize = (ts, needsSndResize && prevTs == ts)     }     newNode = node

@@ -15,6 +15,7 @@   isNodeInfoFocused,   isNodeParentOfFocused,   parentPath,+  isPathParent,   nextTargetStep,   isFocusCandidate,   isTargetReached,@@ -56,6 +57,11 @@ parentPath :: WidgetNode s e -> Path parentPath node = Seq.take (Seq.length path - 1) path where   path = node ^. L.info . L.path++-- | Returns whether the first path is parent of the second path.+isPathParent :: Path -> Path -> Bool+isPathParent path childPath = path == basePath where+  basePath = Seq.take (Seq.length path) childPath  -- | Returns the index of the child matching the next step implied by target. nextTargetStep :: WidgetNode s e -> Path -> Maybe PathStep

@@ -70,11 +70,12 @@ clicked with the main button and has the pointer inside its viewport. -} isNodeInfoActive :: Bool -> WidgetEnv s e -> WidgetNodeInfo -> Bool-isNodeInfoActive includeChildren wenv info = validPos && pressed where+isNodeInfoActive checkChildren wenv info = validPos && pressed && topLevel where   viewport = info ^. L.viewport   mousePos = wenv ^. L.inputStatus . L.mousePos   validPos = pointInRect mousePos viewport-  pressed = isNodeInfoPressed includeChildren wenv info+  pressed = isNodeInfoPressed checkChildren wenv info+  topLevel = isNodeInfoTopLevel wenv info  {-| Checks if the node is pressed, optionally including children. A pressed node was

@@ -14,7 +14,7 @@  import Control.Concurrent (newMVar) import Control.Concurrent.STM.TChan (newTChanIO)-import Control.Lens ((&), (^.), (.~), (.=))+import Control.Lens ((&), (^.), (.~), (.=), (+~)) import Control.Monad.State import Data.Default import Data.Maybe@@ -134,12 +134,14 @@   setStrokeWidth = \width -> return (),   setStrokeLinearGradient = \p1 p2 c1 c2 -> return (),   setStrokeRadialGradient = \p1 a1 a2 c1 c2 -> return (),+  setStrokeBoxGradient = \a r f c1 c2 -> return (),   setStrokeImagePattern = \n1 p1 s1 w1 h1 -> return (),   -- Fill   fill = return (),   setFillColor = \color -> return (),   setFillLinearGradient = \p1 p2 c1 c2 -> return (),   setFillRadialGradient = \p1 a1 a2 c1 c2 -> return (),+  setFillBoxGradient = \a r f c1 c2 -> return (),   setFillImagePattern = \n1 p1 s1 w1 h1 -> return (),   -- Drawing   moveTo = \point -> return (),@@ -326,10 +328,20 @@   -> WidgetNode s e   -> (HandlerStep s e, MonomerCtx s e) nodeHandleEvents wenv init evts node = result where+  result = nodeHandleEventsSteps wenv init [evts] node++nodeHandleEventsSteps+  :: (Eq s)+  => WidgetEnv s e+  -> InitWidget+  -> [[SystemEvent]]+  -> WidgetNode s e+  -> (HandlerStep s e, MonomerCtx s e)+nodeHandleEventsSteps wenv init eventSteps node = result where   steps = case init of-    WInit -> tail $ nodeHandleEvents_ wenv init [evts] node-    WInitKeepFirst -> nodeHandleEvents_ wenv WInit [evts] node-    _ -> nodeHandleEvents_ wenv init [evts] node+    WInit -> tail $ nodeHandleEvents_ wenv init eventSteps node+    WInitKeepFirst -> nodeHandleEvents_ wenv WInit eventSteps node+    _ -> nodeHandleEvents_ wenv init eventSteps node   result = foldl1 stepper steps   stepper step1 step2 = result where     ((_, _, reqs1), _) = step1@@ -381,7 +393,10 @@       & L.info . L.path .~ rootPath       & L.info . L.widgetId .~ WidgetId (wenv ^. L.timestamp) rootPath     runStep (wenv, root, accum) evts = do-      step <- handleSystemEvents wenv root evts+      let newWenv = wenv+            & L.timestamp +~ 1++      step <- handleSystemEvents newWenv root evts       ctx <- get       let (wenv2, root2, reqs2) = step 

@@ -16,8 +16,7 @@  module Monomer.Widgets.CompositeSpec (spec) where -import Control.Lens (-  (&), (^.), (^?), (^?!), (^..), (.~), (%~), _Just, ix, folded, traverse, dropping)+import Control.Lens hiding ((|>), deep) import Control.Lens.TH (abbreviatedFields, makeLensesWith) import Data.Default import Data.Foldable (toList)@@ -63,6 +62,7 @@   = ChildBtnClicked   | ChildMessage String   | ChildResize Rect+  | ChildDispose   deriving (Eq, Show)  data DeepEvt@@ -201,12 +201,10 @@  handleEventOnDispose :: Spec handleEventOnDispose = describe "handleEventOnDispose" $ do-  it "should generate an init event" $ do-    let val = case evts [] ^?! L.requests . ix 1 of-          SendMessage wid msg -> cast msg-          _ -> Nothing--    val `shouldBe` Just OnDispose+  it "should generate a dispose event" $ do+    evts ^? L.requests . ix 0 `shouldBe` Just RenderOnce+    evts ^? L.requests . ix 1 `shouldBe` Just (RaiseEvent ChildClicked)+    evts ^? L.requests . ix 2 `shouldBe` Just (SetClipboard ClipboardEmpty)    where     wenv = mockWenv def@@ -217,12 +215,12 @@       -> MainEvt       -> [EventResponse MainModel MainEvt MainModel MainEvt]     handleEvent wenv node model evt = case evt of-      OnInit{} -> [Report evt]+      OnDispose{} -> [ Request RenderOnce, Report ChildClicked ]       _ -> []     buildUI wenv model = vstack []     cmpNode = nodeInit wenv-      $ composite_ "main" id buildUI handleEvent [onDispose OnDispose]-    evts es = widgetDispose (cmpNode ^. L.widget) wenv cmpNode+      $ composite_ "main" id buildUI handleEvent [onDispose OnDispose, onDisposeReq (SetClipboard ClipboardEmpty)]+    evts = widgetDispose (cmpNode ^. L.widget) wenv cmpNode  handleEventOnChange :: Spec handleEventOnChange = describe "handleEventOnChange" $ do

@@ -0,0 +1,65 @@+{-|+Module      : Monomer.Widgets.Containers.BoxShadowSpec+Copyright   : (c) 2022 Gareth Smith, Francisco Vallarino+License     : BSD-3-Clause (see the LICENSE file)+Maintainer  : fjvallarino@gmail.com+Stability   : experimental+Portability : non-portable++Unit tests for BoxShadow widget.+-}++module Monomer.Widgets.Containers.BoxShadowSpec (spec) where++import Control.Lens ((^.))+import Test.Hspec++import qualified Data.Sequence as Seq++import Monomer.Core+import Monomer.Core.Combinators+import Monomer.TestUtil+import Monomer.Widgets.Containers.BoxShadow+import Monomer.Widgets.Singles.Label++import qualified Monomer.Lens as L++spec :: Spec+spec = describe "BoxShadow" $ do+  getSizeReq+  resize++getSizeReq :: Spec+getSizeReq = describe "getSizeReq" $ do+  it "should return child width plus radius on each side" $ do+    sizeW `shouldBe` fixedSize (6 + 7 * 2)++  it "should return child height plus radius on each side" $ do+    sizeH `shouldBe` fixedSize (9 + 7 * 2)++  where+    wenv = mockWenvEvtUnit ()+    boxShadowNode = boxShadow_ [radius 7] $+      label "test" `styleBasic` [sizeReqW (fixedSize 6), sizeReqH (fixedSize 9)]+    (sizeW, sizeH) = nodeGetSizeReq wenv boxShadowNode++resize :: Spec+resize = describe "resize" $ do+  it "shadow in middle-center should put child in middle-center" $ do+    childVp [radius 8, alignMiddle, alignCenter] `shouldBe` Rect 8 8 624 464++  it "shadow in top-left should put child in bottom-right" $ do+    childVp [radius 8, alignTop, alignLeft] `shouldBe` Rect 10 10 624 464++  it "shadow in bottom-right should put child in top-left" $ do+    childVp [radius 8, alignBottom, alignRight] `shouldBe` Rect 6 6 624 464++  it "shadow in default location should put child in top-center" $ do+    childVp [radius 8] `shouldBe` Rect 8 6 624 464++  where+    wenv = mockWenvEvtUnit ()+    childVp config = childWidget ^. L.info . L.viewport where+      node = boxShadow_ config (label "test")+      initedNode = nodeInit wenv node+      childWidget = Seq.index (initedNode ^. L.children) 0

@@ -43,7 +43,7 @@     events (Point 500 280) `shouldBe` Seq.singleton AcceptClick    it "should generate a Cancel event when clicking the Cancel button" $-    events (Point 600 280) `shouldBe` Seq.singleton CancelClick+    events (Point 590 280) `shouldBe` Seq.singleton CancelClick    it "should not generate a close event when clicking the dialog" $     events (Point 300 200) `shouldBe` Seq.empty

@@ -0,0 +1,200 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++module Monomer.Widgets.Containers.PopupSpec where++import Control.Lens+import Control.Lens.TH (abbreviatedFields, makeLensesWith)+import Data.Sequence (Seq)+import Data.Text (Text)+import Test.Hspec++import qualified Data.Sequence as Seq++import Monomer.Core+import Monomer.Core.Combinators+import Monomer.Core.Themes.SampleThemes+import Monomer.Event+import Monomer.TestEventUtil+import Monomer.TestUtil+import Monomer.Widgets.Composite+import Monomer.Widgets.Containers.Grid+import Monomer.Widgets.Containers.Popup+import Monomer.Widgets.Containers.Stack+import Monomer.Widgets.Singles.Label+import Monomer.Widgets.Singles.Spacer+import Monomer.Widgets.Singles.ToggleButton++import qualified Monomer.Lens as L++newtype TestEvent+  = OnPopupChange Bool+  deriving (Eq, Show)++data TestModel = TestModel {+  _tmOpen :: Bool,+  _tmPopupToggle :: Bool+} deriving (Eq, Show)++makeLensesWith abbreviatedFields ''TestModel++spec :: Spec+spec = describe "Popup" $ do+  handleEvent+  handleEventAnchor++handleEvent :: Spec+handleEvent = describe "handleEvent" $ do+  describe "basics" $ do+    it "should update the model when the popup is open" $ do+      let evts = [evtClick (Point 50 10)]+      modelBase evts ^. open `shouldBe` True+      eventsBase evts `shouldBe` Seq.fromList [OnPopupChange True]++    it "should close the popup when clicked outside the content" $ do+      let evts = [evtClick (Point 50 10), evtClick (Point 50 100)]+      modelBase evts `shouldBe` TestModel False False+      eventsBase evts `shouldBe` Seq.fromList [OnPopupChange True, OnPopupChange False]++    it "should close the popup when Esc is pressed" $ do+      let evts = [evtClick (Point 50 10), evtK keyEscape]+      modelBase evts `shouldBe` TestModel False False+      eventsBase evts `shouldBe` Seq.fromList [OnPopupChange True, OnPopupChange False]++    it "should close the popup when clicked in the content's toggle button" $ do+      let evts = [evtClick (Point 50 10), evtClick (Point 40 60)]+      modelBase evts `shouldBe` TestModel False False+      eventsBase evts `shouldBe` Seq.fromList [OnPopupChange True, OnPopupChange False]++    it "should not close the popup when clicked in the content's test toggle button" $ do+      let evts = [evtClick (Point 50 10), evtClick (Point 80 60)]+      modelBase evts `shouldBe` TestModel True True+      eventsBase evts `shouldBe` Seq.fromList [OnPopupChange True]++  describe "popupDisabledClose" $ do+    it "should not close the popup when clicked outside the content if popupDisableClose is set" $ do+      let evts = [evtClick (Point 50 10), evtClick (Point 50 100)]+      modelDisable evts `shouldBe` TestModel True False+      eventsDisable evts `shouldBe` Seq.fromList [OnPopupChange True]++    it "should not close the popup when Esc is pressed if popupDisableClose is set" $ do+      let evts = [evtClick (Point 50 10), evtK keyEscape]+      modelDisable evts `shouldBe` TestModel True False+      eventsDisable evts `shouldBe` Seq.fromList [OnPopupChange True]++  describe "alignment" $ do+    it "should toggle the popupToggle button when aligned center to the widget" $ do+      let cfgs = [popupOffset (Point 10 10), alignCenter]+      let evts = [evtClick (Point 50 10), evtClick (Point 340 60)]+      modelAlign cfgs evts `shouldBe` TestModel True True+      eventsAlign cfgs evts `shouldBe` Seq.fromList [OnPopupChange True]++    it "should toggle the popupToggle button when aligned top-center to the window" $ do+      let cfgs = [popupAlignToWindow, popupOffset (Point 10 10), alignTop, alignCenter]+      let evts = [evtClick (Point 50 10), evtClick (Point 340 10)]+      modelAlign cfgs evts `shouldBe` TestModel True True+      eventsAlign cfgs evts `shouldBe` Seq.fromList [OnPopupChange True]++    it "should toggle the popupToggle button when aligned bottom-right to the window" $ do+      let cfgs = [popupAlignToWindow, popupOffset (Point 10 10), alignBottom, alignRight]+      let evts = [evtClick (Point 50 10), evtClick (Point 620 460)]+      modelAlign cfgs evts `shouldBe` TestModel True True+      eventsAlign cfgs evts `shouldBe` Seq.fromList [OnPopupChange True]++  where+    wenv = mockWenv (TestModel False False)+      & L.theme .~ darkTheme+    handleEvent :: EventHandler TestModel TestEvent TestModel TestEvent+    handleEvent wenv node model evt = [ Report evt ]+    buildUI cfgs wenv model = vstack [+        toggleButton "Open" open,+        popup_ open cfgs $ hgrid [+            toggleButton "Close" open,+            toggleButton "Test" popupToggle+          ],+        filler+      ]+    popupNode cfgs = composite "popupNode" id (buildUI cfgs) handleEvent++    modelBase es = localHandleEventModel wenv es (popupNode [])+    modelDisable es = localHandleEventModel wenv es (popupNode [popupDisableClose])+    modelAlign cfgs es = localHandleEventModel wenv es (popupNode (popupDisableClose : cfgs))++    eventsBase es = localHandleEventEvts wenv es (popupNode [onChange OnPopupChange])+    eventsDisable es = localHandleEventEvts wenv es (popupNode [onChange OnPopupChange, popupDisableClose])+    eventsAlign cfgs es = localHandleEventEvts wenv es (popupNode (onChange OnPopupChange : popupDisableClose : cfgs))++handleEventAnchor :: Spec+handleEventAnchor = describe "handleEventAnchor" $ do+  describe "alignment outer border" $ do+    it "should toggle the popupToggle button when aligned above the widget" $ do+      let cfgs = [popupAlignToOuterV, alignTop, alignRight]+      let evts = [evtClick (Point 50 110), evtClick (Point 600 80)]++      modelAlign cfgs [] evts `shouldBe` TestModel True True+      eventsAlign cfgs [] evts `shouldBe` Seq.fromList [OnPopupChange True]++    it "should toggle the popupToggle button when aligned below the widget" $ do+      let cfgs = [popupAlignToOuterV, alignBottom, alignRight]+      let evts = [evtClick (Point 50 110), evtClick (Point 600 140)]++      modelAlign cfgs [] evts `shouldBe` TestModel True True+      eventsAlign cfgs [] evts `shouldBe` Seq.fromList [OnPopupChange True]++    it "should close the popup when aligned above the widget and the toggle button is clicked" $ do+      let cfgs = [popupAlignToOuterV, alignTop, alignRight]+      let evts = [evtClick (Point 50 110), evtClick (Point 520 80)]++      modelAlign cfgs [] evts `shouldBe` TestModel False False+      eventsAlign cfgs [] evts `shouldBe` Seq.fromList [OnPopupChange True, OnPopupChange False]++    it "should close the popup when aligned below the widget and the toggle button is clicked" $ do+      let cfgs = [popupAlignToOuterV, alignBottom, alignRight]+      let evts = [evtClick (Point 50 110), evtClick (Point 520 140)]++      modelAlign cfgs [] evts `shouldBe` TestModel False False+      eventsAlign cfgs [] evts `shouldBe` Seq.fromList [OnPopupChange True, OnPopupChange False]++    describe "Re align outer" $ do+      it "should re-locate the anchor below the widget, because it did not fit above" $ do+        let cfgs = [popupAlignToOuterV, alignTop, alignRight]+        let styles = [height 200]+        let evts = [evtClick (Point 50 110), evtClick (Point 600 140)]++        modelAlign cfgs styles evts `shouldBe` TestModel True True+        eventsAlign cfgs styles evts `shouldBe` Seq.fromList [OnPopupChange True]++  where+    wenv = mockWenv (TestModel False False)+      & L.theme .~ darkTheme+    handleEvent :: EventHandler TestModel TestEvent TestModel TestEvent+    handleEvent wenv node model evt = [ Report evt ]+    buildUI cfgs styles wenv model = vstack [+        spacer `styleBasic` [height 100],+        popup_ open cfgs $ hgrid [+            toggleButton "Close" open,+            toggleButton "Test" popupToggle+          ] `styleBasic` styles,+        filler+      ]+    popupNode cfgs styles = composite "popupNode" id (buildUI cfgs styles) handleEvent+    baseCfgs = [popupAnchor (toggleButton "Open" open), onChange OnPopupChange]++    modelAlign cfgs styles es = localHandleEventModel wenv es $+      popupNode (popupDisableClose : (baseCfgs ++ cfgs)) styles+    eventsAlign cfgs styles es = localHandleEventEvts wenv es $+      popupNode (popupDisableClose : (baseCfgs ++ cfgs)) styles++localHandleEventModel :: (Eq s, WidgetModel s) => WidgetEnv s e -> [SystemEvent] -> WidgetNode s e -> s+localHandleEventModel wenv steps node = _weModel wenv2 where+  stepEvts = (: []) <$> steps+  (wenv2, _, _) = fst $ nodeHandleEventsSteps wenv WInit stepEvts node++localHandleEventEvts :: Eq s => WidgetEnv s e -> [SystemEvent] -> WidgetNode s e -> Seq e+localHandleEventEvts wenv steps node = eventsFromReqs reqs where+  stepEvts = (: []) <$> steps+  (_, _, reqs) = fst $ nodeHandleEventsSteps wenv WInit stepEvts node

@@ -22,11 +22,13 @@  import qualified Monomer.Widgets.Containers.AlertSpec as AlertSpec import qualified Monomer.Widgets.Containers.BoxSpec as BoxSpec+import qualified Monomer.Widgets.Containers.BoxShadowSpec as BoxShadowSpec import qualified Monomer.Widgets.Containers.ConfirmSpec as ConfirmSpec import qualified Monomer.Widgets.Containers.DragDropSpec as DragDropSpec import qualified Monomer.Widgets.Containers.DropdownSpec as DropdownSpec import qualified Monomer.Widgets.Containers.GridSpec as GridSpec import qualified Monomer.Widgets.Containers.KeystrokeSpec as KeystrokeSpec+import qualified Monomer.Widgets.Containers.PopupSpec as PopupSpec import qualified Monomer.Widgets.Containers.ScrollSpec as ScrollSpec import qualified Monomer.Widgets.Containers.SelectListSpec as SelectListSpec import qualified Monomer.Widgets.Containers.SplitSpec as SplitSpec@@ -114,11 +116,13 @@ containers = describe "Containers" $ do   AlertSpec.spec   BoxSpec.spec+  BoxShadowSpec.spec   ConfirmSpec.spec   DragDropSpec.spec   DropdownSpec.spec   GridSpec.spec   KeystrokeSpec.spec+  PopupSpec.spec   ScrollSpec.spec   SelectListSpec.spec   SplitSpec.spec