{-|
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 using the keyboard arrows, dragging the mouse or using the wheel.

@
hslider numericLens 0 100
@

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, typeOf)
import GHC.Generics
import TextShow

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 the slider widget.
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 {
  forall s e a. SliderCfg s e a -> Maybe Double
_slcRadius :: Maybe Double,
  forall s e a. SliderCfg s e a -> Maybe Double
_slcWidth :: Maybe Double,
  forall s e a. SliderCfg s e a -> Maybe Rational
_slcWheelRate :: Maybe Rational,
  forall s e a. SliderCfg s e a -> Maybe Rational
_slcDragRate :: Maybe Rational,
  forall s e a. SliderCfg s e a -> Maybe Bool
_slcThumbVisible :: Maybe Bool,
  forall s e a. SliderCfg s e a -> Maybe Double
_slcThumbFactor :: Maybe Double,
  forall s e a. SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnFocusReq :: [Path -> WidgetRequest s e],
  forall s e a. SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnBlurReq :: [Path -> WidgetRequest s e],
  forall s e a. 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 {
    _slcRadius :: Maybe Double
_slcRadius = forall a. Maybe a
Nothing,
    _slcWidth :: Maybe Double
_slcWidth = forall a. Maybe a
Nothing,
    _slcWheelRate :: Maybe Rational
_slcWheelRate = forall a. Maybe a
Nothing,
    _slcDragRate :: Maybe Rational
_slcDragRate = forall a. Maybe a
Nothing,
    _slcThumbVisible :: Maybe Bool
_slcThumbVisible = forall a. Maybe a
Nothing,
    _slcThumbFactor :: Maybe Double
_slcThumbFactor = 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 {
    _slcRadius :: Maybe Double
_slcRadius = forall s e a. SliderCfg s e a -> Maybe Double
_slcRadius SliderCfg s e a
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e a. SliderCfg s e a -> Maybe Double
_slcRadius SliderCfg s e a
t1,
    _slcWidth :: Maybe Double
_slcWidth = forall s e a. SliderCfg s e a -> Maybe Double
_slcWidth SliderCfg s e a
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e a. SliderCfg s e a -> Maybe Double
_slcWidth SliderCfg s e a
t1,
    _slcWheelRate :: Maybe Rational
_slcWheelRate = forall s e a. SliderCfg s e a -> Maybe Rational
_slcWheelRate SliderCfg s e a
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e a. SliderCfg s e a -> Maybe Rational
_slcWheelRate SliderCfg s e a
t1,
    _slcDragRate :: Maybe Rational
_slcDragRate = forall s e a. SliderCfg s e a -> Maybe Rational
_slcDragRate SliderCfg s e a
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e a. SliderCfg s e a -> Maybe Rational
_slcDragRate SliderCfg s e a
t1,
    _slcThumbVisible :: Maybe Bool
_slcThumbVisible = forall s e a. SliderCfg s e a -> Maybe Bool
_slcThumbVisible SliderCfg s e a
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e a. SliderCfg s e a -> Maybe Bool
_slcThumbVisible SliderCfg s e a
t1,
    _slcThumbFactor :: Maybe Double
_slcThumbFactor = forall s e a. SliderCfg s e a -> Maybe Double
_slcThumbFactor SliderCfg s e a
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e a. SliderCfg s e a -> Maybe Double
_slcThumbFactor SliderCfg s e a
t1,
    _slcOnFocusReq :: [Path -> WidgetRequest s e]
_slcOnFocusReq = forall s e a. SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnFocusReq SliderCfg s e a
t1 forall a. Semigroup a => a -> a -> a
<> forall s e a. SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnFocusReq SliderCfg s e a
t2,
    _slcOnBlurReq :: [Path -> WidgetRequest s e]
_slcOnBlurReq = forall s e a. SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnBlurReq SliderCfg s e a
t1 forall a. Semigroup a => a -> a -> a
<> forall s e a. SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnBlurReq SliderCfg s e a
t2,
    _slcOnChangeReq :: [a -> WidgetRequest s e]
_slcOnChangeReq = forall s e a. SliderCfg s e a -> [a -> WidgetRequest s e]
_slcOnChangeReq SliderCfg s e a
t1 forall a. Semigroup a => a -> a -> a
<> 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 = forall a. Default a => a
def

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

instance CmbRadius (SliderCfg s e a) where
  radius :: Double -> SliderCfg s e a
radius Double
w = forall a. Default a => a
def {
    _slcRadius :: Maybe Double
_slcRadius = 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 = forall a. Default a => a
def {
    _slcWheelRate :: Maybe Rational
_slcWheelRate = 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 = forall a. Default a => a
def {
    _slcDragRate :: Maybe Rational
_slcDragRate = forall a. a -> Maybe a
Just Rational
rate
  }

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

instance CmbThumbVisible (SliderCfg s e a) where
  thumbVisible_ :: Bool -> SliderCfg s e a
thumbVisible_ Bool
w = forall a. Default a => a
def {
    _slcThumbVisible :: Maybe Bool
_slcThumbVisible = 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 = forall a. Default a => a
def {
    _slcOnFocusReq :: [Path -> WidgetRequest s e]
_slcOnFocusReq = [forall s e. WidgetEvent e => e -> WidgetRequest s e
RaiseEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> e
fn]
  }

instance CmbOnFocusReq (SliderCfg s e a) s e Path where
  onFocusReq :: (Path -> WidgetRequest s e) -> SliderCfg s e a
onFocusReq Path -> WidgetRequest s e
req = 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 = forall a. Default a => a
def {
    _slcOnBlurReq :: [Path -> WidgetRequest s e]
_slcOnBlurReq = [forall s e. WidgetEvent e => e -> WidgetRequest s e
RaiseEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> e
fn]
  }

instance CmbOnBlurReq (SliderCfg s e a) s e Path where
  onBlurReq :: (Path -> WidgetRequest s e) -> SliderCfg s e a
onBlurReq Path -> WidgetRequest s e
req = 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 = forall a. Default a => a
def {
    _slcOnChangeReq :: [a -> WidgetRequest s e]
_slcOnChangeReq = [forall s e. WidgetEvent e => e -> WidgetRequest s e
RaiseEvent 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 = 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
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
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. 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      -- ^ The lens into the model.
  -> a               -- ^ Minimum value.
  -> a               -- ^ Maximum value.
  -> WidgetNode s e  -- ^ The created slider.
hslider :: forall a e s.
(SliderValue a, WidgetEvent e) =>
ALens' s a -> a -> a -> WidgetNode s e
hslider ALens' s a
field a
minVal a
maxVal = 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 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         -- ^ The lens into the model.
  -> a                  -- ^ Minimum value.
  -> a                  -- ^ Maximum value.
  -> [SliderCfg s e a]  -- ^ The config options.
  -> WidgetNode s e     -- ^ The created slider.
hslider_ :: 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]
cfg = 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 = 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      -- ^ The lens into the model.
  -> a               -- ^ Minimum value.
  -> a               -- ^ Maximum value.
  -> WidgetNode s e  -- ^ The created slider.
vslider :: forall a e s.
(SliderValue a, WidgetEvent e) =>
ALens' s a -> a -> a -> WidgetNode s e
vslider ALens' s a
field a
minVal a
maxVal = 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 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         -- ^ The lens into the model.
  -> a                  -- ^ Minimum value.
  -> a                  -- ^ Maximum value.
  -> [SliderCfg s e a]  -- ^ The config options.
  -> WidgetNode s e     -- ^ The created slider.
vslider_ :: 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]
cfg = 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 = 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               -- ^ The current value.
  -> (a -> e)        -- ^ The event to raise on change.
  -> a               -- ^ Minimum value.
  -> a               -- ^ Maximum value.
  -> WidgetNode s e  -- ^ The created slider.
hsliderV :: forall a e s.
(SliderValue a, WidgetEvent e) =>
a -> (a -> e) -> a -> a -> WidgetNode s e
hsliderV a
value a -> e
handler a
minVal a
maxVal = 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 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                  -- ^ The current value.
  -> (a -> e)           -- ^ The event to raise on change.
  -> a                  -- ^ Minimum value.
  -> a                  -- ^ Maximum value.
  -> [SliderCfg s e a]  -- ^ The config options.
  -> WidgetNode s e     -- ^ The created slider.
hsliderV_ :: 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]
configs = WidgetNode s e
newNode where
  widgetData :: WidgetData s a
widgetData = forall s a. a -> WidgetData s a
WidgetValue a
value
  newConfigs :: [SliderCfg s e a]
newConfigs = forall t a e. CmbOnChange t a e => (a -> e) -> t
onChange a -> e
handler forall a. a -> [a] -> [a]
: [SliderCfg s e a]
configs
  newNode :: WidgetNode s e
newNode = forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
sliderD_ Bool
True 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               -- ^ The current value.
  -> (a -> e)        -- ^ The event to raise on change.
  -> a               -- ^ Minimum value.
  -> a               -- ^ Maximum value.
  -> WidgetNode s e  -- ^ The created slider.
vsliderV :: forall a e s.
(SliderValue a, WidgetEvent e) =>
a -> (a -> e) -> a -> a -> WidgetNode s e
vsliderV a
value a -> e
handler a
minVal a
maxVal = 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 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                  -- ^ The current value.
  -> (a -> e)           -- ^ The event to raise on change.
  -> a                  -- ^ Minimum value.
  -> a                  -- ^ Maximum value.
  -> [SliderCfg s e a]  -- ^ The config options.
  -> WidgetNode s e     -- ^ The created slider.
vsliderV_ :: 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]
configs = WidgetNode s e
newNode where
  widgetData :: WidgetData s a
widgetData = forall s a. a -> WidgetData s a
WidgetValue a
value
  newConfigs :: [SliderCfg s e a]
newConfigs = forall t a e. CmbOnChange t a e => (a -> e) -> t
onChange a -> e
handler forall a. a -> [a] -> [a]
: [SliderCfg s e a]
configs
  newNode :: WidgetNode s e
newNode = forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
sliderD_ Bool
False 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               -- ^ True if horizontal, False if vertical
  -> WidgetData s a     -- ^ The 'WidgetData' to retrieve the value from.
  -> a                  -- ^ Minimum value.
  -> a                  -- ^ Maximum value.
  -> [SliderCfg s e a]  -- ^ The config options.
  -> WidgetNode s e     -- ^ The created slider.
sliderD_ :: forall a e s.
(SliderValue a, WidgetEvent e) =>
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 = forall a. Monoid a => [a] -> a
mconcat [SliderCfg s e a]
configs
  state :: SliderState
state = Integer -> Integer -> SliderState
SliderState Integer
0 Integer
0
  wtype :: WidgetType
wtype = Text -> WidgetType
WidgetType (Text
"slider-" forall a. Semigroup a => a -> a -> a
<> forall a. TextShow a => a -> Text
showt (forall a. Typeable a => a -> TypeRep
typeOf a
minVal))
  widget :: Widget s e
widget = 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 = forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
wtype Widget s e
widget
    forall a b. a -> (a -> b) -> b
& forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasFocusable s a => Lens' s a
L.focusable 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 :: 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
state = Widget s e
widget where
  widget :: Widget s e
widget = forall a s e. WidgetModel a => a -> Single s e a -> Widget s e
createSingle SliderState
state forall a. Default a => a
def {
    singleFocusOnBtnPressed :: Bool
singleFocusOnBtnPressed = Bool
False,
    singleGetBaseStyle :: SingleGetBaseStyle s e
singleGetBaseStyle = forall {s} {e} {p}. WidgetEnv s e -> p -> Maybe Style
getBaseStyle,
    singleInit :: SingleInitHandler s e
singleInit = forall {p}. HasModel p s => p -> WidgetNode s e -> WidgetResult s e
init,
    singleMerge :: SingleMergeHandler s e SliderState
singleMerge = forall {p}.
WidgetEnv s e
-> WidgetNode s e -> p -> SliderState -> WidgetResult s e
merge,
    singleHandleEvent :: SingleEventHandler s e
singleHandleEvent = forall {p}.
WidgetEnv s e
-> WidgetNode s e -> p -> SystemEvent -> Maybe (WidgetResult s e)
handleEvent,
    singleGetSizeReq :: SingleGetSizeReqHandler s e
singleGetSizeReq = forall {s} {e}.
WidgetEnv s e -> WidgetNode s e -> (SizeReq, SizeReq)
getSizeReq,
    singleRender :: SingleRenderHandler s e
singleRender = forall {s} {e}.
WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render
  }

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

  getBaseStyle :: WidgetEnv s e -> p -> Maybe Style
getBaseStyle WidgetEnv s e
wenv p
node = forall a. a -> Maybe a
Just Style
style where
    style :: Style
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
L.sliderStyle

  init :: p -> WidgetNode s e -> WidgetResult s e
init p
wenv WidgetNode s e
node = forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
resNode where
    currVal :: a
currVal = forall s a. s -> WidgetData s a -> a
widgetDataGet (p
wenv forall s a. s -> Getting a s a -> a
^. 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
      forall a b. a -> (a -> b) -> b
& forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ 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 = forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
resNode where
    stateVal :: a
stateVal = forall {p}. Integral p => p -> a
valueFromPos (SliderState -> Integer
_slsPos SliderState
oldState)
    modelVal :: a
modelVal = forall s a. s -> WidgetData s a -> a
widgetDataGet (WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasModel s a => Lens' s a
L.model) WidgetData s a
field
    newState :: SliderState
newState
      | forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodePressed WidgetEnv s e
wenv WidgetNode s e
newNode = SliderState
oldState
      | a
stateVal 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
      forall a b. a -> (a -> b) -> b
& forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ 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 -> forall s e.
WidgetNode s e
-> Path -> [Path -> WidgetRequest s e] -> Maybe (WidgetResult s e)
handleFocusChange WidgetNode s e
node Path
prev (forall s e a. SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnFocusReq SliderCfg s e a
config)

    Blur Path
next -> forall s e.
WidgetNode s e
-> Path -> [Path -> WidgetRequest s e] -> Maybe (WidgetResult s e)
handleFocusChange WidgetNode s e
node Path
next (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 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 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 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 forall a. Num a => a -> a -> a
- Integer
baseSpeed)
      | KeyCode -> Bool
isInc KeyCode
code -> Integer -> Maybe (WidgetResult s e)
handleNewPos (Integer
pos forall a. Num a => a -> a -> a
+ Integer
fastSpeed)
      | KeyCode -> Bool
isDec KeyCode
code -> Integer -> Maybe (WidgetResult s e)
handleNewPos (Integer
pos forall a. Num a => a -> a -> a
- Integer
fastSpeed)
      where
        ctrlPressed :: Bool
ctrlPressed = 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 = forall a. Ord a => a -> a -> a
max Integer
1 forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
round (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxPos forall a. Fractional a => a -> a -> a
/ Double
1000)
        fastSpeed :: Integer
fastSpeed = forall a. Ord a => a -> a -> a
max Integer
1 forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
round (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxPos forall a. Fractional a => a -> a -> a
/ Double
100)
        warpSpeed :: Integer
warpSpeed = forall a. Ord a => a -> a -> a
max Integer
1 forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
round (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxPos forall a. Fractional a => a -> a -> a
/ Double
10)

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

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

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

    ButtonAction Point
point Button
btn ButtonState
BtnReleased Int
clicks  -> forall {p}.
(HasX p Double, HasY p Double) =>
p -> [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 forall {s} {e}. [WidgetRequest s e]
reqs where
      wheelCfg :: Rational
wheelCfg = forall a. a -> Maybe a -> a
fromMaybe (ThemeState
theme forall s a. s -> Getting a s a -> a
^. forall s a. HasSliderWheelRate s a => Lens' s a
L.sliderWheelRate) (forall s e a. SliderCfg s e a -> Maybe Rational
_slcWheelRate SliderCfg s e a
config)
      wheelRate :: Double
wheelRate = forall a. Fractional a => Rational -> a
fromRational Rational
wheelCfg
      tmpPos :: Integer
tmpPos = Integer
pos forall a. Num a => a -> a -> a
+ forall a b. (RealFrac a, Integral b) => a -> b
round (Double
wy forall a. Num a => a -> a -> a
* Double
wheelRate)
      newPos :: Integer
newPos = forall a. Ord a => a -> a -> a -> a
clamp Integer
0 Integer
maxPos Integer
tmpPos
      reqs :: [WidgetRequest s e]
reqs = [forall s e. WidgetRequest s e
IgnoreParentEvents]
    SystemEvent
_ -> forall a. Maybe a
Nothing
    where
      theme :: ThemeState
theme = forall s e. WidgetEnv s e -> WidgetNode s e -> ThemeState
currentTheme WidgetEnv s e
wenv WidgetNode s e
node
      style :: StyleState
style = forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle WidgetEnv s e
wenv WidgetNode s e
node
      vp :: Rect
vp = forall s e. WidgetNode s e -> StyleState -> Rect
getContentArea WidgetNode s e
node StyleState
style
      widgetId :: WidgetId
widgetId = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidgetId s a => Lens' s a
L.widgetId
      shiftPressed :: Bool
shiftPressed = WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasInputStatus s a => Lens' s a
L.inputStatus forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasKeyMod s a => Lens' s a
L.keyMod forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasLeftShift s a => Lens' s a
L.leftShift
      SliderState Integer
maxPos Integer
pos = SliderState
state

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

      resultFromPos :: Integer -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPos !Integer
newPos ![WidgetRequest s e]
extraReqs = 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
          forall a b. a -> (a -> b) -> b
& forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ 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 = forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
newNode [forall s e. WidgetRequest s e
RenderOnce]
        !newVal :: a
newVal = forall {p}. Integral p => p -> a
valueFromPos Integer
newPos

        !reqs :: [WidgetRequest s e]
reqs = forall s a e. WidgetData s a -> a -> [WidgetRequest s e]
widgetDataSet WidgetData s a
field a
newVal
          forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> a -> b
$ a
newVal) (forall s e a. SliderCfg s e a -> [a -> WidgetRequest s e]
_slcOnChangeReq SliderCfg s e a
config)
          forall a. [a] -> [a] -> [a]
++ [WidgetRequest s e]
extraReqs
        !newResult :: WidgetResult s e
newResult
          | Integer
pos forall a. Eq a => a -> a -> Bool
/= Integer
newPos = WidgetResult s e
result
              forall a b. a -> (a -> b) -> b
& forall s a. HasRequests s a => Lens' s a
L.requests forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ 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 = forall s e. WidgetEnv s e -> WidgetNode s e -> ThemeState
currentTheme WidgetEnv s e
wenv WidgetNode s e
node
    maxPos :: Double
maxPos = forall a b. (Real a, Fractional b) => a -> b
realToFrac (forall a. Real a => a -> Rational
toRational (a
maxVal forall a. Num a => a -> a -> a
- a
minVal) forall a. Fractional a => a -> a -> a
/ Rational
dragRate)
    width :: Double
width = forall a. a -> Maybe a -> a
fromMaybe (ThemeState
theme forall s a. s -> Getting a s a -> a
^. forall s a. HasSliderWidth s a => Lens' s a
L.sliderWidth) (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 (forall a. a -> Maybe a
Just Color
sndColor) Maybe Radius
sliderRadius

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

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
thbVisible forall a b. (a -> b) -> a -> b
$
      Renderer -> Rect -> Maybe Color -> IO ()
drawEllipse Renderer
renderer Rect
thbArea (forall a. a -> Maybe a
Just Color
hlColor)
    where
      theme :: ThemeState
theme = forall s e. WidgetEnv s e -> WidgetNode s e -> ThemeState
currentTheme WidgetEnv s e
wenv WidgetNode s e
node
      style :: StyleState
style = 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 = forall s e a. SliderCfg s e a -> Maybe Double
_slcRadius SliderCfg s e a
config forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ThemeState
theme forall s a. s -> Getting a s a -> a
^. forall s a. HasSliderRadius s a => Lens' s a
L.sliderRadius
      sliderRadius :: Maybe Radius
sliderRadius = forall t. CmbRadius t => Double -> t
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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
pos forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxPos
      carea :: Rect
carea = 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 = forall a. a -> Maybe a -> a
fromMaybe Bool
False (forall s e a. SliderCfg s e a -> Maybe Bool
_slcThumbVisible SliderCfg s e a
config)
      thbF :: Double
thbF = forall a. a -> Maybe a -> a
fromMaybe (ThemeState
theme forall s a. s -> Getting a s a -> a
^. forall s a. HasSliderThumbFactor s a => Lens' s a
L.sliderThumbFactor) (forall s e a. SliderCfg s e a -> Maybe Double
_slcThumbFactor SliderCfg s e a
config)
      thbW :: Double
thbW = Double
thbF forall a. Num a => a -> a -> a
* Double
barW
      thbPos :: Double -> Double
thbPos Double
dim = (Double
dim forall a. Num a => a -> a -> a
- Double
thbW) forall a. Num a => a -> a -> a
* Double
posPct
      thbDif :: Double
thbDif = (Double
thbW forall a. Num a => a -> a -> a
- Double
barW) forall a. Fractional a => a -> a -> a
/ Double
2
      thbArea :: Rect
thbArea
        | Bool
isHz = Double -> Double -> Double -> Double -> Rect
Rect (Double
cx forall a. Num a => a -> a -> a
+ Double -> Double
thbPos Double
cw) (Double
cy forall a. Num a => a -> a -> a
- Double
thbDif) Double
thbW Double
thbW
        | Bool
otherwise = Double -> Double -> Double -> Double -> Rect
Rect (Double
cx forall a. Num a => a -> a -> a
- Double
thbDif) (Double
cy forall a. Num a => a -> a -> a
+ Double
ch forall a. Num a => a -> a -> a
- Double
thbW forall a. Num a => a -> a -> a
- Double -> Double
thbPos Double
ch) Double
thbW Double
thbW
      -- Bar
      tw2 :: Double
tw2 = Double
thbW forall a. Fractional a => a -> a -> a
/ Double
2
      sliderBgArea :: Rect
sliderBgArea
        | Bool -> Bool
not Bool
thbVisible = Rect
carea
        | Bool
isHz = forall a. a -> Maybe a -> a
fromMaybe 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 = forall a. a -> Maybe a -> a
fromMaybe 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 forall a b. a -> (a -> b) -> b
& forall s a. HasW s a => Lens' s a
L.w forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Num a => a -> a -> a
*Double
posPct)
        | Bool
otherwise = Rect
sliderBgArea
            forall a b. a -> (a -> b) -> b
& forall s a. HasY s a => Lens' s a
L.y forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Num a => a -> a -> a
+ (Rect
sliderBgArea forall s a. s -> Getting a s a -> a
^. forall s a. HasH s a => Lens' s a
L.h forall a. Num a => a -> a -> a
* (Double
1 forall a. Num a => a -> a -> a
- Double
posPct)))
            forall a b. a -> (a -> b) -> b
& forall s a. HasH s a => Lens' s a
L.h forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Num a => a -> a -> a
*Double
posPct)

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

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

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