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

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

@
dial numericLens 0 100
@

Similar in objective to "Monomer.Widgets.Singles.Slider", but uses less visual
space in its parent container.
-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}

module Monomer.Widgets.Singles.Dial (
  -- * Configuration
  DialValue,
  DialCfg,
  -- * Constructors
  dial,
  dial_,
  dialV,
  dialV_
) 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 dial.
type DialValue a = (Eq a, Show a, Real a, FromFractional a, Typeable a)

{-|
Configuration options for dial:

- 'width': sets the max width/height of the dial.
- 'wheelRate': The rate at which wheel movement affects the number.
- 'dragRate': The rate at which drag movement affects the number.
- '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 DialCfg s e a = DialCfg {
  forall s e a. DialCfg s e a -> Maybe Double
_dlcWidth :: Maybe Double,
  forall s e a. DialCfg s e a -> Maybe Rational
_dlcWheelRate :: Maybe Rational,
  forall s e a. DialCfg s e a -> Maybe Rational
_dlcDragRate :: Maybe Rational,
  forall s e a. DialCfg s e a -> [Path -> WidgetRequest s e]
_dlcOnFocusReq :: [Path -> WidgetRequest s e],
  forall s e a. DialCfg s e a -> [Path -> WidgetRequest s e]
_dlcOnBlurReq :: [Path -> WidgetRequest s e],
  forall s e a. DialCfg s e a -> [a -> WidgetRequest s e]
_dlcOnChangeReq :: [a -> WidgetRequest s e]
}

instance Default (DialCfg s e a) where
  def :: DialCfg s e a
def = DialCfg {
    _dlcWidth :: Maybe Double
_dlcWidth = forall a. Maybe a
Nothing,
    _dlcWheelRate :: Maybe Rational
_dlcWheelRate = forall a. Maybe a
Nothing,
    _dlcDragRate :: Maybe Rational
_dlcDragRate = forall a. Maybe a
Nothing,
    _dlcOnFocusReq :: [Path -> WidgetRequest s e]
_dlcOnFocusReq = [],
    _dlcOnBlurReq :: [Path -> WidgetRequest s e]
_dlcOnBlurReq = [],
    _dlcOnChangeReq :: [a -> WidgetRequest s e]
_dlcOnChangeReq = []
  }

instance Semigroup (DialCfg s e a) where
  <> :: DialCfg s e a -> DialCfg s e a -> DialCfg s e a
(<>) DialCfg s e a
t1 DialCfg s e a
t2 = DialCfg {
    _dlcWidth :: Maybe Double
_dlcWidth = forall s e a. DialCfg s e a -> Maybe Double
_dlcWidth DialCfg s e a
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e a. DialCfg s e a -> Maybe Double
_dlcWidth DialCfg s e a
t1,
    _dlcWheelRate :: Maybe Rational
_dlcWheelRate = forall s e a. DialCfg s e a -> Maybe Rational
_dlcWheelRate DialCfg s e a
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e a. DialCfg s e a -> Maybe Rational
_dlcWheelRate DialCfg s e a
t1,
    _dlcDragRate :: Maybe Rational
_dlcDragRate = forall s e a. DialCfg s e a -> Maybe Rational
_dlcDragRate DialCfg s e a
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e a. DialCfg s e a -> Maybe Rational
_dlcDragRate DialCfg s e a
t1,
    _dlcOnFocusReq :: [Path -> WidgetRequest s e]
_dlcOnFocusReq = forall s e a. DialCfg s e a -> [Path -> WidgetRequest s e]
_dlcOnFocusReq DialCfg s e a
t1 forall a. Semigroup a => a -> a -> a
<> forall s e a. DialCfg s e a -> [Path -> WidgetRequest s e]
_dlcOnFocusReq DialCfg s e a
t2,
    _dlcOnBlurReq :: [Path -> WidgetRequest s e]
_dlcOnBlurReq = forall s e a. DialCfg s e a -> [Path -> WidgetRequest s e]
_dlcOnBlurReq DialCfg s e a
t1 forall a. Semigroup a => a -> a -> a
<> forall s e a. DialCfg s e a -> [Path -> WidgetRequest s e]
_dlcOnBlurReq DialCfg s e a
t2,
    _dlcOnChangeReq :: [a -> WidgetRequest s e]
_dlcOnChangeReq = forall s e a. DialCfg s e a -> [a -> WidgetRequest s e]
_dlcOnChangeReq DialCfg s e a
t1 forall a. Semigroup a => a -> a -> a
<> forall s e a. DialCfg s e a -> [a -> WidgetRequest s e]
_dlcOnChangeReq DialCfg s e a
t2
  }

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

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

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

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

instance WidgetEvent e => CmbOnFocus (DialCfg s e a) e Path where
  onFocus :: (Path -> e) -> DialCfg s e a
onFocus Path -> e
fn = forall a. Default a => a
def {
    _dlcOnFocusReq :: [Path -> WidgetRequest s e]
_dlcOnFocusReq = [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 (DialCfg s e a) s e Path where
  onFocusReq :: (Path -> WidgetRequest s e) -> DialCfg s e a
onFocusReq Path -> WidgetRequest s e
req = forall a. Default a => a
def {
    _dlcOnFocusReq :: [Path -> WidgetRequest s e]
_dlcOnFocusReq = [Path -> WidgetRequest s e
req]
  }

instance WidgetEvent e => CmbOnBlur (DialCfg s e a) e Path where
  onBlur :: (Path -> e) -> DialCfg s e a
onBlur Path -> e
fn = forall a. Default a => a
def {
    _dlcOnBlurReq :: [Path -> WidgetRequest s e]
_dlcOnBlurReq = [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 (DialCfg s e a) s e Path where
  onBlurReq :: (Path -> WidgetRequest s e) -> DialCfg s e a
onBlurReq Path -> WidgetRequest s e
req = forall a. Default a => a
def {
    _dlcOnBlurReq :: [Path -> WidgetRequest s e]
_dlcOnBlurReq = [Path -> WidgetRequest s e
req]
  }

instance WidgetEvent e => CmbOnChange (DialCfg s e a) a e where
  onChange :: (a -> e) -> DialCfg s e a
onChange a -> e
fn = forall a. Default a => a
def {
    _dlcOnChangeReq :: [a -> WidgetRequest s e]
_dlcOnChangeReq = [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 (DialCfg s e a) s e a where
  onChangeReq :: (a -> WidgetRequest s e) -> DialCfg s e a
onChangeReq a -> WidgetRequest s e
req = forall a. Default a => a
def {
    _dlcOnChangeReq :: [a -> WidgetRequest s e]
_dlcOnChangeReq = [a -> WidgetRequest s e
req]
  }

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

-- | Creates a dial using the given lens, providing minimum and maximum values.
dial
  :: (DialValue a, WidgetEvent e)
  => ALens' s a
  -> a
  -> a
  -> WidgetNode s e
dial :: forall a e s.
(DialValue a, WidgetEvent e) =>
ALens' s a -> a -> a -> WidgetNode s e
dial ALens' s a
field a
minVal a
maxVal = forall a e s.
(DialValue a, WidgetEvent e) =>
ALens' s a -> a -> a -> [DialCfg s e a] -> WidgetNode s e
dial_ ALens' s a
field a
minVal a
maxVal forall a. Default a => a
def

{-|
Creates a dial using the given lens, providing minimum and maximum values.
Accepts config.
-}
dial_
  :: (DialValue a, WidgetEvent e)
  => ALens' s a
  -> a
  -> a
  -> [DialCfg s e a]
  -> WidgetNode s e
dial_ :: forall a e s.
(DialValue a, WidgetEvent e) =>
ALens' s a -> a -> a -> [DialCfg s e a] -> WidgetNode s e
dial_ ALens' s a
field a
minVal a
maxVal [DialCfg s e a]
cfgs = forall a e s.
(DialValue a, WidgetEvent e) =>
WidgetData s a -> a -> a -> [DialCfg s e a] -> WidgetNode s e
dialD_ (forall s a. ALens' s a -> WidgetData s a
WidgetLens ALens' s a
field) a
minVal a
maxVal [DialCfg s e a]
cfgs

{-|
Creates a dial using the given value and 'onChange' event handler, providing
minimum and maximum values.
-}
dialV
  :: (DialValue a, WidgetEvent e)
  => a
  -> (a -> e)
  -> a
  -> a
  -> WidgetNode s e
dialV :: forall a e s.
(DialValue a, WidgetEvent e) =>
a -> (a -> e) -> a -> a -> WidgetNode s e
dialV a
value a -> e
handler a
minVal a
maxVal = forall a e s.
(DialValue a, WidgetEvent e) =>
a -> (a -> e) -> a -> a -> [DialCfg s e a] -> WidgetNode s e
dialV_ a
value a -> e
handler a
minVal a
maxVal forall a. Default a => a
def

{-|
Creates a dial using the given value and 'onChange' event handler, providing
minimum and maximum values.
Accepts config.
-}
dialV_
  :: (DialValue a, WidgetEvent e)
  => a
  -> (a -> e)
  -> a
  -> a
  -> [DialCfg s e a]
  -> WidgetNode s e
dialV_ :: forall a e s.
(DialValue a, WidgetEvent e) =>
a -> (a -> e) -> a -> a -> [DialCfg s e a] -> WidgetNode s e
dialV_ a
value a -> e
handler a
minVal a
maxVal [DialCfg 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 :: [DialCfg s e a]
newConfigs = forall t a e. CmbOnChange t a e => (a -> e) -> t
onChange a -> e
handler forall a. a -> [a] -> [a]
: [DialCfg s e a]
configs
  newNode :: WidgetNode s e
newNode = forall a e s.
(DialValue a, WidgetEvent e) =>
WidgetData s a -> a -> a -> [DialCfg s e a] -> WidgetNode s e
dialD_ forall {s}. WidgetData s a
widgetData a
minVal a
maxVal [DialCfg s e a]
newConfigs

{-|
Creates a dial providing a 'WidgetData' instance, minimum and maximum values and
config.
-}
dialD_
  :: (DialValue a, WidgetEvent e)
  => WidgetData s a
  -> a
  -> a
  -> [DialCfg s e a]
  -> WidgetNode s e
dialD_ :: forall a e s.
(DialValue a, WidgetEvent e) =>
WidgetData s a -> a -> a -> [DialCfg s e a] -> WidgetNode s e
dialD_ WidgetData s a
widgetData a
minVal a
maxVal [DialCfg s e a]
configs = WidgetNode s e
dialNode where
  config :: DialCfg s e a
config = forall a. Monoid a => [a] -> a
mconcat [DialCfg s e a]
configs
  state :: DialState
state = Integer -> Integer -> DialState
DialState Integer
0 Integer
0
  wtype :: WidgetType
wtype = Text -> WidgetType
WidgetType (Text
"dial-" 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.
(DialValue a, WidgetEvent e) =>
WidgetData s a
-> a -> a -> DialCfg s e a -> DialState -> Widget s e
makeDial WidgetData s a
widgetData a
minVal a
maxVal DialCfg s e a
config DialState
state
  dialNode :: WidgetNode s e
dialNode = 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

makeDial
  :: (DialValue a, WidgetEvent e)
  => WidgetData s a
  -> a
  -> a
  -> DialCfg s e a
  -> DialState
  -> Widget s e
makeDial :: forall a e s.
(DialValue a, WidgetEvent e) =>
WidgetData s a
-> a -> a -> DialCfg s e a -> DialState -> Widget s e
makeDial !WidgetData s a
field !a
minVal !a
maxVal !DialCfg s e a
config !DialState
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 DialState
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,
    singleGetCurrentStyle :: SingleGetCurrentStyle s e
singleGetCurrentStyle = SingleGetCurrentStyle s e
getCurrentStyle,
    singleInit :: SingleInitHandler s e
singleInit = forall {p}. HasModel p s => p -> WidgetNode s e -> WidgetResult s e
init,
    singleMerge :: SingleMergeHandler s e DialState
singleMerge = forall {p}.
WidgetEnv s e
-> WidgetNode s e -> p -> DialState -> WidgetResult s e
merge,
    singleFindByPoint :: SingleFindByPointHandler s e
singleFindByPoint = forall {p}.
WidgetEnv s e
-> WidgetNode s e -> p -> Point -> Maybe WidgetNodeInfo
findByPoint,
    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 = SingleRenderHandler s e
render
  }

  dragRate :: Rational
dragRate
    | forall a. Maybe a -> Bool
isJust (forall s e a. DialCfg s e a -> Maybe Rational
_dlcDragRate DialCfg s e a
config) = forall a. HasCallStack => Maybe a -> a
fromJust (forall s e a. DialCfg s e a -> Maybe Rational
_dlcDragRate DialCfg 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. HasDialStyle s a => Lens' s a
L.dialStyle

  getCurrentStyle :: SingleGetCurrentStyle s e
getCurrentStyle WidgetEnv s e
wenv WidgetNode s e
node = StyleState
style where
    (Point
_, Rect
dialArea) = forall s e a.
WidgetEnv s e -> WidgetNode s e -> DialCfg s e a -> (Point, Rect)
getDialInfo WidgetEnv s e
wenv WidgetNode s e
node DialCfg s e a
config
    style :: StyleState
style = forall s e.
CurrentStyleCfg s e
-> WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle_ (forall s e. Rect -> CurrentStyleCfg s e
currentStyleConfig Rect
dialArea) WidgetEnv s e
wenv WidgetNode s e
node

  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
    newState :: DialState
newState = forall {p} {p}. HasModel p s => p -> p -> DialState -> DialState
newStateFromModel p
wenv WidgetNode s e
node DialState
state
    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.
(DialValue a, WidgetEvent e) =>
WidgetData s a
-> a -> a -> DialCfg s e a -> DialState -> Widget s e
makeDial WidgetData s a
field a
minVal a
maxVal DialCfg s e a
config DialState
newState

  merge :: WidgetEnv s e
-> WidgetNode s e -> p -> DialState -> WidgetResult s e
merge WidgetEnv s e
wenv WidgetNode s e
newNode p
oldNode DialState
oldState = forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
resNode where
    newState :: DialState
newState
      | forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodePressed WidgetEnv s e
wenv WidgetNode s e
newNode = DialState
oldState
      | Bool
otherwise = forall {p} {p}. HasModel p s => p -> p -> DialState -> DialState
newStateFromModel WidgetEnv s e
wenv WidgetNode s e
newNode DialState
oldState
    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.
(DialValue a, WidgetEvent e) =>
WidgetData s a
-> a -> a -> DialCfg s e a -> DialState -> Widget s e
makeDial WidgetData s a
field a
minVal a
maxVal DialCfg s e a
config DialState
newState

  findByPoint :: WidgetEnv s e
-> WidgetNode s e -> p -> Point -> Maybe WidgetNodeInfo
findByPoint WidgetEnv s e
wenv WidgetNode s e
node p
path Point
point
    | Bool
isVisible Bool -> Bool -> Bool
&& Point -> Rect -> Bool
pointInEllipse Point
point Rect
dialArea = forall a. a -> Maybe a
Just WidgetNodeInfo
wni
    | Bool
otherwise = forall a. Maybe a
Nothing
    where
      isVisible :: Bool
isVisible = 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. HasVisible s a => Lens' s a
L.visible
      wni :: WidgetNodeInfo
wni = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info
      (Point
_, Rect
dialArea) = forall s e a.
WidgetEnv s e -> WidgetNode s e -> DialCfg s e a -> (Point, Rect)
getDialInfo WidgetEnv s e
wenv WidgetNode s e
node DialCfg s e a
config

  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. DialCfg s e a -> [Path -> WidgetRequest s e]
_dlcOnFocusReq DialCfg 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. DialCfg s e a -> [Path -> WidgetRequest s e]
_dlcOnBlurReq DialCfg s e a
config)

    KeyAction KeyMod
mod KeyCode
code KeyStatus
KeyPressed
      | Bool
ctrlPressed Bool -> Bool -> Bool
&& KeyCode -> Bool
isKeyUp 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
isKeyDown 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
isKeyUp 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
isKeyDown KeyCode
code -> Integer -> Maybe (WidgetResult s e)
handleNewPos (Integer
pos forall a. Num a => a -> a -> a
- Integer
baseSpeed)
      | KeyCode -> Bool
isKeyUp KeyCode
code -> Integer -> Maybe (WidgetResult s e)
handleNewPos (Integer
pos forall a. Num a => a -> a -> a
+ Integer
fastSpeed)
      | KeyCode -> Bool
isKeyDown KeyCode
code -> Integer -> Maybe (WidgetResult s e)
handleNewPos (Integer
pos forall a. Num a => a -> a -> a
- Integer
fastSpeed)
      where
        DialState Integer
maxPos Integer
pos = DialState
state
        ctrlPressed :: Bool
ctrlPressed = forall s e. WidgetEnv s e -> KeyMod -> Bool
isShortCutControl WidgetEnv s e
wenv KeyMod
mod
        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)
        vPos :: Integer -> Integer
vPos Integer
pos = forall a. Ord a => a -> a -> a -> a
clamp Integer
0 Integer
maxPos Integer
pos
        newResult :: Integer -> WidgetResult s e
newResult !Integer
newPos = forall {p}. HasRequests p (Seq (WidgetRequest s e)) => p -> a -> p
addReqsEvts (forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
newNode) a
newVal where
          newVal :: a
newVal = forall a. DialValue a => a -> Rational -> Integer -> a
valueFromPos a
minVal Rational
dragRate Integer
newPos
          !newState :: DialState
newState = DialState
state { _dlsPos :: Integer
_dlsPos = 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.
(DialValue a, WidgetEvent e) =>
WidgetData s a
-> a -> a -> DialCfg s e a -> DialState -> Widget s e
makeDial WidgetData s a
field a
minVal a
maxVal DialCfg s e a
config DialState
newState
        handleNewPos :: Integer -> Maybe (WidgetResult s e)
handleNewPos !Integer
newPos
          | Integer -> Integer
vPos Integer
newPos forall a. Eq a => a -> a -> Bool
/= Integer
pos = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> WidgetResult s e
newResult (Integer -> Integer
vPos Integer
newPos)
          | Bool
otherwise = forall a. Maybe a
Nothing

    Move Point
point
      | forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodePressed WidgetEnv s e
wenv WidgetNode s e
node -> forall a. a -> Maybe a
Just WidgetResult s e
result where
        (Path
_, Point
start) = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasMainBtnPress s a => Lens' s a
L.mainBtnPress
        (Integer
_, a
newVal) = forall a.
DialValue a =>
a -> a -> DialState -> Rational -> Point -> Point -> (Integer, a)
posFromPoint a
minVal a
maxVal DialState
state Rational
dragRate Point
start Point
point
        result :: WidgetResult s e
result = forall {p}. HasRequests p (Seq (WidgetRequest s e)) => p -> a -> p
addReqsEvts (forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
node [forall s e. WidgetRequest s e
RenderOnce]) a
newVal

    ButtonAction Point
point Button
btn ButtonState
BtnPressed Int
clicks
      | Bool -> Bool
not (forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodeFocused WidgetEnv s e
wenv WidgetNode s e
node) Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
shiftPressed -> forall a. a -> Maybe a
Just WidgetResult s e
result where
        result :: WidgetResult s e
result = forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
node [forall s e. WidgetId -> WidgetRequest s e
SetFocus WidgetId
widgetId]

    ButtonAction Point
point Button
btn ButtonState
BtnReleased Int
clicks -> forall a. a -> Maybe a
Just WidgetResult s e
result where
      reqs :: [WidgetRequest s e]
reqs = [forall s e. WidgetRequest s e
RenderOnce]
      newState :: DialState
newState = forall {p} {p}. HasModel p s => p -> p -> DialState -> DialState
newStateFromModel WidgetEnv s e
wenv WidgetNode s e
node DialState
state
      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.
(DialValue a, WidgetEvent e) =>
WidgetData s a
-> a -> a -> DialCfg s e a -> DialState -> Widget s e
makeDial WidgetData s a
field a
minVal a
maxVal DialCfg s e a
config DialState
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]
reqs

    WheelScroll Point
_ (Point Double
_ Double
wy) WheelDirection
wheelDirection -> forall a. a -> Maybe a
Just WidgetResult s e
result where
      DialState Integer
maxPos Integer
pos = DialState
state
      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. DialCfg s e a -> Maybe Rational
_dlcWheelRate DialCfg 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
      newVal :: a
newVal = forall a. DialValue a => a -> Rational -> Integer -> a
valueFromPos a
minVal Rational
dragRate Integer
newPos
      reqs :: [WidgetRequest s e]
reqs = [forall s e. WidgetRequest s e
RenderOnce, forall s e. WidgetRequest s e
IgnoreParentEvents]
      result :: WidgetResult s e
result = forall {p}. HasRequests p (Seq (WidgetRequest s e)) => p -> a -> p
addReqsEvts (forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
node forall {s} {e}. [WidgetRequest s e]
reqs) a
newVal
    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
      (Point
_, Rect
dialArea) = forall s e a.
WidgetEnv s e -> WidgetNode s e -> DialCfg s e a -> (Point, Rect)
getDialInfo WidgetEnv s e
wenv WidgetNode s e
node DialCfg s e a
config
      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
      path :: Path
path = 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. HasPath s a => Lens' s a
L.path

      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
      isSelectKey :: KeyCode -> Bool
isSelectKey KeyCode
code = KeyCode -> Bool
isKeyReturn KeyCode
code Bool -> Bool -> Bool
|| KeyCode -> Bool
isKeySpace KeyCode
code
      addReqsEvts :: p -> a -> p
addReqsEvts p
result a
newVal = p
newResult where
        currVal :: a
currVal = 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
        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. DialCfg s e a -> [a -> WidgetRequest s e]
_dlcOnChangeReq DialCfg s e a
config)
        newResult :: p
newResult
          | a
currVal forall a. Eq a => a -> a -> Bool
/= a
newVal = p
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 = p
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
    width :: Double
width = forall a. a -> Maybe a -> a
fromMaybe (ThemeState
theme forall s a. s -> Getting a s a -> a
^. forall s a. HasDialWidth s a => Lens' s a
L.dialWidth) (forall s e a. DialCfg s e a -> Maybe Double
_dlcWidth DialCfg s e a
config)
    req :: (SizeReq, SizeReq)
req = (Double -> SizeReq
fixedSize Double
width, Double -> SizeReq
fixedSize Double
width)

  render :: SingleRenderHandler s e
render WidgetEnv s e
wenv WidgetNode s e
node Renderer
renderer = do
    Renderer
-> Rect
-> Double
-> Double
-> Winding
-> Maybe Color
-> Double
-> IO ()
drawArcBorder Renderer
renderer Rect
dialArea Double
start Double
endSnd Winding
CW (forall a. a -> Maybe a
Just Color
sndColor) Double
dialBW
    Renderer
-> Rect
-> Double
-> Double
-> Winding
-> Maybe Color
-> Double
-> IO ()
drawArcBorder Renderer
renderer Rect
dialArea Double
start Double
endFg Winding
CW (forall a. a -> Maybe a
Just Color
fgColor) Double
dialBW
    where
      (Point
dialCenter, Rect
dialArea) = forall s e a.
WidgetEnv s e -> WidgetNode s e -> DialCfg s e a -> (Point, Rect)
getDialInfo WidgetEnv s e
wenv WidgetNode s e
node DialCfg s e a
config
      DialState Integer
maxPos Integer
pos = forall {p} {p}. HasModel p s => p -> p -> DialState -> DialState
newStateFromModel WidgetEnv s e
wenv WidgetNode s e
node DialState
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
      dialBW :: Double
dialBW = forall a. Ord a => a -> a -> a
max Double
1 (Rect -> Double
_rW Rect
dialArea forall a. Num a => a -> a -> a
* Double
0.15)
      style :: StyleState
style = SingleGetCurrentStyle s e
getCurrentStyle WidgetEnv s e
wenv WidgetNode s e
node
      fgColor :: Color
fgColor = StyleState -> Color
styleFgColor StyleState
style
      sndColor :: Color
sndColor = StyleState -> Color
styleSndColor StyleState
style
      start :: Double
start = Double
90 forall a. Num a => a -> a -> a
+ Double
45
      endFg :: Double
endFg = Double
start forall a. Num a => a -> a -> a
+ Double
270 forall a. Num a => a -> a -> a
* Double
posPct
      endSnd :: Double
endSnd = Double
45

  newStateFromModel :: p -> p -> DialState -> DialState
newStateFromModel p
wenv p
node DialState
oldState = DialState
newState 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
    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 :: DialState
newState = DialState
oldState {
      _dlsMaxPos :: Integer
_dlsMaxPos = Integer
newMaxPos,
      _dlsPos :: Integer
_dlsPos = Integer
newPos
    }

posFromPoint
  :: DialValue a
  => a
  -> a
  -> DialState
  -> Rational
  -> Point
  -> Point
  -> (Integer, a)
posFromPoint :: forall a.
DialValue a =>
a -> a -> DialState -> Rational -> Point -> Point -> (Integer, a)
posFromPoint a
minVal a
maxVal DialState
state Rational
dragRate Point
stPoint Point
point = (Integer
newPos, a
newVal) where
  DialState Integer
maxPos Integer
pos = DialState
state
  Point Double
_ Double
dy = Point -> Point -> Point
subPoint Point
stPoint Point
point
  tmpPos :: Integer
tmpPos = Integer
pos forall a. Num a => a -> a -> a
+ forall a b. (RealFrac a, Integral b) => a -> b
round Double
dy
  newPos :: Integer
newPos = forall a. Ord a => a -> a -> a -> a
clamp Integer
0 Integer
maxPos Integer
tmpPos
  newVal :: a
newVal = forall a. DialValue a => a -> Rational -> Integer -> a
valueFromPos a
minVal Rational
dragRate Integer
newPos

valueFromPos :: DialValue a => a -> Rational -> Integer -> a
valueFromPos :: forall a. DialValue a => a -> Rational -> Integer -> a
valueFromPos !a
minVal !Rational
dragRate !Integer
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 Integer
newPos)

getDialInfo :: WidgetEnv s e -> WidgetNode s e -> DialCfg s e a -> (Point, Rect)
getDialInfo :: forall s e a.
WidgetEnv s e -> WidgetNode s e -> DialCfg s e a -> (Point, Rect)
getDialInfo WidgetEnv s e
wenv WidgetNode s e
node DialCfg s e a
config = (Point
dialCenter, Rect
dialArea) 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
  carea :: Rect
carea = forall s e. WidgetNode s e -> StyleState -> Rect
getContentArea WidgetNode s e
node StyleState
style

  dialW :: Double
dialW = forall a. a -> Maybe a -> a
fromMaybe (ThemeState
theme forall s a. s -> Getting a s a -> a
^. forall s a. HasDialWidth s a => Lens' s a
L.dialWidth) (forall s e a. DialCfg s e a -> Maybe Double
_dlcWidth DialCfg s e a
config)
  dialL :: Double
dialL = Rect -> Double
_rX Rect
carea forall a. Num a => a -> a -> a
+ (Rect -> Double
_rW Rect
carea forall a. Num a => a -> a -> a
- Double
dialW) forall a. Fractional a => a -> a -> a
/ Double
2
  dialT :: Double
dialT = Rect -> Double
_rY Rect
carea forall a. Num a => a -> a -> a
+ (Rect -> Double
_rH Rect
carea forall a. Num a => a -> a -> a
- Double
dialW) forall a. Fractional a => a -> a -> a
/ Double
2
  !dialCenter :: Point
dialCenter = Double -> Double -> Point
Point (Double
dialL forall a. Num a => a -> a -> a
+ Double
dialW forall a. Fractional a => a -> a -> a
/ Double
2) (Double
dialT forall a. Num a => a -> a -> a
+ Double
dialW forall a. Fractional a => a -> a -> a
/ Double
2)
  !dialArea :: Rect
dialArea = Double -> Double -> Double -> Double -> Rect
Rect Double
dialL Double
dialT Double
dialW Double
dialW

currentStyleConfig :: Rect -> CurrentStyleCfg s e
currentStyleConfig :: forall s e. Rect -> CurrentStyleCfg s e
currentStyleConfig Rect
dialArea = forall a. Default a => a
def
  forall a b. a -> (a -> b) -> b
& forall s a. HasIsHovered s a => Lens' s a
L.isHovered forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall s e. Rect -> WidgetEnv s e -> WidgetNode s e -> Bool
isNodeHoveredEllipse_ Rect
dialArea