-
Notifications
You must be signed in to change notification settings - Fork 41
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
* Add initial version of ColorPopup * Add theme entry for colorPopup container * Add minimal Haddock to new widget
- Loading branch information
1 parent
2c52bc8
commit 0364e86
Showing
7 changed files
with
270 additions
and
1 deletion.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -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 |