mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-09-11 12:05:35 +03:00
Add color popup widget (#247)
* Add initial version of ColorPopup * Add theme entry for colorPopup container * Add minimal Haddock to new widget
This commit is contained in:
parent
2c52bc891a
commit
0364e86b06
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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,
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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 #-}
|
||||
|
247
src/Monomer/Widgets/Singles/ColorPopup.hs
Normal file
247
src/Monomer/Widgets/Singles/ColorPopup.hs
Normal file
@ -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
|
Loading…
Reference in New Issue
Block a user