{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Monomer.Widgets.Singles.Slider (
SliderValue,
SliderCfg,
hslider,
hslider_,
vslider,
vslider_,
hsliderV,
hsliderV_,
vsliderV,
vsliderV_,
sliderD_
) where
import Control.Applicative ((<|>))
import Control.Lens (ALens', (&), (^.), (.~), (%~), (<>~))
import Control.Monad
import Data.Default
import Data.Maybe
import Data.Text (Text)
import Data.Typeable (Typeable)
import GHC.Generics
import qualified Data.Sequence as Seq
import Monomer.Helper
import Monomer.Widgets.Single
import qualified Monomer.Lens as L
type SliderValue a = (Eq a, Show a, Real a, FromFractional a, Typeable a)
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)
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
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
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
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
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
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
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
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
sliderD_
:: (SliderValue a, WidgetEvent e)
=> Bool
-> WidgetData s a
-> a
-> a
-> [SliderCfg s e a]
-> WidgetNode s e
sliderD_ :: Bool
-> WidgetData s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
sliderD_ Bool
isHz WidgetData s a
widgetData a
minVal a
maxVal [SliderCfg s e a]
configs = WidgetNode s e
sliderNode where
config :: SliderCfg s e a
config = [SliderCfg s e a] -> SliderCfg s e a
forall a. Monoid a => [a] -> a
mconcat [SliderCfg s e a]
configs
state :: SliderState
state = Integer -> Integer -> SliderState
SliderState Integer
0 Integer
0
widget :: Widget s e
widget = Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
makeSlider Bool
isHz WidgetData s a
widgetData a
minVal a
maxVal SliderCfg s e a
config SliderState
state
sliderNode :: WidgetNode s e
sliderNode = WidgetType -> Widget s e -> WidgetNode s e
forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"slider" Widget s e
widget
WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (WidgetNodeInfo -> Identity WidgetNodeInfo)
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Identity WidgetNodeInfo)
-> WidgetNode s e -> Identity (WidgetNode s e))
-> ((Bool -> Identity Bool)
-> WidgetNodeInfo -> Identity WidgetNodeInfo)
-> (Bool -> Identity Bool)
-> WidgetNode s e
-> Identity (WidgetNode s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> WidgetNodeInfo -> Identity WidgetNodeInfo
forall s a. HasFocusable s a => Lens' s a
L.focusable ((Bool -> Identity Bool)
-> WidgetNode s e -> Identity (WidgetNode s e))
-> Bool -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
makeSlider
:: (SliderValue a, WidgetEvent e)
=> Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
makeSlider :: Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
makeSlider Bool
isHz WidgetData s a
field a
minVal a
maxVal SliderCfg s e a
config SliderState
state = Widget s e
widget where
widget :: Widget s e
widget = SliderState -> Single s e SliderState -> Widget s e
forall a s e. WidgetModel a => a -> Single s e a -> Widget s e
createSingle SliderState
state Single s e Any
forall a. Default a => a
def {
singleFocusOnBtnPressed :: Bool
singleFocusOnBtnPressed = Bool
False,
singleGetBaseStyle :: SingleGetBaseStyle s e
singleGetBaseStyle = SingleGetBaseStyle s e
forall s e p. WidgetEnv s e -> p -> Maybe Style
getBaseStyle,
singleInit :: SingleInitHandler s e
singleInit = SingleInitHandler s e
forall s. HasModel s s => s -> WidgetNode s e -> WidgetResult s e
init,
singleMerge :: SingleMergeHandler s e SliderState
singleMerge = SingleMergeHandler s e SliderState
forall p.
WidgetEnv s e
-> WidgetNode s e -> p -> SliderState -> WidgetResult s e
merge,
singleHandleEvent :: SingleEventHandler s e
singleHandleEvent = SingleEventHandler s e
forall p.
WidgetEnv s e
-> WidgetNode s e -> p -> SystemEvent -> Maybe (WidgetResult s e)
handleEvent,
singleGetSizeReq :: SingleGetSizeReqHandler s e
singleGetSizeReq = SingleGetSizeReqHandler s e
forall s e. WidgetEnv s e -> WidgetNode s e -> (SizeReq, SizeReq)
getSizeReq,
singleRender :: SingleRenderHandler s e
singleRender = SingleRenderHandler s e
forall s e. WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render
}
dragRate :: Rational
dragRate
| Maybe Rational -> Bool
forall a. Maybe a -> Bool
isJust (SliderCfg s e a -> Maybe Rational
forall s e a. SliderCfg s e a -> Maybe Rational
_slcDragRate SliderCfg s e a
config) = Maybe Rational -> Rational
forall a. HasCallStack => Maybe a -> a
fromJust (SliderCfg s e a -> Maybe Rational
forall s e a. SliderCfg s e a -> Maybe Rational
_slcDragRate SliderCfg s e a
config)
| Bool
otherwise = a -> Rational
forall a. Real a => a -> Rational
toRational (a
maxVal a -> a -> a
forall a. Num a => a -> a -> a
- a
minVal) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
1000
getBaseStyle :: WidgetEnv s e -> p -> Maybe Style
getBaseStyle WidgetEnv s e
wenv p
node = Style -> Maybe Style
forall a. a -> Maybe a
Just Style
style where
style :: Style
style = WidgetEnv s e -> Lens' ThemeState StyleState -> Style
forall s e. WidgetEnv s e -> Lens' ThemeState StyleState -> Style
collectTheme WidgetEnv s e
wenv forall s a. HasSliderStyle s a => Lens' s a
Lens' ThemeState StyleState
L.sliderStyle
init :: s -> WidgetNode s e -> WidgetResult s e
init s
wenv WidgetNode s e
node = WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
resNode where
currVal :: a
currVal = s -> WidgetData s a -> a
forall s a. s -> WidgetData s a -> a
widgetDataGet (s
wenv s -> Getting s s s -> s
forall s a. s -> Getting a s a -> a
^. Getting s s s
forall s a. HasModel s a => Lens' s a
L.model) WidgetData s a
field
newState :: SliderState
newState = a -> SliderState
newStateFromValue a
currVal
resNode :: WidgetNode s e
resNode = WidgetNode s e
node
WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasWidget s a => Lens' s a
L.widget ((Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e))
-> Widget s e -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
makeSlider Bool
isHz WidgetData s a
field a
minVal a
maxVal SliderCfg s e a
config SliderState
newState
merge :: WidgetEnv s e
-> WidgetNode s e -> p -> SliderState -> WidgetResult s e
merge WidgetEnv s e
wenv WidgetNode s e
newNode p
oldNode SliderState
oldState = WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
resNode where
stateVal :: a
stateVal = Integer -> a
forall a. Integral a => a -> a
valueFromPos (SliderState -> Integer
_slsPos SliderState
oldState)
modelVal :: a
modelVal = s -> WidgetData s a -> a
forall s a. s -> WidgetData s a -> a
widgetDataGet (WidgetEnv s e
wenv WidgetEnv s e -> Getting s (WidgetEnv s e) s -> s
forall s a. s -> Getting a s a -> a
^. Getting s (WidgetEnv s e) s
forall s a. HasModel s a => Lens' s a
L.model) WidgetData s a
field
newState :: SliderState
newState
| WidgetEnv s e -> WidgetNode s e -> Bool
forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodePressed WidgetEnv s e
wenv WidgetNode s e
newNode = SliderState
oldState
| a
stateVal a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
modelVal = SliderState
oldState
| Bool
otherwise = a -> SliderState
newStateFromValue a
modelVal
resNode :: WidgetNode s e
resNode = WidgetNode s e
newNode
WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasWidget s a => Lens' s a
L.widget ((Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e))
-> Widget s e -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
makeSlider Bool
isHz WidgetData s a
field a
minVal a
maxVal SliderCfg s e a
config SliderState
newState
handleEvent :: WidgetEnv s e
-> WidgetNode s e -> p -> SystemEvent -> Maybe (WidgetResult s e)
handleEvent WidgetEnv s e
wenv WidgetNode s e
node p
target SystemEvent
evt = case SystemEvent
evt of
Focus Path
prev -> WidgetNode s e
-> Path -> [Path -> WidgetRequest s e] -> Maybe (WidgetResult s e)
forall s e.
WidgetNode s e
-> Path -> [Path -> WidgetRequest s e] -> Maybe (WidgetResult s e)
handleFocusChange WidgetNode s e
node Path
prev (SliderCfg s e a -> [Path -> WidgetRequest s e]
forall s e a. SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnFocusReq SliderCfg s e a
config)
Blur Path
next -> WidgetNode s e
-> Path -> [Path -> WidgetRequest s e] -> Maybe (WidgetResult s e)
forall s e.
WidgetNode s e
-> Path -> [Path -> WidgetRequest s e] -> Maybe (WidgetResult s e)
handleFocusChange WidgetNode s e
node Path
next (SliderCfg s e a -> [Path -> WidgetRequest s e]
forall s e a. SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnBlurReq SliderCfg s e a
config)
KeyAction KeyMod
mod KeyCode
code KeyStatus
KeyPressed
| Bool
ctrlPressed Bool -> Bool -> Bool
&& KeyCode -> Bool
isInc KeyCode
code -> Integer -> Maybe (WidgetResult s e)
handleNewPos (Integer
pos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
warpSpeed)
| Bool
ctrlPressed Bool -> Bool -> Bool
&& KeyCode -> Bool
isDec KeyCode
code -> Integer -> Maybe (WidgetResult s e)
handleNewPos (Integer
pos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
warpSpeed)
| Bool
shiftPressed Bool -> Bool -> Bool
&& KeyCode -> Bool
isInc KeyCode
code -> Integer -> Maybe (WidgetResult s e)
handleNewPos (Integer
pos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
baseSpeed)
| Bool
shiftPressed Bool -> Bool -> Bool
&& KeyCode -> Bool
isDec KeyCode
code -> Integer -> Maybe (WidgetResult s e)
handleNewPos (Integer
pos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
baseSpeed)
| KeyCode -> Bool
isInc KeyCode
code -> Integer -> Maybe (WidgetResult s e)
handleNewPos (Integer
pos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
fastSpeed)
| KeyCode -> Bool
isDec KeyCode
code -> Integer -> Maybe (WidgetResult s e)
handleNewPos (Integer
pos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
fastSpeed)
where
ctrlPressed :: Bool
ctrlPressed = WidgetEnv s e -> KeyMod -> Bool
forall s e. WidgetEnv s e -> KeyMod -> Bool
isShortCutControl WidgetEnv s e
wenv KeyMod
mod
(KeyCode -> Bool
isDec, KeyCode -> Bool
isInc)
| Bool
isHz = (KeyCode -> Bool
isKeyLeft, KeyCode -> Bool
isKeyRight)
| Bool
otherwise = (KeyCode -> Bool
isKeyDown, KeyCode -> Bool
isKeyUp)
baseSpeed :: Integer
baseSpeed = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
1 (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxPos Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1000)
fastSpeed :: Integer
fastSpeed = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
1 (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxPos Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
100)
warpSpeed :: Integer
warpSpeed = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
1 (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxPos Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
10)
handleNewPos :: Integer -> Maybe (WidgetResult s e)
handleNewPos Integer
newPos
| Integer
validPos Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
pos = Integer -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPos Integer
validPos []
| Bool
otherwise = Maybe (WidgetResult s e)
forall a. Maybe a
Nothing
where
validPos :: Integer
validPos = Integer -> Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a -> a
clamp Integer
0 Integer
maxPos Integer
newPos
Move Point
point
| WidgetEnv s e -> WidgetNode s e -> Bool
forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodePressed WidgetEnv s e
wenv WidgetNode s e
node -> Point -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
forall s.
(HasX s Double, HasY s Double) =>
s -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPoint Point
point []
ButtonAction Point
point Button
btn ButtonState
BtnPressed Int
clicks -> Point -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
forall s.
(HasX s Double, HasY s Double) =>
s -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPoint Point
point [WidgetRequest s e]
forall s e. [WidgetRequest s e]
reqs where
reqs :: [WidgetRequest s e]
reqs
| Bool
shiftPressed = []
| Bool
otherwise = [WidgetId -> WidgetRequest s e
forall s e. WidgetId -> WidgetRequest s e
SetFocus WidgetId
widgetId]
ButtonAction Point
point Button
btn ButtonState
BtnReleased Int
clicks -> Point -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
forall s.
(HasX s Double, HasY s Double) =>
s -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPoint Point
point []
WheelScroll Point
_ (Point Double
_ Double
wy) WheelDirection
wheelDirection -> Integer -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPos Integer
newPos [] where
wheelCfg :: Rational
wheelCfg = Rational -> Maybe Rational -> Rational
forall a. a -> Maybe a -> a
fromMaybe (ThemeState
theme ThemeState -> Getting Rational ThemeState Rational -> Rational
forall s a. s -> Getting a s a -> a
^. Getting Rational ThemeState Rational
forall s a. HasSliderWheelRate s a => Lens' s a
L.sliderWheelRate) (SliderCfg s e a -> Maybe Rational
forall s e a. SliderCfg s e a -> Maybe Rational
_slcWheelRate SliderCfg s e a
config)
wheelRate :: Double
wheelRate = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
wheelCfg
tmpPos :: Integer
tmpPos = Integer
pos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
wy Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
wheelRate)
newPos :: Integer
newPos = Integer -> Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a -> a
clamp Integer
0 Integer
maxPos Integer
tmpPos
SystemEvent
_ -> Maybe (WidgetResult s e)
forall a. Maybe a
Nothing
where
theme :: ThemeState
theme = WidgetEnv s e -> WidgetNode s e -> ThemeState
forall s e. WidgetEnv s e -> WidgetNode s e -> ThemeState
currentTheme WidgetEnv s e
wenv WidgetNode s e
node
style :: StyleState
style = WidgetEnv s e -> WidgetNode s e -> StyleState
forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle WidgetEnv s e
wenv WidgetNode s e
node
vp :: Rect
vp = WidgetNode s e -> StyleState -> Rect
forall s e. WidgetNode s e -> StyleState -> Rect
getContentArea WidgetNode s e
node StyleState
style
widgetId :: WidgetId
widgetId = WidgetNode s e
node WidgetNode s e
-> Getting WidgetId (WidgetNode s e) WidgetId -> WidgetId
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> WidgetNode s e -> Const WidgetId (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> WidgetNode s e -> Const WidgetId (WidgetNode s e))
-> ((WidgetId -> Const WidgetId WidgetId)
-> WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> Getting WidgetId (WidgetNode s e) WidgetId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetId -> Const WidgetId WidgetId)
-> WidgetNodeInfo -> Const WidgetId WidgetNodeInfo
forall s a. HasWidgetId s a => Lens' s a
L.widgetId
shiftPressed :: Bool
shiftPressed = WidgetEnv s e
wenv WidgetEnv s e -> Getting Bool (WidgetEnv s e) Bool -> Bool
forall s a. s -> Getting a s a -> a
^. (InputStatus -> Const Bool InputStatus)
-> WidgetEnv s e -> Const Bool (WidgetEnv s e)
forall s a. HasInputStatus s a => Lens' s a
L.inputStatus ((InputStatus -> Const Bool InputStatus)
-> WidgetEnv s e -> Const Bool (WidgetEnv s e))
-> ((Bool -> Const Bool Bool)
-> InputStatus -> Const Bool InputStatus)
-> Getting Bool (WidgetEnv s e) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyMod -> Const Bool KeyMod)
-> InputStatus -> Const Bool InputStatus
forall s a. HasKeyMod s a => Lens' s a
L.keyMod ((KeyMod -> Const Bool KeyMod)
-> InputStatus -> Const Bool InputStatus)
-> ((Bool -> Const Bool Bool) -> KeyMod -> Const Bool KeyMod)
-> (Bool -> Const Bool Bool)
-> InputStatus
-> Const Bool InputStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Const Bool Bool) -> KeyMod -> Const Bool KeyMod
forall s a. HasLeftShift s a => Lens' s a
L.leftShift
SliderState Integer
maxPos Integer
pos = SliderState
state
resultFromPoint :: s -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPoint s
point [WidgetRequest s e]
reqs = Integer -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPos Integer
newPos [WidgetRequest s e]
reqs where
newPos :: Integer
newPos = Bool -> Rect -> s -> Integer
forall p s s.
(HasX s p, HasX s p, HasY s p, HasY s p, RealFrac p, HasW s p,
HasH s p) =>
Bool -> s -> s -> Integer
posFromMouse Bool
isHz Rect
vp s
point
resultFromPos :: Integer -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPos Integer
newPos [WidgetRequest s e]
extraReqs = WidgetResult s e -> Maybe (WidgetResult s e)
forall a. a -> Maybe a
Just WidgetResult s e
newResult where
newState :: SliderState
newState = SliderState
state {
_slsPos :: Integer
_slsPos = Integer
newPos
}
newNode :: WidgetNode s e
newNode = WidgetNode s e
node
WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasWidget s a => Lens' s a
L.widget ((Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e))
-> Widget s e -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
makeSlider Bool
isHz WidgetData s a
field a
minVal a
maxVal SliderCfg s e a
config SliderState
newState
result :: WidgetResult s e
result = WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
newNode [WidgetRequest s e
forall s e. WidgetRequest s e
RenderOnce]
newVal :: a
newVal = Integer -> a
forall a. Integral a => a -> a
valueFromPos Integer
newPos
reqs :: [WidgetRequest s e]
reqs = WidgetData s a -> a -> [WidgetRequest s e]
forall s a e. WidgetData s a -> a -> [WidgetRequest s e]
widgetDataSet WidgetData s a
field a
newVal
[WidgetRequest s e] -> [WidgetRequest s e] -> [WidgetRequest s e]
forall a. [a] -> [a] -> [a]
++ ((a -> WidgetRequest s e) -> WidgetRequest s e)
-> [a -> WidgetRequest s e] -> [WidgetRequest s e]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> WidgetRequest s e) -> a -> WidgetRequest s e
forall a b. (a -> b) -> a -> b
$ a
newVal) (SliderCfg s e a -> [a -> WidgetRequest s e]
forall s e a. SliderCfg s e a -> [a -> WidgetRequest s e]
_slcOnChangeReq SliderCfg s e a
config)
[WidgetRequest s e] -> [WidgetRequest s e] -> [WidgetRequest s e]
forall a. [a] -> [a] -> [a]
++ [WidgetRequest s e]
extraReqs
newResult :: WidgetResult s e
newResult
| Integer
pos Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
newPos = WidgetResult s e
result
WidgetResult s e
-> (WidgetResult s e -> WidgetResult s e) -> WidgetResult s e
forall a b. a -> (a -> b) -> b
& (Seq (WidgetRequest s e) -> Identity (Seq (WidgetRequest s e)))
-> WidgetResult s e -> Identity (WidgetResult s e)
forall s a. HasRequests s a => Lens' s a
L.requests ((Seq (WidgetRequest s e) -> Identity (Seq (WidgetRequest s e)))
-> WidgetResult s e -> Identity (WidgetResult s e))
-> Seq (WidgetRequest s e) -> WidgetResult s e -> WidgetResult s e
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ [WidgetRequest s e] -> Seq (WidgetRequest s e)
forall a. [a] -> Seq a
Seq.fromList [WidgetRequest s e]
reqs
| Bool
otherwise = WidgetResult s e
result
getSizeReq :: WidgetEnv s e -> WidgetNode s e -> (SizeReq, SizeReq)
getSizeReq WidgetEnv s e
wenv WidgetNode s e
node = (SizeReq, SizeReq)
req where
theme :: ThemeState
theme = WidgetEnv s e -> WidgetNode s e -> ThemeState
forall s e. WidgetEnv s e -> WidgetNode s e -> ThemeState
currentTheme WidgetEnv s e
wenv WidgetNode s e
node
maxPos :: Double
maxPos = Rational -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (a -> Rational
forall a. Real a => a -> Rational
toRational (a
maxVal a -> a -> a
forall a. Num a => a -> a -> a
- a
minVal) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
dragRate)
width :: Double
width = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe (ThemeState
theme ThemeState -> Getting Double ThemeState Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double ThemeState Double
forall s a. HasSliderWidth s a => Lens' s a
L.sliderWidth) (SliderCfg s e a -> Maybe Double
forall s e a. SliderCfg s e a -> Maybe Double
_slcWidth SliderCfg s e a
config)
req :: (SizeReq, SizeReq)
req
| Bool
isHz = (Double -> Double -> SizeReq
expandSize Double
maxPos Double
1, Double -> SizeReq
fixedSize Double
width)
| Bool
otherwise = (Double -> SizeReq
fixedSize Double
width, Double -> Double -> SizeReq
expandSize Double
maxPos Double
1)
render :: WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render WidgetEnv s e
wenv WidgetNode s e
node Renderer
renderer = do
Renderer -> Rect -> Maybe Color -> Maybe Radius -> IO ()
drawRect Renderer
renderer Rect
sliderBgArea (Color -> Maybe Color
forall a. a -> Maybe a
Just Color
sndColor) Maybe Radius
sliderRadius
Renderer -> Bool -> Rect -> IO () -> IO ()
drawInScissor Renderer
renderer Bool
True Rect
sliderFgArea (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Renderer -> Rect -> Maybe Color -> Maybe Radius -> IO ()
drawRect Renderer
renderer Rect
sliderBgArea (Color -> Maybe Color
forall a. a -> Maybe a
Just Color
fgColor) Maybe Radius
sliderRadius
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
thbVisible (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Renderer -> Rect -> Maybe Color -> IO ()
drawEllipse Renderer
renderer Rect
thbArea (Color -> Maybe Color
forall a. a -> Maybe a
Just Color
hlColor)
where
theme :: ThemeState
theme = WidgetEnv s e -> WidgetNode s e -> ThemeState
forall s e. WidgetEnv s e -> WidgetNode s e -> ThemeState
currentTheme WidgetEnv s e
wenv WidgetNode s e
node
style :: StyleState
style = WidgetEnv s e -> WidgetNode s e -> StyleState
forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle WidgetEnv s e
wenv WidgetNode s e
node
fgColor :: Color
fgColor = StyleState -> Color
styleFgColor StyleState
style
hlColor :: Color
hlColor = StyleState -> Color
styleHlColor StyleState
style
sndColor :: Color
sndColor = StyleState -> Color
styleSndColor StyleState
style
radiusW :: Maybe Double
radiusW = SliderCfg s e a -> Maybe Double
forall s e a. SliderCfg s e a -> Maybe Double
_slcRadius SliderCfg s e a
config Maybe Double -> Maybe Double -> Maybe Double
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ThemeState
theme ThemeState
-> Getting (Maybe Double) ThemeState (Maybe Double) -> Maybe Double
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Double) ThemeState (Maybe Double)
forall s a. HasSliderRadius s a => Lens' s a
L.sliderRadius
sliderRadius :: Maybe Radius
sliderRadius = Double -> Radius
forall t. CmbRadius t => Double -> t
radius (Double -> Radius) -> Maybe Double -> Maybe Radius
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Double
radiusW
SliderState Integer
maxPos Integer
pos = SliderState
state
posPct :: Double
posPct = Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
pos Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxPos
carea :: Rect
carea = WidgetNode s e -> StyleState -> Rect
forall s e. WidgetNode s e -> StyleState -> Rect
getContentArea WidgetNode s e
node StyleState
style
Rect Double
cx Double
cy Double
cw Double
ch = Rect
carea
barW :: Double
barW
| Bool
isHz = Double
ch
| Bool
otherwise = Double
cw
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
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)