diff --git a/examples/tutorial/Tutorial02_Styling.hs b/examples/tutorial/Tutorial02_Styling.hs index 55408d13..999a9449 100644 --- a/examples/tutorial/Tutorial02_Styling.hs +++ b/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) diff --git a/monomer.cabal b/monomer.cabal index 0b8928c1..21ab5bd5 100644 --- a/monomer.cabal +++ b/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 diff --git a/src/Monomer/Core/ThemeTypes.hs b/src/Monomer/Core/ThemeTypes.hs index e132659b..48884c36 100644 --- a/src/Monomer/Core/ThemeTypes.hs +++ b/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, diff --git a/src/Monomer/Core/Themes/BaseTheme.hs b/src/Monomer/Core/Themes/BaseTheme.hs index 3ce64296..4f057556 100644 --- a/src/Monomer/Core/Themes/BaseTheme.hs +++ b/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 diff --git a/src/Monomer/Widgets.hs b/src/Monomer/Widgets.hs index 2d96079e..7a717f49 100644 --- a/src/Monomer/Widgets.hs +++ b/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 diff --git a/src/Monomer/Widgets/Singles/ColorPicker.hs b/src/Monomer/Widgets/Singles/ColorPicker.hs index 53c9b8d6..7d077bbd 100644 --- a/src/Monomer/Widgets/Singles/ColorPicker.hs +++ b/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 #-} diff --git a/src/Monomer/Widgets/Singles/ColorPopup.hs b/src/Monomer/Widgets/Singles/ColorPopup.hs new file mode 100644 index 00000000..1b651040 --- /dev/null +++ b/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