{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
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, 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
type SliderValue a = (Eq a, Show a, Real a, FromFractional a, Typeable a)
data SliderCfg s e a = SliderCfg {
forall s e a. SliderCfg s e a -> Maybe Double
_slcRadius :: Maybe Double,
forall s e a. SliderCfg s e a -> Maybe Double
_slcWidth :: Maybe Double,
forall s e a. SliderCfg s e a -> Maybe Rational
_slcWheelRate :: Maybe Rational,
forall s e a. SliderCfg s e a -> Maybe Rational
_slcDragRate :: Maybe Rational,
forall s e a. SliderCfg s e a -> Maybe Bool
_slcThumbVisible :: Maybe Bool,
forall s e a. SliderCfg s e a -> Maybe Double
_slcThumbFactor :: Maybe Double,
forall s e a. SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnFocusReq :: [Path -> WidgetRequest s e],
forall s e a. SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnBlurReq :: [Path -> WidgetRequest s e],
forall s e a. SliderCfg s e a -> [a -> WidgetRequest s e]
_slcOnChangeReq :: [a -> WidgetRequest s e]
}
instance Default (SliderCfg s e a) where
def :: SliderCfg s e a
def = SliderCfg {
_slcRadius :: Maybe Double
_slcRadius = forall a. Maybe a
Nothing,
_slcWidth :: Maybe Double
_slcWidth = forall a. Maybe a
Nothing,
_slcWheelRate :: Maybe Rational
_slcWheelRate = forall a. Maybe a
Nothing,
_slcDragRate :: Maybe Rational
_slcDragRate = forall a. Maybe a
Nothing,
_slcThumbVisible :: Maybe Bool
_slcThumbVisible = forall a. Maybe a
Nothing,
_slcThumbFactor :: Maybe Double
_slcThumbFactor = forall a. Maybe a
Nothing,
_slcOnFocusReq :: [Path -> WidgetRequest s e]
_slcOnFocusReq = [],
_slcOnBlurReq :: [Path -> WidgetRequest s e]
_slcOnBlurReq = [],
_slcOnChangeReq :: [a -> WidgetRequest s e]
_slcOnChangeReq = []
}
instance Semigroup (SliderCfg s e a) where
<> :: SliderCfg s e a -> SliderCfg s e a -> SliderCfg s e a
(<>) SliderCfg s e a
t1 SliderCfg s e a
t2 = SliderCfg {
_slcRadius :: Maybe Double
_slcRadius = forall s e a. SliderCfg s e a -> Maybe Double
_slcRadius SliderCfg s e a
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e a. SliderCfg s e a -> Maybe Double
_slcRadius SliderCfg s e a
t1,
_slcWidth :: Maybe Double
_slcWidth = forall s e a. SliderCfg s e a -> Maybe Double
_slcWidth SliderCfg s e a
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e a. SliderCfg s e a -> Maybe Double
_slcWidth SliderCfg s e a
t1,
_slcWheelRate :: Maybe Rational
_slcWheelRate = forall s e a. SliderCfg s e a -> Maybe Rational
_slcWheelRate SliderCfg s e a
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e a. SliderCfg s e a -> Maybe Rational
_slcWheelRate SliderCfg s e a
t1,
_slcDragRate :: Maybe Rational
_slcDragRate = forall s e a. SliderCfg s e a -> Maybe Rational
_slcDragRate SliderCfg s e a
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e a. SliderCfg s e a -> Maybe Rational
_slcDragRate SliderCfg s e a
t1,
_slcThumbVisible :: Maybe Bool
_slcThumbVisible = forall s e a. SliderCfg s e a -> Maybe Bool
_slcThumbVisible SliderCfg s e a
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e a. SliderCfg s e a -> Maybe Bool
_slcThumbVisible SliderCfg s e a
t1,
_slcThumbFactor :: Maybe Double
_slcThumbFactor = forall s e a. SliderCfg s e a -> Maybe Double
_slcThumbFactor SliderCfg s e a
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e a. SliderCfg s e a -> Maybe Double
_slcThumbFactor SliderCfg s e a
t1,
_slcOnFocusReq :: [Path -> WidgetRequest s e]
_slcOnFocusReq = forall s e a. SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnFocusReq SliderCfg s e a
t1 forall a. Semigroup a => a -> a -> a
<> forall s e a. SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnFocusReq SliderCfg s e a
t2,
_slcOnBlurReq :: [Path -> WidgetRequest s e]
_slcOnBlurReq = forall s e a. SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnBlurReq SliderCfg s e a
t1 forall a. Semigroup a => a -> a -> a
<> forall s e a. SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnBlurReq SliderCfg s e a
t2,
_slcOnChangeReq :: [a -> WidgetRequest s e]
_slcOnChangeReq = forall s e a. SliderCfg s e a -> [a -> WidgetRequest s e]
_slcOnChangeReq SliderCfg s e a
t1 forall a. Semigroup a => a -> a -> a
<> forall s e a. SliderCfg s e a -> [a -> WidgetRequest s e]
_slcOnChangeReq SliderCfg s e a
t2
}
instance Monoid (SliderCfg s e a) where
mempty :: SliderCfg s e a
mempty = forall a. Default a => a
def
instance CmbWidth (SliderCfg s e a) where
width :: Double -> SliderCfg s e a
width Double
w = forall a. Default a => a
def {
_slcWidth :: Maybe Double
_slcWidth = forall a. a -> Maybe a
Just Double
w
}
instance CmbRadius (SliderCfg s e a) where
radius :: Double -> SliderCfg s e a
radius Double
w = forall a. Default a => a
def {
_slcRadius :: Maybe Double
_slcRadius = forall a. a -> Maybe a
Just Double
w
}
instance CmbWheelRate (SliderCfg s e a) Rational where
wheelRate :: Rational -> SliderCfg s e a
wheelRate Rational
rate = forall a. Default a => a
def {
_slcWheelRate :: Maybe Rational
_slcWheelRate = forall a. a -> Maybe a
Just Rational
rate
}
instance CmbDragRate (SliderCfg s e a) Rational where
dragRate :: Rational -> SliderCfg s e a
dragRate Rational
rate = forall a. Default a => a
def {
_slcDragRate :: Maybe Rational
_slcDragRate = forall a. a -> Maybe a
Just Rational
rate
}
instance CmbThumbFactor (SliderCfg s e a) where
thumbFactor :: Double -> SliderCfg s e a
thumbFactor Double
w = forall a. Default a => a
def {
_slcThumbFactor :: Maybe Double
_slcThumbFactor = forall a. a -> Maybe a
Just Double
w
}
instance CmbThumbVisible (SliderCfg s e a) where
thumbVisible_ :: Bool -> SliderCfg s e a
thumbVisible_ Bool
w = forall a. Default a => a
def {
_slcThumbVisible :: Maybe Bool
_slcThumbVisible = forall a. a -> Maybe a
Just Bool
w
}
instance WidgetEvent e => CmbOnFocus (SliderCfg s e a) e Path where
onFocus :: (Path -> e) -> SliderCfg s e a
onFocus Path -> e
fn = forall a. Default a => a
def {
_slcOnFocusReq :: [Path -> WidgetRequest s e]
_slcOnFocusReq = [forall s e. WidgetEvent e => e -> WidgetRequest s e
RaiseEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> e
fn]
}
instance CmbOnFocusReq (SliderCfg s e a) s e Path where
onFocusReq :: (Path -> WidgetRequest s e) -> SliderCfg s e a
onFocusReq Path -> WidgetRequest s e
req = forall a. Default a => a
def {
_slcOnFocusReq :: [Path -> WidgetRequest s e]
_slcOnFocusReq = [Path -> WidgetRequest s e
req]
}
instance WidgetEvent e => CmbOnBlur (SliderCfg s e a) e Path where
onBlur :: (Path -> e) -> SliderCfg s e a
onBlur Path -> e
fn = forall a. Default a => a
def {
_slcOnBlurReq :: [Path -> WidgetRequest s e]
_slcOnBlurReq = [forall s e. WidgetEvent e => e -> WidgetRequest s e
RaiseEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> e
fn]
}
instance CmbOnBlurReq (SliderCfg s e a) s e Path where
onBlurReq :: (Path -> WidgetRequest s e) -> SliderCfg s e a
onBlurReq Path -> WidgetRequest s e
req = forall a. Default a => a
def {
_slcOnBlurReq :: [Path -> WidgetRequest s e]
_slcOnBlurReq = [Path -> WidgetRequest s e
req]
}
instance WidgetEvent e => CmbOnChange (SliderCfg s e a) a e where
onChange :: (a -> e) -> SliderCfg s e a
onChange a -> e
fn = forall a. Default a => a
def {
_slcOnChangeReq :: [a -> WidgetRequest s e]
_slcOnChangeReq = [forall s e. WidgetEvent e => e -> WidgetRequest s e
RaiseEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> e
fn]
}
instance CmbOnChangeReq (SliderCfg s e a) s e a where
onChangeReq :: (a -> WidgetRequest s e) -> SliderCfg s e a
onChangeReq a -> WidgetRequest s e
req = forall a. Default a => a
def {
_slcOnChangeReq :: [a -> WidgetRequest s e]
_slcOnChangeReq = [a -> WidgetRequest s e
req]
}
data SliderState = SliderState {
SliderState -> Integer
_slsMaxPos :: Integer,
SliderState -> Integer
_slsPos :: Integer
} deriving (SliderState -> SliderState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SliderState -> SliderState -> Bool
$c/= :: SliderState -> SliderState -> Bool
== :: SliderState -> SliderState -> Bool
$c== :: SliderState -> SliderState -> Bool
Eq, Int -> SliderState -> ShowS
[SliderState] -> ShowS
SliderState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SliderState] -> ShowS
$cshowList :: [SliderState] -> ShowS
show :: SliderState -> String
$cshow :: SliderState -> String
showsPrec :: Int -> SliderState -> ShowS
$cshowsPrec :: Int -> SliderState -> ShowS
Show, forall x. Rep SliderState x -> SliderState
forall x. SliderState -> Rep SliderState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SliderState x -> SliderState
$cfrom :: forall x. SliderState -> Rep SliderState x
Generic)
hslider
:: (SliderValue a, WidgetEvent e)
=> ALens' s a
-> a
-> a
-> WidgetNode s e
hslider :: forall a e s.
(SliderValue a, WidgetEvent e) =>
ALens' s a -> a -> a -> WidgetNode s e
hslider ALens' s a
field a
minVal a
maxVal = forall a e s.
(SliderValue a, WidgetEvent e) =>
ALens' s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
hslider_ ALens' s a
field a
minVal a
maxVal forall a. Default a => a
def
hslider_
:: (SliderValue a, WidgetEvent e)
=> ALens' s a
-> a
-> a
-> [SliderCfg s e a]
-> WidgetNode s e
hslider_ :: forall a e s.
(SliderValue a, WidgetEvent e) =>
ALens' s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
hslider_ ALens' s a
field a
minVal a
maxVal [SliderCfg s e a]
cfg = forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
sliderD_ Bool
True WidgetData s a
wlens a
minVal a
maxVal [SliderCfg s e a]
cfg where
wlens :: WidgetData s a
wlens = forall s a. ALens' s a -> WidgetData s a
WidgetLens ALens' s a
field
vslider
:: (SliderValue a, WidgetEvent e)
=> ALens' s a
-> a
-> a
-> WidgetNode s e
vslider :: forall a e s.
(SliderValue a, WidgetEvent e) =>
ALens' s a -> a -> a -> WidgetNode s e
vslider ALens' s a
field a
minVal a
maxVal = forall a e s.
(SliderValue a, WidgetEvent e) =>
ALens' s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
vslider_ ALens' s a
field a
minVal a
maxVal forall a. Default a => a
def
vslider_
:: (SliderValue a, WidgetEvent e)
=> ALens' s a
-> a
-> a
-> [SliderCfg s e a]
-> WidgetNode s e
vslider_ :: forall a e s.
(SliderValue a, WidgetEvent e) =>
ALens' s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
vslider_ ALens' s a
field a
minVal a
maxVal [SliderCfg s e a]
cfg = forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
sliderD_ Bool
False WidgetData s a
wlens a
minVal a
maxVal [SliderCfg s e a]
cfg where
wlens :: WidgetData s a
wlens = forall s a. ALens' s a -> WidgetData s a
WidgetLens ALens' s a
field
hsliderV
:: (SliderValue a, WidgetEvent e)
=> a
-> (a -> e)
-> a
-> a
-> WidgetNode s e
hsliderV :: forall a e s.
(SliderValue a, WidgetEvent e) =>
a -> (a -> e) -> a -> a -> WidgetNode s e
hsliderV a
value a -> e
handler a
minVal a
maxVal = forall a e s.
(SliderValue a, WidgetEvent e) =>
a -> (a -> e) -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
hsliderV_ a
value a -> e
handler a
minVal a
maxVal forall a. Default a => a
def
hsliderV_
:: (SliderValue a, WidgetEvent e)
=> a
-> (a -> e)
-> a
-> a
-> [SliderCfg s e a]
-> WidgetNode s e
hsliderV_ :: forall a e s.
(SliderValue a, WidgetEvent e) =>
a -> (a -> e) -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
hsliderV_ a
value a -> e
handler a
minVal a
maxVal [SliderCfg s e a]
configs = WidgetNode s e
newNode where
widgetData :: WidgetData s a
widgetData = forall s a. a -> WidgetData s a
WidgetValue a
value
newConfigs :: [SliderCfg s e a]
newConfigs = forall t a e. CmbOnChange t a e => (a -> e) -> t
onChange a -> e
handler forall a. a -> [a] -> [a]
: [SliderCfg s e a]
configs
newNode :: WidgetNode s e
newNode = forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
sliderD_ Bool
True forall {s}. WidgetData s a
widgetData a
minVal a
maxVal [SliderCfg s e a]
newConfigs
vsliderV
:: (SliderValue a, WidgetEvent e)
=> a
-> (a -> e)
-> a
-> a
-> WidgetNode s e
vsliderV :: forall a e s.
(SliderValue a, WidgetEvent e) =>
a -> (a -> e) -> a -> a -> WidgetNode s e
vsliderV a
value a -> e
handler a
minVal a
maxVal = forall a e s.
(SliderValue a, WidgetEvent e) =>
a -> (a -> e) -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
vsliderV_ a
value a -> e
handler a
minVal a
maxVal forall a. Default a => a
def
vsliderV_
:: (SliderValue a, WidgetEvent e)
=> a
-> (a -> e)
-> a
-> a
-> [SliderCfg s e a]
-> WidgetNode s e
vsliderV_ :: forall a e s.
(SliderValue a, WidgetEvent e) =>
a -> (a -> e) -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
vsliderV_ a
value a -> e
handler a
minVal a
maxVal [SliderCfg s e a]
configs = WidgetNode s e
newNode where
widgetData :: WidgetData s a
widgetData = forall s a. a -> WidgetData s a
WidgetValue a
value
newConfigs :: [SliderCfg s e a]
newConfigs = forall t a e. CmbOnChange t a e => (a -> e) -> t
onChange a -> e
handler forall a. a -> [a] -> [a]
: [SliderCfg s e a]
configs
newNode :: WidgetNode s e
newNode = forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
sliderD_ Bool
False forall {s}. WidgetData s a
widgetData a
minVal a
maxVal [SliderCfg s e a]
newConfigs
sliderD_
:: (SliderValue a, WidgetEvent e)
=> Bool
-> WidgetData s a
-> a
-> a
-> [SliderCfg s e a]
-> WidgetNode s e
sliderD_ :: forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a -> a -> a -> [SliderCfg s e a] -> WidgetNode s e
sliderD_ Bool
isHz WidgetData s a
widgetData a
minVal a
maxVal [SliderCfg s e a]
configs = WidgetNode s e
sliderNode where
config :: SliderCfg s e a
config = forall a. Monoid a => [a] -> a
mconcat [SliderCfg s e a]
configs
state :: SliderState
state = Integer -> Integer -> SliderState
SliderState Integer
0 Integer
0
wtype :: WidgetType
wtype = Text -> WidgetType
WidgetType (Text
"slider-" forall a. Semigroup a => a -> a -> a
<> forall a. TextShow a => a -> Text
showt (forall a. Typeable a => a -> TypeRep
typeOf a
minVal))
widget :: Widget s e
widget = forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
makeSlider Bool
isHz WidgetData s a
widgetData a
minVal a
maxVal SliderCfg s e a
config SliderState
state
sliderNode :: WidgetNode s e
sliderNode = forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
wtype Widget s e
widget
forall a b. a -> (a -> b) -> b
& forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasFocusable s a => Lens' s a
L.focusable forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
makeSlider
:: (SliderValue a, WidgetEvent e)
=> Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
makeSlider :: forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
makeSlider !Bool
isHz !WidgetData s a
field !a
minVal !a
maxVal !SliderCfg s e a
config !SliderState
state = Widget s e
widget where
widget :: Widget s e
widget = forall a s e. WidgetModel a => a -> Single s e a -> Widget s e
createSingle SliderState
state forall a. Default a => a
def {
singleFocusOnBtnPressed :: Bool
singleFocusOnBtnPressed = Bool
False,
singleGetBaseStyle :: SingleGetBaseStyle s e
singleGetBaseStyle = forall {s} {e} {p}. WidgetEnv s e -> p -> Maybe Style
getBaseStyle,
singleInit :: SingleInitHandler s e
singleInit = forall {p}. HasModel p s => p -> WidgetNode s e -> WidgetResult s e
init,
singleMerge :: SingleMergeHandler s e SliderState
singleMerge = forall {p}.
WidgetEnv s e
-> WidgetNode s e -> p -> SliderState -> WidgetResult s e
merge,
singleHandleEvent :: SingleEventHandler s e
singleHandleEvent = forall {p}.
WidgetEnv s e
-> WidgetNode s e -> p -> SystemEvent -> Maybe (WidgetResult s e)
handleEvent,
singleGetSizeReq :: SingleGetSizeReqHandler s e
singleGetSizeReq = forall {s} {e}.
WidgetEnv s e -> WidgetNode s e -> (SizeReq, SizeReq)
getSizeReq,
singleRender :: SingleRenderHandler s e
singleRender = forall {s} {e}.
WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render
}
dragRate :: Rational
dragRate
| forall a. Maybe a -> Bool
isJust (forall s e a. SliderCfg s e a -> Maybe Rational
_slcDragRate SliderCfg s e a
config) = forall a. HasCallStack => Maybe a -> a
fromJust (forall s e a. SliderCfg s e a -> Maybe Rational
_slcDragRate SliderCfg s e a
config)
| Bool
otherwise = forall a. Real a => a -> Rational
toRational (a
maxVal forall a. Num a => a -> a -> a
- a
minVal) forall a. Fractional a => a -> a -> a
/ Rational
1000
getBaseStyle :: WidgetEnv s e -> p -> Maybe Style
getBaseStyle WidgetEnv s e
wenv p
node = forall a. a -> Maybe a
Just Style
style where
style :: Style
style = forall s e. WidgetEnv s e -> Lens' ThemeState StyleState -> Style
collectTheme WidgetEnv s e
wenv forall s a. HasSliderStyle s a => Lens' s a
L.sliderStyle
init :: p -> WidgetNode s e -> WidgetResult s e
init p
wenv WidgetNode s e
node = forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
resNode where
currVal :: a
currVal = forall s a. s -> WidgetData s a -> a
widgetDataGet (p
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasModel s a => Lens' s a
L.model) WidgetData s a
field
newState :: SliderState
newState = a -> SliderState
newStateFromValue a
currVal
resNode :: WidgetNode s e
resNode = WidgetNode s e
node
forall a b. a -> (a -> b) -> b
& forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
makeSlider Bool
isHz WidgetData s a
field a
minVal a
maxVal SliderCfg s e a
config SliderState
newState
merge :: WidgetEnv s e
-> WidgetNode s e -> p -> SliderState -> WidgetResult s e
merge WidgetEnv s e
wenv WidgetNode s e
newNode p
oldNode SliderState
oldState = forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
resNode where
stateVal :: a
stateVal = forall {p}. Integral p => p -> a
valueFromPos (SliderState -> Integer
_slsPos SliderState
oldState)
modelVal :: a
modelVal = forall s a. s -> WidgetData s a -> a
widgetDataGet (WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasModel s a => Lens' s a
L.model) WidgetData s a
field
newState :: SliderState
newState
| forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodePressed WidgetEnv s e
wenv WidgetNode s e
newNode = SliderState
oldState
| a
stateVal forall a. Eq a => a -> a -> Bool
== a
modelVal = SliderState
oldState
| Bool
otherwise = a -> SliderState
newStateFromValue a
modelVal
resNode :: WidgetNode s e
resNode = WidgetNode s e
newNode
forall a b. a -> (a -> b) -> b
& forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
makeSlider Bool
isHz WidgetData s a
field a
minVal a
maxVal SliderCfg s e a
config SliderState
newState
handleEvent :: WidgetEnv s e
-> WidgetNode s e -> p -> SystemEvent -> Maybe (WidgetResult s e)
handleEvent WidgetEnv s e
wenv WidgetNode s e
node p
target SystemEvent
evt = case SystemEvent
evt of
Focus Path
prev -> forall s e.
WidgetNode s e
-> Path -> [Path -> WidgetRequest s e] -> Maybe (WidgetResult s e)
handleFocusChange WidgetNode s e
node Path
prev (forall s e a. SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnFocusReq SliderCfg s e a
config)
Blur Path
next -> forall s e.
WidgetNode s e
-> Path -> [Path -> WidgetRequest s e] -> Maybe (WidgetResult s e)
handleFocusChange WidgetNode s e
node Path
next (forall s e a. SliderCfg s e a -> [Path -> WidgetRequest s e]
_slcOnBlurReq SliderCfg s e a
config)
KeyAction KeyMod
mod KeyCode
code KeyStatus
KeyPressed
| Bool
ctrlPressed Bool -> Bool -> Bool
&& KeyCode -> Bool
isInc KeyCode
code -> Integer -> Maybe (WidgetResult s e)
handleNewPos (Integer
pos forall a. Num a => a -> a -> a
+ Integer
warpSpeed)
| Bool
ctrlPressed Bool -> Bool -> Bool
&& KeyCode -> Bool
isDec KeyCode
code -> Integer -> Maybe (WidgetResult s e)
handleNewPos (Integer
pos forall a. Num a => a -> a -> a
- Integer
warpSpeed)
| Bool
shiftPressed Bool -> Bool -> Bool
&& KeyCode -> Bool
isInc KeyCode
code -> Integer -> Maybe (WidgetResult s e)
handleNewPos (Integer
pos forall a. Num a => a -> a -> a
+ Integer
baseSpeed)
| Bool
shiftPressed Bool -> Bool -> Bool
&& KeyCode -> Bool
isDec KeyCode
code -> Integer -> Maybe (WidgetResult s e)
handleNewPos (Integer
pos forall a. Num a => a -> a -> a
- Integer
baseSpeed)
| KeyCode -> Bool
isInc KeyCode
code -> Integer -> Maybe (WidgetResult s e)
handleNewPos (Integer
pos forall a. Num a => a -> a -> a
+ Integer
fastSpeed)
| KeyCode -> Bool
isDec KeyCode
code -> Integer -> Maybe (WidgetResult s e)
handleNewPos (Integer
pos forall a. Num a => a -> a -> a
- Integer
fastSpeed)
where
ctrlPressed :: Bool
ctrlPressed = forall s e. WidgetEnv s e -> KeyMod -> Bool
isShortCutControl WidgetEnv s e
wenv KeyMod
mod
(KeyCode -> Bool
isDec, KeyCode -> Bool
isInc)
| Bool
isHz = (KeyCode -> Bool
isKeyLeft, KeyCode -> Bool
isKeyRight)
| Bool
otherwise = (KeyCode -> Bool
isKeyDown, KeyCode -> Bool
isKeyUp)
baseSpeed :: Integer
baseSpeed = forall a. Ord a => a -> a -> a
max Integer
1 forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
round (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxPos forall a. Fractional a => a -> a -> a
/ Double
1000)
fastSpeed :: Integer
fastSpeed = forall a. Ord a => a -> a -> a
max Integer
1 forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
round (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxPos forall a. Fractional a => a -> a -> a
/ Double
100)
warpSpeed :: Integer
warpSpeed = forall a. Ord a => a -> a -> a
max Integer
1 forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
round (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxPos forall a. Fractional a => a -> a -> a
/ Double
10)
handleNewPos :: Integer -> Maybe (WidgetResult s e)
handleNewPos !Integer
newPos
| Integer
validPos forall a. Eq a => a -> a -> Bool
/= Integer
pos = Integer -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPos Integer
validPos []
| Bool
otherwise = forall a. Maybe a
Nothing
where
validPos :: Integer
validPos = forall a. Ord a => a -> a -> a -> a
clamp Integer
0 Integer
maxPos Integer
newPos
Move Point
point
| forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodePressed WidgetEnv s e
wenv WidgetNode s e
node -> forall {p}.
(HasX p Double, HasY p Double) =>
p -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPoint Point
point []
ButtonAction Point
point Button
btn ButtonState
BtnPressed Int
clicks -> forall {p}.
(HasX p Double, HasY p Double) =>
p -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPoint Point
point forall {s} {e}. [WidgetRequest s e]
reqs where
reqs :: [WidgetRequest s e]
reqs
| Bool
shiftPressed = []
| Bool
otherwise = [forall s e. WidgetId -> WidgetRequest s e
SetFocus WidgetId
widgetId]
ButtonAction Point
point Button
btn ButtonState
BtnReleased Int
clicks -> forall {p}.
(HasX p Double, HasY p Double) =>
p -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPoint Point
point []
WheelScroll Point
_ (Point Double
_ Double
wy) WheelDirection
wheelDirection -> Integer -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPos Integer
newPos forall {s} {e}. [WidgetRequest s e]
reqs where
wheelCfg :: Rational
wheelCfg = forall a. a -> Maybe a -> a
fromMaybe (ThemeState
theme forall s a. s -> Getting a s a -> a
^. forall s a. HasSliderWheelRate s a => Lens' s a
L.sliderWheelRate) (forall s e a. SliderCfg s e a -> Maybe Rational
_slcWheelRate SliderCfg s e a
config)
wheelRate :: Double
wheelRate = forall a. Fractional a => Rational -> a
fromRational Rational
wheelCfg
tmpPos :: Integer
tmpPos = Integer
pos forall a. Num a => a -> a -> a
+ forall a b. (RealFrac a, Integral b) => a -> b
round (Double
wy forall a. Num a => a -> a -> a
* Double
wheelRate)
newPos :: Integer
newPos = forall a. Ord a => a -> a -> a -> a
clamp Integer
0 Integer
maxPos Integer
tmpPos
reqs :: [WidgetRequest s e]
reqs = [forall s e. WidgetRequest s e
IgnoreParentEvents]
SystemEvent
_ -> forall a. Maybe a
Nothing
where
theme :: ThemeState
theme = forall s e. WidgetEnv s e -> WidgetNode s e -> ThemeState
currentTheme WidgetEnv s e
wenv WidgetNode s e
node
style :: StyleState
style = forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle WidgetEnv s e
wenv WidgetNode s e
node
vp :: Rect
vp = forall s e. WidgetNode s e -> StyleState -> Rect
getContentArea WidgetNode s e
node StyleState
style
widgetId :: WidgetId
widgetId = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidgetId s a => Lens' s a
L.widgetId
shiftPressed :: Bool
shiftPressed = WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasInputStatus s a => Lens' s a
L.inputStatus forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasKeyMod s a => Lens' s a
L.keyMod forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasLeftShift s a => Lens' s a
L.leftShift
SliderState Integer
maxPos Integer
pos = SliderState
state
resultFromPoint :: p -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPoint !p
point ![WidgetRequest s e]
reqs = Integer -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPos Integer
newPos [WidgetRequest s e]
reqs where
!newPos :: Integer
newPos = forall {a} {p} {p}.
(HasX p a, HasX p a, HasY p a, HasY p a, RealFrac a, HasW p a,
HasH p a) =>
Bool -> p -> p -> Integer
posFromMouse Bool
isHz Rect
vp p
point
resultFromPos :: Integer -> [WidgetRequest s e] -> Maybe (WidgetResult s e)
resultFromPos !Integer
newPos ![WidgetRequest s e]
extraReqs = forall a. a -> Maybe a
Just WidgetResult s e
newResult where
!newState :: SliderState
newState = SliderState
state {
_slsPos :: Integer
_slsPos = Integer
newPos
}
!newNode :: WidgetNode s e
newNode = WidgetNode s e
node
forall a b. a -> (a -> b) -> b
& forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a e s.
(SliderValue a, WidgetEvent e) =>
Bool
-> WidgetData s a
-> a
-> a
-> SliderCfg s e a
-> SliderState
-> Widget s e
makeSlider Bool
isHz WidgetData s a
field a
minVal a
maxVal SliderCfg s e a
config SliderState
newState
!result :: WidgetResult s e
result = forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
newNode [forall s e. WidgetRequest s e
RenderOnce]
!newVal :: a
newVal = forall {p}. Integral p => p -> a
valueFromPos Integer
newPos
!reqs :: [WidgetRequest s e]
reqs = forall s a e. WidgetData s a -> a -> [WidgetRequest s e]
widgetDataSet WidgetData s a
field a
newVal
forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> a -> b
$ a
newVal) (forall s e a. SliderCfg s e a -> [a -> WidgetRequest s e]
_slcOnChangeReq SliderCfg s e a
config)
forall a. [a] -> [a] -> [a]
++ [WidgetRequest s e]
extraReqs
!newResult :: WidgetResult s e
newResult
| Integer
pos forall a. Eq a => a -> a -> Bool
/= Integer
newPos = WidgetResult s e
result
forall a b. a -> (a -> b) -> b
& forall s a. HasRequests s a => Lens' s a
L.requests forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ forall a. [a] -> Seq a
Seq.fromList [WidgetRequest s e]
reqs
| Bool
otherwise = WidgetResult s e
result
getSizeReq :: WidgetEnv s e -> WidgetNode s e -> (SizeReq, SizeReq)
getSizeReq WidgetEnv s e
wenv WidgetNode s e
node = (SizeReq, SizeReq)
req where
theme :: ThemeState
theme = forall s e. WidgetEnv s e -> WidgetNode s e -> ThemeState
currentTheme WidgetEnv s e
wenv WidgetNode s e
node
maxPos :: Double
maxPos = forall a b. (Real a, Fractional b) => a -> b
realToFrac (forall a. Real a => a -> Rational
toRational (a
maxVal forall a. Num a => a -> a -> a
- a
minVal) forall a. Fractional a => a -> a -> a
/ Rational
dragRate)
width :: Double
width = forall a. a -> Maybe a -> a
fromMaybe (ThemeState
theme forall s a. s -> Getting a s a -> a
^. forall s a. HasSliderWidth s a => Lens' s a
L.sliderWidth) (forall s e a. SliderCfg s e a -> Maybe Double
_slcWidth SliderCfg s e a
config)
req :: (SizeReq, SizeReq)
req
| Bool
isHz = (Double -> Double -> SizeReq
expandSize Double
maxPos Double
1, Double -> SizeReq
fixedSize Double
width)
| Bool
otherwise = (Double -> SizeReq
fixedSize Double
width, Double -> Double -> SizeReq
expandSize Double
maxPos Double
1)
render :: WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render WidgetEnv s e
wenv WidgetNode s e
node Renderer
renderer = do
Renderer -> Rect -> Maybe Color -> Maybe Radius -> IO ()
drawRect Renderer
renderer Rect
sliderBgArea (forall a. a -> Maybe a
Just Color
sndColor) Maybe Radius
sliderRadius
Renderer -> Bool -> Rect -> IO () -> IO ()
drawInScissor Renderer
renderer Bool
True Rect
sliderFgArea forall a b. (a -> b) -> a -> b
$
Renderer -> Rect -> Maybe Color -> Maybe Radius -> IO ()
drawRect Renderer
renderer Rect
sliderBgArea (forall a. a -> Maybe a
Just Color
fgColor) Maybe Radius
sliderRadius
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
thbVisible forall a b. (a -> b) -> a -> b
$
Renderer -> Rect -> Maybe Color -> IO ()
drawEllipse Renderer
renderer Rect
thbArea (forall a. a -> Maybe a
Just Color
hlColor)
where
theme :: ThemeState
theme = forall s e. WidgetEnv s e -> WidgetNode s e -> ThemeState
currentTheme WidgetEnv s e
wenv WidgetNode s e
node
style :: StyleState
style = forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle WidgetEnv s e
wenv WidgetNode s e
node
fgColor :: Color
fgColor = StyleState -> Color
styleFgColor StyleState
style
hlColor :: Color
hlColor = StyleState -> Color
styleHlColor StyleState
style
sndColor :: Color
sndColor = StyleState -> Color
styleSndColor StyleState
style
radiusW :: Maybe Double
radiusW = forall s e a. SliderCfg s e a -> Maybe Double
_slcRadius SliderCfg s e a
config forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ThemeState
theme forall s a. s -> Getting a s a -> a
^. forall s a. HasSliderRadius s a => Lens' s a
L.sliderRadius
sliderRadius :: Maybe Radius
sliderRadius = forall t. CmbRadius t => Double -> t
radius forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Double
radiusW
SliderState Integer
maxPos Integer
pos = SliderState
state
posPct :: Double
posPct = forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
pos forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxPos
carea :: Rect
carea = forall s e. WidgetNode s e -> StyleState -> Rect
getContentArea WidgetNode s e
node StyleState
style
Rect Double
cx Double
cy Double
cw Double
ch = Rect
carea
barW :: Double
barW
| Bool
isHz = Double
ch
| Bool
otherwise = Double
cw
thbVisible :: Bool
thbVisible = forall a. a -> Maybe a -> a
fromMaybe Bool
False (forall s e a. SliderCfg s e a -> Maybe Bool
_slcThumbVisible SliderCfg s e a
config)
thbF :: Double
thbF = forall a. a -> Maybe a -> a
fromMaybe (ThemeState
theme forall s a. s -> Getting a s a -> a
^. forall s a. HasSliderThumbFactor s a => Lens' s a
L.sliderThumbFactor) (forall s e a. SliderCfg s e a -> Maybe Double
_slcThumbFactor SliderCfg s e a
config)
thbW :: Double
thbW = Double
thbF forall a. Num a => a -> a -> a
* Double
barW
thbPos :: Double -> Double
thbPos Double
dim = (Double
dim forall a. Num a => a -> a -> a
- Double
thbW) forall a. Num a => a -> a -> a
* Double
posPct
thbDif :: Double
thbDif = (Double
thbW forall a. Num a => a -> a -> a
- Double
barW) forall a. Fractional a => a -> a -> a
/ Double
2
thbArea :: Rect
thbArea
| Bool
isHz = Double -> Double -> Double -> Double -> Rect
Rect (Double
cx forall a. Num a => a -> a -> a
+ Double -> Double
thbPos Double
cw) (Double
cy forall a. Num a => a -> a -> a
- Double
thbDif) Double
thbW Double
thbW
| Bool
otherwise = Double -> Double -> Double -> Double -> Rect
Rect (Double
cx forall a. Num a => a -> a -> a
- Double
thbDif) (Double
cy forall a. Num a => a -> a -> a
+ Double
ch forall a. Num a => a -> a -> a
- Double
thbW forall a. Num a => a -> a -> a
- Double -> Double
thbPos Double
ch) Double
thbW Double
thbW
tw2 :: Double
tw2 = Double
thbW forall a. Fractional a => a -> a -> a
/ Double
2
sliderBgArea :: Rect
sliderBgArea
| Bool -> Bool
not Bool
thbVisible = Rect
carea
| Bool
isHz = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def (Rect -> Double -> Double -> Double -> Double -> Maybe Rect
subtractFromRect Rect
carea Double
tw2 Double
tw2 Double
0 Double
0)
| Bool
otherwise = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def (Rect -> Double -> Double -> Double -> Double -> Maybe Rect
subtractFromRect Rect
carea Double
0 Double
0 Double
tw2 Double
tw2)
sliderFgArea :: Rect
sliderFgArea
| Bool
isHz = Rect
sliderBgArea forall a b. a -> (a -> b) -> b
& forall s a. HasW s a => Lens' s a
L.w forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Num a => a -> a -> a
*Double
posPct)
| Bool
otherwise = Rect
sliderBgArea
forall a b. a -> (a -> b) -> b
& forall s a. HasY s a => Lens' s a
L.y forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Num a => a -> a -> a
+ (Rect
sliderBgArea forall s a. s -> Getting a s a -> a
^. forall s a. HasH s a => Lens' s a
L.h forall a. Num a => a -> a -> a
* (Double
1 forall a. Num a => a -> a -> a
- Double
posPct)))
forall a b. a -> (a -> b) -> b
& forall s a. HasH s a => Lens' s a
L.h forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Num a => a -> a -> a
*Double
posPct)
newStateFromValue :: a -> SliderState
newStateFromValue a
currVal = SliderState
newState where
newMaxPos :: Integer
newMaxPos = forall a b. (RealFrac a, Integral b) => a -> b
round (forall a. Real a => a -> Rational
toRational (a
maxVal forall a. Num a => a -> a -> a
- a
minVal) forall a. Fractional a => a -> a -> a
/ Rational
dragRate)
newPos :: Integer
newPos = forall a b. (RealFrac a, Integral b) => a -> b
round (forall a. Real a => a -> Rational
toRational (a
currVal forall a. Num a => a -> a -> a
- a
minVal) forall a. Fractional a => a -> a -> a
/ Rational
dragRate)
newState :: SliderState
newState = SliderState {
_slsMaxPos :: Integer
_slsMaxPos = Integer
newMaxPos,
_slsPos :: Integer
_slsPos = Integer
newPos
}
posFromMouse :: Bool -> p -> p -> Integer
posFromMouse Bool
isHz p
vp p
point = Integer
newPos where
SliderState Integer
maxPos Integer
_ = SliderState
state
dv :: a
dv
| Bool
isHz = p
point forall s a. s -> Getting a s a -> a
^. forall s a. HasX s a => Lens' s a
L.x forall a. Num a => a -> a -> a
- p
vp forall s a. s -> Getting a s a -> a
^. forall s a. HasX s a => Lens' s a
L.x
| Bool
otherwise = p
vp forall s a. s -> Getting a s a -> a
^. forall s a. HasY s a => Lens' s a
L.y forall a. Num a => a -> a -> a
+ p
vp forall s a. s -> Getting a s a -> a
^. forall s a. HasH s a => Lens' s a
L.h forall a. Num a => a -> a -> a
- p
point forall s a. s -> Getting a s a -> a
^. forall s a. HasY s a => Lens' s a
L.y
tmpPos :: Integer
tmpPos
| Bool
isHz = forall a b. (RealFrac a, Integral b) => a -> b
round (a
dv forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxPos forall a. Fractional a => a -> a -> a
/ p
vp forall s a. s -> Getting a s a -> a
^. forall s a. HasW s a => Lens' s a
L.w)
| Bool
otherwise = forall a b. (RealFrac a, Integral b) => a -> b
round (a
dv forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxPos forall a. Fractional a => a -> a -> a
/ p
vp forall s a. s -> Getting a s a -> a
^. forall s a. HasH s a => Lens' s a
L.h)
newPos :: Integer
newPos = forall a. Ord a => a -> a -> a -> a
clamp Integer
0 Integer
maxPos Integer
tmpPos
valueFromPos :: p -> a
valueFromPos p
newPos = a
newVal where
newVal :: a
newVal = a
minVal forall a. Num a => a -> a -> a
+ forall a b. (FromFractional a, Real b, Fractional b) => b -> a
fromFractional (Rational
dragRate forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral p
newPos)