content: {-|
  Module      : Monomer.Widgets.Singles.Slider
  Copyright   : (c) 2018 Francisco Vallarino
  License     : BSD-3-Clause (see the LICENSE file)
  Maintainer  : fjvallarino@gmail.com
  Stability   : experimental
  Portability : non-portable
  
  Slider widget, used for interacting with numeric values. It allows changing the
  value using the keyboard arrows, dragging the mouse or using the wheel.
  
  @
  hslider numericLens 0 100
  @
  
  Similar in objective to "Monomer.Widgets.Singles.Dial", but more convenient in
  some layouts.
  -}
  {-# LANGUAGE BangPatterns #-}
  {-# LANGUAGE ConstraintKinds #-}
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE StrictData #-}
  
  module Monomer.Widgets.Singles.Slider (
    -- * Configuration
    SliderValue,
    SliderCfg,
    -- * Constructors
    hslider,
    hslider_,
    vslider,
    vslider_,
    hsliderV,
    hsliderV_,
    vsliderV,
    vsliderV_,
    sliderD_
  ) where
  
  import Control.Applicative ((<|>))
  import Control.Lens (ALens', (&), (^.), (.~), (%~), (<>~))
  import Control.Monad
  import Data.Default
  import Data.Maybe
  import Data.Typeable (Typeable, typeOf)
  import GHC.Generics
  import TextShow
  
  import qualified Data.Sequence as Seq
  
  import Monomer.Helper
  import Monomer.Widgets.Single
  
  import qualified Monomer.Lens as L
  
  -- | Constraints for numeric types accepted by the slider widget.
  type SliderValue a = (Eq a, Show a, Real a, FromFractional a, Typeable a)
  
  {-|
  Configuration options for slider:
  
  - 'width': sets the size of the secondary axis of the Slider.
  - 'radius': the radius of the corners of the Slider.
  - 'wheelRate': The rate at which wheel movement affects the number.
  - 'dragRate': The rate at which drag movement affects the number.
  - 'thumbVisible': whether a thumb should be visible or not.
  - 'thumbFactor': the size of the thumb relative to width.
  - 'onFocus': event to raise when focus is received.
  - 'onFocusReq': 'WidgetRequest' to generate when focus is received.
  - 'onBlur': event to raise when focus is lost.
  - 'onBlurReq': 'WidgetRequest' to generate when focus is lost.
  - 'onChange': event to raise when the value changes.
  - 'onChangeReq': 'WidgetRequest' to generate when the value changes.
  -}
  data SliderCfg s e a = SliderCfg {
    _slcRadius :: Maybe Double,
    _slcWidth :: Maybe Double,
    _slcWheelRate :: Maybe Rational,
    _slcDragRate :: Maybe Rational,
    _slcThumbVisible :: Maybe Bool,
    _slcThumbFactor :: Maybe Double,
    _slcOnFocusReq :: [Path -> WidgetRequest s e],
    _slcOnBlurReq :: [Path -> WidgetRequest s e],
    _slcOnChangeReq :: [a -> WidgetRequest s e]
  }
  
  instance Default (SliderCfg s e a) where
    def = SliderCfg {
      _slcRadius = Nothing,
      _slcWidth = Nothing,
      _slcWheelRate = Nothing,
      _slcDragRate = Nothing,
      _slcThumbVisible = Nothing,
      _slcThumbFactor = Nothing,
      _slcOnFocusReq = [],
      _slcOnBlurReq = [],
      _slcOnChangeReq = []
    }
  
  instance Semigroup (SliderCfg s e a) where
    (<>) t1 t2 = SliderCfg {
      _slcRadius = _slcRadius t2 <|> _slcRadius t1,
      _slcWidth = _slcWidth t2 <|> _slcWidth t1,
      _slcWheelRate = _slcWheelRate t2 <|> _slcWheelRate t1,
      _slcDragRate = _slcDragRate t2 <|> _slcDragRate t1,
      _slcThumbVisible = _slcThumbVisible t2 <|> _slcThumbVisible t1,
      _slcThumbFactor = _slcThumbFactor t2 <|> _slcThumbFactor t1,
      _slcOnFocusReq = _slcOnFocusReq t1 <> _slcOnFocusReq t2,
      _slcOnBlurReq = _slcOnBlurReq t1 <> _slcOnBlurReq t2,
      _slcOnChangeReq = _slcOnChangeReq t1 <> _slcOnChangeReq t2
    }
  
  instance Monoid (SliderCfg s e a) where
    mempty = def
  
  instance CmbWidth (SliderCfg s e a) where
    width w = def {
      _slcWidth = Just w
  }
  
  instance CmbRadius (SliderCfg s e a) where
    radius w = def {
      _slcRadius = Just w
    }
  
  instance CmbWheelRate (SliderCfg s e a) Rational where
    wheelRate rate = def {
      _slcWheelRate = Just rate
    }
  
  instance CmbDragRate (SliderCfg s e a) Rational where
    dragRate rate = def {
      _slcDragRate = Just rate
    }
  
  instance CmbThumbFactor (SliderCfg s e a) where
    thumbFactor w = def {
      _slcThumbFactor = Just w
    }
  
  instance CmbThumbVisible (SliderCfg s e a) where
    thumbVisible_ w = def {
      _slcThumbVisible = Just w
    }
  
  instance WidgetEvent e => CmbOnFocus (SliderCfg s e a) e Path where
    onFocus fn = def {
      _slcOnFocusReq = [RaiseEvent . fn]
    }
  
  instance CmbOnFocusReq (SliderCfg s e a) s e Path where
    onFocusReq req = def {
      _slcOnFocusReq = [req]
    }
  
  instance WidgetEvent e => CmbOnBlur (SliderCfg s e a) e Path where
    onBlur fn = def {
      _slcOnBlurReq = [RaiseEvent . fn]
    }
  
  instance CmbOnBlurReq (SliderCfg s e a) s e Path where
    onBlurReq req = def {
      _slcOnBlurReq = [req]
    }
  
  instance WidgetEvent e => CmbOnChange (SliderCfg s e a) a e where
    onChange fn = def {
      _slcOnChangeReq = [RaiseEvent . fn]
    }
  
  instance CmbOnChangeReq (SliderCfg s e a) s e a where
    onChangeReq req = def {
      _slcOnChangeReq = [req]
    }
  
  data SliderState = SliderState {
    _slsMaxPos :: Integer,
    _slsPos :: Integer
  } deriving (Eq, Show, Generic)
  
  
  {-|
  Creates a horizontal slider using the given lens, providing minimum and maximum
  values.
  -}
  hslider
    :: (SliderValue a, WidgetEvent e)
    => ALens' s a      -- ^ The lens into the model.
    -> a               -- ^ Minimum value.
    -> a               -- ^ Maximum value.
    -> WidgetNode s e  -- ^ The created slider.
  hslider field minVal maxVal = hslider_ field minVal maxVal def
  
  {-|
  Creates a horizontal slider using the given lens, providing minimum and maximum
  values. Accepts config.
  -}
  hslider_
    :: (SliderValue a, WidgetEvent e)
    => ALens' s a         -- ^ The lens into the model.
    -> a                  -- ^ Minimum value.
    -> a                  -- ^ Maximum value.
    -> [SliderCfg s e a]  -- ^ The config options.
    -> WidgetNode s e     -- ^ The created slider.
  hslider_ field minVal maxVal cfg = sliderD_ True wlens minVal maxVal cfg where
    wlens = WidgetLens field
  
  {-|
  Creates a vertical slider using the given lens, providing minimum and maximum
  values.
  -}
  vslider
    :: (SliderValue a, WidgetEvent e)
    => ALens' s a      -- ^ The lens into the model.
    -> a               -- ^ Minimum value.
    -> a               -- ^ Maximum value.
    -> WidgetNode s e  -- ^ The created slider.
  vslider field minVal maxVal = vslider_ field minVal maxVal def
  
  {-|
  Creates a vertical slider using the given lens, providing minimum and maximum
  values. Accepts config.
  -}
  vslider_
    :: (SliderValue a, WidgetEvent e)
    => ALens' s a         -- ^ The lens into the model.
    -> a                  -- ^ Minimum value.
    -> a                  -- ^ Maximum value.
    -> [SliderCfg s e a]  -- ^ The config options.
    -> WidgetNode s e     -- ^ The created slider.
  vslider_ field minVal maxVal cfg = sliderD_ False wlens minVal maxVal cfg where
    wlens = WidgetLens field
  
  {-|
  Creates a horizontal slider using the given value and 'onChange' event handler,
  providing minimum and maximum values.
  -}
  hsliderV
    :: (SliderValue a, WidgetEvent e)
    => a               -- ^ The current value.
    -> (a -> e)        -- ^ The event to raise on change.
    -> a               -- ^ Minimum value.
    -> a               -- ^ Maximum value.
    -> WidgetNode s e  -- ^ The created slider.
  hsliderV value handler minVal maxVal = hsliderV_ value handler minVal maxVal def
  
  {-|
  Creates a horizontal slider using the given value and 'onChange' event handler,
  providing minimum and maximum values. Accepts config.
  -}
  hsliderV_
    :: (SliderValue a, WidgetEvent e)
    => a                  -- ^ The current value.
    -> (a -> e)           -- ^ The event to raise on change.
    -> a                  -- ^ Minimum value.
    -> a                  -- ^ Maximum value.
    -> [SliderCfg s e a]  -- ^ The config options.
    -> WidgetNode s e     -- ^ The created slider.
  hsliderV_ value handler minVal maxVal configs = newNode where
    widgetData = WidgetValue value
    newConfigs = onChange handler : configs
    newNode = sliderD_ True widgetData minVal maxVal newConfigs
  
  {-|
  Creates a vertical slider using the given value and 'onChange' event handler,
  providing minimum and maximum values.
  -}
  vsliderV
    :: (SliderValue a, WidgetEvent e)
    => a               -- ^ The current value.
    -> (a -> e)        -- ^ The event to raise on change.
    -> a               -- ^ Minimum value.
    -> a               -- ^ Maximum value.
    -> WidgetNode s e  -- ^ The created slider.
  vsliderV value handler minVal maxVal = vsliderV_ value handler minVal maxVal def
  
  {-|
  Creates a vertical slider using the given value and 'onChange' event handler,
  providing minimum and maximum values. Accepts config.
  -}
  vsliderV_
    :: (SliderValue a, WidgetEvent e)
    => a                  -- ^ The current value.
    -> (a -> e)           -- ^ The event to raise on change.
    -> a                  -- ^ Minimum value.
    -> a                  -- ^ Maximum value.
    -> [SliderCfg s e a]  -- ^ The config options.
    -> WidgetNode s e     -- ^ The created slider.
  vsliderV_ value handler minVal maxVal configs = newNode where
    widgetData = WidgetValue value
    newConfigs = onChange handler : configs
    newNode = sliderD_ False widgetData minVal maxVal newConfigs
  
  {-|
  Creates a slider providing direction, a 'WidgetData' instance, minimum and
  maximum values and config.
  -}
  sliderD_
    :: (SliderValue a, WidgetEvent e)
    => Bool               -- ^ True if horizontal, False if vertical
    -> WidgetData s a     -- ^ The 'WidgetData' to retrieve the value from.
    -> a                  -- ^ Minimum value.
    -> a                  -- ^ Maximum value.
    -> [SliderCfg s e a]  -- ^ The config options.
    -> WidgetNode s e     -- ^ The created slider.
  sliderD_ isHz widgetData minVal maxVal configs = sliderNode where
    config = mconcat configs
    state = SliderState 0 0
    wtype = WidgetType ("slider-" <> showt (typeOf minVal))
    widget = makeSlider isHz widgetData minVal maxVal config state
    sliderNode = defaultWidgetNode wtype widget
      & L.info . L.focusable .~ True
  
  makeSlider
    :: (SliderValue a, WidgetEvent e)
    => Bool
    -> WidgetData s a
    -> a
    -> a
    -> SliderCfg s e a
    -> SliderState
    -> Widget s e
  makeSlider !isHz !field !minVal !maxVal !config !state = widget where
    widget = createSingle state def {
      singleFocusOnBtnPressed = False,
      singleGetBaseStyle = getBaseStyle,
      singleInit = init,
      singleMerge = merge,
      singleHandleEvent = handleEvent,
      singleGetSizeReq = getSizeReq,
      singleRender = render
    }
  
    dragRate
      | isJust (_slcDragRate config) = fromJust (_slcDragRate config)
      | otherwise = toRational (maxVal - minVal) / 1000
  
    getBaseStyle wenv node = Just style where
      style = collectTheme wenv L.sliderStyle
  
    init wenv node = resultNode resNode where
      currVal = widgetDataGet (wenv ^. L.model) field
      newState = newStateFromValue currVal
      resNode = node
        & L.widget .~ makeSlider isHz field minVal maxVal config newState
  
    merge wenv newNode oldNode oldState = resultNode resNode where
      stateVal = valueFromPos (_slsPos oldState)
      modelVal = widgetDataGet (wenv ^. L.model) field
      newState
        | isNodePressed wenv newNode = oldState
        | stateVal == modelVal = oldState
        | otherwise = newStateFromValue modelVal
      resNode = newNode
        & L.widget .~ makeSlider isHz field minVal maxVal config newState
  
    handleEvent wenv node target evt = case evt of
      Focus prev -> handleFocusChange node prev (_slcOnFocusReq config)
  
      Blur next -> handleFocusChange node next (_slcOnBlurReq config)
  
      KeyAction mod code KeyPressed
        | ctrlPressed && isInc code -> handleNewPos (pos + warpSpeed)
        | ctrlPressed && isDec code -> handleNewPos (pos - warpSpeed)
        | shiftPressed && isInc code -> handleNewPos (pos + baseSpeed)
        | shiftPressed && isDec code -> handleNewPos (pos - baseSpeed)
        | isInc code -> handleNewPos (pos + fastSpeed)
        | isDec code -> handleNewPos (pos - fastSpeed)
        where
          ctrlPressed = isShortCutControl wenv mod
          (isDec, isInc)
            | isHz = (isKeyLeft, isKeyRight)
            | otherwise = (isKeyDown, isKeyUp)
  
          baseSpeed = max 1 $ round (fromIntegral maxPos / 1000)
          fastSpeed = max 1 $ round (fromIntegral maxPos / 100)
          warpSpeed = max 1 $ round (fromIntegral maxPos / 10)
  
          handleNewPos !newPos
            | validPos /= pos = resultFromPos validPos []
            | otherwise = Nothing
            where
              validPos = clamp 0 maxPos newPos
  
      Move point
        | isNodePressed wenv node -> resultFromPoint point []
  
      ButtonAction point btn BtnPressed clicks -> resultFromPoint point reqs where
        reqs
          | shiftPressed = []
          | otherwise = [SetFocus widgetId]
  
      ButtonAction point btn BtnReleased clicks  -> resultFromPoint point []
  
      WheelScroll _ (Point _ wy) wheelDirection -> resultFromPos newPos reqs where
        wheelCfg = fromMaybe (theme ^. L.sliderWheelRate) (_slcWheelRate config)
        wheelRate = fromRational wheelCfg
        tmpPos = pos + round (wy * wheelRate)
        newPos = clamp 0 maxPos tmpPos
        reqs = [IgnoreParentEvents]
      _ -> Nothing
      where
        theme = currentTheme wenv node
        style = currentStyle wenv node
        vp = getContentArea node style
        widgetId = node ^. L.info . L.widgetId
        shiftPressed = wenv ^. L.inputStatus . L.keyMod . L.leftShift
        SliderState maxPos pos = state
  
        resultFromPoint !point !reqs = resultFromPos newPos reqs where
          !newPos = posFromMouse isHz vp point
  
        resultFromPos !newPos !extraReqs = Just newResult where
          !newState = state {
            _slsPos = newPos
          }
          !newNode = node
            & L.widget .~ makeSlider isHz field minVal maxVal config newState
          !result = resultReqs newNode [RenderOnce]
          !newVal = valueFromPos newPos
  
          !reqs = widgetDataSet field newVal
            ++ fmap ($ newVal) (_slcOnChangeReq config)
            ++ extraReqs
          !newResult
            | pos /= newPos = result
                & L.requests <>~ Seq.fromList reqs
            | otherwise = result
  
    getSizeReq wenv node = req where
      theme = currentTheme wenv node
      maxPos = realToFrac (toRational (maxVal - minVal) / dragRate)
      width = fromMaybe (theme ^. L.sliderWidth) (_slcWidth config)
      req
        | isHz = (expandSize maxPos 1, fixedSize width)
        | otherwise = (fixedSize width, expandSize maxPos 1)
  
    render wenv node renderer = do
      drawRect renderer sliderBgArea (Just sndColor) sliderRadius
  
      drawInScissor renderer True sliderFgArea $
        drawRect renderer sliderBgArea (Just fgColor) sliderRadius
  
      when thbVisible $
        drawEllipse renderer thbArea (Just hlColor)
      where
        theme = currentTheme wenv node
        style = currentStyle wenv node
  
        fgColor = styleFgColor style
        hlColor = styleHlColor style
        sndColor = styleSndColor style
  
        radiusW = _slcRadius config <|> theme ^. L.sliderRadius
        sliderRadius = radius <$> radiusW
        SliderState maxPos pos = state
        posPct = fromIntegral pos / fromIntegral maxPos
        carea = getContentArea node style
        Rect cx cy cw ch = carea
        barW
          | isHz = ch
          | otherwise = cw
        -- Thumb
        thbVisible = fromMaybe False (_slcThumbVisible config)
        thbF = fromMaybe (theme ^. L.sliderThumbFactor) (_slcThumbFactor config)
        thbW = thbF * barW
        thbPos dim = (dim - thbW) * posPct
        thbDif = (thbW - barW) / 2
        thbArea
          | isHz = Rect (cx + thbPos cw) (cy - thbDif) thbW thbW
          | otherwise = Rect (cx - thbDif) (cy + ch - thbW - thbPos ch) thbW thbW
        -- Bar
        tw2 = thbW / 2
        sliderBgArea
          | not thbVisible = carea
          | isHz = fromMaybe def (subtractFromRect carea tw2 tw2 0 0)
          | otherwise = fromMaybe def (subtractFromRect carea 0 0 tw2 tw2)
        sliderFgArea
          | isHz = sliderBgArea & L.w %~ (*posPct)
          | otherwise = sliderBgArea
              & L.y %~ (+ (sliderBgArea ^. L.h * (1 - posPct)))
              & L.h %~ (*posPct)
  
    newStateFromValue currVal = newState where
      newMaxPos = round (toRational (maxVal - minVal) / dragRate)
      newPos = round (toRational (currVal - minVal) / dragRate)
      newState = SliderState {
        _slsMaxPos = newMaxPos,
        _slsPos = newPos
      }
  
    posFromMouse isHz vp point = newPos where
      SliderState maxPos _ = state
      dv
        | isHz = point ^. L.x - vp ^. L.x
        | otherwise = vp ^. L.y + vp ^. L.h - point ^. L.y
      tmpPos
        | isHz = round (dv * fromIntegral maxPos / vp ^. L.w)
        | otherwise = round (dv * fromIntegral maxPos / vp ^. L.h)
      newPos = clamp 0 maxPos tmpPos
  
    valueFromPos newPos = newVal where
      newVal = minVal + fromFractional (dragRate * fromIntegral newPos)
  