{-|
Module      : Monomer.Widgets.Singles.ColorPicker
Copyright   : (c) 2018 Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

Color picker using sliders and numeric fields.
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TemplateHaskell #-}

module Monomer.Widgets.Singles.ColorPicker (
  -- * Configuration
  ColorPickerCfg,
  -- * Constructors
  colorPicker,
  colorPicker_,
  colorPickerV,
  colorPickerV_,
  colorPickerD_
) where

import Control.Applicative ((<|>))
import Control.Lens ((&), (^.), (.~), ALens', abbreviatedFields, makeLensesWith)
import Data.ByteString (ByteString)
import Data.ByteString.Builder (Builder, toLazyByteString)
import Data.Default
import Data.Maybe
import Data.Text (Text)

import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Builder as B
import Monomer.Core
import Monomer.Core.Combinators
import Monomer.Graphics

import Monomer.Widgets.Composite
import Monomer.Widgets.Containers.Box
import Monomer.Widgets.Containers.Stack
import Monomer.Widgets.Containers.ZStack
import Monomer.Widgets.Singles.Image
import Monomer.Widgets.Singles.Label
import Monomer.Widgets.Singles.NumericField
import Monomer.Widgets.Singles.Slider
import Monomer.Widgets.Singles.Spacer

import qualified Monomer.Lens as L

{-|
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 ColorPickerCfg s e = ColorPickerCfg {
  ColorPickerCfg s e -> Maybe Bool
_cpcShowAlpha :: Maybe Bool,
  ColorPickerCfg s e -> [Path -> WidgetRequest s e]
_cpcOnFocusReq :: [Path -> WidgetRequest s e],
  ColorPickerCfg s e -> [Path -> WidgetRequest s e]
_cpcOnBlurReq :: [Path -> WidgetRequest s e],
  ColorPickerCfg s e -> [Color -> WidgetRequest s e]
_cpcOnChangeReq :: [Color -> WidgetRequest s e]
}

instance Default (ColorPickerCfg s e) where
  def :: ColorPickerCfg s e
def = ColorPickerCfg :: forall s e.
Maybe Bool
-> [Path -> WidgetRequest s e]
-> [Path -> WidgetRequest s e]
-> [Color -> WidgetRequest s e]
-> ColorPickerCfg s e
ColorPickerCfg {
    _cpcShowAlpha :: Maybe Bool
_cpcShowAlpha = Maybe Bool
forall a. Maybe a
Nothing,
    _cpcOnFocusReq :: [Path -> WidgetRequest s e]
_cpcOnFocusReq = [],
    _cpcOnBlurReq :: [Path -> WidgetRequest s e]
_cpcOnBlurReq = [],
    _cpcOnChangeReq :: [Color -> WidgetRequest s e]
_cpcOnChangeReq = []
  }

instance Semigroup (ColorPickerCfg s e) where
  <> :: ColorPickerCfg s e -> ColorPickerCfg s e -> ColorPickerCfg s e
(<>) ColorPickerCfg s e
a1 ColorPickerCfg s e
a2 = ColorPickerCfg Any Any
forall a. Default a => a
def {
    _cpcShowAlpha :: Maybe Bool
_cpcShowAlpha = ColorPickerCfg s e -> Maybe Bool
forall s e. ColorPickerCfg s e -> Maybe Bool
_cpcShowAlpha ColorPickerCfg s e
a2 Maybe Bool -> Maybe Bool -> Maybe Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ColorPickerCfg s e -> Maybe Bool
forall s e. ColorPickerCfg s e -> Maybe Bool
_cpcShowAlpha ColorPickerCfg s e
a1,
    _cpcOnFocusReq :: [Path -> WidgetRequest s e]
_cpcOnFocusReq = ColorPickerCfg s e -> [Path -> WidgetRequest s e]
forall s e. ColorPickerCfg s e -> [Path -> WidgetRequest s e]
_cpcOnFocusReq ColorPickerCfg s e
a1 [Path -> WidgetRequest s e]
-> [Path -> WidgetRequest s e] -> [Path -> WidgetRequest s e]
forall a. Semigroup a => a -> a -> a
<> ColorPickerCfg s e -> [Path -> WidgetRequest s e]
forall s e. ColorPickerCfg s e -> [Path -> WidgetRequest s e]
_cpcOnFocusReq ColorPickerCfg s e
a2,
    _cpcOnBlurReq :: [Path -> WidgetRequest s e]
_cpcOnBlurReq = ColorPickerCfg s e -> [Path -> WidgetRequest s e]
forall s e. ColorPickerCfg s e -> [Path -> WidgetRequest s e]
_cpcOnBlurReq ColorPickerCfg s e
a1 [Path -> WidgetRequest s e]
-> [Path -> WidgetRequest s e] -> [Path -> WidgetRequest s e]
forall a. Semigroup a => a -> a -> a
<> ColorPickerCfg s e -> [Path -> WidgetRequest s e]
forall s e. ColorPickerCfg s e -> [Path -> WidgetRequest s e]
_cpcOnBlurReq ColorPickerCfg s e
a2,
    _cpcOnChangeReq :: [Color -> WidgetRequest s e]
_cpcOnChangeReq = ColorPickerCfg s e -> [Color -> WidgetRequest s e]
forall s e. ColorPickerCfg s e -> [Color -> WidgetRequest s e]
_cpcOnChangeReq ColorPickerCfg s e
a1 [Color -> WidgetRequest s e]
-> [Color -> WidgetRequest s e] -> [Color -> WidgetRequest s e]
forall a. Semigroup a => a -> a -> a
<> ColorPickerCfg s e -> [Color -> WidgetRequest s e]
forall s e. ColorPickerCfg s e -> [Color -> WidgetRequest s e]
_cpcOnChangeReq ColorPickerCfg s e
a2
  }

instance Monoid (ColorPickerCfg s e) where
  mempty :: ColorPickerCfg s e
mempty = ColorPickerCfg s e
forall a. Default a => a
def

instance CmbShowAlpha (ColorPickerCfg s e) where
  showAlpha_ :: Bool -> ColorPickerCfg s e
showAlpha_ Bool
show = ColorPickerCfg s e
forall a. Default a => a
def {
    _cpcShowAlpha :: Maybe Bool
_cpcShowAlpha = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
show
  }

instance WidgetEvent e => CmbOnFocus (ColorPickerCfg s e) e Path where
  onFocus :: (Path -> e) -> ColorPickerCfg s e
onFocus Path -> e
fn = ColorPickerCfg s e
forall a. Default a => a
def {
    _cpcOnFocusReq :: [Path -> WidgetRequest s e]
_cpcOnFocusReq = [e -> WidgetRequest s e
forall s e. WidgetEvent e => e -> WidgetRequest s e
RaiseEvent (e -> WidgetRequest s e)
-> (Path -> e) -> Path -> WidgetRequest s e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> e
fn]
  }

instance CmbOnFocusReq (ColorPickerCfg s e) s e Path where
  onFocusReq :: (Path -> WidgetRequest s e) -> ColorPickerCfg s e
onFocusReq Path -> WidgetRequest s e
req = ColorPickerCfg s e
forall a. Default a => a
def {
    _cpcOnFocusReq :: [Path -> WidgetRequest s e]
_cpcOnFocusReq = [Path -> WidgetRequest s e
req]
  }

instance WidgetEvent e => CmbOnBlur (ColorPickerCfg s e) e Path where
  onBlur :: (Path -> e) -> ColorPickerCfg s e
onBlur Path -> e
fn = ColorPickerCfg s e
forall a. Default a => a
def {
    _cpcOnBlurReq :: [Path -> WidgetRequest s e]
_cpcOnBlurReq = [e -> WidgetRequest s e
forall s e. WidgetEvent e => e -> WidgetRequest s e
RaiseEvent (e -> WidgetRequest s e)
-> (Path -> e) -> Path -> WidgetRequest s e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> e
fn]
  }

instance CmbOnBlurReq (ColorPickerCfg s e) s e Path where
  onBlurReq :: (Path -> WidgetRequest s e) -> ColorPickerCfg s e
onBlurReq Path -> WidgetRequest s e
req = ColorPickerCfg s e
forall a. Default a => a
def {
    _cpcOnBlurReq :: [Path -> WidgetRequest s e]
_cpcOnBlurReq = [Path -> WidgetRequest s e
req]
  }

instance WidgetEvent e => CmbOnChange (ColorPickerCfg s e) Color e where
  onChange :: (Color -> e) -> ColorPickerCfg s e
onChange Color -> e
fn = ColorPickerCfg s e
forall a. Default a => a
def {
    _cpcOnChangeReq :: [Color -> WidgetRequest s e]
_cpcOnChangeReq = [e -> WidgetRequest s e
forall s e. WidgetEvent e => e -> WidgetRequest s e
RaiseEvent (e -> WidgetRequest s e)
-> (Color -> e) -> Color -> WidgetRequest s e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> e
fn]
  }

instance CmbOnChangeReq (ColorPickerCfg s e) s e Color where
  onChangeReq :: (Color -> WidgetRequest s e) -> ColorPickerCfg s e
onChangeReq Color -> WidgetRequest s e
req = ColorPickerCfg s e
forall a. Default a => a
def {
    _cpcOnChangeReq :: [Color -> WidgetRequest s e]
_cpcOnChangeReq = [Color -> WidgetRequest s e
req]
  }

data ColorPickerEvt
  = PickerFocus Path
  | PickerBlur Path
  | ColorChanged Int
  | AlphaChanged Double
  deriving (ColorPickerEvt -> ColorPickerEvt -> Bool
(ColorPickerEvt -> ColorPickerEvt -> Bool)
-> (ColorPickerEvt -> ColorPickerEvt -> Bool) -> Eq ColorPickerEvt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ColorPickerEvt -> ColorPickerEvt -> Bool
$c/= :: ColorPickerEvt -> ColorPickerEvt -> Bool
== :: ColorPickerEvt -> ColorPickerEvt -> Bool
$c== :: ColorPickerEvt -> ColorPickerEvt -> Bool
Eq, Int -> ColorPickerEvt -> ShowS
[ColorPickerEvt] -> ShowS
ColorPickerEvt -> String
(Int -> ColorPickerEvt -> ShowS)
-> (ColorPickerEvt -> String)
-> ([ColorPickerEvt] -> ShowS)
-> Show ColorPickerEvt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ColorPickerEvt] -> ShowS
$cshowList :: [ColorPickerEvt] -> ShowS
show :: ColorPickerEvt -> String
$cshow :: ColorPickerEvt -> String
showsPrec :: Int -> ColorPickerEvt -> ShowS
$cshowsPrec :: Int -> ColorPickerEvt -> ShowS
Show)

-- | Creates a color picker using the given lens.
colorPicker
  :: (WidgetModel s, WidgetEvent e)
  => ALens' s Color
  -> WidgetNode s e
colorPicker :: ALens' s Color -> WidgetNode s e
colorPicker ALens' s Color
field = ALens' s Color -> [ColorPickerCfg s e] -> WidgetNode s e
forall s e.
(WidgetModel s, WidgetEvent e) =>
ALens' s Color -> [ColorPickerCfg s e] -> WidgetNode s e
colorPicker_ ALens' s Color
field [ColorPickerCfg s e]
forall a. Default a => a
def

-- | Creates a color picker using the given lens. Accepts config.
colorPicker_
  :: (WidgetModel s, WidgetEvent e)
  => ALens' s Color
  -> [ColorPickerCfg s e]
  -> WidgetNode s e
colorPicker_ :: ALens' s Color -> [ColorPickerCfg s e] -> WidgetNode s e
colorPicker_ ALens' s Color
field [ColorPickerCfg s e]
configs = WidgetData s Color
-> [ColorPickerCfg s e]
-> [CompositeCfg Color ColorPickerEvt s e]
-> WidgetNode s e
forall s e.
(WidgetModel s, WidgetEvent e) =>
WidgetData s Color
-> [ColorPickerCfg s e]
-> [CompositeCfg Color ColorPickerEvt s e]
-> WidgetNode s e
colorPickerD_ WidgetData s Color
wlens [ColorPickerCfg s e]
configs [] where
  wlens :: WidgetData s Color
wlens = ALens' s Color -> WidgetData s Color
forall s a. ALens' s a -> WidgetData s a
WidgetLens ALens' s Color
field

-- | Creates a color picker using the given value and 'onChange' event handler.
colorPickerV
  :: (WidgetModel s, WidgetEvent e)
  => Color
  -> (Color -> e)
  -> WidgetNode s e
colorPickerV :: Color -> (Color -> e) -> WidgetNode s e
colorPickerV Color
value Color -> e
handler = Color -> (Color -> e) -> [ColorPickerCfg s e] -> WidgetNode s e
forall s e.
(WidgetModel s, WidgetEvent e) =>
Color -> (Color -> e) -> [ColorPickerCfg s e] -> WidgetNode s e
colorPickerV_ Color
value Color -> e
handler [ColorPickerCfg s e]
forall a. Default a => a
def

{-|
Creates a color picker using the given value and 'onChange' event handler.
Accepts config.
-}
colorPickerV_
  :: (WidgetModel s, WidgetEvent e)
  => Color
  -> (Color -> e)
  -> [ColorPickerCfg s e]
  -> WidgetNode s e
colorPickerV_ :: Color -> (Color -> e) -> [ColorPickerCfg s e] -> WidgetNode s e
colorPickerV_ Color
value Color -> e
handler [ColorPickerCfg s e]
configs = WidgetData s Color
-> [ColorPickerCfg s e]
-> [CompositeCfg Color ColorPickerEvt s e]
-> WidgetNode s e
forall s e.
(WidgetModel s, WidgetEvent e) =>
WidgetData s Color
-> [ColorPickerCfg s e]
-> [CompositeCfg Color ColorPickerEvt s e]
-> WidgetNode s e
colorPickerD_ WidgetData s Color
forall s. WidgetData s Color
wdata [ColorPickerCfg s e]
newCfgs [] where
  wdata :: WidgetData s Color
wdata = Color -> WidgetData s Color
forall s a. a -> WidgetData s a
WidgetValue Color
value
  newCfgs :: [ColorPickerCfg s e]
newCfgs = (Color -> e) -> ColorPickerCfg s e
forall t a e. CmbOnChange t a e => (a -> e) -> t
onChange Color -> e
handler ColorPickerCfg s e -> [ColorPickerCfg s e] -> [ColorPickerCfg s e]
forall a. a -> [a] -> [a]
: [ColorPickerCfg s e]
configs

-- | Creates a color picker providing a 'WidgetData' instance and config.
colorPickerD_
  :: (WidgetModel s, WidgetEvent e)
  => WidgetData s Color
  -> [ColorPickerCfg s e]
  -> [CompositeCfg Color ColorPickerEvt s e]
  -> WidgetNode s e
colorPickerD_ :: WidgetData s Color
-> [ColorPickerCfg s e]
-> [CompositeCfg Color ColorPickerEvt s e]
-> WidgetNode s e
colorPickerD_ WidgetData s Color
wdata [ColorPickerCfg s e]
cfgs [CompositeCfg Color ColorPickerEvt s e]
cmpCfgs = WidgetNode s e
newNode where
  cfg :: ColorPickerCfg s e
cfg = [ColorPickerCfg s e] -> ColorPickerCfg s e
forall a. Monoid a => [a] -> a
mconcat [ColorPickerCfg s e]
cfgs
  uiBuilder :: WidgetEnv Color ColorPickerEvt
-> Color -> WidgetNode Color ColorPickerEvt
uiBuilder = ColorPickerCfg s e
-> WidgetEnv Color ColorPickerEvt
-> Color
-> WidgetNode Color ColorPickerEvt
forall sp ep.
ColorPickerCfg sp ep
-> WidgetEnv Color ColorPickerEvt
-> Color
-> WidgetNode Color ColorPickerEvt
buildUI ColorPickerCfg s e
cfg
  evtHandler :: WidgetEnv Color ColorPickerEvt
-> WidgetNode Color ColorPickerEvt
-> Color
-> ColorPickerEvt
-> [EventResponse Color ColorPickerEvt s e]
evtHandler = ColorPickerCfg s e
-> WidgetEnv Color ColorPickerEvt
-> WidgetNode Color ColorPickerEvt
-> Color
-> ColorPickerEvt
-> [EventResponse Color ColorPickerEvt s e]
forall sp ep.
(WidgetModel sp, WidgetEvent ep) =>
ColorPickerCfg sp ep
-> WidgetEnv Color ColorPickerEvt
-> WidgetNode Color ColorPickerEvt
-> Color
-> ColorPickerEvt
-> [EventResponse Color ColorPickerEvt sp ep]
handleEvent ColorPickerCfg s e
cfg
  newNode :: WidgetNode s e
newNode = WidgetType
-> WidgetData s Color
-> (WidgetEnv Color ColorPickerEvt
    -> Color -> WidgetNode Color ColorPickerEvt)
-> (WidgetEnv Color ColorPickerEvt
    -> WidgetNode Color ColorPickerEvt
    -> Color
    -> ColorPickerEvt
    -> [EventResponse Color ColorPickerEvt s e])
-> [CompositeCfg Color ColorPickerEvt s e]
-> WidgetNode s e
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
"colorPicker" WidgetData s Color
wdata WidgetEnv Color ColorPickerEvt
-> Color -> WidgetNode Color ColorPickerEvt
uiBuilder WidgetEnv Color ColorPickerEvt
-> WidgetNode Color ColorPickerEvt
-> Color
-> ColorPickerEvt
-> [EventResponse Color ColorPickerEvt s e]
evtHandler [CompositeCfg Color ColorPickerEvt s e]
cmpCfgs

buildUI
  :: ColorPickerCfg sp ep
  -> WidgetEnv Color ColorPickerEvt
  -> Color
  -> WidgetNode Color ColorPickerEvt
buildUI :: ColorPickerCfg sp ep
-> WidgetEnv Color ColorPickerEvt
-> Color
-> WidgetNode Color ColorPickerEvt
buildUI ColorPickerCfg sp ep
config WidgetEnv Color ColorPickerEvt
wenv Color
model = WidgetNode Color ColorPickerEvt
mainTree where
  showAlpha :: Bool
showAlpha = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (ColorPickerCfg sp ep -> Maybe Bool
forall s e. ColorPickerCfg s e -> Maybe Bool
_cpcShowAlpha ColorPickerCfg sp ep
config)
  colorSample :: WidgetNode s ColorPickerEvt
colorSample = [WidgetNode s ColorPickerEvt] -> WidgetNode s ColorPickerEvt
forall (t :: * -> *) s e.
Traversable t =>
t (WidgetNode s e) -> WidgetNode s e
zstack [
      Int -> Int -> Color -> Color -> WidgetNode s ColorPickerEvt
forall e s.
WidgetEvent e =>
Int -> Int -> Color -> Color -> WidgetNode s e
patternImage Int
2 Int
10 (Int -> Int -> Int -> Color
rgb Int
255 Int
255 Int
255) (Int -> Int -> Int -> Color
rgb Int
150 Int
150 Int
150),
      WidgetNode s ColorPickerEvt
forall s e. WidgetNode s e
filler WidgetNode s ColorPickerEvt
-> [StyleState] -> WidgetNode s ColorPickerEvt
forall t. CmbStyleBasic t => t -> [StyleState] -> t
`styleBasic` [Color -> StyleState
forall t. CmbBgColor t => Color -> t
bgColor Color
model]
    ] WidgetNode s ColorPickerEvt
-> [StyleState] -> WidgetNode s ColorPickerEvt
forall t. CmbStyleBasic t => t -> [StyleState] -> t
`styleBasic` [Double -> StyleState
forall t. CmbWidth t => Double -> t
width Double
32]

  compRow :: ALens' s a
-> (a -> ColorPickerEvt)
-> Text
-> a
-> a
-> WidgetNode s ColorPickerEvt
compRow ALens' s a
lensCol a -> ColorPickerEvt
evt Text
lbl a
minV a
maxV = [WidgetNode s ColorPickerEvt] -> WidgetNode s ColorPickerEvt
forall (t :: * -> *) s e.
Traversable t =>
t (WidgetNode s e) -> WidgetNode s e
hstack [
      Text -> WidgetNode s ColorPickerEvt
forall s e. Text -> WidgetNode s e
label Text
lbl WidgetNode s ColorPickerEvt
-> [StyleState] -> WidgetNode s ColorPickerEvt
forall t. CmbStyleBasic t => t -> [StyleState] -> t
`styleBasic` [Double -> StyleState
forall t. CmbWidth t => Double -> t
width Double
48],
      [SpacerCfg] -> WidgetNode s ColorPickerEvt
forall s e. [SpacerCfg] -> WidgetNode s e
spacer_ [Double -> SpacerCfg
forall t. CmbWidth t => Double -> t
width Double
2],
      ALens' s a
-> a
-> a
-> [SliderCfg s ColorPickerEvt a]
-> WidgetNode s ColorPickerEvt
forall a e s.
(SliderValue a, WidgetEvent e) =>
ALens' s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
hslider_ ALens' s a
lensCol a
minV a
maxV [(a -> ColorPickerEvt) -> SliderCfg s ColorPickerEvt a
forall t a e. CmbOnChange t a e => (a -> e) -> t
onChange a -> ColorPickerEvt
evt, (Path -> ColorPickerEvt) -> SliderCfg s ColorPickerEvt a
forall t e a. CmbOnFocus t e a => (a -> e) -> t
onFocus Path -> ColorPickerEvt
PickerFocus,
        (Path -> ColorPickerEvt) -> SliderCfg s ColorPickerEvt a
forall t e a. CmbOnBlur t e a => (a -> e) -> t
onBlur Path -> ColorPickerEvt
PickerBlur]
        WidgetNode s ColorPickerEvt
-> [StyleState] -> WidgetNode s ColorPickerEvt
forall t. CmbStyleBasic t => t -> [StyleState] -> t
`styleBasic` [Double -> StyleState
forall a.
(Semigroup a, CmbPaddingT a, CmbPaddingB a) =>
Double -> a
paddingV Double
5],
      [SpacerCfg] -> WidgetNode s ColorPickerEvt
forall s e. [SpacerCfg] -> WidgetNode s e
spacer_ [Double -> SpacerCfg
forall t. CmbWidth t => Double -> t
width Double
2],
      ALens' s a
-> [NumericFieldCfg s ColorPickerEvt a]
-> WidgetNode s ColorPickerEvt
forall a e s.
(FormattableNumber a, WidgetEvent e) =>
ALens' s a -> [NumericFieldCfg s e a] -> WidgetNode s e
numericField_ ALens' s a
lensCol [a -> NumericFieldCfg s ColorPickerEvt a
forall t a. CmbMinValue t a => a -> t
minValue a
minV, a -> NumericFieldCfg s ColorPickerEvt a
forall t a. CmbMaxValue t a => a -> t
maxValue a
maxV, (a -> ColorPickerEvt) -> NumericFieldCfg s ColorPickerEvt a
forall t a e. CmbOnChange t a e => (a -> e) -> t
onChange a -> ColorPickerEvt
evt,
        (Path -> ColorPickerEvt) -> NumericFieldCfg s ColorPickerEvt a
forall t e a. CmbOnFocus t e a => (a -> e) -> t
onFocus Path -> ColorPickerEvt
PickerFocus, (Path -> ColorPickerEvt) -> NumericFieldCfg s ColorPickerEvt a
forall t e a. CmbOnBlur t e a => (a -> e) -> t
onBlur Path -> ColorPickerEvt
PickerBlur]
        WidgetNode s ColorPickerEvt
-> [StyleState] -> WidgetNode s ColorPickerEvt
forall t. CmbStyleBasic t => t -> [StyleState] -> t
`styleBasic` [Double -> StyleState
forall t. CmbWidth t => Double -> t
width Double
40, Double -> StyleState
forall t. CmbPadding t => Double -> t
padding Double
0, StyleState
forall t. CmbTextRight t => t
textRight]
    ]

  colorRow :: ALens' s a -> Text -> WidgetNode s ColorPickerEvt
colorRow ALens' s a
lens Text
lbl = ALens' s a
-> (Int -> ColorPickerEvt)
-> Text
-> a
-> a
-> WidgetNode s ColorPickerEvt
forall a s a.
(Typeable a, Show a, FromFractional a, NumericTextConverter a,
 CmbOnChange (SliderCfg s ColorPickerEvt a) a ColorPickerEvt,
 CmbOnChange
   (NumericFieldCfg s ColorPickerEvt a) a ColorPickerEvt) =>
ALens' s a
-> (a -> ColorPickerEvt)
-> Text
-> a
-> a
-> WidgetNode s ColorPickerEvt
compRow ALens' s a
lens Int -> ColorPickerEvt
ColorChanged Text
lbl a
0 a
255
  alphaRow :: ALens' s a -> Text -> WidgetNode s ColorPickerEvt
alphaRow ALens' s a
lens Text
lbl = ALens' s a
-> (Double -> ColorPickerEvt)
-> Text
-> a
-> a
-> WidgetNode s ColorPickerEvt
forall a s a.
(Typeable a, Show a, FromFractional a, NumericTextConverter a,
 CmbOnChange (SliderCfg s ColorPickerEvt a) a ColorPickerEvt,
 CmbOnChange
   (NumericFieldCfg s ColorPickerEvt a) a ColorPickerEvt) =>
ALens' s a
-> (a -> ColorPickerEvt)
-> Text
-> a
-> a
-> WidgetNode s ColorPickerEvt
compRow ALens' s a
lens Double -> ColorPickerEvt
AlphaChanged Text
lbl a
0 a
1

  mainTree :: WidgetNode Color ColorPickerEvt
mainTree = [StackCfg]
-> [WidgetNode Color ColorPickerEvt]
-> WidgetNode Color ColorPickerEvt
forall (t :: * -> *) s e.
Traversable t =>
[StackCfg] -> t (WidgetNode s e) -> WidgetNode s e
hstack_ [((SizeReq, SizeReq) -> (SizeReq, SizeReq)) -> StackCfg
forall t.
CmbSizeReqUpdater t =>
((SizeReq, SizeReq) -> (SizeReq, SizeReq)) -> t
sizeReqUpdater (SizeReq, SizeReq) -> (SizeReq, SizeReq)
clearExtra] [
      [WidgetNode Color ColorPickerEvt]
-> WidgetNode Color ColorPickerEvt
forall (t :: * -> *) s e.
Traversable t =>
t (WidgetNode s e) -> WidgetNode s e
vstack [
        ALens' Color Int -> Text -> WidgetNode Color ColorPickerEvt
forall a s.
(Typeable a, Show a, FromFractional a, NumericTextConverter a,
 CmbOnChange (SliderCfg s ColorPickerEvt a) Int ColorPickerEvt,
 CmbOnChange
   (NumericFieldCfg s ColorPickerEvt a) Int ColorPickerEvt) =>
ALens' s a -> Text -> WidgetNode s ColorPickerEvt
colorRow ALens' Color Int
forall s a. HasR s a => Lens' s a
L.r Text
"Red",
        [SpacerCfg] -> WidgetNode Color ColorPickerEvt
forall s e. [SpacerCfg] -> WidgetNode s e
spacer_ [Double -> SpacerCfg
forall t. CmbWidth t => Double -> t
width Double
2],
        ALens' Color Int -> Text -> WidgetNode Color ColorPickerEvt
forall a s.
(Typeable a, Show a, FromFractional a, NumericTextConverter a,
 CmbOnChange (SliderCfg s ColorPickerEvt a) Int ColorPickerEvt,
 CmbOnChange
   (NumericFieldCfg s ColorPickerEvt a) Int ColorPickerEvt) =>
ALens' s a -> Text -> WidgetNode s ColorPickerEvt
colorRow ALens' Color Int
forall s a. HasG s a => Lens' s a
L.g Text
"Green",
        [SpacerCfg] -> WidgetNode Color ColorPickerEvt
forall s e. [SpacerCfg] -> WidgetNode s e
spacer_ [Double -> SpacerCfg
forall t. CmbWidth t => Double -> t
width Double
2],
        ALens' Color Int -> Text -> WidgetNode Color ColorPickerEvt
forall a s.
(Typeable a, Show a, FromFractional a, NumericTextConverter a,
 CmbOnChange (SliderCfg s ColorPickerEvt a) Int ColorPickerEvt,
 CmbOnChange
   (NumericFieldCfg s ColorPickerEvt a) Int ColorPickerEvt) =>
ALens' s a -> Text -> WidgetNode s ColorPickerEvt
colorRow ALens' Color Int
forall s a. HasB s a => Lens' s a
L.b Text
"Blue",
        [SpacerCfg] -> WidgetNode Color ColorPickerEvt
forall s e. [SpacerCfg] -> WidgetNode s e
spacer_ [Double -> SpacerCfg
forall t. CmbWidth t => Double -> t
width Double
2] WidgetNode Color ColorPickerEvt
-> Bool -> WidgetNode Color ColorPickerEvt
forall s e. WidgetNode s e -> Bool -> WidgetNode s e
`nodeVisible` Bool
showAlpha,
        ALens' Color Double -> Text -> WidgetNode Color ColorPickerEvt
forall a s.
(Typeable a, Show a, FromFractional a, NumericTextConverter a,
 CmbOnChange (SliderCfg s ColorPickerEvt a) Double ColorPickerEvt,
 CmbOnChange
   (NumericFieldCfg s ColorPickerEvt a) Double ColorPickerEvt) =>
ALens' s a -> Text -> WidgetNode s ColorPickerEvt
alphaRow ALens' Color Double
forall s a. HasA s a => Lens' s a
L.a Text
"Alpha" WidgetNode Color ColorPickerEvt
-> Bool -> WidgetNode Color ColorPickerEvt
forall s e. WidgetNode s e -> Bool -> WidgetNode s e
`nodeVisible` Bool
showAlpha
      ],
      [SpacerCfg] -> WidgetNode Color ColorPickerEvt
forall s e. [SpacerCfg] -> WidgetNode s e
spacer_ [Double -> SpacerCfg
forall t. CmbWidth t => Double -> t
width Double
2],
      [BoxCfg Color ColorPickerEvt]
-> WidgetNode Color ColorPickerEvt
-> WidgetNode Color ColorPickerEvt
forall s e.
(WidgetModel s, WidgetEvent e) =>
[BoxCfg s e] -> WidgetNode s e -> WidgetNode s e
box_ [BoxCfg Color ColorPickerEvt
forall t. CmbAlignTop t => t
alignTop] WidgetNode Color ColorPickerEvt
forall s. WidgetNode s ColorPickerEvt
colorSample WidgetNode Color ColorPickerEvt
-> [StyleState] -> WidgetNode Color ColorPickerEvt
forall t. CmbStyleBasic t => t -> [StyleState] -> t
`styleBasic` [Double -> StyleState
forall t. CmbFlexHeight t => Double -> t
flexHeight Double
50]
    ] WidgetNode Color ColorPickerEvt
-> [StyleState] -> WidgetNode Color ColorPickerEvt
forall t. CmbStyleBasic t => t -> [StyleState] -> t
`styleBasic` [Double -> StyleState
forall t. CmbPadding t => Double -> t
padding Double
0]

handleEvent
  :: (WidgetModel sp, WidgetEvent ep)
  => ColorPickerCfg sp ep
  -> WidgetEnv Color ColorPickerEvt
  -> WidgetNode Color ColorPickerEvt
  -> Color
  -> ColorPickerEvt
  -> [EventResponse Color ColorPickerEvt sp ep]
handleEvent :: ColorPickerCfg sp ep
-> WidgetEnv Color ColorPickerEvt
-> WidgetNode Color ColorPickerEvt
-> Color
-> ColorPickerEvt
-> [EventResponse Color ColorPickerEvt sp ep]
handleEvent ColorPickerCfg sp ep
cfg WidgetEnv Color ColorPickerEvt
wenv WidgetNode Color ColorPickerEvt
node Color
model ColorPickerEvt
evt = case ColorPickerEvt
evt of
  PickerFocus Path
prev
    | Bool -> Bool
not (WidgetNode Color ColorPickerEvt -> Path -> Bool
forall s e. WidgetNode s e -> Path -> Bool
isNodeParentOfPath WidgetNode Color ColorPickerEvt
node Path
prev) -> Path -> [EventResponse Color ColorPickerEvt sp ep]
forall s e. Path -> [EventResponse s e sp ep]
reportFocus Path
prev
  PickerBlur Path
next
    | Bool -> Bool
not (WidgetNode Color ColorPickerEvt -> Path -> Bool
forall s e. WidgetNode s e -> Path -> Bool
isNodeParentOfPath WidgetNode Color ColorPickerEvt
node Path
next) -> Path -> [EventResponse Color ColorPickerEvt sp ep]
forall s e. Path -> [EventResponse s e sp ep]
reportBlur Path
next
  ColorChanged Int
_ -> [EventResponse Color ColorPickerEvt sp ep]
forall s e. [EventResponse s e sp ep]
reportChange
  AlphaChanged Double
_ -> [EventResponse Color ColorPickerEvt sp ep]
forall s e. [EventResponse s e sp ep]
reportChange
  ColorPickerEvt
_ -> []
  where
    report :: f (WidgetRequest sp ep) -> f (EventResponse s e sp ep)
report f (WidgetRequest sp ep)
reqs = WidgetRequest sp ep -> EventResponse s e sp ep
forall s e sp ep. WidgetRequest sp ep -> EventResponse s e sp ep
RequestParent (WidgetRequest sp ep -> EventResponse s e sp ep)
-> f (WidgetRequest sp ep) -> f (EventResponse s e sp ep)
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 = [WidgetRequest sp ep] -> [EventResponse s e sp ep]
forall (f :: * -> *) sp ep s e.
Functor f =>
f (WidgetRequest sp ep) -> f (EventResponse s e sp ep)
report (((Path -> WidgetRequest sp ep) -> Path -> WidgetRequest sp ep
forall a b. (a -> b) -> a -> b
$ Path
prev) ((Path -> WidgetRequest sp ep) -> WidgetRequest sp ep)
-> [Path -> WidgetRequest sp ep] -> [WidgetRequest sp ep]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ColorPickerCfg sp ep -> [Path -> WidgetRequest sp ep]
forall s e. ColorPickerCfg s e -> [Path -> WidgetRequest s e]
_cpcOnFocusReq ColorPickerCfg sp ep
cfg)
    reportBlur :: Path -> [EventResponse s e sp ep]
reportBlur Path
next = [WidgetRequest sp ep] -> [EventResponse s e sp ep]
forall (f :: * -> *) sp ep s e.
Functor f =>
f (WidgetRequest sp ep) -> f (EventResponse s e sp ep)
report (((Path -> WidgetRequest sp ep) -> Path -> WidgetRequest sp ep
forall a b. (a -> b) -> a -> b
$ Path
next) ((Path -> WidgetRequest sp ep) -> WidgetRequest sp ep)
-> [Path -> WidgetRequest sp ep] -> [WidgetRequest sp ep]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ColorPickerCfg sp ep -> [Path -> WidgetRequest sp ep]
forall s e. ColorPickerCfg s e -> [Path -> WidgetRequest s e]
_cpcOnBlurReq ColorPickerCfg sp ep
cfg)
    reportChange :: [EventResponse s e sp ep]
reportChange = [WidgetRequest sp ep] -> [EventResponse s e sp ep]
forall (f :: * -> *) sp ep s e.
Functor f =>
f (WidgetRequest sp ep) -> f (EventResponse s e sp ep)
report (((Color -> WidgetRequest sp ep) -> Color -> WidgetRequest sp ep
forall a b. (a -> b) -> a -> b
$ Color
model) ((Color -> WidgetRequest sp ep) -> WidgetRequest sp ep)
-> [Color -> WidgetRequest sp ep] -> [WidgetRequest sp ep]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ColorPickerCfg sp ep -> [Color -> WidgetRequest sp ep]
forall s e. ColorPickerCfg s e -> [Color -> WidgetRequest s e]
_cpcOnChangeReq ColorPickerCfg sp ep
cfg)

patternImage :: WidgetEvent e => Int -> Int -> Color -> Color -> WidgetNode s e
patternImage :: Int -> Int -> Color -> Color -> WidgetNode s e
patternImage Int
steps Int
blockW Color
col1 Color
col2 = WidgetNode s e
forall s. WidgetNode s e
newImg where
  row1 :: Builder
row1 = Int -> Int -> Color -> Color -> Builder
encodeRow Int
steps Int
blockW Color
col1 Color
col2
  row2 :: Builder
row2 = Int -> Int -> Color -> Color -> Builder
encodeRow Int
steps Int
blockW Color
col2 Color
col1
  builder :: Builder
builder = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (Int -> Builder -> [Builder]
forall a. Int -> a -> [a]
replicate Int
steps (Builder
row1 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
row2))

  imgData :: ByteString
imgData = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString Builder
builder
  imgLen :: Double
imgLen = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
steps Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
blockW)
  imgSize :: Size
imgSize = Double -> Double -> Size
Size Double
imgLen Double
imgLen
  imgConfig :: [ImageCfg e]
imgConfig = [ImageCfg e
forall t. CmbFitFill t => t
fitFill, ImageCfg e
forall t. CmbImageRepeatX t => t
imageRepeatX, ImageCfg e
forall t. CmbImageRepeatY t => t
imageRepeatY]

  newImg :: WidgetNode s e
newImg = Text -> ByteString -> Size -> [ImageCfg e] -> WidgetNode s e
forall e s.
WidgetEvent e =>
Text -> ByteString -> Size -> [ImageCfg e] -> WidgetNode s e
imageMem_ Text
"colorPickerAlphaBg" ByteString
imgData Size
imgSize [ImageCfg e]
imgConfig

encodeRow :: Int -> Int -> Color -> Color -> Builder
encodeRow :: Int -> Int -> Color -> Color -> Builder
encodeRow Int
steps Int
blockW Color
col1 Color
col2 = Builder
builder where
  line :: Builder
line = Int -> Int -> Color -> Color -> Builder
encodeLine Int
steps Int
blockW Color
col1 Color
col2
  builder :: Builder
builder = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (Int -> Builder -> [Builder]
forall a. Int -> a -> [a]
replicate Int
blockW Builder
line)

encodeLine :: Int -> Int -> Color -> Color -> Builder
encodeLine :: Int -> Int -> Color -> Color -> Builder
encodeLine Int
steps Int
blockW Color
col1 Color
col2 = Builder
builder where
  p1 :: Builder
p1 = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Builder -> [Builder]
forall a. Int -> a -> [a]
replicate Int
blockW (Color -> Builder
encodeColor Color
col1)
  p2 :: Builder
p2 = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Builder -> [Builder]
forall a. Int -> a -> [a]
replicate Int
blockW (Color -> Builder
encodeColor Color
col2)
  builder :: Builder
builder = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Builder -> [Builder]
forall a. Int -> a -> [a]
replicate (Int
steps Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) (Builder
p1 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
p2)

encodeColor :: Color -> Builder
encodeColor :: Color -> Builder
encodeColor (Color Int
r Int
g Int
b Double
a) = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Builder
er, Builder
eg, Builder
eb, Builder
ea] where
  er :: Builder
er = Int8 -> Builder
B.int8 (Int8 -> Builder) -> Int8 -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r
  eg :: Builder
eg = Int8 -> Builder
B.int8 (Int8 -> Builder) -> Int8 -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
g
  eb :: Builder
eb = Int8 -> Builder
B.int8 (Int8 -> Builder) -> Int8 -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
b
  ea :: Builder
ea = Int8 -> Builder
B.int8 (Int8 -> Builder) -> Int8 -> Builder
forall a b. (a -> b) -> a -> b
$ Double -> Int8
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
255 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
a)