Add color popup widget

examples/tutorial/Tutorial02_Styling.hs

@@ -68,7 +68,8 @@ buildUI wenv model = widgetTree where
       titleText "Font color",
       hstack [
         labeledCheckbox "Show color picker " showPicker,
-        filler
+        filler,
+        colorPopup fontColor
       ] `styleBasic` [paddingT 10, paddingB 5],
       colorPicker fontColor
         `nodeVisible` (model ^. showPicker)

monomer.cabal

@@ -111,6 +111,7 @@ library
       Monomer.Widgets.Singles.Button
       Monomer.Widgets.Singles.Checkbox
       Monomer.Widgets.Singles.ColorPicker
+      Monomer.Widgets.Singles.ColorPopup
       Monomer.Widgets.Singles.DateField
       Monomer.Widgets.Singles.Dial
       Monomer.Widgets.Singles.ExternalLink

src/Monomer/Core/ThemeTypes.hs

@@ -58,6 +58,7 @@ data ThemeState = ThemeState {
   _thsShadowAlignV :: AlignV,
   _thsBtnStyle :: StyleState,
   _thsBtnMainStyle :: StyleState,
+  _thsColorPopupStyle :: StyleState,
   _thsCheckboxStyle :: StyleState,
   _thsCheckboxWidth :: Double,
   _thsDateFieldStyle :: StyleState,
@@ -118,6 +119,7 @@ instance Default ThemeState where
     _thsShadowAlignV = ABottom,
     _thsBtnStyle = def,
     _thsBtnMainStyle = def,
+    _thsColorPopupStyle = def,
     _thsCheckboxStyle = def,
     _thsCheckboxWidth = 20,
     _thsDateFieldStyle = def,
@@ -178,6 +180,7 @@ instance Semigroup ThemeState where
     _thsShadowAlignV = _thsShadowAlignV t2,
     _thsBtnStyle = _thsBtnStyle t1 <> _thsBtnStyle t2,
     _thsBtnMainStyle = _thsBtnMainStyle t1 <> _thsBtnMainStyle t2,
+    _thsColorPopupStyle = _thsColorPopupStyle t1 <> _thsColorPopupStyle t2,
     _thsCheckboxStyle = _thsCheckboxStyle t1 <> _thsCheckboxStyle t2,
     _thsCheckboxWidth = _thsCheckboxWidth t2,
     _thsDateFieldStyle = _thsDateFieldStyle t1 <> _thsDateFieldStyle t2,

src/Monomer/Core/Themes/BaseTheme.hs

@@ -140,6 +140,11 @@ titleFont = def
   & L.fontSize ?~ FontSize 20
   & L.fontSpaceV ?~ FontSpace 2
 
+colorPopupStyle :: BaseThemeColors -> StyleState
+colorPopupStyle themeMod = popupStyle where
+  sectionBg = sectionColor themeMod
+  popupStyle = mconcat [width 400, padding 10, bgColor sectionBg, radius 4]
+
 dialogMsgBodyFont :: BaseThemeColors -> TextStyle
 dialogMsgBodyFont themeMod = fontStyle where
   fontStyle = normalFont
@@ -226,6 +231,7 @@ baseBasic themeMod = def
   & L.shadowColor .~ shadow themeMod
   & L.btnStyle .~ btnStyle themeMod
   & L.btnMainStyle .~ btnMainStyle themeMod
+  & L.colorPopupStyle .~ colorPopupStyle themeMod
   & L.checkboxWidth .~ 20
   & L.checkboxStyle . L.fgColor ?~ inputFgBasic themeMod
   & L.checkboxStyle . L.hlColor ?~ inputHlBasic themeMod

src/Monomer/Widgets.hs

@@ -36,6 +36,7 @@ module Monomer.Widgets (
   module Monomer.Widgets.Singles.Button,
   module Monomer.Widgets.Singles.Checkbox,
   module Monomer.Widgets.Singles.ColorPicker,
+  module Monomer.Widgets.Singles.ColorPopup,
   module Monomer.Widgets.Singles.DateField,
   module Monomer.Widgets.Singles.Dial,
   module Monomer.Widgets.Singles.ExternalLink,
@@ -83,6 +84,7 @@ import Monomer.Widgets.Containers.ZStack
 import Monomer.Widgets.Singles.Button
 import Monomer.Widgets.Singles.Checkbox
 import Monomer.Widgets.Singles.ColorPicker
+import Monomer.Widgets.Singles.ColorPopup
 import Monomer.Widgets.Singles.DateField
 import Monomer.Widgets.Singles.Dial
 import Monomer.Widgets.Singles.ExternalLink

src/Monomer/Widgets/Singles/ColorPicker.hs

@@ -8,9 +8,18 @@ Portability : non-portable
 
 Color picker, displayed inside its parent container as a regular widget.
 
+Shows sliders for the color components.
+
 @
 colorPicker colorLens
 @
+
+Optionally shows a slider for the alpha channel.
+
+@
+colorPicker_ colorLens [showAlpha]
+@
+
 -}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}

src/Monomer/Widgets/Singles/ColorPopup.hs

@@ -0,0 +1,247 @@
+{-|
+Module      : Monomer.Widgets.Singles.ColorPopup
+Copyright   : (c) 2018 Francisco Vallarino
+License     : BSD-3-Clause (see the LICENSE file)
+Maintainer  : fjvallarino@gmail.com
+Stability   : experimental
+Portability : non-portable
+
+Color popup, displayed inside its parent container as a colored square. When
+clicked, it opens a color picker overlay.
+
+Shows sliders for the color components.
+
+@
+colorPopup colorLens
+@
+
+Optionally shows a slider for the alpha channel.
+
+@
+colorPopup_ colorLens [showAlpha]
+@
+-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE Strict #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Monomer.Widgets.Singles.ColorPopup (
+  -- * Constructors
+  colorPopup,
+  colorPopup_,
+  colorPopupV,
+  colorPopupV_
+) where
+
+import Control.Applicative ((<|>))
+import Control.Lens ((&), (^.), (.~), (?~), ALens', abbreviatedFields, makeLensesWith, non)
+import Data.Default
+import Data.Text (Text)
+
+import Monomer.Core.Combinators
+import Monomer.Graphics.Types
+
+import Monomer.Widgets.Composite
+import Monomer.Widgets.Containers.Popup
+import Monomer.Widgets.Containers.Stack
+import Monomer.Widgets.Singles.ColorPicker
+import Monomer.Widgets.Singles.ToggleButton
+
+import qualified Monomer.Lens as L
+
+type ColorPopupEnv = WidgetEnv ColorPopupModel ColorPopupEvt
+type ColorPopupNode = WidgetNode ColorPopupModel ColorPopupEvt
+
+{-|
+Configuration options for colorPicker:
+
+- 'showAlpha': whether to allow modifying the alpha channel or not.
+- 'onFocus': event to raise when focus is received.
+- 'onFocusReq': 'WidgetRequest' to generate when focus is received.
+- 'onBlur': event to raise when focus is lost.
+- 'onBlurReq': 'WidgetRequest' to generate when focus is lost.
+- 'onChange': event to raise when any of the values changes.
+- 'onChangeReq': 'WidgetRequest' to generate when any of the values changes.
+-}
+data ColorPopupCfg s e = ColorPopupCfg {
+  _cpcColorPickerCfg :: ColorPickerCfg ColorPopupModel ColorPopupEvt,
+  _cpcOnFocusReq :: [Path -> WidgetRequest s e],
+  _cpcOnBlurReq :: [Path -> WidgetRequest s e],
+  _cpcOnChangeReq :: [Color -> WidgetRequest s e]
+}
+
+instance Default (ColorPopupCfg s e) where
+  def = ColorPopupCfg {
+    _cpcColorPickerCfg = def,
+    _cpcOnFocusReq = [],
+    _cpcOnBlurReq = [],
+    _cpcOnChangeReq = []
+  }
+
+instance Semigroup (ColorPopupCfg s e) where
+  (<>) a1 a2 = def {
+    _cpcColorPickerCfg = _cpcColorPickerCfg a1 <> _cpcColorPickerCfg a2,
+    _cpcOnFocusReq = _cpcOnFocusReq a1 <> _cpcOnFocusReq a2,
+    _cpcOnBlurReq = _cpcOnBlurReq a1 <> _cpcOnBlurReq a2,
+    _cpcOnChangeReq = _cpcOnChangeReq a1 <> _cpcOnChangeReq a2
+  }
+
+instance Monoid (ColorPopupCfg s e) where
+  mempty = def
+
+instance CmbShowAlpha (ColorPopupCfg s e) where
+  showAlpha_ show = def {
+    _cpcColorPickerCfg = showAlpha_ show
+  }
+
+instance WidgetEvent e => CmbOnFocus (ColorPopupCfg s e) e Path where
+  onFocus fn = def {
+    _cpcOnFocusReq = [RaiseEvent . fn]
+  }
+
+instance CmbOnFocusReq (ColorPopupCfg s e) s e Path where
+  onFocusReq req = def {
+    _cpcOnFocusReq = [req]
+  }
+
+instance WidgetEvent e => CmbOnBlur (ColorPopupCfg s e) e Path where
+  onBlur fn = def {
+    _cpcOnBlurReq = [RaiseEvent . fn]
+  }
+
+instance CmbOnBlurReq (ColorPopupCfg s e) s e Path where
+  onBlurReq req = def {
+    _cpcOnBlurReq = [req]
+  }
+
+instance WidgetEvent e => CmbOnChange (ColorPopupCfg s e) Color e where
+  onChange fn = def {
+    _cpcOnChangeReq = [RaiseEvent . fn]
+  }
+
+instance CmbOnChangeReq (ColorPopupCfg s e) s e Color where
+  onChangeReq req = def {
+    _cpcOnChangeReq = [req]
+  }
+
+data ColorPopupModel = ColorPopupModel {
+  _cpmPopupShowColor :: Bool,
+  _cpmPopupColor :: Color
+} deriving (Eq, Show)
+
+data ColorPopupEvt
+  = ColorChanged Color
+  | PopupFocus Path
+  | PopupBlur Path
+
+instance Default ColorPopupModel where
+  def = ColorPopupModel {
+    _cpmPopupShowColor = False,
+    _cpmPopupColor = def
+  }
+
+makeLensesWith abbreviatedFields 'ColorPopupModel
+
+-- | Creates a colorPopup using the given lens.
+colorPopup :: (WidgetModel s, WidgetEvent e) => ALens' s Color -> WidgetNode s e
+colorPopup field = colorPopup_ field def
+
+-- | Creates a colorPopup using the given lens. Accepts config.
+colorPopup_
+  :: (WidgetModel s, WidgetEvent e)
+  => ALens' s Color
+  -> [ColorPopupCfg s e]
+  -> WidgetNode s e
+colorPopup_ field configs = colorPopupD_ (WidgetLens field) configs
+
+-- | Creates a colorPopup using the given value and 'onChange' event handler.
+colorPopupV
+  :: (WidgetModel s, WidgetEvent e)
+  => Color
+  -> (Color -> e)
+  -> WidgetNode s e
+colorPopupV value handler = colorPopupV_ value handler def
+
+-- | Creates a colorPopup using the given value and 'onChange' event handler.
+--   Accepts config.
+colorPopupV_
+  :: (WidgetModel s, WidgetEvent e)
+  => Color
+  -> (Color -> e)
+  -> [ColorPopupCfg s e]
+  -> WidgetNode s e
+colorPopupV_ value handler configs = newNode where
+  newConfigs = onChange handler : configs
+  newNode = colorPopupD_ (WidgetValue value) newConfigs
+
+-- | Creates a colorPopup providing a 'WidgetData' instance and config.
+colorPopupD_
+  :: (WidgetModel s, WidgetEvent e)
+  => WidgetData s Color
+  -> [ColorPopupCfg s e]
+  -> WidgetNode s e
+colorPopupD_ wdata configs = newNode where
+  config = mconcat configs
+  model = WidgetValue def
+  uiBuilder = buildUI config
+  eventHandler = handleEvent wdata config
+  mergeModel wenv parentModel oldModel newModel = oldModel
+    & popupColor .~ widgetDataGet parentModel wdata
+  compCfg = [compositeMergeModel mergeModel]
+  newNode = compositeD_ "colorPopup" model uiBuilder eventHandler compCfg
+
+buildUI
+  :: WidgetModel sp
+  => ColorPopupCfg sp ep
+  -> ColorPopupEnv
+  -> ColorPopupModel
+  -> ColorPopupNode
+buildUI config wenv model = widgetTree where
+  containerStyle = collectTheme wenv L.colorPopupStyle
+  selColor = model ^. popupColor
+
+  toggleStyle = mergeBasicStyle $ def
+    & L.basic . non def . L.sizeReqW ?~ width 30
+    & L.basic . non def . L.sizeReqH ?~ height 30
+    & L.basic . non def . L.bgColor ?~ selColor
+    & L.basic . non def . L.border ?~ border 1 selColor
+
+  toggleCfg = [toggleButtonOffStyle toggleStyle]
+  toggle = toggleButton_ "" popupShowColor toggleCfg
+    & L.info . L.style .~ toggleStyle
+
+  pickerCfg = _cpcColorPickerCfg config
+  picker = colorPicker_ popupColor [pickerCfg, onChange ColorChanged]
+    & L.info . L.style .~ containerStyle
+
+  popupCfg = [popupAlignToOuterV, popupOffset (Point 0 10), alignBottom, alignLeft]
+  widgetTree = popup_ popupShowColor (popupAnchor toggle : popupCfg) picker
+
+handleEvent
+  :: WidgetModel sp
+  => WidgetData sp Color
+  -> ColorPopupCfg sp ep
+  -> ColorPopupEnv
+  -> ColorPopupNode
+  -> ColorPopupModel
+  -> ColorPopupEvt
+  -> [EventResponse ColorPopupModel ColorPopupEvt sp ep]
+handleEvent wdata cfg wenv node model evt = case evt of
+  PopupFocus prev
+    | not (isNodeParentOfPath node prev) -> reportFocus prev
+  PopupBlur next
+    | not (isNodeParentOfPath node next) -> reportBlur next
+  ColorChanged col -> reportChange col
+  _ -> []
+  where
+    parentColor pm = widgetDataGet pm wdata
+    parentChanged pm = parentColor pm /= model ^. popupColor
+
+    report reqs = RequestParent <$> reqs
+    reportFocus prev = report (($ prev) <$> _cpcOnFocusReq cfg)
+    reportBlur next = report (($ next) <$> _cpcOnBlurReq cfg)
+    reportChange col = report (wdataReqs ++ changeReqs) where
+      wdataReqs = widgetDataSet wdata col
+      changeReqs =  ($ col) <$> _cpcOnChangeReq cfg