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",
|
titleText "Font color",
|
||||||
hstack [
|
hstack [
|
||||||
labeledCheckbox "Show color picker " showPicker,
|
labeledCheckbox "Show color picker " showPicker,
|
||||||
filler
|
filler,
|
||||||
|
colorPopup fontColor
|
||||||
] `styleBasic` [paddingT 10, paddingB 5],
|
] `styleBasic` [paddingT 10, paddingB 5],
|
||||||
colorPicker fontColor
|
colorPicker fontColor
|
||||||
`nodeVisible` (model ^. showPicker)
|
`nodeVisible` (model ^. showPicker)
|
||||||
|
@ -111,6 +111,7 @@ library
|
|||||||
Monomer.Widgets.Singles.Button
|
Monomer.Widgets.Singles.Button
|
||||||
Monomer.Widgets.Singles.Checkbox
|
Monomer.Widgets.Singles.Checkbox
|
||||||
Monomer.Widgets.Singles.ColorPicker
|
Monomer.Widgets.Singles.ColorPicker
|
||||||
|
Monomer.Widgets.Singles.ColorPopup
|
||||||
Monomer.Widgets.Singles.DateField
|
Monomer.Widgets.Singles.DateField
|
||||||
Monomer.Widgets.Singles.Dial
|
Monomer.Widgets.Singles.Dial
|
||||||
Monomer.Widgets.Singles.ExternalLink
|
Monomer.Widgets.Singles.ExternalLink
|
||||||
|
@ -58,6 +58,7 @@ data ThemeState = ThemeState {
|
|||||||
_thsShadowAlignV :: AlignV,
|
_thsShadowAlignV :: AlignV,
|
||||||
_thsBtnStyle :: StyleState,
|
_thsBtnStyle :: StyleState,
|
||||||
_thsBtnMainStyle :: StyleState,
|
_thsBtnMainStyle :: StyleState,
|
||||||
|
_thsColorPopupStyle :: StyleState,
|
||||||
_thsCheckboxStyle :: StyleState,
|
_thsCheckboxStyle :: StyleState,
|
||||||
_thsCheckboxWidth :: Double,
|
_thsCheckboxWidth :: Double,
|
||||||
_thsDateFieldStyle :: StyleState,
|
_thsDateFieldStyle :: StyleState,
|
||||||
@ -118,6 +119,7 @@ instance Default ThemeState where
|
|||||||
_thsShadowAlignV = ABottom,
|
_thsShadowAlignV = ABottom,
|
||||||
_thsBtnStyle = def,
|
_thsBtnStyle = def,
|
||||||
_thsBtnMainStyle = def,
|
_thsBtnMainStyle = def,
|
||||||
|
_thsColorPopupStyle = def,
|
||||||
_thsCheckboxStyle = def,
|
_thsCheckboxStyle = def,
|
||||||
_thsCheckboxWidth = 20,
|
_thsCheckboxWidth = 20,
|
||||||
_thsDateFieldStyle = def,
|
_thsDateFieldStyle = def,
|
||||||
@ -178,6 +180,7 @@ instance Semigroup ThemeState where
|
|||||||
_thsShadowAlignV = _thsShadowAlignV t2,
|
_thsShadowAlignV = _thsShadowAlignV t2,
|
||||||
_thsBtnStyle = _thsBtnStyle t1 <> _thsBtnStyle t2,
|
_thsBtnStyle = _thsBtnStyle t1 <> _thsBtnStyle t2,
|
||||||
_thsBtnMainStyle = _thsBtnMainStyle t1 <> _thsBtnMainStyle t2,
|
_thsBtnMainStyle = _thsBtnMainStyle t1 <> _thsBtnMainStyle t2,
|
||||||
|
_thsColorPopupStyle = _thsColorPopupStyle t1 <> _thsColorPopupStyle t2,
|
||||||
_thsCheckboxStyle = _thsCheckboxStyle t1 <> _thsCheckboxStyle t2,
|
_thsCheckboxStyle = _thsCheckboxStyle t1 <> _thsCheckboxStyle t2,
|
||||||
_thsCheckboxWidth = _thsCheckboxWidth t2,
|
_thsCheckboxWidth = _thsCheckboxWidth t2,
|
||||||
_thsDateFieldStyle = _thsDateFieldStyle t1 <> _thsDateFieldStyle t2,
|
_thsDateFieldStyle = _thsDateFieldStyle t1 <> _thsDateFieldStyle t2,
|
||||||
|
@ -140,6 +140,11 @@ titleFont = def
|
|||||||
& L.fontSize ?~ FontSize 20
|
& L.fontSize ?~ FontSize 20
|
||||||
& L.fontSpaceV ?~ FontSpace 2
|
& 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 :: BaseThemeColors -> TextStyle
|
||||||
dialogMsgBodyFont themeMod = fontStyle where
|
dialogMsgBodyFont themeMod = fontStyle where
|
||||||
fontStyle = normalFont
|
fontStyle = normalFont
|
||||||
@ -226,6 +231,7 @@ baseBasic themeMod = def
|
|||||||
& L.shadowColor .~ shadow themeMod
|
& L.shadowColor .~ shadow themeMod
|
||||||
& L.btnStyle .~ btnStyle themeMod
|
& L.btnStyle .~ btnStyle themeMod
|
||||||
& L.btnMainStyle .~ btnMainStyle themeMod
|
& L.btnMainStyle .~ btnMainStyle themeMod
|
||||||
|
& L.colorPopupStyle .~ colorPopupStyle themeMod
|
||||||
& L.checkboxWidth .~ 20
|
& L.checkboxWidth .~ 20
|
||||||
& L.checkboxStyle . L.fgColor ?~ inputFgBasic themeMod
|
& L.checkboxStyle . L.fgColor ?~ inputFgBasic themeMod
|
||||||
& L.checkboxStyle . L.hlColor ?~ inputHlBasic themeMod
|
& L.checkboxStyle . L.hlColor ?~ inputHlBasic themeMod
|
||||||
|
@ -36,6 +36,7 @@ module Monomer.Widgets (
|
|||||||
module Monomer.Widgets.Singles.Button,
|
module Monomer.Widgets.Singles.Button,
|
||||||
module Monomer.Widgets.Singles.Checkbox,
|
module Monomer.Widgets.Singles.Checkbox,
|
||||||
module Monomer.Widgets.Singles.ColorPicker,
|
module Monomer.Widgets.Singles.ColorPicker,
|
||||||
|
module Monomer.Widgets.Singles.ColorPopup,
|
||||||
module Monomer.Widgets.Singles.DateField,
|
module Monomer.Widgets.Singles.DateField,
|
||||||
module Monomer.Widgets.Singles.Dial,
|
module Monomer.Widgets.Singles.Dial,
|
||||||
module Monomer.Widgets.Singles.ExternalLink,
|
module Monomer.Widgets.Singles.ExternalLink,
|
||||||
@ -83,6 +84,7 @@ import Monomer.Widgets.Containers.ZStack
|
|||||||
import Monomer.Widgets.Singles.Button
|
import Monomer.Widgets.Singles.Button
|
||||||
import Monomer.Widgets.Singles.Checkbox
|
import Monomer.Widgets.Singles.Checkbox
|
||||||
import Monomer.Widgets.Singles.ColorPicker
|
import Monomer.Widgets.Singles.ColorPicker
|
||||||
|
import Monomer.Widgets.Singles.ColorPopup
|
||||||
import Monomer.Widgets.Singles.DateField
|
import Monomer.Widgets.Singles.DateField
|
||||||
import Monomer.Widgets.Singles.Dial
|
import Monomer.Widgets.Singles.Dial
|
||||||
import Monomer.Widgets.Singles.ExternalLink
|
import Monomer.Widgets.Singles.ExternalLink
|
||||||
|
@ -8,9 +8,18 @@ Portability : non-portable
|
|||||||
|
|
||||||
Color picker, displayed inside its parent container as a regular widget.
|
Color picker, displayed inside its parent container as a regular widget.
|
||||||
|
|
||||||
|
Shows sliders for the color components.
|
||||||
|
|
||||||
@
|
@
|
||||||
colorPicker colorLens
|
colorPicker colorLens
|
||||||
@
|
@
|
||||||
|
|
||||||
|
Optionally shows a slider for the alpha channel.
|
||||||
|
|
||||||
|
@
|
||||||
|
colorPicker_ colorLens [showAlpha]
|
||||||
|
@
|
||||||
|
|
||||||
-}
|
-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# 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