{-# LANGUAGE OverloadedStrings #-}

-- | Colour picker. The saturation / value field, the hue bar, the alpha bar and
-- the Current / New preview are separate 'NodeColorPicker' nodes in one row,
-- so each bar is its own focus stop with its own keyboard control.
module NanoUI.Widgets.ColorPicker
  ( ColorPickerPart (..)
  , colorPickerPartOf
  , widgetStoreColor
  , widgetStoreBaseColor
  , colorPickerSvSquare
  , colorPickerPartRect
  , colorPickerPreviewGeom
  , drawColorPickerPart
  , colorPicker
  , colorPicker'
  , colorPickerRGBA
  , colorPickerRGBA'
  )
where

import Control.Monad (forM_, void, when)
import Data.Bits ((.&.))
import Data.IORef (readIORef, writeIORef)
import Data.IntMap.Strict qualified as IM
import Data.Maybe (fromMaybe, isJust)
import Data.Text (Text)
import Data.Word (Word8)
import Effectful (Eff, type (:>))
import NanoUI.Context
  ( Context (..)
  , WidgetStore (..)
  , getMenuPointerGesture
  , getStore
  , intKey
  , recordStoreInt
  , registerFocusable
  , setStore
  , getsOverlay
  , OverlayState (..)
  , modifyStore
  )
import NanoUI.Draw
  ( DrawArena
  , pushQuadGradient
  , pushRect
  , pushRoundedRect
  , pushRoundedStroke
  )
import NanoUI.Font
  ( FontMetrics (..)
  )
import NanoUI.Id (WidgetId (..), hashWidgetId)
import NanoUI.Input (Input (..), Key (..), inputKeys, inputKeysElem, inputModifiers, inputMouseDown, inputMousePressed, modShift)
import NanoUI.Layout.Arena
  ( NodeArena
  , NodeIdx
  , NodeType (..)
  , getFirstChild
  , getNextSibling
  , getNodeType
  , getParent
  , getRect
  , getStyleIdx
  , getWidgetId
  )
import NanoUI.Monad (Ui, askContext, askInput, nextId, uiIO, withKey)
import NanoUI.Store (Slot (..), slotKey)
import NanoUI.Style
  ( AlignY (..)
  , Direction (..)
  , Layout (..)
  , Padding (..)
  , Sizing (..)
  , Style (..)
  , defaultLayout
  )
import NanoUI.Types
  ( Color (..)
  , Rect (..)
  , clamp
  , clamp01
  , colorA
  , colorB
  , colorFromWord32
  , colorG
  , colorR
  , colorRGBA
  , colorToWord32
  , hsvToRgb
  , rectH
  , rectW
  , rectX
  , rectY
  , rgbToHsv
  )
import NanoUI.WidgetText
  ( colorPickerGap
  , colorPickerParseHex
  , colorPickerSvH
  , colorToHex
  , colorToHexA
  )
import NanoUI.Widgets.Behavior
  ( DragAxis (..)
  , keyboardFocused
  , keyedDragHeld
  , useDrag1D
  )
import NanoUI.Widgets.Node
  ( Response (..)
  , addWidget
  , addWidgetStyled
  , container
  , respRect
  , setChanged
  )
import NanoUI.Widgets.NumericInput (NumericInputConfig (..), defaultNumericInputConfig, numericInputConfigured)
import NanoUI.Widgets.TextEditor (singleLineMode)
import NanoUI.Widgets.TextInput (editTextField)

colorPickerDefaultColor :: Color
colorPickerDefaultColor :: Color
colorPickerDefaultColor = Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
128 Word8
128 Word8
128 Word8
255

colorPickerBarW :: Float
colorPickerBarW :: Float
colorPickerBarW = Float
14

colorPickerSwatchH :: Float
colorPickerSwatchH :: Float
colorPickerSwatchH = Float
30

colorPickerSwatchW :: Float
colorPickerSwatchW :: Float
colorPickerSwatchW = Float
80

-- Width reserved for the Current / New preview column (label plus swatch).
colorPickerPreviewW :: Float
colorPickerPreviewW :: Float
colorPickerPreviewW = Float
112

-- | The piece of a colour picker a 'NodeColorPicker' node paints, kept in the
-- low bits of its style.
data ColorPickerPart = PickerSv | PickerHue | PickerAlpha | PickerPreview
  deriving (ColorPickerPart -> ColorPickerPart -> Bool
(ColorPickerPart -> ColorPickerPart -> Bool)
-> (ColorPickerPart -> ColorPickerPart -> Bool)
-> Eq ColorPickerPart
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ColorPickerPart -> ColorPickerPart -> Bool
== :: ColorPickerPart -> ColorPickerPart -> Bool
$c/= :: ColorPickerPart -> ColorPickerPart -> Bool
/= :: ColorPickerPart -> ColorPickerPart -> Bool
Eq, Int -> ColorPickerPart -> ShowS
[ColorPickerPart] -> ShowS
ColorPickerPart -> String
(Int -> ColorPickerPart -> ShowS)
-> (ColorPickerPart -> String)
-> ([ColorPickerPart] -> ShowS)
-> Show ColorPickerPart
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ColorPickerPart -> ShowS
showsPrec :: Int -> ColorPickerPart -> ShowS
$cshow :: ColorPickerPart -> String
show :: ColorPickerPart -> String
$cshowList :: [ColorPickerPart] -> ShowS
showList :: [ColorPickerPart] -> ShowS
Show, Int -> ColorPickerPart
ColorPickerPart -> Int
ColorPickerPart -> [ColorPickerPart]
ColorPickerPart -> ColorPickerPart
ColorPickerPart -> ColorPickerPart -> [ColorPickerPart]
ColorPickerPart
-> ColorPickerPart -> ColorPickerPart -> [ColorPickerPart]
(ColorPickerPart -> ColorPickerPart)
-> (ColorPickerPart -> ColorPickerPart)
-> (Int -> ColorPickerPart)
-> (ColorPickerPart -> Int)
-> (ColorPickerPart -> [ColorPickerPart])
-> (ColorPickerPart -> ColorPickerPart -> [ColorPickerPart])
-> (ColorPickerPart -> ColorPickerPart -> [ColorPickerPart])
-> (ColorPickerPart
    -> ColorPickerPart -> ColorPickerPart -> [ColorPickerPart])
-> Enum ColorPickerPart
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: ColorPickerPart -> ColorPickerPart
succ :: ColorPickerPart -> ColorPickerPart
$cpred :: ColorPickerPart -> ColorPickerPart
pred :: ColorPickerPart -> ColorPickerPart
$ctoEnum :: Int -> ColorPickerPart
toEnum :: Int -> ColorPickerPart
$cfromEnum :: ColorPickerPart -> Int
fromEnum :: ColorPickerPart -> Int
$cenumFrom :: ColorPickerPart -> [ColorPickerPart]
enumFrom :: ColorPickerPart -> [ColorPickerPart]
$cenumFromThen :: ColorPickerPart -> ColorPickerPart -> [ColorPickerPart]
enumFromThen :: ColorPickerPart -> ColorPickerPart -> [ColorPickerPart]
$cenumFromTo :: ColorPickerPart -> ColorPickerPart -> [ColorPickerPart]
enumFromTo :: ColorPickerPart -> ColorPickerPart -> [ColorPickerPart]
$cenumFromThenTo :: ColorPickerPart
-> ColorPickerPart -> ColorPickerPart -> [ColorPickerPart]
enumFromThenTo :: ColorPickerPart
-> ColorPickerPart -> ColorPickerPart -> [ColorPickerPart]
Enum, ColorPickerPart
ColorPickerPart -> ColorPickerPart -> Bounded ColorPickerPart
forall a. a -> a -> Bounded a
$cminBound :: ColorPickerPart
minBound :: ColorPickerPart
$cmaxBound :: ColorPickerPart
maxBound :: ColorPickerPart
Bounded)

{-# INLINE colorPickerPartOf #-}
colorPickerPartOf :: Int -> ColorPickerPart
colorPickerPartOf :: Int -> ColorPickerPart
colorPickerPartOf Int
si = Int -> ColorPickerPart
forall a. Enum a => Int -> a
toEnum (Int
si Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
3)

storeColorAt :: WidgetStore -> Int -> Color -> Color
storeColorAt :: WidgetStore -> Int -> Color -> Color
storeColorAt WidgetStore
store Int
key Color
fallback =
  Word32 -> Color
colorFromWord32
    ( Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral
        ( Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault
            (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Color -> Word32
colorToWord32 Color
fallback))
            Int
key
            (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
        )
    )

widgetStoreColor :: WidgetStore -> WidgetId -> Color -> Color
widgetStoreColor :: WidgetStore -> WidgetId -> Color -> Color
widgetStoreColor WidgetStore
store WidgetId
wid Color
fallback = WidgetStore -> Int -> Color -> Color
storeColorAt WidgetStore
store (WidgetId -> Int
intKey WidgetId
wid) Color
fallback

widgetStoreBaseColor :: WidgetStore -> WidgetId -> Color -> Color
widgetStoreBaseColor :: WidgetStore -> WidgetId -> Color -> Color
widgetStoreBaseColor WidgetStore
store WidgetId
wid Color
fallback =
  WidgetStore -> Int -> Color -> Color
storeColorAt
    WidgetStore
store
    (Slot -> Int -> Int
slotKey Slot
SlotColorBase (WidgetId -> Int
intKey WidgetId
wid))
    (WidgetStore -> WidgetId -> Color -> Color
widgetStoreColor WidgetStore
store WidgetId
wid Color
fallback)

-- RGB cannot tell hue 0 from 360. Keep the slider end the user last set.
widgetStoreHue :: WidgetStore -> WidgetId -> Color -> Float
widgetStoreHue :: WidgetStore -> WidgetId -> Color -> Float
widgetStoreHue WidgetStore
store WidgetId
wid Color
fallback =
  let
    (Float
h0, Float
_, Float
_) = Color -> (Float, Float, Float)
rgbToHsv (WidgetStore -> WidgetId -> Color -> Color
widgetStoreColor WidgetStore
store WidgetId
wid Color
fallback)
   in
    Float -> Int -> IntMap Float -> Float
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Float
h0 (WidgetId -> Int
intKey WidgetId
wid) (WidgetStore -> IntMap Float
storeFloat WidgetStore
store)

-- Black collapses S in RGB. Keep the last mouse S/V so the marker does not jitter.
widgetStoreSv :: WidgetStore -> WidgetId -> Color -> (Float, Float)
widgetStoreSv :: WidgetStore -> WidgetId -> Color -> (Float, Float)
widgetStoreSv WidgetStore
store WidgetId
wid Color
fallback =
  let
    (Float
_, Float
s0, Float
v0) = Color -> (Float, Float, Float)
rgbToHsv (WidgetStore -> WidgetId -> Color -> Color
widgetStoreColor WidgetStore
store WidgetId
wid Color
fallback)
   in
    (Float, Float) -> Maybe (Float, Float) -> (Float, Float)
forall a. a -> Maybe a -> a
fromMaybe (Float
s0, Float
v0) (Int -> IntMap (Float, Float) -> Maybe (Float, Float)
forall a. Int -> IntMap a -> Maybe a
IM.lookup (WidgetId -> Int
intKey WidgetId
wid) (WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
store))

-- | Store the live colour with the hue and S/V it was set through.
putColorState :: Int -> Color -> Float -> (Float, Float) -> WidgetStore -> WidgetStore
putColorState :: Int
-> Color -> Float -> (Float, Float) -> WidgetStore -> WidgetStore
putColorState Int
key Color
col Float
hue (Float, Float)
sv WidgetStore
st =
  WidgetStore
st
    { storeInt = IM.insert key (fromIntegral (colorToWord32 col)) (storeInt st)
    , storeFloat = IM.insert key hue (storeFloat st)
    , storePoint = IM.insert key sv (storePoint st)
    }

withAlpha :: Word8 -> Color -> Color
withAlpha :: Word8 -> Color -> Color
withAlpha Word8
a Color
c = Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA (Color -> Word8
colorR Color
c) (Color -> Word8
colorG Color
c) (Color -> Word8
colorB Color
c) Word8
a

-- | The square the saturation / value field fills, centered in its node.
colorPickerSvSquare :: Rect -> Rect
colorPickerSvSquare :: Rect -> Rect
colorPickerSvSquare (Rect Float
x Float
y Float
w Float
h) =
  let s :: Float
s = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
w Float
h)
   in Float -> Float -> Float -> Float -> Rect
Rect (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
s) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
h Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
s) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) Float
s Float
s

-- | The field node of the picker a part belongs to: the part's sibling that
-- paints the saturation / value square. Its widget id keys the picker's state.
pickerSvNode :: NodeArena -> NodeIdx -> IO NodeIdx
pickerSvNode :: NodeArena -> Int -> IO Int
pickerSvNode NodeArena
na Int
idx = do
  parent <- NodeArena -> Int -> IO Int
getParent NodeArena
na Int
idx
  if parent < 0 then pure idx else getFirstChild na parent >>= go
  where
    go :: Int -> IO Int
go Int
ci
      | Int
ci Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
idx
      | Bool
otherwise = do
          nt <- NodeArena -> Int -> IO NodeType
getNodeType NodeArena
na Int
ci
          si <- getStyleIdx na ci
          if nt == NodeColorPicker && colorPickerPartOf si == PickerSv
            then pure ci
            else getNextSibling na ci >>= go

-- | Where the part at @idx@ (laid out at @rect@) draws: the field's square, or
-- the part's column cut to the square's height so the bars and the preview
-- line up with the field.
colorPickerPartRect :: NodeArena -> NodeIdx -> Rect -> IO Rect
colorPickerPartRect :: NodeArena -> Int -> Rect -> IO Rect
colorPickerPartRect NodeArena
na Int
idx rect :: Rect
rect@(Rect Float
x Float
_ Float
w Float
_) = do
  si <- NodeArena -> Int -> IO Int
getStyleIdx NodeArena
na Int
idx
  case colorPickerPartOf si of
    ColorPickerPart
PickerSv -> Rect -> IO Rect
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rect -> Rect
colorPickerSvSquare Rect
rect)
    ColorPickerPart
_ -> do
      (sx, sy0, sw, sh) <- NodeArena -> Int -> IO Int
pickerSvNode NodeArena
na Int
idx IO Int
-> (Int -> IO (Float, Float, Float, Float))
-> IO (Float, Float, Float, Float)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NodeArena -> Int -> IO (Float, Float, Float, Float)
getRect NodeArena
na
      let Rect _ sy _ side = colorPickerSvSquare (Rect sx sy0 sw sh)
      pure (Rect x sy w side)

-- | The preview column's rows, stacked and centered in its band: the Current
-- label's top, its swatch, the New label's top, and its swatch.
colorPickerPreviewGeom :: FontMetrics -> Rect -> (Float, Rect, Float, Rect)
colorPickerPreviewGeom :: FontMetrics -> Rect -> (Float, Rect, Float, Rect)
colorPickerPreviewGeom FontMetrics
fm (Rect Float
x Float
y Float
w Float
h) =
  let
    labelH :: Float
labelH = FontMetrics -> Float
fmLineHeight FontMetrics
fm
    swatchW :: Float
swatchW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
colorPickerSwatchW Float
w
    swatchH :: Float
swatchH = Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
0 Float
colorPickerSwatchH (Float
h Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
labelH Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
colorPickerGap)
    stackH :: Float
stackH = Float
labelH Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
swatchH Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
colorPickerGap Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
labelH Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
swatchH
    top :: Float
top = Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 ((Float
h Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
stackH) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2)
    currentY :: Float
currentY = Float
top Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
labelH
    newLabelY :: Float
newLabelY = Float
currentY Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
swatchH Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
colorPickerGap
   in
    (Float
top, Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
currentY Float
swatchW Float
swatchH, Float
newLabelY, Float -> Float -> Float -> Float -> Rect
Rect Float
x (Float
newLabelY Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
labelH) Float
swatchW Float
swatchH)

-- Wider than the painted bar so the handle is easy to grab.
colorPickerBarHitRect :: Rect -> Rect
colorPickerBarHitRect :: Rect -> Rect
colorPickerBarHitRect (Rect Float
x Float
y Float
w Float
h) =
  let
    pad :: Float
pad = Float
2
   in
    Float -> Float -> Float -> Float -> Rect
Rect (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
pad) Float
y (Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
pad Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
2) Float
h

drawSvField :: DrawArena -> Rect -> Float -> IO ()
drawSvField :: DrawArena -> Rect -> Float -> IO ()
drawSvField DrawArena
da Rect
rect Float
hue = do
  let
    white :: Color
white = Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
255 Word8
255 Word8
255 Word8
255
    hueCol :: Color
hueCol = Float -> Float -> Float -> Color
hsvToRgb Float
hue Float
1 Float
1
    clear :: Color
clear = Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
0 Word8
0 Word8
0 Word8
0
    black :: Color
black = Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
0 Word8
0 Word8
0 Word8
255
  -- Horizontal: white to hue. Vertical overlay: fade to black (alpha over).
  DrawArena -> Rect -> Color -> Color -> Color -> Color -> IO ()
pushQuadGradient DrawArena
da Rect
rect Color
white Color
hueCol Color
hueCol Color
white
  DrawArena -> Rect -> Color -> Color -> Color -> Color -> IO ()
pushQuadGradient DrawArena
da Rect
rect Color
clear Color
clear Color
black Color
black

-- Vertical rainbow: each stop band fades into the next.
drawHueBar :: DrawArena -> Rect -> IO ()
drawHueBar :: DrawArena -> Rect -> IO ()
drawHueBar DrawArena
da Rect
rect =
  let
    stops :: Int
stops = (Int
6 :: Int)
    cellH :: Float
cellH = Rect -> Float
rectH Rect
rect Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
stops
    stopCol :: a -> Color
stopCol a
i = Float -> Float -> Float -> Color
hsvToRgb (Float
360 Float -> Float -> Float
forall a. Num a => a -> a -> a
* a -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
stops) Float
1 Float
1
   in
    (Int -> IO ()) -> [Int] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
      ( \Int
i ->
          let
            cell :: Rect
cell = Float -> Float -> Float -> Float -> Rect
Rect (Rect -> Float
rectX Rect
rect) (Rect -> Float
rectY Rect
rect Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
cellH) (Rect -> Float
rectW Rect
rect) Float
cellH
           in
            DrawArena -> Rect -> Color -> Color -> Color -> Color -> IO ()
pushQuadGradient
              DrawArena
da
              Rect
cell
              (Int -> Color
forall {a}. Integral a => a -> Color
stopCol Int
i)
              (Int -> Color
forall {a}. Integral a => a -> Color
stopCol Int
i)
              (Int -> Color
forall {a}. Integral a => a -> Color
stopCol (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
              (Int -> Color
forall {a}. Integral a => a -> Color
stopCol (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
      )
      [Int
0 .. Int
stops Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]

drawChecker :: DrawArena -> Rect -> IO ()
drawChecker :: DrawArena -> Rect -> IO ()
drawChecker DrawArena
da (Rect Float
x Float
y Float
w Float
h) = Int -> IO ()
goRows Int
0
  where
    s :: Float
s = Float
6 :: Float
    cols :: Int
cols = Float -> Int
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 Float
w Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
s) :: Int
    rows :: Int
rows = Float -> Int
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 Float
h Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
s) :: Int
    -- Nested range folds retain a shared column list under -O2. Explicit
    -- counters keep both loops numeric, without allocating that list.
    goRows :: Int -> IO ()
goRows !Int
ry = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
ry Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
rows) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Int -> Int -> IO ()
goCols Int
ry Int
0
      Int -> IO ()
goRows (Int
ry Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    goCols :: Int -> Int -> IO ()
goCols !Int
ry !Int
cx = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
cx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
cols) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      let
        col :: Color
col =
          if Int -> Bool
forall a. Integral a => a -> Bool
even (Int
ry Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cx) then Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
190 Word8
190 Word8
190 Word8
255 else Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
140 Word8
140 Word8
140 Word8
255
        rx :: Float
rx = Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
s
        ry' :: Float
ry' = Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ry Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
s
        cw :: Float
cw = Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
0 Float
s (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
rx)
        ch :: Float
ch = Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
0 Float
s (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ry')
      DrawArena -> Rect -> Color -> IO ()
pushRect DrawArena
da (Float -> Float -> Float -> Float -> Rect
Rect Float
rx Float
ry' Float
cw Float
ch) Color
col
      Int -> Int -> IO ()
goCols Int
ry (Int
cx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

drawAlphaBar :: DrawArena -> Rect -> Color -> IO ()
drawAlphaBar :: DrawArena -> Rect -> Color -> IO ()
drawAlphaBar DrawArena
da Rect
rect Color
col = do
  DrawArena -> Rect -> IO ()
drawChecker DrawArena
da Rect
rect
  let
    c0 :: Color
c0 = Word8 -> Color -> Color
withAlpha Word8
0 Color
col
    c1 :: Color
c1 = Word8 -> Color -> Color
withAlpha Word8
255 Color
col
  DrawArena -> Rect -> Color -> Color -> Color -> Color -> IO ()
pushQuadGradient DrawArena
da Rect
rect Color
c0 Color
c0 Color
c1 Color
c1

drawBarHandle :: DrawArena -> Rect -> Float -> Color -> IO ()
drawBarHandle :: DrawArena -> Rect -> Float -> Color -> IO ()
drawBarHandle DrawArena
da Rect
bar Float
cy Color
col = do
  let
    w :: Float
w = Rect -> Float
rectW Rect
bar
    x :: Float
x = Rect -> Float
rectX Rect
bar
    h :: Float
h = Float
4
    handle :: Rect
handle = Float -> Float -> Float -> Float -> Rect
Rect (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
3) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
h Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) (Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
6) Float
h
  DrawArena -> Rect -> Float -> Color -> IO ()
pushRoundedRect DrawArena
da Rect
handle Float
2 (Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
255 Word8
255 Word8
255 Word8
255)
  DrawArena -> Rect -> Float -> Float -> Color -> IO ()
pushRoundedStroke DrawArena
da Rect
handle Float
2 Float
1 Color
col

-- | Paint one part of a picker from its state in the store.
drawColorPickerPart :: NodeArena -> NodeIdx -> FontMetrics -> DrawArena -> WidgetStore -> Style -> Rect -> IO ()
drawColorPickerPart :: NodeArena
-> Int
-> FontMetrics
-> DrawArena
-> WidgetStore
-> Style
-> Rect
-> IO ()
drawColorPickerPart NodeArena
na Int
idx FontMetrics
fm DrawArena
da WidgetStore
store Style
style Rect
rect = do
  si <- NodeArena -> Int -> IO Int
getStyleIdx NodeArena
na Int
idx
  owner <- pickerSvNode na idx >>= getWidgetId na
  area <- colorPickerPartRect na idx rect
  let
    newCol = WidgetStore -> WidgetId -> Color -> Color
widgetStoreColor WidgetStore
store WidgetId
owner Color
colorPickerDefaultColor
    border = Style -> Color
styleBorder Style
style
    handleCol = Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
0 Word8
0 Word8
0 Word8
180
  case colorPickerPartOf si of
    ColorPickerPart
PickerSv -> do
      let
        hue :: Float
hue = WidgetStore -> WidgetId -> Color -> Float
widgetStoreHue WidgetStore
store WidgetId
owner Color
colorPickerDefaultColor
        (Float
sat, Float
val) = WidgetStore -> WidgetId -> Color -> (Float, Float)
widgetStoreSv WidgetStore
store WidgetId
owner Color
colorPickerDefaultColor
        marker :: Float
marker = Float
6
        mx :: Float
mx = Rect -> Float
rectX Rect
area Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
sat Float -> Float -> Float
forall a. Num a => a -> a -> a
* Rect -> Float
rectW Rect
area
        my :: Float
my = Rect -> Float
rectY Rect
area Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
val) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Rect -> Float
rectH Rect
area
        dot :: Rect
dot = Float -> Float -> Float -> Float -> Rect
Rect (Float
mx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
marker Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) (Float
my Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
marker Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) Float
marker Float
marker
      DrawArena -> Rect -> Float -> IO ()
drawSvField DrawArena
da Rect
area Float
hue
      DrawArena -> Rect -> Float -> Float -> Color -> IO ()
pushRoundedStroke DrawArena
da Rect
area Float
4 Float
1 Color
border
      DrawArena -> Rect -> Float -> Color -> IO ()
pushRoundedRect DrawArena
da Rect
dot (Float
marker Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) (Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
255 Word8
255 Word8
255 Word8
255)
      DrawArena -> Rect -> Float -> Float -> Color -> IO ()
pushRoundedStroke DrawArena
da Rect
dot (Float
marker Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) Float
1 Color
handleCol
    ColorPickerPart
PickerHue -> do
      let hue :: Float
hue = WidgetStore -> WidgetId -> Color -> Float
widgetStoreHue WidgetStore
store WidgetId
owner Color
colorPickerDefaultColor
      DrawArena -> Rect -> IO ()
drawHueBar DrawArena
da Rect
area
      DrawArena -> Rect -> Float -> Float -> Color -> IO ()
pushRoundedStroke DrawArena
da Rect
area Float
3 Float
1 Color
border
      DrawArena -> Rect -> Float -> Color -> IO ()
drawBarHandle DrawArena
da Rect
area (Rect -> Float
rectY Rect
area Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
hue Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
360) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Rect -> Float
rectH Rect
area) Color
handleCol
    ColorPickerPart
PickerAlpha -> do
      DrawArena -> Rect -> Color -> IO ()
drawAlphaBar DrawArena
da Rect
area Color
newCol
      DrawArena -> Rect -> Float -> Float -> Color -> IO ()
pushRoundedStroke DrawArena
da Rect
area Float
3 Float
1 Color
border
      DrawArena -> Rect -> Float -> Color -> IO ()
drawBarHandle DrawArena
da Rect
area (Rect -> Float
rectY Rect
area Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Word8 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Color -> Word8
colorA Color
newCol) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
255) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Rect -> Float
rectH Rect
area) Color
handleCol
    ColorPickerPart
PickerPreview -> do
      let
        (Float
_, Rect
current, Float
_, Rect
new) = FontMetrics -> Rect -> (Float, Rect, Float, Rect)
colorPickerPreviewGeom FontMetrics
fm Rect
area
        swatch :: Rect -> Color -> IO ()
swatch Rect
r Color
col = do
          DrawArena -> Rect -> IO ()
drawChecker DrawArena
da Rect
r
          DrawArena -> Rect -> Color -> IO ()
pushRect DrawArena
da Rect
r Color
col
          DrawArena -> Rect -> Float -> Float -> Color -> IO ()
pushRoundedStroke DrawArena
da Rect
r Float
0 Float
1 Color
border
      Rect -> Color -> IO ()
swatch Rect
current (WidgetStore -> WidgetId -> Color -> Color
widgetStoreBaseColor WidgetStore
store WidgetId
owner Color
colorPickerDefaultColor)
      Rect -> Color -> IO ()
swatch Rect
new Color
newCol

colorPickerLayout :: Layout
colorPickerLayout :: Layout
colorPickerLayout =
  Layout
defaultLayout
    { layoutDirection = Column
    , layoutWidth = Grow 1
    , layoutGap = colorPickerGap
    , layoutPadding = Padding 0 0 0 0
    }

-- The field, bars and preview side by side.
colorPickerCanvasLayout :: Layout
colorPickerCanvasLayout :: Layout
colorPickerCanvasLayout =
  Layout
colorPickerLayout {layoutDirection = Row}

-- The field grows up to a square as tall as the row.
colorPickerSvLayout :: Layout
colorPickerSvLayout :: Layout
colorPickerSvLayout =
  Layout
defaultLayout
    { layoutWidth = Grow 1
    , layoutHeight = Fixed colorPickerSvH
    , layoutMinW = 60
    , layoutMaxW = colorPickerSvH
    , layoutPadding = Padding 0 0 0 0
    }

colorPickerColumnLayout :: Float -> Layout
colorPickerColumnLayout :: Float -> Layout
colorPickerColumnLayout Float
w =
  Layout
colorPickerSvLayout {layoutWidth = Fixed w, layoutMinW = w, layoutMaxW = w}

-- A row of channel fields. Children are groups sized by 'percent' so the
-- R/G/B(/A) and H/S/V rows share the same column widths.
colorPickerRowLayout :: Layout
colorPickerRowLayout :: Layout
colorPickerRowLayout =
  Layout
colorPickerLayout {layoutDirection = Row, layoutAlignY = AlignMiddle}

-- One channel field: an inline label plus its bare box, taking @pct@ of the row.
colorPickerFieldGroupLayout :: Float -> Layout
colorPickerFieldGroupLayout :: Float -> Layout
colorPickerFieldGroupLayout Float
pct =
  Layout
colorPickerLayout
    { layoutDirection = Row
    , layoutWidth = Percent pct
    , layoutAlignY = AlignMiddle
    }

colorPickerFieldLayout :: Layout
colorPickerFieldLayout :: Layout
colorPickerFieldLayout =
  Layout
defaultLayout
    { layoutWidth = Grow 1
    , layoutMinW = 40
    , layoutPadding = Padding 0 0 0 0
    }

-- A numeric channel field: room for three digits beside its stepper.
colorPickerChannelLayout :: Layout
colorPickerChannelLayout :: Layout
colorPickerChannelLayout = Layout
colorPickerFieldLayout {layoutMinW = 60}

colorPickerLabelLayout :: Layout
colorPickerLabelLayout :: Layout
colorPickerLabelLayout =
  Layout
defaultLayout {layoutPadding = Padding 0 0 0 0, layoutAlignY = AlignMiddle}

-- | RGB colour picker: a saturation/value field, a hue bar, and RGB, HSV and
-- hex fields. Pass the current colour; the result is the colour after this
-- frame's edits.
--
-- The field and each bar take keyboard focus in turn. On the field the arrow
-- keys move the marker (left and right for saturation, up and down for
-- value); on a bar they move its handle, and Home and End jump to its ends.
-- Shift takes steps ten times larger.
{-# INLINE colorPicker #-}
colorPicker :: Ui :> es => Color -> Eff es Color
colorPicker :: forall (es :: [Effect]). (Ui :> es) => Color -> Eff es Color
colorPicker Color
value = (Response, Color) -> Color
forall a b. (a, b) -> b
snd ((Response, Color) -> Color)
-> Eff es (Response, Color) -> Eff es Color
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Color -> Eff es (Response, Color)
forall (es :: [Effect]).
(Ui :> es) =>
Bool -> Color -> Eff es (Response, Color)
colorPickerWith Bool
False Color
value

colorPicker' :: Ui :> es => Color -> Eff es (Response, Color)
colorPicker' :: forall (es :: [Effect]).
(Ui :> es) =>
Color -> Eff es (Response, Color)
colorPicker' = Bool -> Color -> Eff es (Response, Color)
forall (es :: [Effect]).
(Ui :> es) =>
Bool -> Color -> Eff es (Response, Color)
colorPickerWith Bool
False

-- | 'colorPicker' with an alpha bar and an A / @#RRGGBBAA@ field.
{-# INLINE colorPickerRGBA #-}
colorPickerRGBA :: Ui :> es => Color -> Eff es Color
colorPickerRGBA :: forall (es :: [Effect]). (Ui :> es) => Color -> Eff es Color
colorPickerRGBA Color
value = (Response, Color) -> Color
forall a b. (a, b) -> b
snd ((Response, Color) -> Color)
-> Eff es (Response, Color) -> Eff es Color
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Color -> Eff es (Response, Color)
forall (es :: [Effect]).
(Ui :> es) =>
Bool -> Color -> Eff es (Response, Color)
colorPickerWith Bool
True Color
value

colorPickerRGBA' :: Ui :> es => Color -> Eff es (Response, Color)
colorPickerRGBA' :: forall (es :: [Effect]).
(Ui :> es) =>
Color -> Eff es (Response, Color)
colorPickerRGBA' = Bool -> Color -> Eff es (Response, Color)
forall (es :: [Effect]).
(Ui :> es) =>
Bool -> Color -> Eff es (Response, Color)
colorPickerWith Bool
True

-- | The byte fields: label, the channel read, and the channel write.
rgbChannels, rgbaChannels :: [(Text, Color -> Word8, Word8 -> Color -> Color)]
rgbChannels :: [(Text, Color -> Word8, Word8 -> Color -> Color)]
rgbChannels =
  [ (Text
"R", Color -> Word8
colorR, \Word8
v Color
c -> Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
v (Color -> Word8
colorG Color
c) (Color -> Word8
colorB Color
c) (Color -> Word8
colorA Color
c))
  , (Text
"G", Color -> Word8
colorG, \Word8
v Color
c -> Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA (Color -> Word8
colorR Color
c) Word8
v (Color -> Word8
colorB Color
c) (Color -> Word8
colorA Color
c))
  , (Text
"B", Color -> Word8
colorB, \Word8
v Color
c -> Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA (Color -> Word8
colorR Color
c) (Color -> Word8
colorG Color
c) Word8
v (Color -> Word8
colorA Color
c))
  ]
rgbaChannels :: [(Text, Color -> Word8, Word8 -> Color -> Color)]
rgbaChannels = [(Text, Color -> Word8, Word8 -> Color -> Color)]
rgbChannels [(Text, Color -> Word8, Word8 -> Color -> Color)]
-> [(Text, Color -> Word8, Word8 -> Color -> Color)]
-> [(Text, Color -> Word8, Word8 -> Color -> Color)]
forall a. [a] -> [a] -> [a]
++ [(Text
"A", Color -> Word8
colorA, \Word8
v Color
c -> Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA (Color -> Word8
colorR Color
c) (Color -> Word8
colorG Color
c) (Color -> Word8
colorB Color
c) Word8
v)]

-- | The HSV fields: label, the largest value, the shown value, and the
-- (hue, s, v) a typed value makes.
hsvChannels :: [(Text, Int, (Float, Float, Float) -> Int, Int -> (Float, Float, Float) -> (Float, Float, Float))]
hsvChannels :: [(Text, Int, (Float, Float, Float) -> Int,
  Int -> (Float, Float, Float) -> (Float, Float, Float))]
hsvChannels =
  [ (Text
"H", Int
360, \(Float
h, Float
_, Float
_) -> Float -> Int
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Float
h, \Int
n (Float
_, Float
s, Float
v) -> (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n, Float
s, Float
v))
  , (Text
"S", Int
100, \(Float
_, Float
s, Float
_) -> Float -> Int
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Float
s Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
100), \Int
n (Float
h, Float
_, Float
v) -> (Float
h, Int -> Float
forall {a} {a}. (Fractional a, Integral a) => a -> a
percent Int
n, Float
v))
  , (Text
"V", Int
100, \(Float
_, Float
_, Float
v) -> Float -> Int
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Float
v Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
100), \Int
n (Float
h, Float
s, Float
_) -> (Float
h, Float
s, Int -> Float
forall {a} {a}. (Fractional a, Integral a) => a -> a
percent Int
n))
  ]
  where
    percent :: a -> a
percent a
n = a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
100

-- | Widget ids of a picker's parts. The field's id keys the picker's state.
data PickerParts = PickerParts
  { PickerParts -> WidgetId
ppSv :: !WidgetId
  , PickerParts -> WidgetId
ppHue :: !WidgetId
  , PickerParts -> WidgetId
ppAlpha :: !WidgetId
  , PickerParts -> WidgetId
ppPreview :: !WidgetId
  }

colorPickerWith ::
  Ui :> es => Bool -> Color -> Eff es (Response, Color)
colorPickerWith :: forall (es :: [Effect]).
(Ui :> es) =>
Bool -> Color -> Eff es (Response, Color)
colorPickerWith Bool
showAlpha Color
value = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  parts <- PickerParts <$> nextId <*> nextId <*> nextId <*> nextId
  let
    wid = PickerParts -> WidgetId
ppSv PickerParts
parts
    key = WidgetId -> Int
intKey WidgetId
wid
    pct = Float
100 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (if Bool
showAlpha then Float
4 else Float
3)
    readColor = (\WidgetStore
st -> WidgetStore -> WidgetId -> Color -> Color
widgetStoreColor WidgetStore
st WidgetId
wid Color
value) (WidgetStore -> Color) -> Eff es WidgetStore -> Eff es Color
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO WidgetStore -> Eff es WidgetStore
forall (es :: [Effect]) a. (Ui :> es) => IO a -> Eff es a
uiIO (Context -> IO WidgetStore
getStore Context
ctx)
    writePicker Color
col Float
hue (Float, Float)
sv = IO () -> Eff es ()
forall (es :: [Effect]) a. (Ui :> es) => IO a -> Eff es a
uiIO (Context -> (WidgetStore -> WidgetStore) -> IO ()
modifyStore Context
ctx (Int
-> Color -> Float -> (Float, Float) -> WidgetStore -> WidgetStore
putColorState Int
key Color
col Float
hue (Float, Float)
sv))
    writeColor Color
col =
      let (Float
h, Float
s, Float
v) = Color -> (Float, Float, Float)
rgbToHsv Color
col
       in Color -> Float -> (Float, Float) -> Eff es ()
writePicker Color
col (Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
0 Float
360 Float
h) (Float
s, Float
v)
    -- Without the alpha bar the colour stays opaque.
    alphaOf Color
c = if Bool
showAlpha then Color -> Word8
colorA Color
c else Word8
255
    part WidgetId
pid a
p Layout
lay = WidgetId
-> NodeType -> Text -> Float -> Layout -> Int -> Eff es Response
forall (es :: [Effect]).
(Ui :> es) =>
WidgetId
-> NodeType -> Text -> Float -> Layout -> Int -> Eff es Response
addWidgetStyled WidgetId
pid NodeType
NodeColorPicker Text
"" Float
0 Layout
lay (a -> Int
forall a. Enum a => a -> Int
fromEnum a
p)
  uiIO $ do
    adoptColorPickerValue ctx wid value
    mapM_ (registerFocusable ctx) (wid : ppHue parts : [ppAlpha parts | showAlpha])
  (start, final, svResp) <- container NodeContainer colorPickerLayout $ do
    (svResp, hueResp, alphaResp) <-
      container NodeContainer colorPickerCanvasLayout $ do
        sv <- part wid PickerSv colorPickerSvLayout
        hue <- part (ppHue parts) PickerHue (colorPickerColumnLayout colorPickerBarW)
        alpha <-
          if showAlpha
            then Just <$> part (ppAlpha parts) PickerAlpha (colorPickerColumnLayout colorPickerBarW)
            else pure Nothing
        void (part (ppPreview parts) PickerPreview (colorPickerColumnLayout colorPickerPreviewW))
        pure (sv, hue, alpha)
    start <- colorPickerCanvas parts value svResp hueResp alphaResp
    -- Only the focused field edits, so each row's fields share one store read.
    rgb <- readColor
    _ <- container NodeContainer colorPickerRowLayout $
      forM_ (if showAlpha then rgbaChannels else rgbChannels) $ \(Text
lbl, Color -> Word8
get, Word8 -> Color -> Color
set) -> do
        let shown :: Int
shown = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Color -> Word8
get Color
rgb)
        n <- Float -> Text -> Int -> Int -> Eff es Int
forall (es :: [Effect]).
(Ui :> es) =>
Float -> Text -> Int -> Int -> Eff es Int
channelField Float
pct Text
lbl Int
255 Int
shown
        when (n /= shown) $
          writeColor (set (fromIntegral n) (withAlpha (alphaOf rgb) rgb))
    hsvStore <- uiIO (getStore ctx)
    let
      (s0, v0) = widgetStoreSv hsvStore wid value
      hsv = (WidgetStore -> WidgetId -> Color -> Float
widgetStoreHue WidgetStore
hsvStore WidgetId
wid Color
value, Float
s0, Float
v0)
      alpha = Color -> Word8
alphaOf (WidgetStore -> WidgetId -> Color -> Color
widgetStoreColor WidgetStore
hsvStore WidgetId
wid Color
value)
    _ <- container NodeContainer colorPickerRowLayout $ do
      forM_ hsvChannels $ \(Text
lbl, Int
hi, (Float, Float, Float) -> Int
shown, Int -> (Float, Float, Float) -> (Float, Float, Float)
edit) -> do
        n <- Float -> Text -> Int -> Int -> Eff es Int
forall (es :: [Effect]).
(Ui :> es) =>
Float -> Text -> Int -> Int -> Eff es Int
channelField Float
pct Text
lbl Int
hi ((Float, Float, Float) -> Int
shown (Float, Float, Float)
hsv)
        when (n /= shown hsv) $ do
          let (h, s, v) = edit n hsv
          writePicker (withAlpha alpha (hsvToRgb h s v)) h (s, v)
      when showAlpha $
        void (container NodeContainer (colorPickerFieldGroupLayout pct) (pure ()))
    hex <- readColor
    let hexText = if Bool
showAlpha then Color -> Text
colorToHexA Color
hex else Color -> Text
colorToHex Color
hex
    hexWid <- nextId
    (_, thex, fhex, _) <- editTextField hexWid singleLineMode hexText (Just hexText)
    _ <-
      container NodeContainer (colorPickerFieldGroupLayout 100) $
        addWidgetStyled hexWid NodeTextInput "" 0 colorPickerFieldLayout 0
    when (fhex && thex /= hexText) $
      forM_ (colorPickerParseHex thex) $ \(Word8
r, Word8
g, Word8
b, Maybe Word8
ma) ->
        Color -> Eff es ()
writeColor (Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
r Word8
g Word8
b (if Bool
showAlpha then Word8 -> Maybe Word8 -> Word8
forall a. a -> Maybe a -> a
fromMaybe (Color -> Word8
colorA Color
hex) Maybe Word8
ma else Word8
255))
    final <- readColor
    pure (start, final, svResp)
  uiIO $ recordStoreInt ctx key (fromIntegral (colorToWord32 final))
  pure (setChanged (final /= start) svResp, final)

-- | The field and the bars: pointer drags, then arrow keys on whichever part
-- holds focus, then committing the "current" swatch when a drag ends or a key
-- moved the colour. Returns the colour the frame started with.
colorPickerCanvas :: Ui :> es => PickerParts -> Color -> Response -> Response -> Maybe Response -> Eff es Color
colorPickerCanvas :: forall (es :: [Effect]).
(Ui :> es) =>
PickerParts
-> Color -> Response -> Response -> Maybe Response -> Eff es Color
colorPickerCanvas PickerParts
parts Color
initial Response
svResp Response
hueResp Maybe Response
alphaResp = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  inp <- askInput
  active <- uiIO (readIORef (ctxActiveId ctx))
  blocked <- uiIO (getsOverlay ctx osLastPointerBlocked)
  gesture <- uiIO (getMenuPointerGesture ctx)
  store0 <- uiIO (getStore ctx)
  hueHeld0 <- keyedDragHeld ("hue" :: Text)
  alphaHeld0 <- keyedDragHeld ("alpha" :: Text)
  sHeld0 <- keyedDragHeld ("s" :: Text)
  vHeld0 <- keyedDragHeld ("v" :: Text)
  let
    wid = PickerParts -> WidgetId
ppSv PickerParts
parts
    showAlpha = Maybe Response -> Bool
forall a. Maybe a -> Bool
isJust Maybe Response
alphaResp
    current0 = WidgetStore -> WidgetId -> Color -> Color
widgetStoreColor WidgetStore
store0 WidgetId
wid Color
initial
    h0 = WidgetStore -> WidgetId -> Color -> Float
widgetStoreHue WidgetStore
store0 WidgetId
wid Color
initial
    (s0, v0) = widgetStoreSv store0 wid initial
    svHeld0 = Bool
sHeld0 Bool -> Bool -> Bool
|| Bool
vHeld0
    empty = Float -> Float -> Float -> Float -> Rect
Rect Float
0 Float
0 Float
0 Float
0
    isActive = WidgetId
active WidgetId -> WidgetId -> Bool
forall a. Eq a => a -> a -> Bool
== WidgetId
wid
    -- A press lands on whichever part is under the pointer; the picker then
    -- takes the active id over while it drags.
    ownsActive = WidgetId
active WidgetId -> [WidgetId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [WidgetId
wid, PickerParts -> WidgetId
ppHue PickerParts
parts, PickerParts -> WidgetId
ppAlpha PickerParts
parts, PickerParts -> WidgetId
ppPreview PickerParts
parts]
    heldByOther =
      Input -> Bool
inputMouseDown Input
inp
        Bool -> Bool -> Bool
&& Bool -> Bool
not (Input -> Bool
inputMousePressed Input
inp)
        Bool -> Bool -> Bool
&& WidgetId -> Word64
hashWidgetId WidgetId
active Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
0
        Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
ownsActive
    locked = Bool
blocked Bool -> Bool -> Bool
|| Bool
heldByOther Bool -> Bool -> Bool
|| Bool
gesture
    svSquare = Rect -> Rect
colorPickerSvSquare (Response -> Rect
forall r. HasResponse r => r -> Rect
respRect Response
svResp)
    band Response
resp = Float -> Float -> Float -> Float -> Rect
Rect (Rect -> Float
rectX (Response -> Rect
forall r. HasResponse r => r -> Rect
respRect Response
resp)) (Rect -> Float
rectY Rect
svSquare) (Rect -> Float
rectW (Response -> Rect
forall r. HasResponse r => r -> Rect
respRect Response
resp)) (Rect -> Float
rectH Rect
svSquare)
    svRect = if Bool
locked Bool -> Bool -> Bool
|| Bool
hueHeld0 Bool -> Bool -> Bool
|| Bool
alphaHeld0 then Rect
empty else Rect
svSquare
    hueRect = if Bool
locked Bool -> Bool -> Bool
|| Bool
svHeld0 Bool -> Bool -> Bool
|| Bool
alphaHeld0 then Rect
empty else Rect -> Rect
colorPickerBarHitRect (Response -> Rect
band Response
hueResp)
    alphaRect =
      case Maybe Response
alphaResp of
        Just Response
r | Bool -> Bool
not (Bool
locked Bool -> Bool -> Bool
|| Bool
svHeld0 Bool -> Bool -> Bool
|| Bool
hueHeld0) -> Rect -> Rect
colorPickerBarHitRect (Response -> Rect
band Response
r)
        Maybe Response
_ -> Rect
empty
  (sDrag, sA) <- withKey ("s" :: Text) (useDrag1D DragAxisX 0 1 s0 svRect)
  (vDrag, vA) <- withKey ("v" :: Text) (useDrag1D DragAxisY 1 0 v0 svRect)
  let svA = Bool
sA Bool -> Bool -> Bool
|| Bool
vA
  (hDrag, hA) <-
    withKey ("hue" :: Text) (useDrag1D DragAxisY 0 360 h0 (if svA then empty else hueRect))
  (aDrag, aA) <-
    withKey
      ("alpha" :: Text)
      (useDrag1D DragAxisY 0 255 (fromIntegral (colorA current0)) (if svA || hA then empty else alphaRect))
  let
    dragging = Bool
svA Bool -> Bool -> Bool
|| Bool
hA Bool -> Bool -> Bool
|| Bool
aA
    nextHue = if Bool
hA then Float
hDrag else Float
h0
    nextS = if Bool
sA then Float
sDrag else Float
s0
    nextV = if Bool
vA then Float
vDrag else Float
v0
    nextA =
      if Bool
aA then Int -> Int -> Int -> Int
forall a. Ord a => a -> a -> a -> a
clamp Int
0 Int
255 (Float -> Int
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Float
aDrag :: Int) else Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Color -> Word8
colorA Color
current0)
    base = Float -> Float -> Float -> Color
hsvToRgb Float
nextHue Float
nextS Float
nextV
    dragged
      | Bool
aA Bool -> Bool -> Bool
&& Bool -> Bool
not (Bool
svA Bool -> Bool -> Bool
|| Bool
hA) = Word8 -> Color -> Color
withAlpha (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nextA) Color
current0
      | Bool
otherwise = Word8 -> Color -> Color
withAlpha (if Bool
showAlpha then Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nextA else Word8
255) Color
base
  when (dragging && not isActive) $ uiIO $ writeIORef (ctxActiveId ctx) wid
  when ((not dragging || blocked) && isActive) $
    uiIO $ writeIORef (ctxActiveId ctx) (WidgetId 0)
  when (dragging && (dragged /= current0 || nextHue /= h0 || nextS /= s0 || nextV /= v0)) $
    uiIO $ modifyStore ctx (putColorState (intKey wid) dragged nextHue (nextS, nextV))
  svFocus <- keyboardFocused wid
  hueFocus <- keyboardFocused (ppHue parts)
  alphaFocus <- if showAlpha then keyboardFocused (ppAlpha parts) else pure False
  keyMoved <-
    if not (svFocus || hueFocus || alphaFocus)
      then pure False
      else uiIO (applyColorPickerKeys ctx wid initial inp svFocus hueFocus)
  let releasedDrag = (Bool
hueHeld0 Bool -> Bool -> Bool
|| Bool
alphaHeld0 Bool -> Bool -> Bool
|| Bool
svHeld0) Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
dragging
  when (releasedDrag || keyMoved) $
    uiIO $ do
      st <- getStore ctx
      commitColorPickerCurrent ctx wid (widgetStoreColor st wid initial)
  pure current0

-- | One channel field: an inline label and a numeric box over @0..hi@ that
-- shows @value@ while unfocused. Returns the value after this frame's edits.
channelField :: Ui :> es => Float -> Text -> Int -> Int -> Eff es Int
channelField :: forall (es :: [Effect]).
(Ui :> es) =>
Float -> Text -> Int -> Int -> Eff es Int
channelField Float
pct Text
label Int
hi Int
value =
  NodeType -> Layout -> Eff es Int -> Eff es Int
forall (es :: [Effect]) a.
(Ui :> es) =>
NodeType -> Layout -> Eff es a -> Eff es a
container NodeType
NodeContainer (Float -> Layout
colorPickerFieldGroupLayout Float
pct) (Eff es Int -> Eff es Int) -> Eff es Int -> Eff es Int
forall a b. (a -> b) -> a -> b
$ do
    labelWid <- Eff es WidgetId
forall (es :: [Effect]). (Ui :> es) => Eff es WidgetId
nextId
    void (addWidget labelWid NodeText label 0 colorPickerLabelLayout)
    round
      <$> numericInputConfigured
        defaultNumericInputConfig {nicMin = 0, nicMax = fromIntegral hi, nicLayout = colorPickerChannelLayout}
        (fromIntegral value)

-- | Adopt the caller's colour as 'NanoUI.Context.adoptStoreInt' does. A new
-- colour also resets the hue, S/V, and the "current" swatch.
adoptColorPickerValue :: Context -> WidgetId -> Color -> IO ()
adoptColorPickerValue :: Context -> WidgetId -> Color -> IO ()
adoptColorPickerValue Context
ctx WidgetId
wid Color
value = do
  store0 <- Context -> IO WidgetStore
getStore Context
ctx
  let
    key = WidgetId -> Int
intKey WidgetId
wid
    packed = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Color -> Word32
colorToWord32 Color
value)
    seenKey = Slot -> Int -> Int
slotKey Slot
SlotSeen Int
key
    ints = Int -> Int -> IntMap Int -> IntMap Int
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
seenKey Int
packed (WidgetStore -> IntMap Int
storeInt WidgetStore
store0)
  when (IM.lookup seenKey (storeInt store0) /= Just packed) $
    setStore ctx $
      if IM.lookup key (storeInt store0) == Just packed
        then store0 {storeInt = ints}
        else
          let (h, s, v) = rgbToHsv value
           in putColorState key value (clamp 0 360 h) (s, v) $
                store0 {storeInt = IM.insert (slotKey SlotColorBase key) packed ints}

commitColorPickerCurrent :: Context -> WidgetId -> Color -> IO ()
commitColorPickerCurrent :: Context -> WidgetId -> Color -> IO ()
commitColorPickerCurrent Context
ctx WidgetId
wid Color
col = do
  st <- Context -> IO WidgetStore
getStore Context
ctx
  let
    packed = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Color -> Word32
colorToWord32 Color
col)
    k = Slot -> Int -> Int
slotKey Slot
SlotColorBase (WidgetId -> Int
intKey WidgetId
wid)
    old = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
packed Int
k (WidgetStore -> IntMap Int
storeInt WidgetStore
st)
  when (old /= packed) $
    setStore ctx (st {storeInt = IM.insert k packed (storeInt st)})

-- | Arrow, Home and End keys on the focused part: the field when @svFocus@,
-- the hue bar when @hueFocus@, otherwise the alpha bar. Arrows move a part
-- the way it is drawn: the marker right for more saturation and up for more
-- value, a bar's handle down (or right) towards its bottom end. Returns
-- whether the colour moved.
applyColorPickerKeys :: Context -> WidgetId -> Color -> Input -> Bool -> Bool -> IO Bool
applyColorPickerKeys :: Context -> WidgetId -> Color -> Input -> Bool -> Bool -> IO Bool
applyColorPickerKeys Context
ctx WidgetId
wid Color
fallback Input
inp Bool
svFocus Bool
hueFocus = do
  store <- Context -> IO WidgetStore
getStore Context
ctx
  let
    keys = Input -> SmallArray Key
inputKeys Input
inp
    down Key
k = Key -> SmallArray Key -> Bool
inputKeysElem Key
k SmallArray Key
keys
    step = if Modifiers -> Bool
modShift (Input -> Modifiers
inputModifiers Input
inp) then Float
10 else Float
1
    along Key
neg Key
pos = (if Key -> Bool
down Key
pos then Float
1 else Float
0) Float -> Float -> Float
forall a. Num a => a -> a -> a
- (if Key -> Bool
down Key
neg then Float
1 else Float
0) :: Float
    dx = Key -> Key -> Float
along Key
KeyLeft Key
KeyRight
    dy = Key -> Key -> Float
along Key
KeyUp Key
KeyDown
    current = WidgetStore -> WidgetId -> Color -> Color
widgetStoreColor WidgetStore
store WidgetId
wid Color
fallback
    h = WidgetStore -> WidgetId -> Color -> Float
widgetStoreHue WidgetStore
store WidgetId
wid Color
current
    (s, v) = widgetStoreSv store wid current
    a = Word8 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Color -> Word8
colorA Color
current) :: Float
    bar Float
lo Float
hi Float
cur
      | Key -> Bool
down Key
KeyHome = Float
lo
      | Key -> Bool
down Key
KeyEnd = Float
hi
      | Bool
otherwise = Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
lo Float
hi (Float
cur Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
dx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
dy) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
step)
    (col', h', sv')
      | svFocus =
          let sat = Float -> Float
clamp01 (Float
s Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
dx Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
step Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
100)
              val = Float -> Float
clamp01 (Float
v Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
dy Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
step Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
100)
           in (withAlpha (colorA current) (hsvToRgb h sat val), h, (sat, val))
      | hueFocus =
          let hue = Float -> Float -> Float -> Float
bar Float
0 Float
360 Float
h
           in (withAlpha (colorA current) (hsvToRgb hue s v), hue, (s, v))
      | otherwise = (withAlpha (round (bar 0 255 a)) current, h, (s, v))
    moved = Color
col' Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
/= Color
current Bool -> Bool -> Bool
|| Float
h' Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= Float
h Bool -> Bool -> Bool
|| (Float, Float)
sv' (Float, Float) -> (Float, Float) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Float
s, Float
v)
  when moved $
    setStore ctx (putColorState (intKey wid) col' h' sv' store)
  pure moved