{-# LANGUAGE OverloadedStrings #-}

-- | Custom widgets and the reference widgets built on them.
--
-- 'customWidget' takes a 'CustomWidgetSpec': a layout, optional measurement,
-- drawing that sees hover and press state, an optional content key, a cursor,
-- and damage slop.
-- 'canvas' is the short form for drawing into a laid-out rectangle with
-- 'CanvasM'. 'useDrag2D' and 'useWheelDelta' are gesture hooks for your own
-- controls; 'knob' and 'toggleSwitch' show how they fit together.
module NanoUI.Widgets.Custom
  ( -- * Custom widgets
    CustomWidgetSpec (..)
  , defaultCustomWidgetSpec
  , customWidget
  , customWidgetWithId
  , contentKey
  , CustomDrawContext (..)
  , CustomMeasureFn
  , CustomDrawBuild
  , mkCustomDrawContext
    -- * Canvas
  , CanvasM
  , runCanvas
  , canvas
  , drawRect
  , drawRoundedRect
  , drawCircle
  , drawStroke
  , drawStrokeRoundedRect
  , drawStrokeCircle
  , drawStrokeAA
  , drawQuadGradient
  , drawLinearGradientH
  , drawLinearGradientV
  , drawImage
  , drawImageUV
  , drawText
    -- * Gestures
  , useDrag2D
  , Drag2D (..)
  , useWheelDelta
    -- * Reference widgets
  , knob
  , knob'
  , knobWith
  , knobWith'
  , toggleSwitch
  , toggleSwitch'
  , toggleSwitchWith
  , toggleSwitchWith'
  , circularProgress
  , circularProgress'
  , circularProgressWith
  , circularProgressWith'
  , spinner
  , spinner'
  , spinnerWith
  , spinnerWith'
  , progressBar
  , progressBar'
  , progressBarWith
  , progressBarWith'
  , sparkline
  , sparkline'
  , sparklineWith
  , sparklineWith'
  ) where

import Control.Monad (forM_, void, when)
import Data.IORef (readIORef)
import Data.IntMap.Strict qualified as IM
import Data.Text (Text)
import Data.Text qualified as T
import Data.Primitive.SmallArray (SmallArray, emptySmallArray, smallArrayFromList)
import Effectful (Eff, type (:>))
import NanoUI.Context
  ( Context (..)
  , CustomDrawBuild
  , CustomDrawContext (..)
  , CustomMeasureFn
  , adoptStoreFloat
  , adoptStoreInt
  , getFocusId
  , getHotId
  , getStore
  , intKey
  , isDisabled
  , recordStoreFloat
  , recordStoreInt
  , registerCustomCursor
  , registerCustomDamageSlop
  , registerCustomDrawing
  , registerCustomMeasure
  , registerFocusable
  , writeStoreBool
  , writeStoreFloat
  , widgetTheme
  , modifyStore
  , getMenuPointerGesture
  )
import NanoUI.Draw (DrawOp (..))
import NanoUI.Font (FontMetrics)
import GHC.Float (castFloatToWord32)
import NanoUI.Id (WidgetId, mix64)
import NanoUI.Input
  ( Input (..)
  , UiCursorKind (..)
  , inputMouseDown
  , inputMousePos
  , inputMousePressed
  , inputScroll
  )
import NanoUI.Layout.Arena (NodeType (NodeDrawing))
import NanoUI.Monad (Ui, askContext, askInput, nextId, uiIO, uiTime)
import NanoUI.Store (WidgetStore (..), boolInt, intBool, Slot (..), slotKey)
import NanoUI.Style
  ( AlignX (..)
  , AlignY (..)
  , Layout
  , defaultLayout
  , fillW
  , fixedH
  , fixedWH
  , styleActiveBg
  , styleBg
  , styleBorder
  , styleHoverBg
  , themeAccent
  , themeButton
  , themePanel
  , themeOnAccent
  , fadeAlpha
  )
import NanoUI.Types
  ( Color
  , ImageId (..)
  , Rect (..)
  , V2 (..)
  , clamp
  , clamp01
  , defaultDamageSlop
  , rectContains
  , v2X
  , v2Y
  )
import NanoUI.Widgets.Behavior (KeyNav (..), keyActivated, useKeyNav)
import NanoUI.Widgets.Node
  ( Response
  , addWidget
  , respClicked
  , respHovered
  , respPressed
  , respRect
  , setChanged
  )
import NanoUI.Widgets.Animate (keepAnimating)

-- -----------------------------------------------------------------------------
-- Canvas Monad
-- -----------------------------------------------------------------------------

-- | Monadic canvas builder that collects 'DrawOp' vector operations efficiently.
newtype CanvasM a = CanvasM { forall a.
CanvasM a -> ([DrawOp] -> [DrawOp]) -> (a, [DrawOp] -> [DrawOp])
runCanvasM :: ([DrawOp] -> [DrawOp]) -> (a, [DrawOp] -> [DrawOp]) }

instance Functor CanvasM where
  fmap :: forall a b. (a -> b) -> CanvasM a -> CanvasM b
fmap a -> b
f (CanvasM ([DrawOp] -> [DrawOp]) -> (a, [DrawOp] -> [DrawOp])
m) = (([DrawOp] -> [DrawOp]) -> (b, [DrawOp] -> [DrawOp])) -> CanvasM b
forall a.
(([DrawOp] -> [DrawOp]) -> (a, [DrawOp] -> [DrawOp])) -> CanvasM a
CanvasM ((([DrawOp] -> [DrawOp]) -> (b, [DrawOp] -> [DrawOp]))
 -> CanvasM b)
-> (([DrawOp] -> [DrawOp]) -> (b, [DrawOp] -> [DrawOp]))
-> CanvasM b
forall a b. (a -> b) -> a -> b
$ \[DrawOp] -> [DrawOp]
s ->
    case ([DrawOp] -> [DrawOp]) -> (a, [DrawOp] -> [DrawOp])
m [DrawOp] -> [DrawOp]
s of (a
a, [DrawOp] -> [DrawOp]
s') -> (a -> b
f a
a, [DrawOp] -> [DrawOp]
s')

instance Applicative CanvasM where
  pure :: forall a. a -> CanvasM a
pure a
a = (([DrawOp] -> [DrawOp]) -> (a, [DrawOp] -> [DrawOp])) -> CanvasM a
forall a.
(([DrawOp] -> [DrawOp]) -> (a, [DrawOp] -> [DrawOp])) -> CanvasM a
CanvasM ((([DrawOp] -> [DrawOp]) -> (a, [DrawOp] -> [DrawOp]))
 -> CanvasM a)
-> (([DrawOp] -> [DrawOp]) -> (a, [DrawOp] -> [DrawOp]))
-> CanvasM a
forall a b. (a -> b) -> a -> b
$ \[DrawOp] -> [DrawOp]
s -> (a
a, [DrawOp] -> [DrawOp]
s)
  CanvasM ([DrawOp] -> [DrawOp]) -> (a -> b, [DrawOp] -> [DrawOp])
mf <*> :: forall a b. CanvasM (a -> b) -> CanvasM a -> CanvasM b
<*> CanvasM ([DrawOp] -> [DrawOp]) -> (a, [DrawOp] -> [DrawOp])
mx = (([DrawOp] -> [DrawOp]) -> (b, [DrawOp] -> [DrawOp])) -> CanvasM b
forall a.
(([DrawOp] -> [DrawOp]) -> (a, [DrawOp] -> [DrawOp])) -> CanvasM a
CanvasM ((([DrawOp] -> [DrawOp]) -> (b, [DrawOp] -> [DrawOp]))
 -> CanvasM b)
-> (([DrawOp] -> [DrawOp]) -> (b, [DrawOp] -> [DrawOp]))
-> CanvasM b
forall a b. (a -> b) -> a -> b
$ \[DrawOp] -> [DrawOp]
s ->
    case ([DrawOp] -> [DrawOp]) -> (a -> b, [DrawOp] -> [DrawOp])
mf [DrawOp] -> [DrawOp]
s of
      (a -> b
f, [DrawOp] -> [DrawOp]
s1) -> case ([DrawOp] -> [DrawOp]) -> (a, [DrawOp] -> [DrawOp])
mx [DrawOp] -> [DrawOp]
s1 of
        (a
x, [DrawOp] -> [DrawOp]
s2) -> (a -> b
f a
x, [DrawOp] -> [DrawOp]
s2)

instance Monad CanvasM where
  CanvasM ([DrawOp] -> [DrawOp]) -> (a, [DrawOp] -> [DrawOp])
m >>= :: forall a b. CanvasM a -> (a -> CanvasM b) -> CanvasM b
>>= a -> CanvasM b
f = (([DrawOp] -> [DrawOp]) -> (b, [DrawOp] -> [DrawOp])) -> CanvasM b
forall a.
(([DrawOp] -> [DrawOp]) -> (a, [DrawOp] -> [DrawOp])) -> CanvasM a
CanvasM ((([DrawOp] -> [DrawOp]) -> (b, [DrawOp] -> [DrawOp]))
 -> CanvasM b)
-> (([DrawOp] -> [DrawOp]) -> (b, [DrawOp] -> [DrawOp]))
-> CanvasM b
forall a b. (a -> b) -> a -> b
$ \[DrawOp] -> [DrawOp]
s ->
    case ([DrawOp] -> [DrawOp]) -> (a, [DrawOp] -> [DrawOp])
m [DrawOp] -> [DrawOp]
s of (a
a, [DrawOp] -> [DrawOp]
s') -> CanvasM b -> ([DrawOp] -> [DrawOp]) -> (b, [DrawOp] -> [DrawOp])
forall a.
CanvasM a -> ([DrawOp] -> [DrawOp]) -> (a, [DrawOp] -> [DrawOp])
runCanvasM (a -> CanvasM b
f a
a) [DrawOp] -> [DrawOp]
s'

-- | Compile a 'CanvasM' block into an immutable 'SmallArray DrawOp'.
runCanvas :: CanvasM a -> SmallArray DrawOp
runCanvas :: forall a. CanvasM a -> SmallArray DrawOp
runCanvas (CanvasM ([DrawOp] -> [DrawOp]) -> (a, [DrawOp] -> [DrawOp])
m) =
  let (a
_, [DrawOp] -> [DrawOp]
diff) = ([DrawOp] -> [DrawOp]) -> (a, [DrawOp] -> [DrawOp])
m [DrawOp] -> [DrawOp]
forall a. a -> a
id
   in [DrawOp] -> SmallArray DrawOp
forall a. [a] -> SmallArray a
smallArrayFromList ([DrawOp] -> [DrawOp]
diff [])

emitOp :: DrawOp -> CanvasM ()
emitOp :: DrawOp -> CanvasM ()
emitOp DrawOp
op = (([DrawOp] -> [DrawOp]) -> ((), [DrawOp] -> [DrawOp]))
-> CanvasM ()
forall a.
(([DrawOp] -> [DrawOp]) -> (a, [DrawOp] -> [DrawOp])) -> CanvasM a
CanvasM ((([DrawOp] -> [DrawOp]) -> ((), [DrawOp] -> [DrawOp]))
 -> CanvasM ())
-> (([DrawOp] -> [DrawOp]) -> ((), [DrawOp] -> [DrawOp]))
-> CanvasM ()
forall a b. (a -> b) -> a -> b
$ \[DrawOp] -> [DrawOp]
diff -> ((), [DrawOp] -> [DrawOp]
diff ([DrawOp] -> [DrawOp])
-> ([DrawOp] -> [DrawOp]) -> [DrawOp] -> [DrawOp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DrawOp
op DrawOp -> [DrawOp] -> [DrawOp]
forall a. a -> [a] -> [a]
:))

-- | Fill a solid rectangle.
drawRect :: Rect -> Color -> CanvasM ()
drawRect :: Rect -> Color -> CanvasM ()
drawRect Rect
r Color
c = DrawOp -> CanvasM ()
emitOp (Rect -> Color -> DrawOp
FillRect Rect
r Color
c)

-- | Fill a rounded rectangle with given corner radius.
drawRoundedRect :: Rect -> Float -> Color -> CanvasM ()
drawRoundedRect :: Rect -> Float -> Color -> CanvasM ()
drawRoundedRect Rect
r Float
radius Color
c = DrawOp -> CanvasM ()
emitOp (Rect -> Float -> Color -> DrawOp
FillRoundedRect Rect
r Float
radius Color
c)

-- | Fill a solid circle at center with given radius.
drawCircle :: V2 -> Float -> Color -> CanvasM ()
drawCircle :: V2 -> Float -> Color -> CanvasM ()
drawCircle (V2 Float
cx Float
cy) Float
radius Color
c = DrawOp -> CanvasM ()
emitOp (Float -> Float -> Float -> Color -> DrawOp
FillCircle Float
cx Float
cy Float
radius Color
c)

-- | Stroke a straight segment between two points with thickness.
drawStroke :: V2 -> V2 -> Float -> Color -> CanvasM ()
drawStroke :: V2 -> V2 -> Float -> Color -> CanvasM ()
drawStroke (V2 Float
x0 Float
y0) (V2 Float
x1 Float
y1) Float
thickness Color
c = DrawOp -> CanvasM ()
emitOp (Float -> Float -> Float -> Float -> Float -> Color -> DrawOp
Stroke Float
x0 Float
y0 Float
x1 Float
y1 Float
thickness Color
c)

-- | Stroke a rounded rectangle border with given radius and stroke width.
drawStrokeRoundedRect :: Rect -> Float -> Float -> Color -> CanvasM ()
drawStrokeRoundedRect :: Rect -> Float -> Float -> Color -> CanvasM ()
drawStrokeRoundedRect Rect
r Float
radius Float
thickness Color
c = DrawOp -> CanvasM ()
emitOp (Rect -> Float -> Float -> Color -> DrawOp
StrokeRoundedRect Rect
r Float
radius Float
thickness Color
c)

-- | Stroke a circular outline at center with given radius and stroke width.
drawStrokeCircle :: V2 -> Float -> Float -> Color -> CanvasM ()
drawStrokeCircle :: V2 -> Float -> Float -> Color -> CanvasM ()
drawStrokeCircle (V2 Float
cx Float
cy) Float
radius Float
thickness Color
c = DrawOp -> CanvasM ()
emitOp (Float -> Float -> Float -> Float -> Color -> DrawOp
StrokeCircle Float
cx Float
cy Float
radius Float
thickness Color
c)

-- | Antialiased smooth stroke line between two points.
drawStrokeAA :: V2 -> V2 -> Float -> Color -> CanvasM ()
drawStrokeAA :: V2 -> V2 -> Float -> Color -> CanvasM ()
drawStrokeAA (V2 Float
x0 Float
y0) (V2 Float
x1 Float
y1) Float
thickness Color
c = DrawOp -> CanvasM ()
emitOp (Float -> Float -> Float -> Float -> Float -> Color -> DrawOp
StrokeLineAA Float
x0 Float
y0 Float
x1 Float
y1 Float
thickness Color
c)

-- | Four-corner bilinear gradient fill (top-left, top-right, bottom-right, bottom-left).
drawQuadGradient :: Rect -> Color -> Color -> Color -> Color -> CanvasM ()
drawQuadGradient :: Rect -> Color -> Color -> Color -> Color -> CanvasM ()
drawQuadGradient Rect
r Color
tl Color
tr Color
br Color
bl = DrawOp -> CanvasM ()
emitOp (Rect -> Color -> Color -> Color -> Color -> DrawOp
FillQuadGradient Rect
r Color
tl Color
tr Color
br Color
bl)

-- | Horizontal 2-color linear gradient fill (left to right).
drawLinearGradientH :: Rect -> Color -> Color -> CanvasM ()
drawLinearGradientH :: Rect -> Color -> Color -> CanvasM ()
drawLinearGradientH Rect
r Color
leftCol Color
rightCol = DrawOp -> CanvasM ()
emitOp (Rect -> Color -> Color -> Color -> Color -> DrawOp
FillQuadGradient Rect
r Color
leftCol Color
rightCol Color
rightCol Color
leftCol)

-- | Vertical 2-color linear gradient fill (top to bottom).
drawLinearGradientV :: Rect -> Color -> Color -> CanvasM ()
drawLinearGradientV :: Rect -> Color -> Color -> CanvasM ()
drawLinearGradientV Rect
r Color
topCol Color
botCol = DrawOp -> CanvasM ()
emitOp (Rect -> Color -> Color -> Color -> Color -> DrawOp
FillQuadGradient Rect
r Color
topCol Color
topCol Color
botCol Color
botCol)

-- | Draw a textured image stretched over given rectangle.
drawImage :: Rect -> ImageId -> Color -> CanvasM ()
drawImage :: Rect -> ImageId -> Color -> CanvasM ()
drawImage Rect
r (ImageId Int
tid) Color
c = DrawOp -> CanvasM ()
emitOp (Rect -> Int -> Float -> Float -> Float -> Float -> Color -> DrawOp
DrawImageRect Rect
r Int
tid Float
0 Float
0 Float
1 Float
1 Color
c)

-- | Draw a sub-region of a textured image with explicit UV texture coordinates.
drawImageUV :: Rect -> ImageId -> Float -> Float -> Float -> Float -> Color -> CanvasM ()
drawImageUV :: Rect
-> ImageId
-> Float
-> Float
-> Float
-> Float
-> Color
-> CanvasM ()
drawImageUV Rect
r (ImageId Int
tid) Float
u0 Float
v0 Float
u1 Float
v1 Color
c = DrawOp -> CanvasM ()
emitOp (Rect -> Int -> Float -> Float -> Float -> Float -> Color -> DrawOp
DrawImageRect Rect
r Int
tid Float
u0 Float
v0 Float
u1 Float
v1 Color
c)

-- | Draw text positioned at a reference point with horizontal and vertical alignment.
drawText :: V2 -> AlignX -> AlignY -> Text -> Color -> CanvasM ()
drawText :: V2 -> AlignX -> AlignY -> Text -> Color -> CanvasM ()
drawText (V2 Float
x Float
y) AlignX
alignX AlignY
alignY Text
txt Color
col =
  let ax :: Float
ax = case AlignX
alignX of AlignX
AlignStart -> Float
0; AlignX
AlignCenter -> Float
0.5; AlignX
AlignEnd -> Float
1
      ay :: Float
ay = case AlignY
alignY of AlignY
AlignTop -> Float
1; AlignY
AlignMiddle -> Float
0.5; AlignY
AlignBottom -> Float
0; AlignY
AlignBaseline -> -Float
1
   in DrawOp -> CanvasM ()
emitOp (Float -> Float -> Float -> Float -> Text -> Color -> DrawOp
DrawText Float
x Float
y Float
ax Float
ay Text
txt Color
col)

-- -----------------------------------------------------------------------------
-- Custom Widget Specification
-- -----------------------------------------------------------------------------

-- | Complete specification for defining a custom widget.
data CustomWidgetSpec a = CustomWidgetSpec
  { forall a. CustomWidgetSpec a -> Layout
widgetLayout     :: !Layout
    -- ^ Flex layout constraints (width/height sizing, min/max, alignment, padding).
  , forall a. CustomWidgetSpec a -> Maybe CustomMeasureFn
widgetMeasure    :: !(Maybe CustomMeasureFn)
    -- ^ Optional intrinsic measurement hook for 'Fit' or dynamic sizing.
  , forall a. CustomWidgetSpec a -> CustomDrawBuild
widgetDraw       :: !CustomDrawBuild
    -- ^ Vector drawing procedure receiving interaction context and layout rect.
  , forall a. CustomWidgetSpec a -> Int
widgetContent    :: !Int
    -- ^ Content key: a number that changes whenever 'widgetDraw' would draw
    -- something different from the state it reads (a value, a flag, a model
    -- revision; 'contentKey' hashes numbers into one). A frame whose key,
    -- size, interaction state and metrics are unchanged neither rebuilds the
    -- ops nor repaints the widget (a widget that only moved has its ops
    -- translated), so key a drawing whose ops are expensive to build. The default 0 means no key: the ops are rebuilt every frame and
    -- compared, which repaints correctly whatever the drawing reads but pays
    -- for the rebuild. A stale key draws stale pixels, so derive it from
    -- everything the drawing reads, an animated value included: a key is
    -- believed while the widget animates, as a versioned drawing's version is.
  , forall a.
CustomWidgetSpec a -> Maybe (CustomDrawContext -> UiCursorKind)
widgetCursor     :: !(Maybe (CustomDrawContext -> UiCursorKind))
    -- ^ Optional custom mouse cursor when pointer is over the widget.
  , forall a. CustomWidgetSpec a -> Bool
widgetFocusable  :: !Bool
    -- ^ Whether this widget accepts tab/keyboard focus.
  , forall a. CustomWidgetSpec a -> Float
widgetDamageSlop :: !Float
    -- ^ Padding added to dirty rectangles (for shadows, glow, or drag handles).
  , forall a.
CustomWidgetSpec a
-> Response -> CustomDrawContext -> Input -> (Response, a)
widgetInteract   :: !(Response -> CustomDrawContext -> Input -> (Response, a))
    -- ^ Interaction hook. It receives the widget's resolved 'Response' (hover,
    -- press, right-click, and clicks including one queued from a previous
    -- frame), the draw context and the input, and returns the final response
    -- and value.
  }

-- | Default configuration for a custom widget with standard hover/press/click behavior.
defaultCustomWidgetSpec :: CustomWidgetSpec ()
defaultCustomWidgetSpec :: CustomWidgetSpec ()
defaultCustomWidgetSpec = CustomWidgetSpec
  { widgetLayout :: Layout
widgetLayout     = Layout
defaultLayout
  , widgetMeasure :: Maybe CustomMeasureFn
widgetMeasure    = Maybe CustomMeasureFn
forall a. Maybe a
Nothing
  , widgetDraw :: CustomDrawBuild
widgetDraw       = \CustomDrawContext
_ Rect
_ -> SmallArray DrawOp
forall a. SmallArray a
emptySmallArray
  , widgetContent :: Int
widgetContent    = Int
0
  , widgetCursor :: Maybe (CustomDrawContext -> UiCursorKind)
widgetCursor     = Maybe (CustomDrawContext -> UiCursorKind)
forall a. Maybe a
Nothing
  , widgetFocusable :: Bool
widgetFocusable  = Bool
False
  , widgetDamageSlop :: Float
widgetDamageSlop = Float
defaultDamageSlop
  , widgetInteract :: Response -> CustomDrawContext -> Input -> (Response, ())
widgetInteract   = \Response
resp CustomDrawContext
_ Input
_ -> (Response
resp, ())
  }

-- | A 'widgetContent' key for a drawing whose output follows these numbers.
-- Pass every value the drawing reads; @0@ means "no key", so a hash that lands
-- there becomes 1.
{-# INLINE contentKey #-}
contentKey :: [Float] -> Int
contentKey :: [Float] -> Int
contentKey [Float]
vs =
  let raw :: Word64
raw = (Word64 -> Float -> Word64) -> Word64 -> [Float] -> Word64
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Word64
acc Float
v -> Word64 -> Word64 -> Word64
mix64 Word64
acc (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Float -> Word32
castFloatToWord32 Float
v))) Word64
0x9E3779B97F4A7C15 [Float]
vs
      k :: Int
k = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
raw
   in if Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int
1 else Int
k

-- | Build the draw context a custom widget sees, resolving hover/press/focus
-- state for @wid@ from the ambient context. One policy for state masking.
mkCustomDrawContext :: Context -> FontMetrics -> WidgetId -> IO CustomDrawContext
mkCustomDrawContext :: Context -> FontMetrics -> WidgetId -> IO CustomDrawContext
mkCustomDrawContext Context
ctx FontMetrics
fm WidgetId
wid = do
  hot <- Context -> IO WidgetId
getHotId Context
ctx
  active <- readIORef (ctxActiveId ctx)
  customDrawContext ctx fm wid (hot == wid) (active == wid)

-- | Draw context for @wid@ with the given hover and press state; a disabled
-- widget is never hovered or pressed.
customDrawContext :: Context -> FontMetrics -> WidgetId -> Bool -> Bool -> IO CustomDrawContext
customDrawContext :: Context
-> FontMetrics -> WidgetId -> Bool -> Bool -> IO CustomDrawContext
customDrawContext Context
ctx FontMetrics
fm WidgetId
wid Bool
hovered Bool
pressed = do
  disabled <- Context -> WidgetId -> IO Bool
isDisabled Context
ctx WidgetId
wid
  focused <- (== wid) <$> getFocusId ctx
  active <- readIORef (ctxActiveId ctx)
  theme <- widgetTheme ctx wid
  pure
    CustomDrawContext
      { cdcHovered = hovered && not disabled
      , cdcPressed = pressed && not disabled
      , cdcFocused = focused
      , cdcActive = active == wid
      , cdcDisabled = disabled
      , cdcTheme = theme
      , cdcFont = fm
      }

-- | Instantiates a custom widget using an existing 'WidgetId'.
customWidgetWithId :: (Ui :> es) => WidgetId -> CustomWidgetSpec a -> Eff es (Response, a)
customWidgetWithId :: forall (es :: [Effect]) a.
(Ui :> es) =>
WidgetId -> CustomWidgetSpec a -> Eff es (Response, a)
customWidgetWithId WidgetId
wid CustomWidgetSpec a
spec = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  inp <- askInput
  uiIO $ do
    when (widgetFocusable spec) $ registerFocusable ctx wid
    mapM_ (registerCustomMeasure ctx wid) (widgetMeasure spec)
    registerCustomDrawing ctx wid (widgetContent spec) (widgetDraw spec)
    mapM_ (registerCustomCursor ctx wid) (widgetCursor spec)
    when (widgetDamageSlop spec > 0) $
      registerCustomDamageSlop ctx wid (widgetDamageSlop spec)
  resp0 <- addWidget wid NodeDrawing T.empty 0 (widgetLayout spec)
  cdc <- uiIO (customDrawContext ctx (ctxFontMetrics ctx) wid (respHovered resp0) (respPressed resp0))
  pure (widgetInteract spec resp0 cdc inp)

-- | Instantiates a custom widget from a 'CustomWidgetSpec'.
--
-- Connects the widget into:
-- - The two-pass layout arena (respecting 'widgetMeasure' or layout constraints).
-- - Off-heap vector drawing pipeline. Without a 'widgetContent' key the draw
--   function runs once a frame and the widget repaints when its ops change, so
--   it may read anything; with one, an unchanged key skips both.
-- - Interactive hit-testing, focus management, and custom cursor resolution.
-- - Accurate damage region tracking with 'widgetDamageSlop'.
customWidget :: (Ui :> es) => CustomWidgetSpec a -> Eff es (Response, a)
customWidget :: forall (es :: [Effect]) a.
(Ui :> es) =>
CustomWidgetSpec a -> Eff es (Response, a)
customWidget CustomWidgetSpec a
spec = do
  wid <- Eff es WidgetId
forall (es :: [Effect]). (Ui :> es) => Eff es WidgetId
nextId
  customWidgetWithId wid spec

-- | Draw into a rectangle sized by the layout modifier. Use 'customWidget'
-- when the drawing needs hover or press state.
canvas :: (Ui :> es) => (Layout -> Layout) -> (Rect -> CanvasM ()) -> Eff es Response
canvas :: forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> (Rect -> CanvasM ()) -> Eff es Response
canvas Layout -> Layout
f Rect -> CanvasM ()
drawAction =
  (Response, ()) -> Response
forall a b. (a, b) -> a
fst ((Response, ()) -> Response)
-> Eff es (Response, ()) -> Eff es Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CustomWidgetSpec () -> Eff es (Response, ())
forall (es :: [Effect]) a.
(Ui :> es) =>
CustomWidgetSpec a -> Eff es (Response, a)
customWidget CustomWidgetSpec ()
defaultCustomWidgetSpec
    { widgetLayout = f defaultLayout
    , widgetDraw   = \CustomDrawContext
_ Rect
rect -> CanvasM () -> SmallArray DrawOp
forall a. CanvasM a -> SmallArray DrawOp
runCanvas (Rect -> CanvasM ()
drawAction Rect
rect)
    }

-- -----------------------------------------------------------------------------
-- Common Gesture & Behavior Helpers
-- -----------------------------------------------------------------------------

-- | Result of a 2D drag gesture.
data Drag2D = Drag2D
  { Drag2D -> V2
dragPosition :: !V2
    -- ^ Current dragged pointer position clamped within bounds.
  , Drag2D -> Bool
dragActive   :: !Bool
    -- ^ True while pointer is pressed and dragging is active.
  , Drag2D -> V2
dragDelta    :: !V2
    -- ^ Movement delta since previous frame.
  }
  deriving (Drag2D -> Drag2D -> Bool
(Drag2D -> Drag2D -> Bool)
-> (Drag2D -> Drag2D -> Bool) -> Eq Drag2D
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Drag2D -> Drag2D -> Bool
== :: Drag2D -> Drag2D -> Bool
$c/= :: Drag2D -> Drag2D -> Bool
/= :: Drag2D -> Drag2D -> Bool
Eq, Int -> Drag2D -> ShowS
[Drag2D] -> ShowS
Drag2D -> String
(Int -> Drag2D -> ShowS)
-> (Drag2D -> String) -> ([Drag2D] -> ShowS) -> Show Drag2D
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Drag2D -> ShowS
showsPrec :: Int -> Drag2D -> ShowS
$cshow :: Drag2D -> String
show :: Drag2D -> String
$cshowList :: [Drag2D] -> ShowS
showList :: [Drag2D] -> ShowS
Show)

-- | Tracks pointer dragging across a 2D area (e.g. for color pickers, joysticks, canvas panning).
useDrag2D ::
  (Ui :> es) =>
  Rect ->
  Eff es Drag2D
useDrag2D :: forall (es :: [Effect]). (Ui :> es) => Rect -> Eff es Drag2D
useDrag2D Rect
bounds = do
  wid <- Eff es WidgetId
forall (es :: [Effect]). (Ui :> es) => Eff es WidgetId
nextId
  ctx <- askContext
  inp <- askInput
  -- The drag flag lives in 'storeInt' and the last pointer position in
  -- 'storePoint', both under the widget's drag slot.
  let dragK = Slot -> Int -> Int
slotKey Slot
SlotDrag (WidgetId -> Int
intKey WidgetId
wid)
      mouse = Input -> V2
inputMousePos Input
inp
  store <- uiIO (getStore ctx)
  -- A press that belongs to an open menu's pointer gesture drags nothing.
  gesture <- uiIO (getMenuPointerGesture ctx)
  let active0 = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 Int
dragK (WidgetStore -> IntMap Int
storeInt WidgetStore
store) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
      active = Input -> Bool
inputMouseDown Input
inp Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
gesture Bool -> Bool -> Bool
&& (Bool
active0 Bool -> Bool -> Bool
|| (Input -> Bool
inputMousePressed Input
inp Bool -> Bool -> Bool
&& Rect -> V2 -> Bool
rectContains Rect
bounds V2
mouse))
      (prevX, prevY) = IM.findWithDefault (v2X mouse, v2Y mouse) dragK (storePoint store)
      delta =
        if Bool
active Bool -> Bool -> Bool
&& Bool
active0
          then Float -> Float -> V2
V2 (V2 -> Float
v2X V2
mouse Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
prevX) (V2 -> Float
v2Y V2
mouse Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
prevY)
          else Float -> Float -> V2
V2 Float
0 Float
0
      clampedMouse =
        Float -> Float -> V2
V2
          (Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp (Rect -> Float
rectX Rect
bounds) (Rect -> Float
rectX Rect
bounds Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Rect -> Float
rectW Rect
bounds) (V2 -> Float
v2X V2
mouse))
          (Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp (Rect -> Float
rectY Rect
bounds) (Rect -> Float
rectY Rect
bounds Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Rect -> Float
rectH Rect
bounds) (V2 -> Float
v2Y V2
mouse))
  when (active || active0) $
    uiIO $
      modifyStore ctx $ \WidgetStore
st ->
        if Bool
active
          then
            WidgetStore
st
              { storeInt = IM.insert dragK 1 (storeInt st)
              , storePoint = IM.insert dragK (v2X mouse, v2Y mouse) (storePoint st)
              }
          else
            WidgetStore
st
              { storeInt = IM.delete dragK (storeInt st)
              , storePoint = IM.delete dragK (storePoint st)
              }
  pure Drag2D { dragPosition = clampedMouse, dragActive = active, dragDelta = delta }

-- | Inspects mouse wheel scroll delta when pointer is hovering over bounds.
useWheelDelta :: (Ui :> es) => Rect -> Eff es (Float, Float)
useWheelDelta :: forall (es :: [Effect]).
(Ui :> es) =>
Rect -> Eff es (Float, Float)
useWheelDelta Rect
bounds = do
  inp <- Eff es Input
forall (es :: [Effect]). (Ui :> es) => Eff es Input
askInput
  let mouse = Input -> V2
inputMousePos Input
inp
  if rectContains bounds mouse
    then pure (v2X (inputScroll inp), v2Y (inputScroll inp))
    else pure (0, 0)

-- -----------------------------------------------------------------------------
-- Reference Custom Widgets
-- -----------------------------------------------------------------------------

-- | Rotary knob over @[minV, maxV]@, 36 px across. Drag vertically, scroll,
-- or use the arrow keys. Pass the current value; the result is the value
-- after this frame.
{-# INLINE knob #-}
knob :: Ui :> es => Float -> Float -> Float -> Eff es Float
knob :: forall (es :: [Effect]).
(Ui :> es) =>
Float -> Float -> Float -> Eff es Float
knob Float
minV Float
maxV Float
value = (Response, Float) -> Float
forall a b. (a, b) -> b
snd ((Response, Float) -> Float)
-> Eff es (Response, Float) -> Eff es Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Layout -> Layout)
-> Float -> Float -> Float -> Float -> Eff es (Response, Float)
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout)
-> Float -> Float -> Float -> Float -> Eff es (Response, Float)
knobWith' Layout -> Layout
forall a. a -> a
id Float
36 Float
minV Float
maxV Float
value

{-# INLINE knob' #-}
knob' :: Ui :> es => Float -> Float -> Float -> Eff es (Response, Float)
knob' :: forall (es :: [Effect]).
(Ui :> es) =>
Float -> Float -> Float -> Eff es (Response, Float)
knob' = (Layout -> Layout)
-> Float -> Float -> Float -> Float -> Eff es (Response, Float)
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout)
-> Float -> Float -> Float -> Float -> Eff es (Response, Float)
knobWith' Layout -> Layout
forall a. a -> a
id Float
36

-- | 'knob' with a layout modifier and a diameter in pixels.
{-# INLINE knobWith #-}
knobWith :: Ui :> es => (Layout -> Layout) -> Float -> Float -> Float -> Float -> Eff es Float
knobWith :: forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout)
-> Float -> Float -> Float -> Float -> Eff es Float
knobWith Layout -> Layout
f Float
diameter Float
minV Float
maxV Float
value = (Response, Float) -> Float
forall a b. (a, b) -> b
snd ((Response, Float) -> Float)
-> Eff es (Response, Float) -> Eff es Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Layout -> Layout)
-> Float -> Float -> Float -> Float -> Eff es (Response, Float)
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout)
-> Float -> Float -> Float -> Float -> Eff es (Response, Float)
knobWith' Layout -> Layout
f Float
diameter Float
minV Float
maxV Float
value

knobWith' ::
  Ui :> es =>
  (Layout -> Layout) -> Float -> Float -> Float -> Float -> Eff es (Response, Float)
knobWith' :: forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout)
-> Float -> Float -> Float -> Float -> Eff es (Response, Float)
knobWith' Layout -> Layout
f Float
diameter Float
minV Float
maxV Float
value = do
  wid <- Eff es WidgetId
forall (es :: [Effect]). (Ui :> es) => Eff es WidgetId
nextId
  ctx <- askContext
  let key = WidgetId -> Int
intKey WidgetId
wid
  current <- uiIO $ adoptStoreFloat ctx wid key value
  let range = Float
maxV Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
minV
      frac = if Float
range Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 then Float -> Float
clamp01 ((Float
current Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
minV) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
range) else Float
0
  (resp, ()) <- customWidgetWithId wid defaultCustomWidgetSpec
    { widgetLayout = fixedWH diameter diameter (f defaultLayout)
    , widgetMeasure = Just $ \FontMetrics
_ (Float, Float)
_ -> (Float
diameter, Float
diameter)
    , widgetCursor = Just (\CustomDrawContext
_ -> UiCursorKind
UiCursorNsResize)
    , widgetFocusable = True
    , widgetContent = contentKey [frac]
    , widgetDraw = \CustomDrawContext
cdc (Rect Float
x Float
y Float
w Float
h) -> CanvasM () -> SmallArray DrawOp
forall a. CanvasM a -> SmallArray DrawOp
runCanvas (CanvasM () -> SmallArray DrawOp)
-> CanvasM () -> SmallArray DrawOp
forall a b. (a -> b) -> a -> b
$ do
        let cx :: Float
cx = Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
            cy :: Float
cy = Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
            r :: Float
r = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min (Float
w Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) (Float
h Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2
            theme :: Theme
theme = CustomDrawContext -> Theme
cdcTheme CustomDrawContext
cdc
            hover :: Bool
hover = CustomDrawContext -> Bool
cdcHovered CustomDrawContext
cdc
            pressed :: Bool
pressed = CustomDrawContext -> Bool
cdcPressed CustomDrawContext
cdc
            bgCol :: Color
bgCol =
              if Bool
pressed
                then Style -> Color
styleActiveBg (Theme -> Style
themeButton Theme
theme)
                else if Bool
hover
                  then Style -> Color
styleHoverBg (Theme -> Style
themeButton Theme
theme)
                  else Style -> Color
styleBg (Theme -> Style
themeButton Theme
theme)
            accent :: Color
accent = Theme -> Color
themeAccent Theme
theme
            borderCol :: Color
borderCol = Style -> Color
styleBorder (Theme -> Style
themeButton Theme
theme)
            angle :: Float
angle = (Float
135 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
frac Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
270) Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
forall a. Floating a => a
pi Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
180)
            ix :: Float
ix = Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float -> Float
forall a. Floating a => a -> a
cos Float
angle Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
r Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.75)
            iy :: Float
iy = Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float -> Float
forall a. Floating a => a -> a
sin Float
angle Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
r Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.75)
        V2 -> Float -> Color -> CanvasM ()
drawCircle (Float -> Float -> V2
V2 Float
cx Float
cy) Float
r Color
bgCol
        V2 -> Float -> Float -> Color -> CanvasM ()
drawStrokeCircle (Float -> Float -> V2
V2 Float
cx Float
cy) Float
r Float
1.5 Color
borderCol
        V2 -> V2 -> Float -> Color -> CanvasM ()
drawStrokeAA (Float -> Float -> V2
V2 Float
cx Float
cy) (Float -> Float -> V2
V2 Float
ix Float
iy) Float
2.5 Color
accent
    }
  let bounds = Response -> Rect
forall r. HasResponse r => r -> Rect
respRect Response
resp
  drag <- useDrag2D bounds
  (_scrollX, scrollY) <- useWheelDelta bounds
  nav <- useKeyNav wid
  let isDragging = Drag2D -> Bool
dragActive Drag2D
drag
      dy = if Bool
isDragging then - V2 -> Float
v2Y (Drag2D -> V2
dragDelta Drag2D
drag) else Float
0
      dScroll = Float
scrollY Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
2.0
      dKey =
        (if KeyNav -> Bool
knRight KeyNav
nav Bool -> Bool -> Bool
|| KeyNav -> Bool
knUp KeyNav
nav then Int
1 else Int
0 :: Int)
          Int -> Int -> Int
forall a. Num a => a -> a -> a
- (if KeyNav -> Bool
knLeft KeyNav
nav Bool -> Bool -> Bool
|| KeyNav -> Bool
knDown KeyNav
nav then Int
1 else Int
0)
      deltaNorm =
        if Float
range Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0
          then (Float
dy Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
120.0) Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
dScroll Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
60.0) Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
dKey Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.05
          else Float
0
      finalVal =
        if Float
deltaNorm Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= Float
0
          then Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minV Float
maxV (Float
current Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
deltaNorm Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
range)
          else Float
current
  uiIO $ do
    writeStoreFloat ctx wid key finalVal
    recordStoreFloat ctx key finalVal
  pure (setChanged (finalVal /= current) resp, finalVal)

-- | On/off switch. Pass the current state; the result is the state after
-- this frame's click or Space/Enter.
{-# INLINE toggleSwitch #-}
toggleSwitch :: Ui :> es => Bool -> Eff es Bool
toggleSwitch :: forall (es :: [Effect]). (Ui :> es) => Bool -> Eff es Bool
toggleSwitch Bool
on = (Response, Bool) -> Bool
forall a b. (a, b) -> b
snd ((Response, Bool) -> Bool)
-> Eff es (Response, Bool) -> Eff es Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Layout -> Layout) -> Bool -> Eff es (Response, Bool)
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Bool -> Eff es (Response, Bool)
toggleSwitchWith' Layout -> Layout
forall a. a -> a
id Bool
on

{-# INLINE toggleSwitch' #-}
toggleSwitch' :: Ui :> es => Bool -> Eff es (Response, Bool)
toggleSwitch' :: forall (es :: [Effect]).
(Ui :> es) =>
Bool -> Eff es (Response, Bool)
toggleSwitch' = (Layout -> Layout) -> Bool -> Eff es (Response, Bool)
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Bool -> Eff es (Response, Bool)
toggleSwitchWith' Layout -> Layout
forall a. a -> a
id

-- | 'toggleSwitch' with a layout modifier.
{-# INLINE toggleSwitchWith #-}
toggleSwitchWith :: Ui :> es => (Layout -> Layout) -> Bool -> Eff es Bool
toggleSwitchWith :: forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Bool -> Eff es Bool
toggleSwitchWith Layout -> Layout
f Bool
on = (Response, Bool) -> Bool
forall a b. (a, b) -> b
snd ((Response, Bool) -> Bool)
-> Eff es (Response, Bool) -> Eff es Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Layout -> Layout) -> Bool -> Eff es (Response, Bool)
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Bool -> Eff es (Response, Bool)
toggleSwitchWith' Layout -> Layout
f Bool
on

toggleSwitchWith' :: Ui :> es => (Layout -> Layout) -> Bool -> Eff es (Response, Bool)
toggleSwitchWith' :: forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Bool -> Eff es (Response, Bool)
toggleSwitchWith' Layout -> Layout
f Bool
on = do
  wid <- Eff es WidgetId
forall (es :: [Effect]). (Ui :> es) => Eff es WidgetId
nextId
  ctx <- askContext
  let key = WidgetId -> Int
intKey WidgetId
wid
  current <- intBool <$> uiIO (adoptStoreInt ctx wid key (boolInt on))
  let pillW = Float
44.0
      pillH = Float
24.0
  (resp, ()) <- customWidgetWithId wid defaultCustomWidgetSpec
    { widgetLayout = fixedWH pillW pillH (f defaultLayout)
    , widgetMeasure = Just $ \FontMetrics
_ (Float, Float)
_ -> (Float
pillW, Float
pillH)
    , widgetCursor = Just (\CustomDrawContext
_ -> UiCursorKind
UiCursorPointer)
    , widgetFocusable = True
    , widgetContent = contentKey [if current then 1 else 0]
    , widgetDraw = \CustomDrawContext
cdc (Rect Float
x Float
y Float
w Float
h) -> CanvasM () -> SmallArray DrawOp
forall a. CanvasM a -> SmallArray DrawOp
runCanvas (CanvasM () -> SmallArray DrawOp)
-> CanvasM () -> SmallArray DrawOp
forall a b. (a -> b) -> a -> b
$ do
        let theme :: Theme
theme = CustomDrawContext -> Theme
cdcTheme CustomDrawContext
cdc
            r :: Float
r = Float
h Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
            accent :: Color
accent = Theme -> Color
themeAccent Theme
theme
            mutedCol :: Color
mutedCol = Style -> Color
styleBg (Theme -> Style
themeButton Theme
theme)
            bgCol :: Color
bgCol = if Bool
current then Color
accent else Color
mutedCol
            thumbR :: Float
thumbR = Float
r Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
3
            thumbX :: Float
thumbX = if Bool
current then (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
r) else (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
r)
            thumbY :: Float
thumbY = Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
r
            thumbCol :: Color
thumbCol = Theme -> Color
themeOnAccent Theme
theme
        Rect -> Float -> Color -> CanvasM ()
drawRoundedRect (Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
h) Float
r Color
bgCol
        Rect -> Float -> Float -> Color -> CanvasM ()
drawStrokeRoundedRect (Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
h) Float
r Float
1 (Style -> Color
styleBorder (Theme -> Style
themeButton Theme
theme))
        V2 -> Float -> Color -> CanvasM ()
drawCircle (Float -> Float -> V2
V2 Float
thumbX Float
thumbY) Float
thumbR Color
thumbCol
    }
  keyClick <- keyActivated wid
  let clicked = Response -> Bool
forall r. HasResponse r => r -> Bool
respClicked Response
resp Bool -> Bool -> Bool
|| Bool
keyClick
      newVal = Bool
current Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
clicked
  uiIO $ do
    writeStoreBool ctx wid newVal
    recordStoreInt ctx key (boolInt newVal)
  pure (setChanged clicked resp, newVal)

-- | Progress ring for a fraction in @[0, 1]@, 32 px across.
{-# INLINE circularProgress #-}
circularProgress :: Ui :> es => Float -> Eff es ()
circularProgress :: forall (es :: [Effect]). (Ui :> es) => Float -> Eff es ()
circularProgress Float
frac = Eff es Response -> Eff es ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((Layout -> Layout) -> Float -> Float -> Eff es Response
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Float -> Float -> Eff es Response
circularProgressWith' Layout -> Layout
forall a. a -> a
id Float
32 Float
frac)

{-# INLINE circularProgress' #-}
circularProgress' :: Ui :> es => Float -> Eff es Response
circularProgress' :: forall (es :: [Effect]). (Ui :> es) => Float -> Eff es Response
circularProgress' = (Layout -> Layout) -> Float -> Float -> Eff es Response
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Float -> Float -> Eff es Response
circularProgressWith' Layout -> Layout
forall a. a -> a
id Float
32

-- | 'circularProgress' with a layout modifier and a diameter in pixels.
{-# INLINE circularProgressWith #-}
circularProgressWith :: Ui :> es => (Layout -> Layout) -> Float -> Float -> Eff es ()
circularProgressWith :: forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Float -> Float -> Eff es ()
circularProgressWith Layout -> Layout
f Float
diameter Float
frac = Eff es Response -> Eff es ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((Layout -> Layout) -> Float -> Float -> Eff es Response
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Float -> Float -> Eff es Response
circularProgressWith' Layout -> Layout
f Float
diameter Float
frac)

circularProgressWith' :: Ui :> es => (Layout -> Layout) -> Float -> Float -> Eff es Response
circularProgressWith' :: forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Float -> Float -> Eff es Response
circularProgressWith' Layout -> Layout
f Float
diameter Float
frac =
  (Response, ()) -> Response
forall a b. (a, b) -> a
fst ((Response, ()) -> Response)
-> Eff es (Response, ()) -> Eff es Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CustomWidgetSpec () -> Eff es (Response, ())
forall (es :: [Effect]) a.
(Ui :> es) =>
CustomWidgetSpec a -> Eff es (Response, a)
customWidget CustomWidgetSpec ()
defaultCustomWidgetSpec
    { widgetLayout = fixedWH diameter diameter (f defaultLayout)
    , widgetMeasure = Just $ \FontMetrics
_ (Float, Float)
_ -> (Float
diameter, Float
diameter)
    , widgetContent = contentKey [clamp01 frac]
    , widgetDraw = \CustomDrawContext
cdc (Rect Float
x Float
y Float
w Float
h) -> CanvasM () -> SmallArray DrawOp
forall a. CanvasM a -> SmallArray DrawOp
runCanvas (CanvasM () -> SmallArray DrawOp)
-> CanvasM () -> SmallArray DrawOp
forall a b. (a -> b) -> a -> b
$ do
        let cx :: Float
cx = Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
            cy :: Float
cy = Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
            r :: Float
r = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min (Float
w Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) (Float
h Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2
            theme :: Theme
theme = CustomDrawContext -> Theme
cdcTheme CustomDrawContext
cdc
            trackCol :: Color
trackCol = Style -> Color
styleBorder (Theme -> Style
themeButton Theme
theme)
            accent :: Color
accent = Theme -> Color
themeAccent Theme
theme
            clampedFrac :: Float
clampedFrac = Float -> Float
clamp01 Float
frac
        V2 -> Float -> Float -> Color -> CanvasM ()
drawStrokeCircle (Float -> Float -> V2
V2 Float
cx Float
cy) Float
r Float
2.0 Color
trackCol
        Bool -> CanvasM () -> CanvasM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Float
clampedFrac Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0) (CanvasM () -> CanvasM ()) -> CanvasM () -> CanvasM ()
forall a b. (a -> b) -> a -> b
$
          V2 -> Float -> Color -> CanvasM ()
drawCircle (Float -> Float -> V2
V2 Float
cx Float
cy) (Float
r Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
clampedFrac) Color
accent
    }

-- | An indeterminate loading indicator: a short accent arc turning over a
-- faint ring, 18 px across. It keeps the frame loop running while it is on
-- screen and repaints only its own rect.
{-# INLINE spinner #-}
spinner :: Ui :> es => Eff es ()
spinner :: forall (es :: [Effect]). (Ui :> es) => Eff es ()
spinner = Eff es Response -> Eff es ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((Layout -> Layout) -> Float -> Eff es Response
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Float -> Eff es Response
spinnerWith' Layout -> Layout
forall a. a -> a
id Float
18)

{-# INLINE spinner' #-}
spinner' :: Ui :> es => Eff es Response
spinner' :: forall (es :: [Effect]). (Ui :> es) => Eff es Response
spinner' = (Layout -> Layout) -> Float -> Eff es Response
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Float -> Eff es Response
spinnerWith' Layout -> Layout
forall a. a -> a
id Float
18

-- | 'spinner' with a layout modifier and a diameter in pixels.
{-# INLINE spinnerWith #-}
spinnerWith :: Ui :> es => (Layout -> Layout) -> Float -> Eff es ()
spinnerWith :: forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Float -> Eff es ()
spinnerWith Layout -> Layout
f Float
diameter = Eff es Response -> Eff es ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((Layout -> Layout) -> Float -> Eff es Response
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Float -> Eff es Response
spinnerWith' Layout -> Layout
f Float
diameter)

spinnerWith' :: Ui :> es => (Layout -> Layout) -> Float -> Eff es Response
spinnerWith' :: forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Float -> Eff es Response
spinnerWith' Layout -> Layout
f Float
diameter = do
  t <- Eff es Double
forall (es :: [Effect]). (Ui :> es) => Eff es Double
uiTime
  let !d = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
4 Float
diameter
      -- One turn every 0.8 s, in 48 steps: the step is the content key, so
      -- frames within a step reuse the ops.
      !step = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
t Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
48 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0.8) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
48 :: Int
  resp <-
    fst <$> customWidget defaultCustomWidgetSpec
      { widgetLayout = fixedWH d d (f defaultLayout)
      , widgetMeasure = Just $ \FontMetrics
_ (Float, Float)
_ -> (Float
d, Float
d)
      , widgetContent = step + 1
      , widgetDraw = \CustomDrawContext
cdc (Rect Float
x Float
y Float
w Float
h) -> CanvasM () -> SmallArray DrawOp
forall a. CanvasM a -> SmallArray DrawOp
runCanvas (CanvasM () -> SmallArray DrawOp)
-> CanvasM () -> SmallArray DrawOp
forall a b. (a -> b) -> a -> b
$ do
          let theme :: Theme
theme = CustomDrawContext -> Theme
cdcTheme CustomDrawContext
cdc
              thick :: Float
thick = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1.5 (Float
d Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
9)
              r :: Float
r = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
w Float
h Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
thick Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
              cx :: Float
cx = Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
              cy :: Float
cy = Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
              start :: Float
start = Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
forall a. Floating a => a
pi Float -> Float -> Float
forall a. Num a => a -> a -> a
* Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
step Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
48
              at :: Float -> V2
at Float
a = Float -> Float -> V2
V2 (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
r Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float -> Float
forall a. Floating a => a -> a
cos Float
a) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
r Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float -> Float
forall a. Floating a => a -> a
sin Float
a)
              segments :: Int
segments = Int
8 :: Int
              sweep :: Float
sweep = Float
forall a. Floating a => a
pi Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
          V2 -> Float -> Float -> Color -> CanvasM ()
drawStrokeCircle (Float -> Float -> V2
V2 Float
cx Float
cy) Float
r Float
thick (Color -> Word8 -> Color
fadeAlpha (Theme -> Color
themeAccent Theme
theme) Word8
48)
          [Int] -> (Int -> CanvasM ()) -> CanvasM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
segments Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> CanvasM ()) -> CanvasM ())
-> (Int -> CanvasM ()) -> CanvasM ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
            let a0 :: Float
a0 = Float
start Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
sweep 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. Fractional a => a -> a -> a
/ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
segments
                a1 :: Float
a1 = Float
start Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
sweep Float -> Float -> Float
forall a. Num a => a -> a -> a
* Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
segments
            V2 -> V2 -> Float -> Color -> CanvasM ()
drawStrokeAA (Float -> V2
at Float
a0) (Float -> V2
at Float
a1) Float
thick (Theme -> Color
themeAccent Theme
theme)
      }
  keepAnimating resp
  pure resp

-- | Horizontal progress bar for a fraction in @[0, 1]@. It fills the
-- available width at a fixed height.
{-# INLINE progressBar #-}
progressBar :: Ui :> es => Float -> Eff es ()
progressBar :: forall (es :: [Effect]). (Ui :> es) => Float -> Eff es ()
progressBar Float
frac = Eff es Response -> Eff es ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((Layout -> Layout) -> Float -> Float -> Eff es Response
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Float -> Float -> Eff es Response
progressBarWith' Layout -> Layout
forall a. a -> a
id Float
progressBarDefaultHeight Float
frac)

{-# INLINE progressBar' #-}
progressBar' :: Ui :> es => Float -> Eff es Response
progressBar' :: forall (es :: [Effect]). (Ui :> es) => Float -> Eff es Response
progressBar' = (Layout -> Layout) -> Float -> Float -> Eff es Response
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Float -> Float -> Eff es Response
progressBarWith' Layout -> Layout
forall a. a -> a
id Float
progressBarDefaultHeight

-- | 'progressBar' with a layout modifier and a bar height in pixels.
{-# INLINE progressBarWith #-}
progressBarWith :: Ui :> es => (Layout -> Layout) -> Float -> Float -> Eff es ()
progressBarWith :: forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Float -> Float -> Eff es ()
progressBarWith Layout -> Layout
f Float
height Float
frac = Eff es Response -> Eff es ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((Layout -> Layout) -> Float -> Float -> Eff es Response
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Float -> Float -> Eff es Response
progressBarWith' Layout -> Layout
f Float
height Float
frac)

progressBarWith' :: Ui :> es => (Layout -> Layout) -> Float -> Float -> Eff es Response
progressBarWith' :: forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Float -> Float -> Eff es Response
progressBarWith' Layout -> Layout
f Float
height Float
frac =
  let !barH :: Float
barH = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 Float
height
   in (Response, ()) -> Response
forall a b. (a, b) -> a
fst ((Response, ()) -> Response)
-> Eff es (Response, ()) -> Eff es Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CustomWidgetSpec () -> Eff es (Response, ())
forall (es :: [Effect]) a.
(Ui :> es) =>
CustomWidgetSpec a -> Eff es (Response, a)
customWidget CustomWidgetSpec ()
defaultCustomWidgetSpec
        { widgetLayout = fillW (fixedH barH (f defaultLayout))
        , widgetMeasure = Just $ \FontMetrics
_ (Float, Float)
_ -> (Float
progressBarDefaultWidth, Float
barH)
        , widgetContent = contentKey [clamp01 frac]
        , widgetDraw = \CustomDrawContext
cdc (Rect Float
x Float
y Float
w Float
h) -> CanvasM () -> SmallArray DrawOp
forall a. CanvasM a -> SmallArray DrawOp
runCanvas (CanvasM () -> SmallArray DrawOp)
-> CanvasM () -> SmallArray DrawOp
forall a b. (a -> b) -> a -> b
$ do
            let theme :: Theme
theme = CustomDrawContext -> Theme
cdcTheme CustomDrawContext
cdc
                trackCol :: Color
trackCol = Style -> Color
styleBg (Theme -> Style
themeButton Theme
theme)
                borderCol :: Color
borderCol = Style -> Color
styleBorder (Theme -> Style
themeButton Theme
theme)
                fillCol :: Color
fillCol = Theme -> Color
themeAccent Theme
theme
                barW :: Float
barW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 Float
w
                barH' :: Float
barH' = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 Float
h
                rad :: Float
rad = Float
barH' Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
                clamped :: Float
clamped = Float -> Float
clamp01 Float
frac
                fillWpx :: Float
fillWpx = Float
barW Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
clamped
                fillRad :: Float
fillRad = if Float
barH' Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 then Float
0 else Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
rad (Float
fillWpx Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2)
            Rect -> Float -> Color -> CanvasM ()
drawRoundedRect (Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
barW Float
barH') Float
rad Color
trackCol
            Bool -> CanvasM () -> CanvasM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Float
clamped Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 Bool -> Bool -> Bool
&& Float
fillWpx Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0) (CanvasM () -> CanvasM ()) -> CanvasM () -> CanvasM ()
forall a b. (a -> b) -> a -> b
$
              Rect -> Float -> Color -> CanvasM ()
drawRoundedRect (Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
fillWpx Float
barH') Float
fillRad Color
fillCol
            Rect -> Float -> Float -> Color -> CanvasM ()
drawStrokeRoundedRect (Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
barW Float
barH') Float
rad Float
1 Color
borderCol
        }

-- | Default height and minimum content width for 'progressBar'.
progressBarDefaultHeight, progressBarDefaultWidth :: Float
progressBarDefaultHeight :: Float
progressBarDefaultHeight = Float
12.0
progressBarDefaultWidth :: Float
progressBarDefaultWidth = Float
120.0

-- | A small line chart of the values, 80 by 24 px, scaled to their range.
{-# INLINE sparkline #-}
sparkline :: Ui :> es => [Float] -> Eff es ()
sparkline :: forall (es :: [Effect]). (Ui :> es) => [Float] -> Eff es ()
sparkline [Float]
values = Eff es Response -> Eff es ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((Layout -> Layout) -> Float -> Float -> [Float] -> Eff es Response
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Float -> Float -> [Float] -> Eff es Response
sparklineWith' Layout -> Layout
forall a. a -> a
id Float
80 Float
24 [Float]
values)

{-# INLINE sparkline' #-}
sparkline' :: Ui :> es => [Float] -> Eff es Response
sparkline' :: forall (es :: [Effect]). (Ui :> es) => [Float] -> Eff es Response
sparkline' = (Layout -> Layout) -> Float -> Float -> [Float] -> Eff es Response
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Float -> Float -> [Float] -> Eff es Response
sparklineWith' Layout -> Layout
forall a. a -> a
id Float
80 Float
24

-- | 'sparkline' with a layout modifier and a width and height in pixels.
{-# INLINE sparklineWith #-}
sparklineWith :: Ui :> es => (Layout -> Layout) -> Float -> Float -> [Float] -> Eff es ()
sparklineWith :: forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Float -> Float -> [Float] -> Eff es ()
sparklineWith Layout -> Layout
f Float
prefW Float
prefH [Float]
values = Eff es Response -> Eff es ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((Layout -> Layout) -> Float -> Float -> [Float] -> Eff es Response
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Float -> Float -> [Float] -> Eff es Response
sparklineWith' Layout -> Layout
f Float
prefW Float
prefH [Float]
values)

sparklineWith' :: Ui :> es => (Layout -> Layout) -> Float -> Float -> [Float] -> Eff es Response
sparklineWith' :: forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Float -> Float -> [Float] -> Eff es Response
sparklineWith' Layout -> Layout
f Float
prefW Float
prefH [Float]
values =
  (Response, ()) -> Response
forall a b. (a, b) -> a
fst ((Response, ()) -> Response)
-> Eff es (Response, ()) -> Eff es Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CustomWidgetSpec () -> Eff es (Response, ())
forall (es :: [Effect]) a.
(Ui :> es) =>
CustomWidgetSpec a -> Eff es (Response, a)
customWidget CustomWidgetSpec ()
defaultCustomWidgetSpec
    { widgetLayout = fixedWH prefW prefH (f defaultLayout)
    , widgetMeasure = Just $ \FontMetrics
_ (Float, Float)
_ -> (Float
prefW, Float
prefH)
    , widgetContent = contentKey values
    , widgetDraw = \CustomDrawContext
cdc (Rect Float
x Float
y Float
rw Float
rh) -> CanvasM () -> SmallArray DrawOp
forall a. CanvasM a -> SmallArray DrawOp
runCanvas (CanvasM () -> SmallArray DrawOp)
-> CanvasM () -> SmallArray DrawOp
forall a b. (a -> b) -> a -> b
$ do
        let theme :: Theme
theme = CustomDrawContext -> Theme
cdcTheme CustomDrawContext
cdc
            accent :: Color
accent = Theme -> Color
themeAccent Theme
theme
            bg :: Color
bg = Style -> Color
styleBg (Theme -> Style
themePanel Theme
theme)
        Rect -> Float -> Color -> CanvasM ()
drawRoundedRect (Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
rw Float
rh) Float
3.0 Color
bg
        case [Float]
values of
          [] -> () -> CanvasM ()
forall a. a -> CanvasM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          [Float
_] -> V2 -> Float -> Color -> CanvasM ()
drawCircle (Float -> Float -> V2
V2 (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
rw 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
rh Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2)) Float
2.0 Color
accent
          [Float]
vs -> do
            let minV :: Float
minV = [Float] -> Float
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Float]
vs
                maxV :: Float
maxV = [Float] -> Float
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Float]
vs
                range :: Float
range = if Float
maxV Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
minV then Float
maxV Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
minV else Float
1.0
                pad :: Float
pad = Float
4.0
                plotW :: Float
plotW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1.0 (Float
rw Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
pad)
                plotH :: Float
plotH = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1.0 (Float
rh Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
pad)
                n :: Int
n = [Float] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Float]
vs
                stepX :: Float
stepX = Float
plotW Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
                pts :: [V2]
pts = [ Float -> Float -> V2
V2 (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
pad 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
stepX)
                           (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
rh Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
pad Float -> Float -> Float
forall a. Num a => a -> a -> a
- ((Float
v Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
minV) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
range) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
plotH)
                      | (Int
i, Float
v) <- [Int] -> [Float] -> [(Int, Float)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [Float]
vs
                      ]
                drawSegments :: [V2] -> CanvasM ()
drawSegments [] = () -> CanvasM ()
forall a. a -> CanvasM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                drawSegments [V2
_] = () -> CanvasM ()
forall a. a -> CanvasM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                drawSegments (V2
p1 : V2
p2 : [V2]
rest) = do
                  V2 -> V2 -> Float -> Color -> CanvasM ()
drawStrokeAA V2
p1 V2
p2 Float
1.5 Color
accent
                  [V2] -> CanvasM ()
drawSegments (V2
p2 V2 -> [V2] -> [V2]
forall a. a -> [a] -> [a]
: [V2]
rest)
            [V2] -> CanvasM ()
drawSegments [V2]
pts
            case [V2]
pts of
              [] -> () -> CanvasM ()
forall a. a -> CanvasM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              [V2]
_ -> V2 -> Float -> Color -> CanvasM ()
drawCircle ([V2] -> V2
forall a. HasCallStack => [a] -> a
last [V2]
pts) Float
2.5 Color
accent
    }