{-|
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 {
  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
  wtype :: WidgetType
wtype = Text -> WidgetType
WidgetType (Text
"slider-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeRep -> Text
forall a. TextShow a => a -> Text
showt (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
minVal))
  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
wtype 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 [WidgetRequest s e]
forall s e. [WidgetRequest s e]
reqs 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
      reqs :: [WidgetRequest s e]
reqs = [WidgetRequest s e
forall s e. WidgetRequest s e
IgnoreParentEvents]
    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)