Have both alert and confirm receive a widget as its content. Add alertMsg and confirmMsg to handle text

app/Main.hs

@@ -132,7 +132,7 @@ handleAppEvent wenv node model evt = case evt of
   _ -> []
 
 buildUI :: WidgetEnv App AppEvent -> App -> WidgetNode App AppEvent
-buildUI wenv model = traceShow "Creating UI" widgetDial where
+buildUI wenv model = traceShow "Creating UI" widgetTree where
   widgetScroll = vscroll (hgrid [
       vstack [
         scroll (image "assets/images/pecans.jpg") `style` [height 200],
@@ -381,8 +381,8 @@ buildUI wenv model = traceShow "Creating UI" widgetDial where
   longMessage word = "Are you sure?\n\n\n\n" <> T.replicate 100 (word <> " ")
   widgetTree = zstack [
       widgetTreeFull,
-      alert_ (longMessage "Alert") CloseAlert [titleCaption "Hey!"] `visible` model ^. showAlert,
-      confirm_ (longMessage "Confirm") AcceptConfirm CancelConfirm [titleCaption "Hey!"] `visible` model ^. showConfirm
+      alertMsg_ (longMessage "Alert") CloseAlert [titleCaption "Hey!"] `visible` model ^. showAlert,
+      confirmMsg_ (longMessage "Confirm") AcceptConfirm CancelConfirm [titleCaption "Hey!"] `visible` model ^. showConfirm
     ]
   widgetTreeFull = vstack [
       hstack [

examples/books/Main.hs

@@ -26,7 +26,10 @@ buildUI wenv model = widgetTree where
     baseUrl = "http://covers.openlibrary.org/b/id/<id>-<size>.jpg"
     imgUrl i = T.replace "<size>" size $ T.replace "<id>" (showt i) baseUrl
     coverImg i = image_ (imgUrl i) [fitHeight]
-  bookRow b = box_ [expandContent, onClick (BooksShowDetails b)] $ hstack [
+  bookRow b = box_ [expandContent, onClick (BooksShowDetails b)]
+    (bookRowContent b)
+    `hover` [bgColor gray, cursorIcon CursorHand]
+  bookRowContent b = hstack [
       vstack [
         hstack [
           label_ "Title: " [resizeFactor 0] `style` [textFont "Bold"],
@@ -34,7 +37,7 @@ buildUI wenv model = widgetTree where
         ],
         hstack [
           label_ "Authors: " [resizeFactor 0] `style` [textFont "Bold"],
-          label (T.intercalate ", " (b ^. authors))
+          label_ (T.intercalate ", " (b ^. authors)) [resizeFactor 1]
         ]
       ],
       filler,
@@ -45,35 +48,29 @@ buildUI wenv model = widgetTree where
         ]
       ] `style` [width 100],
       bookImage (b ^. cover) "S" `style` [width 50]
-    ] `style` [height 50, padding 5] `hover` [bgColor gray, cursorIcon CursorHand]
+    ] `style` [height 50, padding 5]
   bookDetail b = hstack [
       vstack [
         hstack [
-          label_ "Title: " [resizeFactor 0] `style` [textFont "Bold"],
-          label (b ^. title)
+          label_ "Title: " [resizeFactor 0] `style` [textFont "Bold", textTop],
+          label_ (b ^. title) [textMultiLine] `style` [width 300]
         ],
         hstack [
-          label_ "Authors: " [resizeFactor 0] `style` [textFont "Bold"],
-          label (T.intercalate ", " (b ^. authors))
+          label_ "Authors: " [resizeFactor 0] `style` [textFont "Bold", textTop],
+          label_ (T.intercalate ", " (b ^. authors)) [textMultiLine] `style` [width 300]
         ],
         hstack [
           label_ "Year: " [resizeFactor 0] `style` [textFont "Bold"],
           label $ maybe "" showt (b ^. year)
         ]
-      ] `style` [width 300],
+      ],
       filler,
       bookImage (b ^. cover) "M" `style` [width 200]
     ]
-  bookOverlay = keystroke [("Esc", BooksCloseDetails)] overlay where
-    content = vstack [
-        maybe spacer bookDetail (model ^. selected),
-        spacer,
-        hstack [button "Close" BooksCloseDetails, filler]
-      ] `style` [bgColor gray, border 2 dimGray, padding 5]
-    overlay = box_ [onClick BooksCloseDetails] content
-      `style` [bgColor (darkGray & L.a .~ 0.8)]
-  searchOverlay = box (label "Searching" `style` [textSize 20, textColor black])
-    `style` [bgColor (darkGray & L.a .~ 0.8)]
+  bookOverlay = alert content BooksCloseDetails where
+    content = maybe spacer bookDetail (model ^. selected)
+  searchOverlay = box content `style` [bgColor (darkGray & L.a .~ 0.8)] where
+    content = label "Searching" `style` [textSize 20, textColor black]
   searchForm = keystroke [("Enter", BooksSearch)] $ vstack [
       hstack [
         label "Query: ",

src/Monomer/Core/ThemeTypes.hs

@@ -49,8 +49,8 @@ data ThemeState = ThemeState {
   _thsDialogFrameStyle :: StyleState,
   _thsDialogTitleStyle :: StyleState,
   _thsDialogCloseIconStyle :: StyleState,
-  _thsDialogBodyStyle :: StyleState,
   _thsDialogButtonsStyle :: StyleState,
+  _thsDialogMsgBodyStyle :: StyleState,
   _thsDropdownMaxHeight :: Double,
   _thsDropdownStyle :: StyleState,
   _thsDropdownListStyle :: StyleState,
@@ -91,8 +91,8 @@ instance Default ThemeState where
     _thsDialogFrameStyle = def,
     _thsDialogTitleStyle = def,
     _thsDialogCloseIconStyle = def,
-    _thsDialogBodyStyle = def,
     _thsDialogButtonsStyle = def,
+    _thsDialogMsgBodyStyle = def,
     _thsDropdownMaxHeight = def,
     _thsDropdownStyle = def,
     _thsDropdownListStyle = def,
@@ -133,7 +133,7 @@ instance Semigroup ThemeState where
     _thsDialogFrameStyle = _thsDialogFrameStyle t1 <> _thsDialogFrameStyle t2,
     _thsDialogTitleStyle = _thsDialogTitleStyle t1 <> _thsDialogTitleStyle t2,
     _thsDialogCloseIconStyle = _thsDialogCloseIconStyle t1 <> _thsDialogCloseIconStyle t2,
-    _thsDialogBodyStyle = _thsDialogBodyStyle t1 <> _thsDialogBodyStyle t2,
+    _thsDialogMsgBodyStyle = _thsDialogMsgBodyStyle t1 <> _thsDialogMsgBodyStyle t2,
     _thsDialogButtonsStyle = _thsDialogButtonsStyle t1 <> _thsDialogButtonsStyle t2,
     _thsDropdownMaxHeight = _thsDropdownMaxHeight t2,
     _thsDropdownStyle = _thsDropdownStyle t1 <> _thsDropdownStyle t2,

src/Monomer/Core/Themes/BaseTheme.hs

@@ -165,11 +165,11 @@ baseBasic themeMod = def
   & L.dialogCloseIconStyle . L.fgColor ?~ iconFg themeMod
   & L.dialogCloseIconStyle . L.sizeReqW ?~ width 16
   & L.dialogCloseIconStyle . L.sizeReqH ?~ width 16
-  & L.dialogBodyStyle . L.text
-    ?~ (normalFont & L.fontColor ?~ dialogText themeMod)
-  & L.dialogBodyStyle . L.sizeReqW ?~ minWidth 400
-  & L.dialogBodyStyle . L.sizeReqH ?~ minHeight 250
   & L.dialogButtonsStyle . L.padding ?~ paddingT 5
+  & L.dialogMsgBodyStyle . L.text
+    ?~ (normalFont & L.fontColor ?~ dialogText themeMod)
+  & L.dialogMsgBodyStyle . L.sizeReqW ?~ minWidth 400
+  & L.dialogMsgBodyStyle . L.sizeReqH ?~ minHeight 250
   & L.dropdownStyle .~ inputStyle themeMod
   & L.dropdownStyle . L.fgColor ?~ iconFg themeMod
   & L.dropdownStyle . L.padding ?~ paddingH 5

src/Monomer/Widgets/Alert.hs

@@ -1,6 +1,8 @@
 module Monomer.Widgets.Alert (
   alert,
-  alert_
+  alert_,
+  alertMsg,
+  alertMsg_
 ) where
 
 import Control.Applicative ((<|>))
@@ -53,31 +55,51 @@ instance CmbCloseCaption AlertCfg where
   }
 
 alert
+  :: (WidgetModel sp, WidgetEvent ep)
+  => WidgetNode () ep
+  -> ep
+  -> WidgetNode sp ep
+alert dialogBody evt = alert_ dialogBody evt def
+
+alert_
+  :: (WidgetModel sp, WidgetEvent ep)
+  => WidgetNode () ep
+  -> ep
+  -> [AlertCfg]
+  -> WidgetNode sp ep
+alert_ dialogBody evt configs = newNode where
+  config = mconcat configs
+  createUI = buildUI (const dialogBody) evt config
+  newNode = compositeExt "alert" () createUI handleEvent
+
+alertMsg
   :: (WidgetModel sp, WidgetEvent ep)
   => Text
   -> ep
   -> WidgetNode sp ep
-alert message evt = alert_ message evt def
+alertMsg message evt = alertMsg_ message evt def
 
-alert_
+alertMsg_
   :: (WidgetModel sp, WidgetEvent ep)
   => Text
   -> ep
   -> [AlertCfg]
   -> WidgetNode sp ep
-alert_ message evt configs = newNode where
+alertMsg_ message evt configs = newNode where
   config = mconcat configs
-  createUI = buildUI message evt config
+  dialogBody wenv = label_ message [textMultiLine]
+    & L.info . L.style .~ themeDialogMsgBody wenv
+  createUI = buildUI dialogBody evt config
   newNode = compositeExt "alert" () createUI handleEvent
 
 buildUI
-  :: Text
+  :: (WidgetEnv s ep -> WidgetNode s ep)
   -> ep
   -> AlertCfg
   -> WidgetEnv s ep
   -> s
   -> WidgetNode s ep
-buildUI message cancelEvt config wenv model = mainTree where
+buildUI dialogBody cancelEvt config wenv model = mainTree where
   title = fromMaybe "" (_alcTitle config)
   close = fromMaybe "Close" (_alcClose config)
   emptyOverlayColor = themeEmptyOverlayColor wenv
@@ -88,8 +110,7 @@ buildUI message cancelEvt config wenv model = mainTree where
         label title & L.info . L.style .~ themeDialogTitle wenv,
         box_ [onClick cancelEvt] closeIcon
       ],
-      label_ message [textMultiLine]
-        & L.info . L.style .~ themeDialogBody wenv,
+      dialogBody wenv,
       box_ [alignLeft] dismissButton
         & L.info . L.style .~ themeDialogButtons wenv
     ] & L.info . L.style .~ themeDialogFrame wenv

src/Monomer/Widgets/Box.hs

@@ -147,9 +147,8 @@ makeBox config = widget where
     + length (_boxOnClickEmptyReq config)
 
   getActiveStyle = activeStyle_ activeStyleConfig where
-    activeStyleConfig = def {
-      _ascIsActive = isNodeTreeActive
-    }
+    activeStyleConfig = def
+      & L.isActive .~ isNodeTreeActive
 
   handleEvent wenv target evt node = case evt of
     Click point btn -> result where

src/Monomer/Widgets/Confirm.hs

@@ -1,8 +1,11 @@
 {-# LANGUAGE RankNTypes #-}
 
 module Monomer.Widgets.Confirm (
+  ConfirmEvt(..),
   confirm,
-  confirm_
+  confirm_,
+  confirmMsg,
+  confirmMsg_
 ) where
 
 import Control.Applicative ((<|>))
@@ -64,42 +67,66 @@ instance CmbCancelCaption ConfirmCfg where
   }
 
 data ConfirmEvt e
-  = ParentEvt e
-  | VisibleChanged
+  = ConfirmParentEvt e
+  | ConfirmVisibleChanged
   deriving (Eq, Show)
 
 confirm
+  :: (WidgetModel sp, WidgetEvent ep)
+  => WidgetNode () (ConfirmEvt ep)
+  -> ep
+  -> ep
+  -> WidgetNode sp ep
+confirm dialogBody acceptEvt cancelEvt = newNode where
+  newNode = confirm_ dialogBody acceptEvt cancelEvt def
+
+confirm_
+  :: (WidgetModel sp, WidgetEvent ep)
+  => WidgetNode () (ConfirmEvt ep)
+  -> ep
+  -> ep
+  -> [ConfirmCfg]
+  -> WidgetNode sp ep
+confirm_ dialogBody acceptEvt cancelEvt configs = newNode where
+  config = mconcat configs
+  createUI = buildUI (const dialogBody) acceptEvt cancelEvt config
+  evts = [onVisibleChange ConfirmVisibleChanged]
+  newNode = compositeExt_ "confirm" () createUI handleEvent evts
+
+confirmMsg
   :: (WidgetModel sp, WidgetEvent ep)
   => Text
   -> ep
   -> ep
   -> WidgetNode sp ep
-confirm message acceptEvt cancelEvt = confirm_ message acceptEvt cancelEvt def
+confirmMsg msg acceptEvt cancelEvt = confirmMsg_ msg acceptEvt cancelEvt def
 
-confirm_
+confirmMsg_
   :: (WidgetModel sp, WidgetEvent ep)
   => Text
   -> ep
   -> ep
   -> [ConfirmCfg]
   -> WidgetNode sp ep
-confirm_ message acceptEvt cancelEvt configs = newNode where
+confirmMsg_ message acceptEvt cancelEvt configs = newNode where
   config = mconcat configs
-  createUI = buildUI message acceptEvt cancelEvt config
-  evts = [onVisibleChange VisibleChanged]
+  dialogBody wenv = label_ message [textMultiLine]
+    & L.info . L.style .~ themeDialogMsgBody wenv
+  createUI = buildUI dialogBody acceptEvt cancelEvt config
+  evts = [onVisibleChange ConfirmVisibleChanged]
   newNode = compositeExt_ "confirm" () createUI handleEvent evts
 
 buildUI
-  :: Text
+  :: (WidgetEnv s (ConfirmEvt ep) -> WidgetNode s (ConfirmEvt ep))
   -> ep
   -> ep
   -> ConfirmCfg
   -> WidgetEnv s (ConfirmEvt ep)
   -> s
   -> WidgetNode s (ConfirmEvt ep)
-buildUI message pAcceptEvt pCancelEvt config wenv model = mainTree where
-  acceptEvt = ParentEvt pAcceptEvt
-  cancelEvt = ParentEvt pCancelEvt
+buildUI dialogBody pAcceptEvt pCancelEvt config wenv model = mainTree where
+  acceptEvt = ConfirmParentEvt pAcceptEvt
+  cancelEvt = ConfirmParentEvt pCancelEvt
   title = fromMaybe "" (_cfcTitle config)
   accept = fromMaybe "Accept" (_cfcAccept config)
   cancel = fromMaybe "Cancel" (_cfcCancel config)
@@ -113,8 +140,7 @@ buildUI message pAcceptEvt pCancelEvt config wenv model = mainTree where
         label title & L.info . L.style .~ themeDialogTitle wenv,
         box_ [onClick cancelEvt] closeIcon
       ],
-      label_ message [textMultiLine]
-        & L.info . L.style .~ themeDialogBody wenv,
+      dialogBody wenv,
       box_ [alignLeft] buttons
         & L.info . L.style <>~ themeDialogButtons wenv
     ] & L.info . L.style .~ themeDialogFrame wenv
@@ -129,8 +155,8 @@ handleEvent
   -> ConfirmEvt ep
   -> [EventResponse s (ConfirmEvt ep) ep]
 handleEvent wenv node model evt = case evt of
-  ParentEvt pevt -> [Report pevt]
-  VisibleChanged -> catMaybes [acceptPath | nodeVisible]
+  ConfirmParentEvt pevt -> [Report pevt]
+  ConfirmVisibleChanged -> catMaybes [acceptPath | nodeVisible]
   where
     acceptPath = Request . SetFocus <$> globalKeyPath wenv "acceptBtn"
     ownsFocus = isNodeParentOfFocused wenv node

src/Monomer/Widgets/Stack.hs

@@ -157,6 +157,7 @@ resizeChild horizontal contentArea flexCoeff extraCoeff offset child = result wh
     | horizontal = hRect
     | otherwise = vRect
 
+mainReqSelector :: Bool -> WidgetNode s e -> SizeReq
 mainReqSelector isHorizontal
   | isHorizontal = _wniSizeReqW . _wnInfo
   | otherwise = _wniSizeReqH . _wnInfo

src/Monomer/Widgets/Util/Theme.hs

@@ -31,8 +31,8 @@ themeDialogTitle wenv = collectTheme wenv L.dialogTitleStyle
 themeDialogCloseIcon :: WidgetEnv s e -> Style
 themeDialogCloseIcon wenv = collectTheme wenv L.dialogCloseIconStyle
 
-themeDialogBody :: WidgetEnv s e -> Style
-themeDialogBody wenv = collectTheme wenv L.dialogBodyStyle
+themeDialogMsgBody :: WidgetEnv s e -> Style
+themeDialogMsgBody wenv = collectTheme wenv L.dialogMsgBodyStyle
 
 themeDialogButtons :: WidgetEnv s e -> Style
 themeDialogButtons wenv = collectTheme wenv L.dialogButtonsStyle

tasks.md

@@ -513,6 +513,7 @@
       - Check why border was not shown in some cases (may be ok)
       - Improve cursor handling (if children do not have cursor settings they should not change it)
       - Re-import Color Table and keep it in original order
+      - Maybe internally handle focus as widgetId? (use findWidgetByPath)
 
 - Pending
   - Add header in all files, indicating license and documenting what the module does
@@ -525,12 +526,15 @@ Next
   - Add examples
     - Fetch content from url, show rows of data with embedded images
       - Does it make sense to have Alert/Dialog accept a widget?
-      - Maybe internally handle focus as widgetId? (use findWidgetByPath)
+      - Think about using stack resize logic in box
+        - Maybe whats needed are custom min/max options for box content
       - Add cursor icon unit tests
     - Composite example
       - Validate nested structures update correctly when disabling/enabling parent
     - Something of generative art (OpenGL example)
   - Auto scroll affects dropdown when listView is displayed
+  - Maybe label resizeFactor should default to zero? What about button/others?
+  - Maybe do not resize Single if size did not change? First step towards resize improvements
   - Add underline and strikethrough
   - Add externalLink component
     - https://stackoverflow.com/questions/3037088/how-to-open-the-default-web-browser-in-windows-in-c/54334181

test/unit/Monomer/Widgets/AlertSpec.hs

@@ -35,5 +35,5 @@ handleEvent = describe "handleEvent" $ do
 
   where
     wenv = mockWenv () & L.theme .~ darkTheme
-    alertNode = alert "Alert!" CloseClick
+    alertNode = alertMsg "Alert!" CloseClick
     events p = nodeHandleEventEvts wenv [Click p LeftBtn] alertNode

test/unit/Monomer/Widgets/ConfirmSpec.hs

@@ -39,5 +39,5 @@ handleEvent = describe "handleEvent" $ do
 
   where
     wenv = mockWenv () & L.theme .~ darkTheme
-    confirmNode = confirm "Confirm!" AcceptClick CancelClick
+    confirmNode = confirmMsg "Confirm!" AcceptClick CancelClick
     events p = nodeHandleEventEvts wenv [Click p LeftBtn] confirmNode

test/unit/Monomer/Widgets/ZStackSpec.hs

@@ -164,7 +164,7 @@ handleEventFocusKeep = describe "handleEventFocusKeep" $
     handleEvent wenv _ model (BtnClick idx) = [Report (BtnClick idx), Model idx]
     buildUI wenv model = zstack [
         hstack [
-          confirm "Message" (BtnClick 3) (BtnClick 4)
+          confirmMsg "Message" (BtnClick 3) (BtnClick 4)
         ] `visible` (model <= 2),
         hstack [
           button "1" (BtnClick 1),