{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TemplateHaskell #-}
module Monomer.Widgets.Singles.ColorPopup (
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.BoxShadow
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 = WidgetEnv ColorPopupModel ColorPopupEvt
type = WidgetNode ColorPopupModel ColorPopupEvt
data s e = {
forall s e.
ColorPopupCfg s e -> ColorPickerCfg ColorPopupModel ColorPopupEvt
_cpcColorPickerCfg :: ColorPickerCfg ColorPopupModel ColorPopupEvt,
forall s e. ColorPopupCfg s e -> [Path -> WidgetRequest s e]
_cpcOnFocusReq :: [Path -> WidgetRequest s e],
forall s e. ColorPopupCfg s e -> [Path -> WidgetRequest s e]
_cpcOnBlurReq :: [Path -> WidgetRequest s e],
forall s e. ColorPopupCfg s e -> [Color -> WidgetRequest s e]
_cpcOnChangeReq :: [Color -> WidgetRequest s e]
}
instance Default (ColorPopupCfg s e) where
def :: ColorPopupCfg s e
def = ColorPopupCfg {
_cpcColorPickerCfg :: ColorPickerCfg ColorPopupModel ColorPopupEvt
_cpcColorPickerCfg = forall a. Default a => a
def,
_cpcOnFocusReq :: [Path -> WidgetRequest s e]
_cpcOnFocusReq = [],
_cpcOnBlurReq :: [Path -> WidgetRequest s e]
_cpcOnBlurReq = [],
_cpcOnChangeReq :: [Color -> WidgetRequest s e]
_cpcOnChangeReq = []
}
instance Semigroup (ColorPopupCfg s e) where
<> :: ColorPopupCfg s e -> ColorPopupCfg s e -> ColorPopupCfg s e
(<>) ColorPopupCfg s e
a1 ColorPopupCfg s e
a2 = forall a. Default a => a
def {
_cpcColorPickerCfg :: ColorPickerCfg ColorPopupModel ColorPopupEvt
_cpcColorPickerCfg = forall s e.
ColorPopupCfg s e -> ColorPickerCfg ColorPopupModel ColorPopupEvt
_cpcColorPickerCfg ColorPopupCfg s e
a1 forall a. Semigroup a => a -> a -> a
<> forall s e.
ColorPopupCfg s e -> ColorPickerCfg ColorPopupModel ColorPopupEvt
_cpcColorPickerCfg ColorPopupCfg s e
a2,
_cpcOnFocusReq :: [Path -> WidgetRequest s e]
_cpcOnFocusReq = forall s e. ColorPopupCfg s e -> [Path -> WidgetRequest s e]
_cpcOnFocusReq ColorPopupCfg s e
a1 forall a. Semigroup a => a -> a -> a
<> forall s e. ColorPopupCfg s e -> [Path -> WidgetRequest s e]
_cpcOnFocusReq ColorPopupCfg s e
a2,
_cpcOnBlurReq :: [Path -> WidgetRequest s e]
_cpcOnBlurReq = forall s e. ColorPopupCfg s e -> [Path -> WidgetRequest s e]
_cpcOnBlurReq ColorPopupCfg s e
a1 forall a. Semigroup a => a -> a -> a
<> forall s e. ColorPopupCfg s e -> [Path -> WidgetRequest s e]
_cpcOnBlurReq ColorPopupCfg s e
a2,
_cpcOnChangeReq :: [Color -> WidgetRequest s e]
_cpcOnChangeReq = forall s e. ColorPopupCfg s e -> [Color -> WidgetRequest s e]
_cpcOnChangeReq ColorPopupCfg s e
a1 forall a. Semigroup a => a -> a -> a
<> forall s e. ColorPopupCfg s e -> [Color -> WidgetRequest s e]
_cpcOnChangeReq ColorPopupCfg s e
a2
}
instance Monoid (ColorPopupCfg s e) where
mempty :: ColorPopupCfg s e
mempty = forall a. Default a => a
def
instance CmbShowAlpha (ColorPopupCfg s e) where
showAlpha_ :: Bool -> ColorPopupCfg s e
showAlpha_ Bool
show = forall a. Default a => a
def {
_cpcColorPickerCfg :: ColorPickerCfg ColorPopupModel ColorPopupEvt
_cpcColorPickerCfg = forall t. CmbShowAlpha t => Bool -> t
showAlpha_ Bool
show
}
instance WidgetEvent e => CmbOnFocus (ColorPopupCfg s e) e Path where
onFocus :: (Path -> e) -> ColorPopupCfg s e
onFocus Path -> e
fn = forall a. Default a => a
def {
_cpcOnFocusReq :: [Path -> WidgetRequest s e]
_cpcOnFocusReq = [forall s e. WidgetEvent e => e -> WidgetRequest s e
RaiseEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> e
fn]
}
instance CmbOnFocusReq (ColorPopupCfg s e) s e Path where
onFocusReq :: (Path -> WidgetRequest s e) -> ColorPopupCfg s e
onFocusReq Path -> WidgetRequest s e
req = forall a. Default a => a
def {
_cpcOnFocusReq :: [Path -> WidgetRequest s e]
_cpcOnFocusReq = [Path -> WidgetRequest s e
req]
}
instance WidgetEvent e => CmbOnBlur (ColorPopupCfg s e) e Path where
onBlur :: (Path -> e) -> ColorPopupCfg s e
onBlur Path -> e
fn = forall a. Default a => a
def {
_cpcOnBlurReq :: [Path -> WidgetRequest s e]
_cpcOnBlurReq = [forall s e. WidgetEvent e => e -> WidgetRequest s e
RaiseEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> e
fn]
}
instance CmbOnBlurReq (ColorPopupCfg s e) s e Path where
onBlurReq :: (Path -> WidgetRequest s e) -> ColorPopupCfg s e
onBlurReq Path -> WidgetRequest s e
req = forall a. Default a => a
def {
_cpcOnBlurReq :: [Path -> WidgetRequest s e]
_cpcOnBlurReq = [Path -> WidgetRequest s e
req]
}
instance WidgetEvent e => CmbOnChange (ColorPopupCfg s e) Color e where
onChange :: (Color -> e) -> ColorPopupCfg s e
onChange Color -> e
fn = forall a. Default a => a
def {
_cpcOnChangeReq :: [Color -> WidgetRequest s e]
_cpcOnChangeReq = [forall s e. WidgetEvent e => e -> WidgetRequest s e
RaiseEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> e
fn]
}
instance CmbOnChangeReq (ColorPopupCfg s e) s e Color where
onChangeReq :: (Color -> WidgetRequest s e) -> ColorPopupCfg s e
onChangeReq Color -> WidgetRequest s e
req = forall a. Default a => a
def {
_cpcOnChangeReq :: [Color -> WidgetRequest s e]
_cpcOnChangeReq = [Color -> WidgetRequest s e
req]
}
data = {
:: Bool,
:: Color
} deriving (ColorPopupModel -> ColorPopupModel -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ColorPopupModel -> ColorPopupModel -> Bool
$c/= :: ColorPopupModel -> ColorPopupModel -> Bool
== :: ColorPopupModel -> ColorPopupModel -> Bool
$c== :: ColorPopupModel -> ColorPopupModel -> Bool
Eq, Int -> ColorPopupModel -> ShowS
[ColorPopupModel] -> ShowS
ColorPopupModel -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ColorPopupModel] -> ShowS
$cshowList :: [ColorPopupModel] -> ShowS
show :: ColorPopupModel -> String
$cshow :: ColorPopupModel -> String
showsPrec :: Int -> ColorPopupModel -> ShowS
$cshowsPrec :: Int -> ColorPopupModel -> ShowS
Show)
data
= ColorChanged Color
| Path
| Path
instance Default ColorPopupModel where
def :: ColorPopupModel
def = ColorPopupModel {
_cpmPopupShowColor :: Bool
_cpmPopupShowColor = Bool
False,
_cpmPopupColor :: Color
_cpmPopupColor = forall a. Default a => a
def
}
colorPopup
:: (WidgetModel s, WidgetEvent e)
=> ALens' s Color
-> WidgetNode s e
ALens' s Color
field = forall s e.
(WidgetModel s, WidgetEvent e) =>
ALens' s Color -> [ColorPopupCfg s e] -> WidgetNode s e
colorPopup_ ALens' s Color
field forall a. Default a => a
def
colorPopup_
:: (WidgetModel s, WidgetEvent e)
=> ALens' s Color
-> [ColorPopupCfg s e]
-> WidgetNode s e
ALens' s Color
field [ColorPopupCfg s e]
configs = forall s e.
(WidgetModel s, WidgetEvent e) =>
WidgetData s Color -> [ColorPopupCfg s e] -> WidgetNode s e
colorPopupD_ (forall s a. ALens' s a -> WidgetData s a
WidgetLens ALens' s Color
field) [ColorPopupCfg s e]
configs
colorPopupV
:: (WidgetModel s, WidgetEvent e)
=> Color
-> (Color -> e)
-> WidgetNode s e
Color
value Color -> e
handler = forall s e.
(WidgetModel s, WidgetEvent e) =>
Color -> (Color -> e) -> [ColorPopupCfg s e] -> WidgetNode s e
colorPopupV_ Color
value Color -> e
handler forall a. Default a => a
def
colorPopupV_
:: (WidgetModel s, WidgetEvent e)
=> Color
-> (Color -> e)
-> [ColorPopupCfg s e]
-> WidgetNode s e
Color
value Color -> e
handler [ColorPopupCfg s e]
configs = WidgetNode s e
newNode where
newConfigs :: [ColorPopupCfg s e]
newConfigs = forall t a e. CmbOnChange t a e => (a -> e) -> t
onChange Color -> e
handler forall a. a -> [a] -> [a]
: [ColorPopupCfg s e]
configs
newNode :: WidgetNode s e
newNode = forall s e.
(WidgetModel s, WidgetEvent e) =>
WidgetData s Color -> [ColorPopupCfg s e] -> WidgetNode s e
colorPopupD_ (forall s a. a -> WidgetData s a
WidgetValue Color
value) [ColorPopupCfg s e]
newConfigs
colorPopupD_
:: (WidgetModel s, WidgetEvent e)
=> WidgetData s Color
-> [ColorPopupCfg s e]
-> WidgetNode s e
WidgetData s Color
wdata [ColorPopupCfg s e]
configs = WidgetNode s e
newNode where
config :: ColorPopupCfg s e
config = forall a. Monoid a => [a] -> a
mconcat [ColorPopupCfg s e]
configs
model :: WidgetData s ColorPopupModel
model = forall s a. a -> WidgetData s a
WidgetValue forall a. Default a => a
def
uiBuilder :: ColorPopupEnv -> ColorPopupModel -> ColorPopupNode
uiBuilder = forall sp ep.
WidgetModel sp =>
ColorPopupCfg sp ep
-> ColorPopupEnv -> ColorPopupModel -> ColorPopupNode
buildUI ColorPopupCfg s e
config
eventHandler :: ColorPopupEnv
-> ColorPopupNode
-> ColorPopupModel
-> ColorPopupEvt
-> [EventResponse ColorPopupModel ColorPopupEvt s e]
eventHandler = forall sp ep.
WidgetModel sp =>
WidgetData sp Color
-> ColorPopupCfg sp ep
-> ColorPopupEnv
-> ColorPopupNode
-> ColorPopupModel
-> ColorPopupEvt
-> [EventResponse ColorPopupModel ColorPopupEvt sp ep]
handleEvent WidgetData s Color
wdata ColorPopupCfg s e
config
mergeModel :: p -> s -> b -> p -> b
mergeModel p
wenv s
parentModel b
oldModel p
newModel = b
oldModel
forall a b. a -> (a -> b) -> b
& forall s a. HasPopupColor s a => Lens' s a
popupColor forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall s a. s -> WidgetData s a -> a
widgetDataGet s
parentModel WidgetData s Color
wdata
compCfg :: [CompositeCfg ColorPopupModel e s ep]
compCfg = [forall s e sp ep.
MergeModelHandler s e sp -> CompositeCfg s e sp ep
compositeMergeModel forall {b} {p} {p}. HasPopupColor b Color => p -> s -> b -> p -> b
mergeModel]
newNode :: WidgetNode s e
newNode = forall s e ep sp.
(CompositeModel s, CompositeEvent e, CompositeEvent ep,
CompParentModel sp) =>
WidgetType
-> WidgetData sp s
-> UIBuilder s e
-> EventHandler s e sp ep
-> [CompositeCfg s e sp ep]
-> WidgetNode sp ep
compositeD_ WidgetType
"colorPopup" forall {s}. WidgetData s ColorPopupModel
model ColorPopupEnv -> ColorPopupModel -> ColorPopupNode
uiBuilder ColorPopupEnv
-> ColorPopupNode
-> ColorPopupModel
-> ColorPopupEvt
-> [EventResponse ColorPopupModel ColorPopupEvt s e]
eventHandler forall {e} {ep}. [CompositeCfg ColorPopupModel e s ep]
compCfg
buildUI
:: WidgetModel sp
=> ColorPopupCfg sp ep
-> ColorPopupEnv
-> ColorPopupModel
-> ColorPopupNode
buildUI :: forall sp ep.
WidgetModel sp =>
ColorPopupCfg sp ep
-> ColorPopupEnv -> ColorPopupModel -> ColorPopupNode
buildUI ColorPopupCfg sp ep
config ColorPopupEnv
wenv ColorPopupModel
model = ColorPopupNode
widgetTree where
containerStyle :: Style
containerStyle = forall s e. WidgetEnv s e -> Lens' ThemeState StyleState -> Style
collectTheme ColorPopupEnv
wenv forall s a. HasColorPopupStyle s a => Lens' s a
L.colorPopupStyle
selColor :: Color
selColor = ColorPopupModel
model forall s a. s -> Getting a s a -> a
^. forall s a. HasPopupColor s a => Lens' s a
popupColor
toggleStyle :: Style
toggleStyle = Style -> Style
mergeBasicStyle forall a b. (a -> b) -> a -> b
$ forall a. Default a => a
def
forall a b. a -> (a -> b) -> b
& forall s a. HasBasic s a => Lens' s a
L.basic forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => a -> Iso' (Maybe a) a
non forall a. Default a => a
def forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasSizeReqW s a => Lens' s a
L.sizeReqW forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall t. CmbWidth t => Double -> t
width Double
30
forall a b. a -> (a -> b) -> b
& forall s a. HasBasic s a => Lens' s a
L.basic forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => a -> Iso' (Maybe a) a
non forall a. Default a => a
def forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasSizeReqH s a => Lens' s a
L.sizeReqH forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall t. CmbHeight t => Double -> t
height Double
30
forall a b. a -> (a -> b) -> b
& forall s a. HasBasic s a => Lens' s a
L.basic forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => a -> Iso' (Maybe a) a
non forall a. Default a => a
def forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasBgColor s a => Lens' s a
L.bgColor forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Color
selColor
forall a b. a -> (a -> b) -> b
& forall s a. HasBasic s a => Lens' s a
L.basic forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => a -> Iso' (Maybe a) a
non forall a. Default a => a
def forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasBorder s a => Lens' s a
L.border forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall t. CmbBorder t => Double -> Color -> t
border Double
1 Color
selColor
toggleCfg :: [ToggleButtonCfg s e]
toggleCfg = [forall s e. Style -> ToggleButtonCfg s e
toggleButtonOffStyle Style
toggleStyle]
toggle :: WidgetNode ColorPopupModel e
toggle = forall s e.
Text -> ALens' s Bool -> [ToggleButtonCfg s e] -> WidgetNode s e
toggleButton_ Text
"" forall s a. HasPopupShowColor s a => Lens' s a
popupShowColor forall {s} {e}. [ToggleButtonCfg s e]
toggleCfg
forall a b. a -> (a -> b) -> b
& forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasStyle s a => Lens' s a
L.style forall s t a b. ASetter s t a b -> b -> s -> t
.~ Style
toggleStyle
pickerCfg :: ColorPickerCfg ColorPopupModel ColorPopupEvt
pickerCfg = forall s e.
ColorPopupCfg s e -> ColorPickerCfg ColorPopupModel ColorPopupEvt
_cpcColorPickerCfg ColorPopupCfg sp ep
config
picker :: ColorPopupNode
picker = forall s e.
(WidgetModel s, WidgetEvent e) =>
ALens' s Color -> [ColorPickerCfg s e] -> WidgetNode s e
colorPicker_ forall s a. HasPopupColor s a => Lens' s a
popupColor [ColorPickerCfg ColorPopupModel ColorPopupEvt
pickerCfg, forall t a e. CmbOnChange t a e => (a -> e) -> t
onChange Color -> ColorPopupEvt
ColorChanged]
forall a b. a -> (a -> b) -> b
& forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasStyle s a => Lens' s a
L.style forall s t a b. ASetter s t a b -> b -> s -> t
.~ Style
containerStyle
content :: ColorPopupNode
content = forall s e. WidgetNode s e -> WidgetNode s e
boxShadow ColorPopupNode
picker
popupCfg :: [PopupCfg s e]
popupCfg = [forall s e. PopupCfg s e
popupAlignToOuterV, forall s e. Point -> PopupCfg s e
popupOffset (Double -> Double -> Point
Point Double
0 Double
10), forall t. CmbAlignBottom t => t
alignBottom, forall t. CmbAlignLeft t => t
alignLeft]
widgetTree :: ColorPopupNode
widgetTree = forall s e.
WidgetModel s =>
ALens' s Bool -> [PopupCfg s e] -> WidgetNode s e -> WidgetNode s e
popup_ forall s a. HasPopupShowColor s a => Lens' s a
popupShowColor (forall s e. WidgetNode s e -> PopupCfg s e
popupAnchor forall {e}. WidgetNode ColorPopupModel e
toggle forall a. a -> [a] -> [a]
: forall {s} {e}. [PopupCfg s e]
popupCfg) ColorPopupNode
content
handleEvent
:: WidgetModel sp
=> WidgetData sp Color
-> ColorPopupCfg sp ep
-> ColorPopupEnv
-> ColorPopupNode
-> ColorPopupModel
-> ColorPopupEvt
-> [EventResponse ColorPopupModel ColorPopupEvt sp ep]
handleEvent :: forall sp ep.
WidgetModel sp =>
WidgetData sp Color
-> ColorPopupCfg sp ep
-> ColorPopupEnv
-> ColorPopupNode
-> ColorPopupModel
-> ColorPopupEvt
-> [EventResponse ColorPopupModel ColorPopupEvt sp ep]
handleEvent WidgetData sp Color
wdata ColorPopupCfg sp ep
cfg ColorPopupEnv
wenv ColorPopupNode
node ColorPopupModel
model ColorPopupEvt
evt = case ColorPopupEvt
evt of
PopupFocus Path
prev
| Bool -> Bool
not (forall s e. WidgetNode s e -> Path -> Bool
isNodeParentOfPath ColorPopupNode
node Path
prev) -> forall {s} {e}. Path -> [EventResponse s e sp ep]
reportFocus Path
prev
PopupBlur Path
next
| Bool -> Bool
not (forall s e. WidgetNode s e -> Path -> Bool
isNodeParentOfPath ColorPopupNode
node Path
next) -> forall {s} {e}. Path -> [EventResponse s e sp ep]
reportBlur Path
next
ColorChanged Color
col -> forall {s} {e}. Color -> [EventResponse s e sp ep]
reportChange Color
col
ColorPopupEvt
_ -> []
where
parentColor :: sp -> Color
parentColor sp
pm = forall s a. s -> WidgetData s a -> a
widgetDataGet sp
pm WidgetData sp Color
wdata
parentChanged :: sp -> Bool
parentChanged sp
pm = sp -> Color
parentColor sp
pm forall a. Eq a => a -> a -> Bool
/= ColorPopupModel
model forall s a. s -> Getting a s a -> a
^. forall s a. HasPopupColor s a => Lens' s a
popupColor
report :: f (WidgetRequest sp ep) -> f (EventResponse s e sp ep)
report f (WidgetRequest sp ep)
reqs = forall s e sp ep. WidgetRequest sp ep -> EventResponse s e sp ep
RequestParent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (WidgetRequest sp ep)
reqs
reportFocus :: Path -> [EventResponse s e sp ep]
reportFocus Path
prev = forall {f :: * -> *} {sp} {ep} {s} {e}.
Functor f =>
f (WidgetRequest sp ep) -> f (EventResponse s e sp ep)
report ((forall a b. (a -> b) -> a -> b
$ Path
prev) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s e. ColorPopupCfg s e -> [Path -> WidgetRequest s e]
_cpcOnFocusReq ColorPopupCfg sp ep
cfg)
reportBlur :: Path -> [EventResponse s e sp ep]
reportBlur Path
next = forall {f :: * -> *} {sp} {ep} {s} {e}.
Functor f =>
f (WidgetRequest sp ep) -> f (EventResponse s e sp ep)
report ((forall a b. (a -> b) -> a -> b
$ Path
next) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s e. ColorPopupCfg s e -> [Path -> WidgetRequest s e]
_cpcOnBlurReq ColorPopupCfg sp ep
cfg)
reportChange :: Color -> [EventResponse s e sp ep]
reportChange Color
col = forall {f :: * -> *} {sp} {ep} {s} {e}.
Functor f =>
f (WidgetRequest sp ep) -> f (EventResponse s e sp ep)
report (forall {e}. [WidgetRequest sp e]
wdataReqs forall a. [a] -> [a] -> [a]
++ [WidgetRequest sp ep]
changeReqs) where
wdataReqs :: [WidgetRequest sp e]
wdataReqs = forall s a e. WidgetData s a -> a -> [WidgetRequest s e]
widgetDataSet WidgetData sp Color
wdata Color
col
changeReqs :: [WidgetRequest sp ep]
changeReqs = (forall a b. (a -> b) -> a -> b
$ Color
col) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s e. ColorPopupCfg s e -> [Color -> WidgetRequest s e]
_cpcOnChangeReq ColorPopupCfg sp ep
cfg