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

Slider widget, used for interacting with numeric values. It allows changing the
value by keyboard arrows, dragging the mouse or using the wheel.

Similar in objective to 'Monomer.Widgets.Singles.Dial', but more convenient in
some layouts.
-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}

module Monomer.Widgets.Singles.Slider (
  -- * Configuration
  SliderValue,
  SliderCfg,
  -- * Constructors
  hslider,
  hslider_,
  vslider,
  vslider_,
  hsliderV,
  hsliderV_,
  vsliderV,
  vsliderV_,
  sliderD_
) where

import Control.Applicative ((<|>))
import Control.Lens (ALens', (&), (^.), (.~), (%~), (<>~))
import Control.Monad
import Data.Default
import Data.Maybe
import Data.Text (Text)
import Data.Typeable (Typeable)
import GHC.Generics

import qualified Data.Sequence as Seq

import Monomer.Helper
import Monomer.Widgets.Single

import qualified Monomer.Lens as L

-- | Constraints for numeric types accepted by slider.
type SliderValue a = (Eq a, Show a, Real a, FromFractional a, Typeable a)

{-|
Configuration options for slider:

- 'width': sets the size of the secondary axis of the Slider.
- 'radius': the radius of the corners of the Slider.
- 'wheelRate': The rate at which wheel movement affects the number.
- 'dragRate': The rate at which drag movement affects the number.
- 'thumbVisible': whether a thumb should be visible or not.
- 'thumbFactor': the size of the thumb relative to width.
- 'onFocus': event to raise when focus is received.
- 'onFocusReq': 'WidgetRequest' to generate when focus is received.
- 'onBlur': event to raise when focus is lost.
- 'onBlurReq': 'WidgetRequest' to generate when focus is lost.
- 'onChange': event to raise when the value changes.
- 'onChangeReq': 'WidgetRequest' to generate when the value changes.
-}
data SliderCfg s e a = SliderCfg {
  SliderCfg s e a -> Maybe Double
_slcRadius :: Maybe Double,
  SliderCfg s e a -> Maybe Double
_slcWidth :: Maybe Double,
  SliderCfg s e a -> Maybe Rational
_slcWheelRate :: Maybe Rational,
  SliderCfg s e a -> Maybe Rational
_slcDragRate :: Maybe Rational,
  SliderCfg s e a -> Maybe Bool
_slcThumbVisible :: Maybe Bool,
  SliderCfg s e a -> Maybe Double
_slcThumbFactor :: Maybe Double,
  SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnFocusReq :: [Path -> WidgetRequest s e],
  SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnBlurReq :: [Path -> WidgetRequest s e],
  SliderCfg s e a -> [a -> WidgetRequest s e]
_slcOnChangeReq :: [a -> WidgetRequest s e]
}

instance Default (SliderCfg s e a) where
  def :: SliderCfg s e a
def = SliderCfg :: forall s e a.
Maybe Double
-> Maybe Double
-> Maybe Rational
-> Maybe Rational
-> Maybe Bool
-> Maybe Double
-> [Path -> WidgetRequest s e]
-> [Path -> WidgetRequest s e]
-> [a -> WidgetRequest s e]
-> SliderCfg s e a
SliderCfg {
    _slcRadius :: Maybe Double
_slcRadius = Maybe Double
forall a. Maybe a
Nothing,
    _slcWidth :: Maybe Double
_slcWidth = Maybe Double
forall a. Maybe a
Nothing,
    _slcWheelRate :: Maybe Rational
_slcWheelRate = Maybe Rational
forall a. Maybe a
Nothing,
    _slcDragRate :: Maybe Rational
_slcDragRate = Maybe Rational
forall a. Maybe a
Nothing,
    _slcThumbVisible :: Maybe Bool
_slcThumbVisible = Maybe Bool
forall a. Maybe a
Nothing,
    _slcThumbFactor :: Maybe Double
_slcThumbFactor = Maybe Double
forall a. Maybe a
Nothing,
    _slcOnFocusReq :: [Path -> WidgetRequest s e]
_slcOnFocusReq = [],
    _slcOnBlurReq :: [Path -> WidgetRequest s e]
_slcOnBlurReq = [],
    _slcOnChangeReq :: [a -> WidgetRequest s e]
_slcOnChangeReq = []
  }

instance Semigroup (SliderCfg s e a) where
  <> :: SliderCfg s e a -> SliderCfg s e a -> SliderCfg s e a
(<>) SliderCfg s e a
t1 SliderCfg s e a
t2 = SliderCfg :: forall s e a.
Maybe Double
-> Maybe Double
-> Maybe Rational
-> Maybe Rational
-> Maybe Bool
-> Maybe Double
-> [Path -> WidgetRequest s e]
-> [Path -> WidgetRequest s e]
-> [a -> WidgetRequest s e]
-> SliderCfg s e a
SliderCfg {
    _slcRadius :: Maybe Double
_slcRadius = SliderCfg s e a -> Maybe Double
forall s e a. SliderCfg s e a -> Maybe Double
_slcRadius SliderCfg s e a
t2 Maybe Double -> Maybe Double -> Maybe Double
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SliderCfg s e a -> Maybe Double
forall s e a. SliderCfg s e a -> Maybe Double
_slcRadius SliderCfg s e a
t1,
    _slcWidth :: Maybe Double
_slcWidth = SliderCfg s e a -> Maybe Double
forall s e a. SliderCfg s e a -> Maybe Double
_slcWidth SliderCfg s e a
t2 Maybe Double -> Maybe Double -> Maybe Double
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SliderCfg s e a -> Maybe Double
forall s e a. SliderCfg s e a -> Maybe Double
_slcWidth SliderCfg s e a
t1,
    _slcWheelRate :: Maybe Rational
_slcWheelRate = SliderCfg s e a -> Maybe Rational
forall s e a. SliderCfg s e a -> Maybe Rational
_slcWheelRate SliderCfg s e a
t2 Maybe Rational -> Maybe Rational -> Maybe Rational
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SliderCfg s e a -> Maybe Rational
forall s e a. SliderCfg s e a -> Maybe Rational
_slcWheelRate SliderCfg s e a
t1,
    _slcDragRate :: Maybe Rational
_slcDragRate = SliderCfg s e a -> Maybe Rational
forall s e a. SliderCfg s e a -> Maybe Rational
_slcDragRate SliderCfg s e a
t2 Maybe Rational -> Maybe Rational -> Maybe Rational
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SliderCfg s e a -> Maybe Rational
forall s e a. SliderCfg s e a -> Maybe Rational
_slcDragRate SliderCfg s e a
t1,
    _slcThumbVisible :: Maybe Bool
_slcThumbVisible = SliderCfg s e a -> Maybe Bool
forall s e a. SliderCfg s e a -> Maybe Bool
_slcThumbVisible SliderCfg s e a
t2 Maybe Bool -> Maybe Bool -> Maybe Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SliderCfg s e a -> Maybe Bool
forall s e a. SliderCfg s e a -> Maybe Bool
_slcThumbVisible SliderCfg s e a
t1,
    _slcThumbFactor :: Maybe Double
_slcThumbFactor = SliderCfg s e a -> Maybe Double
forall s e a. SliderCfg s e a -> Maybe Double
_slcThumbFactor SliderCfg s e a
t2 Maybe Double -> Maybe Double -> Maybe Double
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SliderCfg s e a -> Maybe Double
forall s e a. SliderCfg s e a -> Maybe Double
_slcThumbFactor SliderCfg s e a
t1,
    _slcOnFocusReq :: [Path -> WidgetRequest s e]
_slcOnFocusReq = SliderCfg s e a -> [Path -> WidgetRequest s e]
forall s e a. SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnFocusReq SliderCfg s e a
t1 [Path -> WidgetRequest s e]
-> [Path -> WidgetRequest s e] -> [Path -> WidgetRequest s e]
forall a. Semigroup a => a -> a -> a
<> SliderCfg s e a -> [Path -> WidgetRequest s e]
forall s e a. SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnFocusReq SliderCfg s e a
t2,
    _slcOnBlurReq :: [Path -> WidgetRequest s e]
_slcOnBlurReq = SliderCfg s e a -> [Path -> WidgetRequest s e]
forall s e a. SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnBlurReq SliderCfg s e a
t1 [Path -> WidgetRequest s e]
-> [Path -> WidgetRequest s e] -> [Path -> WidgetRequest s e]
forall a. Semigroup a => a -> a -> a
<> SliderCfg s e a -> [Path -> WidgetRequest s e]
forall s e a. SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnBlurReq SliderCfg s e a
t2,
    _slcOnChangeReq :: [a -> WidgetRequest s e]
_slcOnChangeReq = SliderCfg s e a -> [a -> WidgetRequest s e]
forall s e a. SliderCfg s e a -> [a -> WidgetRequest s e]
_slcOnChangeReq SliderCfg s e a
t1 [a -> WidgetRequest s e]
-> [a -> WidgetRequest s e] -> [a -> WidgetRequest s e]
forall a. Semigroup a => a -> a -> a
<> SliderCfg s e a -> [a -> WidgetRequest s e]
forall s e a. SliderCfg s e a -> [a -> WidgetRequest s e]
_slcOnChangeReq SliderCfg s e a
t2
  }

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

instance CmbWidth (SliderCfg s e a) where
  width :: Double -> SliderCfg s e a
width Double
w = SliderCfg s e a
forall a. Default a => a
def {
    _slcWidth :: Maybe Double
_slcWidth = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
w
}

instance CmbRadius (SliderCfg s e a) where
  radius :: Double -> SliderCfg s e a
radius Double
w = SliderCfg s e a
forall a. Default a => a
def {
    _slcRadius :: Maybe Double
_slcRadius = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
w
  }

instance CmbWheelRate (SliderCfg s e a) Rational where
  wheelRate :: Rational -> SliderCfg s e a
wheelRate Rational
rate = SliderCfg s e a
forall a. Default a => a
def {
    _slcWheelRate :: Maybe Rational
_slcWheelRate = Rational -> Maybe Rational
forall a. a -> Maybe a
Just Rational
rate
  }

instance CmbDragRate (SliderCfg s e a) Rational where
  dragRate :: Rational -> SliderCfg s e a
dragRate Rational
rate = SliderCfg s e a
forall a. Default a => a
def {
    _slcDragRate :: Maybe Rational
_slcDragRate = Rational -> Maybe Rational
forall a. a -> Maybe a
Just Rational
rate
  }

instance CmbThumbFactor (SliderCfg s e a) where
  thumbFactor :: Double -> SliderCfg s e a
thumbFactor Double
w = SliderCfg s e a
forall a. Default a => a
def {
    _slcThumbFactor :: Maybe Double
_slcThumbFactor = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
w
  }

instance CmbThumbVisible (SliderCfg s e a) where
  thumbVisible_ :: Bool -> SliderCfg s e a
thumbVisible_ Bool
w = SliderCfg s e a
forall a. Default a => a
def {
    _slcThumbVisible :: Maybe Bool
_slcThumbVisible = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
w
  }

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

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

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

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

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

instance CmbOnChangeReq (SliderCfg s e a) s e a where
  onChangeReq :: (a -> WidgetRequest s e) -> SliderCfg s e a
onChangeReq a -> WidgetRequest s e
req = SliderCfg s e Any
forall a. Default a => a
def {
    _slcOnChangeReq :: [a -> WidgetRequest s e]
_slcOnChangeReq = [a -> WidgetRequest s e
req]
  }

data SliderState = SliderState {
  SliderState -> Integer
_slsMaxPos :: Integer,
  SliderState -> Integer
_slsPos :: Integer
} deriving (SliderState -> SliderState -> Bool
(SliderState -> SliderState -> Bool)
-> (SliderState -> SliderState -> Bool) -> Eq SliderState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SliderState -> SliderState -> Bool
$c/= :: SliderState -> SliderState -> Bool
== :: SliderState -> SliderState -> Bool
$c== :: SliderState -> SliderState -> Bool
Eq, Int -> SliderState -> ShowS
[SliderState] -> ShowS
SliderState -> String
(Int -> SliderState -> ShowS)
-> (SliderState -> String)
-> ([SliderState] -> ShowS)
-> Show SliderState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SliderState] -> ShowS
$cshowList :: [SliderState] -> ShowS
show :: SliderState -> String
$cshow :: SliderState -> String
showsPrec :: Int -> SliderState -> ShowS
$cshowsPrec :: Int -> SliderState -> ShowS
Show, (forall x. SliderState -> Rep SliderState x)
-> (forall x. Rep SliderState x -> SliderState)
-> Generic SliderState
forall x. Rep SliderState x -> SliderState
forall x. SliderState -> Rep SliderState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SliderState x -> SliderState
$cfrom :: forall x. SliderState -> Rep SliderState x
Generic)


{-|
Creates a horizontal slider using the given lens, providing minimum and maximum
values.
-}
hslider
  :: (SliderValue a, WidgetEvent e)
  => ALens' s a
  -> a
  -> a
  -> WidgetNode s e
hslider :: ALens' s a -> a -> a -> WidgetNode s e
hslider ALens' s a
field a
minVal a
maxVal = ALens' s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
forall a e s.
(SliderValue a, WidgetEvent e) =>
ALens' s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
hslider_ ALens' s a
field a
minVal a
maxVal [SliderCfg s e a]
forall a. Default a => a
def

{-|
Creates a horizontal slider using the given lens, providing minimum and maximum
values. Accepts config.
-}
hslider_
  :: (SliderValue a, WidgetEvent e)
  => ALens' s a
  -> a
  -> a
  -> [SliderCfg s e a]
  -> WidgetNode s e
hslider_ :: ALens' s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
hslider_ ALens' s a
field a
minVal a
maxVal [SliderCfg s e a]
cfg = Bool
-> WidgetData s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
sliderD_ Bool
True WidgetData s a
wlens a
minVal a
maxVal [SliderCfg s e a]
cfg where
  wlens :: WidgetData s a
wlens = ALens' s a -> WidgetData s a
forall s a. ALens' s a -> WidgetData s a
WidgetLens ALens' s a
field

{-|
Creates a vertical slider using the given lens, providing minimum and maximum
values.
-}
vslider
  :: (SliderValue a, WidgetEvent e)
  => ALens' s a
  -> a
  -> a
  -> WidgetNode s e
vslider :: ALens' s a -> a -> a -> WidgetNode s e
vslider ALens' s a
field a
minVal a
maxVal = ALens' s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
forall a e s.
(SliderValue a, WidgetEvent e) =>
ALens' s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
vslider_ ALens' s a
field a
minVal a
maxVal [SliderCfg s e a]
forall a. Default a => a
def

{-|
Creates a vertical slider using the given lens, providing minimum and maximum
values. Accepts config.
-}
vslider_
  :: (SliderValue a, WidgetEvent e)
  => ALens' s a
  -> a
  -> a
  -> [SliderCfg s e a]
  -> WidgetNode s e
vslider_ :: ALens' s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
vslider_ ALens' s a
field a
minVal a
maxVal [SliderCfg s e a]
cfg = Bool
-> WidgetData s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
sliderD_ Bool
False WidgetData s a
wlens a
minVal a
maxVal [SliderCfg s e a]
cfg where
  wlens :: WidgetData s a
wlens = ALens' s a -> WidgetData s a
forall s a. ALens' s a -> WidgetData s a
WidgetLens ALens' s a
field

{-|
Creates a horizontal slider using the given value and 'onChange' event handler,
providing minimum and maximum values.
-}
hsliderV
  :: (SliderValue a, WidgetEvent e)
  => a
  -> (a -> e)
  -> a
  -> a
  -> WidgetNode s e
hsliderV :: a -> (a -> e) -> a -> a -> WidgetNode s e
hsliderV a
value a -> e
handler a
minVal a
maxVal = a -> (a -> e) -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
forall a e s.
(SliderValue a, WidgetEvent e) =>
a -> (a -> e) -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
hsliderV_ a
value a -> e
handler a
minVal a
maxVal [SliderCfg s e a]
forall a. Default a => a
def

{-|
Creates a horizontal slider using the given value and 'onChange' event handler,
providing minimum and maximum values. Accepts config.
-}
hsliderV_
  :: (SliderValue a, WidgetEvent e)
  => a
  -> (a -> e)
  -> a
  -> a
  -> [SliderCfg s e a]
  -> WidgetNode s e
hsliderV_ :: a -> (a -> e) -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
hsliderV_ a
value a -> e
handler a
minVal a
maxVal [SliderCfg s e a]
configs = WidgetNode s e
newNode where
  widgetData :: WidgetData s a
widgetData = a -> WidgetData s a
forall s a. a -> WidgetData s a
WidgetValue a
value
  newConfigs :: [SliderCfg s e a]
newConfigs = (a -> e) -> SliderCfg s e a
forall t a e. CmbOnChange t a e => (a -> e) -> t
onChange a -> e
handler SliderCfg s e a -> [SliderCfg s e a] -> [SliderCfg s e a]
forall a. a -> [a] -> [a]
: [SliderCfg s e a]
configs
  newNode :: WidgetNode s e
newNode = Bool
-> WidgetData s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
sliderD_ Bool
True WidgetData s a
forall s. WidgetData s a
widgetData a
minVal a
maxVal [SliderCfg s e a]
newConfigs

{-|
Creates a vertical slider using the given value and 'onChange' event handler,
providing minimum and maximum values.
-}
vsliderV
  :: (SliderValue a, WidgetEvent e)
  => a
  -> (a -> e)
  -> a
  -> a
  -> WidgetNode s e
vsliderV :: a -> (a -> e) -> a -> a -> WidgetNode s e
vsliderV a
value a -> e
handler a
minVal a
maxVal = a -> (a -> e) -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
forall a e s.
(SliderValue a, WidgetEvent e) =>
a -> (a -> e) -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
vsliderV_ a
value a -> e
handler a
minVal a
maxVal [SliderCfg s e a]
forall a. Default a => a
def

{-|
Creates a vertical slider using the given value and 'onChange' event handler,
providing minimum and maximum values. Accepts config.
-}
vsliderV_
  :: (SliderValue a, WidgetEvent e)
  => a
  -> (a -> e)
  -> a
  -> a
  -> [SliderCfg s e a]
  -> WidgetNode s e
vsliderV_ :: a -> (a -> e) -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
vsliderV_ a
value a -> e
handler a
minVal a
maxVal [SliderCfg s e a]
configs = WidgetNode s e
newNode where
  widgetData :: WidgetData s a
widgetData = a -> WidgetData s a
forall s a. a -> WidgetData s a
WidgetValue a
value
  newConfigs :: [SliderCfg s e a]
newConfigs = (a -> e) -> SliderCfg s e a
forall t a e. CmbOnChange t a e => (a -> e) -> t
onChange a -> e
handler SliderCfg s e a -> [SliderCfg s e a] -> [SliderCfg s e a]
forall a. a -> [a] -> [a]
: [SliderCfg s e a]
configs
  newNode :: WidgetNode s e
newNode = Bool
-> WidgetData s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
sliderD_ Bool
False WidgetData s a
forall s. WidgetData s a
widgetData a
minVal a
maxVal [SliderCfg s e a]
newConfigs

{-|
Creates a slider providing direction, a 'WidgetData' instance, minimum and
maximum values and config.
-}
sliderD_
  :: (SliderValue a, WidgetEvent e)
  => Bool
  -> WidgetData s a
  -> a
  -> a
  -> [SliderCfg s e a]
  -> WidgetNode s e
sliderD_ :: Bool
-> WidgetData s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
sliderD_ Bool
isHz WidgetData s a
widgetData a
minVal a
maxVal [SliderCfg s e a]
configs = WidgetNode s e
sliderNode where
  config :: SliderCfg s e a
config = [SliderCfg s e a] -> SliderCfg s e a
forall a. Monoid a => [a] -> a
mconcat [SliderCfg s e a]
configs
  state :: SliderState
state = Integer -> Integer -> SliderState
SliderState Integer
0 Integer
0
  widget :: Widget s e
widget = Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
makeSlider Bool
isHz WidgetData s a
widgetData a
minVal a
maxVal SliderCfg s e a
config SliderState
state
  sliderNode :: WidgetNode s e
sliderNode = WidgetType -> Widget s e -> WidgetNode s e
forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"slider" Widget s e
widget
    WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (WidgetNodeInfo -> Identity WidgetNodeInfo)
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Identity WidgetNodeInfo)
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> ((Bool -> Identity Bool)
    -> WidgetNodeInfo -> Identity WidgetNodeInfo)
-> (Bool -> Identity Bool)
-> WidgetNode s e
-> Identity (WidgetNode s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> WidgetNodeInfo -> Identity WidgetNodeInfo
forall s a. HasFocusable s a => Lens' s a
L.focusable ((Bool -> Identity Bool)
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Bool -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True

makeSlider
  :: (SliderValue a, WidgetEvent e)
  => Bool
  -> WidgetData s a
  -> a
  -> a
  -> SliderCfg s e a
  -> SliderState
  -> Widget s e
makeSlider :: Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
makeSlider !Bool
isHz !WidgetData s a
field !a
minVal !a
maxVal !SliderCfg s e a
config !SliderState
state = Widget s e
widget where
  widget :: Widget s e
widget = SliderState -> Single s e SliderState -> Widget s e
forall a s e. WidgetModel a => a -> Single s e a -> Widget s e
createSingle SliderState
state Single s e Any
forall a. Default a => a
def {
    singleFocusOnBtnPressed :: Bool
singleFocusOnBtnPressed = Bool
False,
    singleGetBaseStyle :: SingleGetBaseStyle s e
singleGetBaseStyle = SingleGetBaseStyle s e
forall s e p. WidgetEnv s e -> p -> Maybe Style
getBaseStyle,
    singleInit :: SingleInitHandler s e
singleInit = SingleInitHandler s e
forall s. HasModel s s => s -> WidgetNode s e -> WidgetResult s e
init,
    singleMerge :: SingleMergeHandler s e SliderState
singleMerge = SingleMergeHandler s e SliderState
forall p.
WidgetEnv s e
-> WidgetNode s e -> p -> SliderState -> WidgetResult s e
merge,
    singleHandleEvent :: SingleEventHandler s e
singleHandleEvent = SingleEventHandler s e
forall p.
WidgetEnv s e
-> WidgetNode s e -> p -> SystemEvent -> Maybe (WidgetResult s e)
handleEvent,
    singleGetSizeReq :: SingleGetSizeReqHandler s e
singleGetSizeReq = SingleGetSizeReqHandler s e
forall s e. WidgetEnv s e -> WidgetNode s e -> (SizeReq, SizeReq)
getSizeReq,
    singleRender :: SingleRenderHandler s e
singleRender = SingleRenderHandler s e
forall s e. WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render
  }

  dragRate :: Rational
dragRate
    | Maybe Rational -> Bool
forall a. Maybe a -> Bool
isJust (SliderCfg s e a -> Maybe Rational
forall s e a. SliderCfg s e a -> Maybe Rational
_slcDragRate SliderCfg s e a
config) = Maybe Rational -> Rational
forall a. HasCallStack => Maybe a -> a
fromJust (SliderCfg s e a -> Maybe Rational
forall s e a. SliderCfg s e a -> Maybe Rational
_slcDragRate SliderCfg s e a
config)
    | Bool
otherwise = a -> Rational
forall a. Real a => a -> Rational
toRational (a
maxVal a -> a -> a
forall a. Num a => a -> a -> a
- a
minVal) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
1000

  getBaseStyle :: WidgetEnv s e -> p -> Maybe Style
getBaseStyle WidgetEnv s e
wenv p
node = Style -> Maybe Style
forall a. a -> Maybe a
Just Style
style where
    style :: Style
style = WidgetEnv s e -> Lens' ThemeState StyleState -> Style
forall s e. WidgetEnv s e -> Lens' ThemeState StyleState -> Style
collectTheme WidgetEnv s e
wenv forall s a. HasSliderStyle s a => Lens' s a
Lens' ThemeState StyleState
L.sliderStyle

  init :: s -> WidgetNode s e -> WidgetResult s e
init s
wenv WidgetNode s e
node = WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
resNode where
    currVal :: a
currVal = s -> WidgetData s a -> a
forall s a. s -> WidgetData s a -> a
widgetDataGet (s
wenv s -> Getting s s s -> s
forall s a. s -> Getting a s a -> a
^. Getting s s s
forall s a. HasModel s a => Lens' s a
L.model) WidgetData s a
field
    newState :: SliderState
newState = a -> SliderState
newStateFromValue a
currVal
    resNode :: WidgetNode s e
resNode = WidgetNode s e
node
      WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasWidget s a => Lens' s a
L.widget ((Widget s e -> Identity (Widget s e))
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Widget s e -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
makeSlider Bool
isHz WidgetData s a
field a
minVal a
maxVal SliderCfg s e a
config SliderState
newState

  merge :: WidgetEnv s e
-> WidgetNode s e -> p -> SliderState -> WidgetResult s e
merge WidgetEnv s e
wenv WidgetNode s e
newNode p
oldNode SliderState
oldState = WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
resNode where
    stateVal :: a
stateVal = Integer -> a
forall a. Integral a => a -> a
valueFromPos (SliderState -> Integer
_slsPos SliderState
oldState)
    modelVal :: a
modelVal = s -> WidgetData s a -> a
forall s a. s -> WidgetData s a -> a
widgetDataGet (WidgetEnv s e
wenv WidgetEnv s e -> Getting s (WidgetEnv s e) s -> s
forall s a. s -> Getting a s a -> a
^. Getting s (WidgetEnv s e) s
forall s a. HasModel s a => Lens' s a
L.model) WidgetData s a
field
    newState :: SliderState
newState
      | WidgetEnv s e -> WidgetNode s e -> Bool
forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodePressed WidgetEnv s e
wenv WidgetNode s e
newNode = SliderState
oldState
      | a
stateVal a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
modelVal = SliderState
oldState
      | Bool
otherwise = a -> SliderState
newStateFromValue a
modelVal
    resNode :: WidgetNode s e
resNode = WidgetNode s e
newNode
      WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasWidget s a => Lens' s a
L.widget ((Widget s e -> Identity (Widget s e))
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Widget s e -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
makeSlider Bool
isHz WidgetData s a
field a
minVal a
maxVal SliderCfg s e a
config SliderState
newState

  handleEvent :: WidgetEnv s e
-> WidgetNode s e -> p -> SystemEvent -> Maybe (WidgetResult s e)
handleEvent WidgetEnv s e
wenv WidgetNode s e
node p
target SystemEvent
evt = case SystemEvent
evt of
    Focus Path
prev -> WidgetNode s e
-> Path -> [Path -> WidgetRequest s e] -> Maybe (WidgetResult s e)
forall s e.
WidgetNode s e
-> Path -> [Path -> WidgetRequest s e] -> Maybe (WidgetResult s e)
handleFocusChange WidgetNode s e
node Path
prev (SliderCfg s e a -> [Path -> WidgetRequest s e]
forall s e a. SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnFocusReq SliderCfg s e a
config)

    Blur Path
next -> WidgetNode s e
-> Path -> [Path -> WidgetRequest s e] -> Maybe (WidgetResult s e)
forall s e.
WidgetNode s e
-> Path -> [Path -> WidgetRequest s e] -> Maybe (WidgetResult s e)
handleFocusChange WidgetNode s e
node Path
next (SliderCfg s e a -> [Path -> WidgetRequest s e]
forall s e a. SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnBlurReq SliderCfg s e a
config)

    KeyAction KeyMod
mod KeyCode
code KeyStatus
KeyPressed
      | Bool
ctrlPressed Bool -> Bool -> Bool
&& KeyCode -> Bool
isInc KeyCode
code -> Integer -> Maybe (WidgetResult s e)
handleNewPos (Integer
pos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
warpSpeed)
      | Bool
ctrlPressed Bool -> Bool -> Bool
&& KeyCode -> Bool
isDec KeyCode
code -> Integer -> Maybe (WidgetResult s e)
handleNewPos (Integer
pos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
warpSpeed)
      | Bool
shiftPressed Bool -> Bool -> Bool
&& KeyCode -> Bool
isInc KeyCode
code -> Integer -> Maybe (WidgetResult s e)
handleNewPos (Integer
pos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
baseSpeed)
      | Bool
shiftPressed Bool -> Bool -> Bool
&& KeyCode -> Bool
isDec KeyCode
code -> Integer -> Maybe (WidgetResult s e)
handleNewPos (Integer
pos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
baseSpeed)
      | KeyCode -> Bool
isInc KeyCode
code -> Integer -> Maybe (WidgetResult s e)
handleNewPos (Integer
pos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
fastSpeed)
      | KeyCode -> Bool
isDec KeyCode
code -> Integer -> Maybe (WidgetResult s e)
handleNewPos (Integer
pos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
fastSpeed)
      where
        ctrlPressed :: Bool
ctrlPressed = WidgetEnv s e -> KeyMod -> Bool
forall s e. WidgetEnv s e -> KeyMod -> Bool
isShortCutControl WidgetEnv s e
wenv KeyMod
mod
        (KeyCode -> Bool
isDec, KeyCode -> Bool
isInc)
          | Bool
isHz = (KeyCode -> Bool
isKeyLeft, KeyCode -> Bool
isKeyRight)
          | Bool
otherwise = (KeyCode -> Bool
isKeyDown, KeyCode -> Bool
isKeyUp)

        baseSpeed :: Integer
baseSpeed = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
1 (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxPos Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1000)
        fastSpeed :: Integer
fastSpeed = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
1 (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxPos Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
100)
        warpSpeed :: Integer
warpSpeed = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
1 (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxPos Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
10)

        handleNewPos :: Integer -> Maybe (WidgetResult s e)
handleNewPos !Integer
newPos
          | Integer
validPos Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
pos = Integer -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPos Integer
validPos []
          | Bool
otherwise = Maybe (WidgetResult s e)
forall a. Maybe a
Nothing
          where
            validPos :: Integer
validPos = Integer -> Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a -> a
clamp Integer
0 Integer
maxPos Integer
newPos

    Move Point
point
      | WidgetEnv s e -> WidgetNode s e -> Bool
forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodePressed WidgetEnv s e
wenv WidgetNode s e
node -> Point -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
forall s.
(HasX s Double, HasY s Double) =>
s -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPoint Point
point []

    ButtonAction Point
point Button
btn ButtonState
BtnPressed Int
clicks -> Point -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
forall s.
(HasX s Double, HasY s Double) =>
s -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPoint Point
point [WidgetRequest s e]
forall s e. [WidgetRequest s e]
reqs where
      reqs :: [WidgetRequest s e]
reqs
        | Bool
shiftPressed = []
        | Bool
otherwise = [WidgetId -> WidgetRequest s e
forall s e. WidgetId -> WidgetRequest s e
SetFocus WidgetId
widgetId]

    ButtonAction Point
point Button
btn ButtonState
BtnReleased Int
clicks  -> Point -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
forall s.
(HasX s Double, HasY s Double) =>
s -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPoint Point
point []

    WheelScroll Point
_ (Point Double
_ Double
wy) WheelDirection
wheelDirection -> Integer -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPos Integer
newPos [] where
      wheelCfg :: Rational
wheelCfg = Rational -> Maybe Rational -> Rational
forall a. a -> Maybe a -> a
fromMaybe (ThemeState
theme ThemeState -> Getting Rational ThemeState Rational -> Rational
forall s a. s -> Getting a s a -> a
^. Getting Rational ThemeState Rational
forall s a. HasSliderWheelRate s a => Lens' s a
L.sliderWheelRate) (SliderCfg s e a -> Maybe Rational
forall s e a. SliderCfg s e a -> Maybe Rational
_slcWheelRate SliderCfg s e a
config)
      wheelRate :: Double
wheelRate = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
wheelCfg
      tmpPos :: Integer
tmpPos = Integer
pos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
wy Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
wheelRate)
      newPos :: Integer
newPos = Integer -> Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a -> a
clamp Integer
0 Integer
maxPos Integer
tmpPos
    SystemEvent
_ -> Maybe (WidgetResult s e)
forall a. Maybe a
Nothing
    where
      theme :: ThemeState
theme = WidgetEnv s e -> WidgetNode s e -> ThemeState
forall s e. WidgetEnv s e -> WidgetNode s e -> ThemeState
currentTheme WidgetEnv s e
wenv WidgetNode s e
node
      style :: StyleState
style = WidgetEnv s e -> WidgetNode s e -> StyleState
forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle WidgetEnv s e
wenv WidgetNode s e
node
      vp :: Rect
vp = WidgetNode s e -> StyleState -> Rect
forall s e. WidgetNode s e -> StyleState -> Rect
getContentArea WidgetNode s e
node StyleState
style
      widgetId :: WidgetId
widgetId = WidgetNode s e
node WidgetNode s e
-> Getting WidgetId (WidgetNode s e) WidgetId -> WidgetId
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> WidgetNode s e -> Const WidgetId (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
 -> WidgetNode s e -> Const WidgetId (WidgetNode s e))
-> ((WidgetId -> Const WidgetId WidgetId)
    -> WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> Getting WidgetId (WidgetNode s e) WidgetId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetId -> Const WidgetId WidgetId)
-> WidgetNodeInfo -> Const WidgetId WidgetNodeInfo
forall s a. HasWidgetId s a => Lens' s a
L.widgetId
      shiftPressed :: Bool
shiftPressed = WidgetEnv s e
wenv WidgetEnv s e -> Getting Bool (WidgetEnv s e) Bool -> Bool
forall s a. s -> Getting a s a -> a
^. (InputStatus -> Const Bool InputStatus)
-> WidgetEnv s e -> Const Bool (WidgetEnv s e)
forall s a. HasInputStatus s a => Lens' s a
L.inputStatus ((InputStatus -> Const Bool InputStatus)
 -> WidgetEnv s e -> Const Bool (WidgetEnv s e))
-> ((Bool -> Const Bool Bool)
    -> InputStatus -> Const Bool InputStatus)
-> Getting Bool (WidgetEnv s e) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyMod -> Const Bool KeyMod)
-> InputStatus -> Const Bool InputStatus
forall s a. HasKeyMod s a => Lens' s a
L.keyMod ((KeyMod -> Const Bool KeyMod)
 -> InputStatus -> Const Bool InputStatus)
-> ((Bool -> Const Bool Bool) -> KeyMod -> Const Bool KeyMod)
-> (Bool -> Const Bool Bool)
-> InputStatus
-> Const Bool InputStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Const Bool Bool) -> KeyMod -> Const Bool KeyMod
forall s a. HasLeftShift s a => Lens' s a
L.leftShift
      SliderState Integer
maxPos Integer
pos = SliderState
state

      resultFromPoint :: s -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPoint !s
point ![WidgetRequest s e]
reqs = Integer -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPos Integer
newPos [WidgetRequest s e]
reqs where
        !newPos :: Integer
newPos = Bool -> Rect -> s -> Integer
forall p s s.
(HasX s p, HasX s p, HasY s p, HasY s p, RealFrac p, HasW s p,
 HasH s p) =>
Bool -> s -> s -> Integer
posFromMouse Bool
isHz Rect
vp s
point

      resultFromPos :: Integer -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPos !Integer
newPos ![WidgetRequest s e]
extraReqs = WidgetResult s e -> Maybe (WidgetResult s e)
forall a. a -> Maybe a
Just WidgetResult s e
newResult where
        !newState :: SliderState
newState = SliderState
state {
          _slsPos :: Integer
_slsPos = Integer
newPos
        }
        !newNode :: WidgetNode s e
newNode = WidgetNode s e
node
          WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasWidget s a => Lens' s a
L.widget ((Widget s e -> Identity (Widget s e))
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Widget s e -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
makeSlider Bool
isHz WidgetData s a
field a
minVal a
maxVal SliderCfg s e a
config SliderState
newState
        !result :: WidgetResult s e
result = WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
newNode [WidgetRequest s e
forall s e. WidgetRequest s e
RenderOnce]
        !newVal :: a
newVal = Integer -> a
forall a. Integral a => a -> a
valueFromPos Integer
newPos

        !reqs :: [WidgetRequest s e]
reqs = WidgetData s a -> a -> [WidgetRequest s e]
forall s a e. WidgetData s a -> a -> [WidgetRequest s e]
widgetDataSet WidgetData s a
field a
newVal
          [WidgetRequest s e] -> [WidgetRequest s e] -> [WidgetRequest s e]
forall a. [a] -> [a] -> [a]
++ ((a -> WidgetRequest s e) -> WidgetRequest s e)
-> [a -> WidgetRequest s e] -> [WidgetRequest s e]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> WidgetRequest s e) -> a -> WidgetRequest s e
forall a b. (a -> b) -> a -> b
$ a
newVal) (SliderCfg s e a -> [a -> WidgetRequest s e]
forall s e a. SliderCfg s e a -> [a -> WidgetRequest s e]
_slcOnChangeReq SliderCfg s e a
config)
          [WidgetRequest s e] -> [WidgetRequest s e] -> [WidgetRequest s e]
forall a. [a] -> [a] -> [a]
++ [WidgetRequest s e]
extraReqs
        !newResult :: WidgetResult s e
newResult
          | Integer
pos Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
newPos = WidgetResult s e
result
              WidgetResult s e
-> (WidgetResult s e -> WidgetResult s e) -> WidgetResult s e
forall a b. a -> (a -> b) -> b
& (Seq (WidgetRequest s e) -> Identity (Seq (WidgetRequest s e)))
-> WidgetResult s e -> Identity (WidgetResult s e)
forall s a. HasRequests s a => Lens' s a
L.requests ((Seq (WidgetRequest s e) -> Identity (Seq (WidgetRequest s e)))
 -> WidgetResult s e -> Identity (WidgetResult s e))
-> Seq (WidgetRequest s e) -> WidgetResult s e -> WidgetResult s e
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ [WidgetRequest s e] -> Seq (WidgetRequest s e)
forall a. [a] -> Seq a
Seq.fromList [WidgetRequest s e]
reqs
          | Bool
otherwise = WidgetResult s e
result

  getSizeReq :: WidgetEnv s e -> WidgetNode s e -> (SizeReq, SizeReq)
getSizeReq WidgetEnv s e
wenv WidgetNode s e
node = (SizeReq, SizeReq)
req where
    theme :: ThemeState
theme = WidgetEnv s e -> WidgetNode s e -> ThemeState
forall s e. WidgetEnv s e -> WidgetNode s e -> ThemeState
currentTheme WidgetEnv s e
wenv WidgetNode s e
node
    maxPos :: Double
maxPos = Rational -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (a -> Rational
forall a. Real a => a -> Rational
toRational (a
maxVal a -> a -> a
forall a. Num a => a -> a -> a
- a
minVal) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
dragRate)
    width :: Double
width = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe (ThemeState
theme ThemeState -> Getting Double ThemeState Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double ThemeState Double
forall s a. HasSliderWidth s a => Lens' s a
L.sliderWidth) (SliderCfg s e a -> Maybe Double
forall s e a. SliderCfg s e a -> Maybe Double
_slcWidth SliderCfg s e a
config)
    req :: (SizeReq, SizeReq)
req
      | Bool
isHz = (Double -> Double -> SizeReq
expandSize Double
maxPos Double
1, Double -> SizeReq
fixedSize Double
width)
      | Bool
otherwise = (Double -> SizeReq
fixedSize Double
width, Double -> Double -> SizeReq
expandSize Double
maxPos Double
1)

  render :: WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render WidgetEnv s e
wenv WidgetNode s e
node Renderer
renderer = do
    Renderer -> Rect -> Maybe Color -> Maybe Radius -> IO ()
drawRect Renderer
renderer Rect
sliderBgArea (Color -> Maybe Color
forall a. a -> Maybe a
Just Color
sndColor) Maybe Radius
sliderRadius

    Renderer -> Bool -> Rect -> IO () -> IO ()
drawInScissor Renderer
renderer Bool
True Rect
sliderFgArea (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Renderer -> Rect -> Maybe Color -> Maybe Radius -> IO ()
drawRect Renderer
renderer Rect
sliderBgArea (Color -> Maybe Color
forall a. a -> Maybe a
Just Color
fgColor) Maybe Radius
sliderRadius

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
thbVisible (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Renderer -> Rect -> Maybe Color -> IO ()
drawEllipse Renderer
renderer Rect
thbArea (Color -> Maybe Color
forall a. a -> Maybe a
Just Color
hlColor)
    where
      theme :: ThemeState
theme = WidgetEnv s e -> WidgetNode s e -> ThemeState
forall s e. WidgetEnv s e -> WidgetNode s e -> ThemeState
currentTheme WidgetEnv s e
wenv WidgetNode s e
node
      style :: StyleState
style = WidgetEnv s e -> WidgetNode s e -> StyleState
forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle WidgetEnv s e
wenv WidgetNode s e
node

      fgColor :: Color
fgColor = StyleState -> Color
styleFgColor StyleState
style
      hlColor :: Color
hlColor = StyleState -> Color
styleHlColor StyleState
style
      sndColor :: Color
sndColor = StyleState -> Color
styleSndColor StyleState
style

      radiusW :: Maybe Double
radiusW = SliderCfg s e a -> Maybe Double
forall s e a. SliderCfg s e a -> Maybe Double
_slcRadius SliderCfg s e a
config Maybe Double -> Maybe Double -> Maybe Double
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ThemeState
theme ThemeState
-> Getting (Maybe Double) ThemeState (Maybe Double) -> Maybe Double
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Double) ThemeState (Maybe Double)
forall s a. HasSliderRadius s a => Lens' s a
L.sliderRadius
      sliderRadius :: Maybe Radius
sliderRadius = Double -> Radius
forall t. CmbRadius t => Double -> t
radius (Double -> Radius) -> Maybe Double -> Maybe Radius
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Double
radiusW
      SliderState Integer
maxPos Integer
pos = SliderState
state
      posPct :: Double
posPct = Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
pos Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxPos
      carea :: Rect
carea = WidgetNode s e -> StyleState -> Rect
forall s e. WidgetNode s e -> StyleState -> Rect
getContentArea WidgetNode s e
node StyleState
style
      Rect Double
cx Double
cy Double
cw Double
ch = Rect
carea
      barW :: Double
barW
        | Bool
isHz = Double
ch
        | Bool
otherwise = Double
cw
      -- Thumb
      thbVisible :: Bool
thbVisible = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (SliderCfg s e a -> Maybe Bool
forall s e a. SliderCfg s e a -> Maybe Bool
_slcThumbVisible SliderCfg s e a
config)
      thbF :: Double
thbF = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe (ThemeState
theme ThemeState -> Getting Double ThemeState Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double ThemeState Double
forall s a. HasSliderThumbFactor s a => Lens' s a
L.sliderThumbFactor) (SliderCfg s e a -> Maybe Double
forall s e a. SliderCfg s e a -> Maybe Double
_slcThumbFactor SliderCfg s e a
config)
      thbW :: Double
thbW = Double
thbF Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
barW
      thbPos :: Double -> Double
thbPos Double
dim = (Double
dim Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
thbW) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
posPct
      thbDif :: Double
thbDif = (Double
thbW Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
barW) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
      thbArea :: Rect
thbArea
        | Bool
isHz = Double -> Double -> Double -> Double -> Rect
Rect (Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double
thbPos Double
cw) (Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
thbDif) Double
thbW Double
thbW
        | Bool
otherwise = Double -> Double -> Double -> Double -> Rect
Rect (Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
thbDif) (Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
ch Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
thbW Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double
thbPos Double
ch) Double
thbW Double
thbW
      -- Bar
      tw2 :: Double
tw2 = Double
thbW Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
      sliderBgArea :: Rect
sliderBgArea
        | Bool -> Bool
not Bool
thbVisible = Rect
carea
        | Bool
isHz = Rect -> Maybe Rect -> Rect
forall a. a -> Maybe a -> a
fromMaybe Rect
forall a. Default a => a
def (Rect -> Double -> Double -> Double -> Double -> Maybe Rect
subtractFromRect Rect
carea Double
tw2 Double
tw2 Double
0 Double
0)
        | Bool
otherwise = Rect -> Maybe Rect -> Rect
forall a. a -> Maybe a -> a
fromMaybe Rect
forall a. Default a => a
def (Rect -> Double -> Double -> Double -> Double -> Maybe Rect
subtractFromRect Rect
carea Double
0 Double
0 Double
tw2 Double
tw2)
      sliderFgArea :: Rect
sliderFgArea
        | Bool
isHz = Rect
sliderBgArea Rect -> (Rect -> Rect) -> Rect
forall a b. a -> (a -> b) -> b
& (Double -> Identity Double) -> Rect -> Identity Rect
forall s a. HasW s a => Lens' s a
L.w ((Double -> Identity Double) -> Rect -> Identity Rect)
-> (Double -> Double) -> Rect -> Rect
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
posPct)
        | Bool
otherwise = Rect
sliderBgArea
            Rect -> (Rect -> Rect) -> Rect
forall a b. a -> (a -> b) -> b
& (Double -> Identity Double) -> Rect -> Identity Rect
forall s a. HasY s a => Lens' s a
L.y ((Double -> Identity Double) -> Rect -> Identity Rect)
-> (Double -> Double) -> Rect -> Rect
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Rect
sliderBgArea Rect -> Getting Double Rect Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double Rect Double
forall s a. HasH s a => Lens' s a
L.h Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
posPct)))
            Rect -> (Rect -> Rect) -> Rect
forall a b. a -> (a -> b) -> b
& (Double -> Identity Double) -> Rect -> Identity Rect
forall s a. HasH s a => Lens' s a
L.h ((Double -> Identity Double) -> Rect -> Identity Rect)
-> (Double -> Double) -> Rect -> Rect
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
posPct)

  newStateFromValue :: a -> SliderState
newStateFromValue a
currVal = SliderState
newState where
    newMaxPos :: Integer
newMaxPos = Rational -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> Rational
forall a. Real a => a -> Rational
toRational (a
maxVal a -> a -> a
forall a. Num a => a -> a -> a
- a
minVal) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
dragRate)
    newPos :: Integer
newPos = Rational -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> Rational
forall a. Real a => a -> Rational
toRational (a
currVal a -> a -> a
forall a. Num a => a -> a -> a
- a
minVal) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
dragRate)
    newState :: SliderState
newState = SliderState :: Integer -> Integer -> SliderState
SliderState {
      _slsMaxPos :: Integer
_slsMaxPos = Integer
newMaxPos,
      _slsPos :: Integer
_slsPos = Integer
newPos
    }

  posFromMouse :: Bool -> s -> s -> Integer
posFromMouse Bool
isHz s
vp s
point = Integer
newPos where
    SliderState Integer
maxPos Integer
_ = SliderState
state
    dv :: p
dv
      | Bool
isHz = s
point s -> Getting p s p -> p
forall s a. s -> Getting a s a -> a
^. Getting p s p
forall s a. HasX s a => Lens' s a
L.x p -> p -> p
forall a. Num a => a -> a -> a
- s
vp s -> Getting p s p -> p
forall s a. s -> Getting a s a -> a
^. Getting p s p
forall s a. HasX s a => Lens' s a
L.x
      | Bool
otherwise = s
vp s -> Getting p s p -> p
forall s a. s -> Getting a s a -> a
^. Getting p s p
forall s a. HasY s a => Lens' s a
L.y p -> p -> p
forall a. Num a => a -> a -> a
+ s
vp s -> Getting p s p -> p
forall s a. s -> Getting a s a -> a
^. Getting p s p
forall s a. HasH s a => Lens' s a
L.h p -> p -> p
forall a. Num a => a -> a -> a
- s
point s -> Getting p s p -> p
forall s a. s -> Getting a s a -> a
^. Getting p s p
forall s a. HasY s a => Lens' s a
L.y
    tmpPos :: Integer
tmpPos
      | Bool
isHz = p -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (p
dv p -> p -> p
forall a. Num a => a -> a -> a
* Integer -> p
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxPos p -> p -> p
forall a. Fractional a => a -> a -> a
/ s
vp s -> Getting p s p -> p
forall s a. s -> Getting a s a -> a
^. Getting p s p
forall s a. HasW s a => Lens' s a
L.w)
      | Bool
otherwise = p -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (p
dv p -> p -> p
forall a. Num a => a -> a -> a
* Integer -> p
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxPos p -> p -> p
forall a. Fractional a => a -> a -> a
/ s
vp s -> Getting p s p -> p
forall s a. s -> Getting a s a -> a
^. Getting p s p
forall s a. HasH s a => Lens' s a
L.h)
    newPos :: Integer
newPos = Integer -> Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a -> a
clamp Integer
0 Integer
maxPos Integer
tmpPos

  valueFromPos :: a -> a
valueFromPos a
newPos = a
newVal where
    newVal :: a
newVal = a
minVal a -> a -> a
forall a. Num a => a -> a -> a
+ Rational -> a
forall a b. (FromFractional a, Real b, Fractional b) => b -> a
fromFractional (Rational
dragRate Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* a -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
newPos)