content: {-|
  Module      : Monomer.Widgets.Singles.Radio
  Copyright   : (c) 2018 Francisco Vallarino
  License     : BSD-3-Clause (see the LICENSE file)
  Maintainer  : fjvallarino@gmail.com
  Stability   : experimental
  Portability : non-portable
  
  Radio widget, used for interacting with a fixed set of values. Each instance of
  the radio is associated with a single value. It does not include text, which can
  be added with a label in the desired position (usually with
  [hstack/vstack]("Monomer.Widgets.Containers.Stack")). Alternatively,
  "Monomer.Widgets.Singles.LabeledRadio" provides this functionality out of the
  box.
  
  @
  radio Option1 optionLens
  @
  
  "Monomer.Widgets.Singles.OptionButton" provides similar functionality but with
  the look of a regular button.
  -}
  {-# LANGUAGE BangPatterns #-}
  {-# LANGUAGE ConstraintKinds #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE StrictData #-}
  
  module Monomer.Widgets.Singles.Radio (
    -- * Configuration
    RadioValue,
    RadioCfg,
    -- * Constructors
    radio,
    radio_,
    radioV,
    radioV_,
    radioD_
  ) where
  
  import Control.Applicative ((<|>))
  import Control.Lens (ALens', (&), (^.), (.~))
  import Control.Monad
  import Data.Default
  import Data.Maybe
  import Data.Typeable (Typeable, typeOf)
  import TextShow
  
  import Monomer.Widgets.Single
  
  import qualified Monomer.Lens as L
  
  -- | Constraints for numeric types accepted by the radio widget.
  type RadioValue a = (Eq a, Typeable a)
  
  {-|
  Configuration options for radio:
  
  - 'width': sets the max width/height of the radio.
  - '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.
  - 'onClick': event to raise when the value is clicked.
  - 'onClickReq': 'WidgetRequest' to generate when the value is clicked.
  - 'onChange': event to raise when the value changes.
  - 'onChangeReq': 'WidgetRequest' to generate when the value changes.
  -}
  data RadioCfg s e a = RadioCfg {
    _rdcWidth :: Maybe Double,
    _rdcOnFocusReq :: [Path -> WidgetRequest s e],
    _rdcOnBlurReq :: [Path -> WidgetRequest s e],
    _rdcOnClickReq :: [WidgetRequest s e],
    _rdcOnChangeReq :: [a -> WidgetRequest s e]
  }
  
  instance Default (RadioCfg s e a) where
    def = RadioCfg {
      _rdcWidth = Nothing,
      _rdcOnFocusReq = [],
      _rdcOnBlurReq = [],
      _rdcOnClickReq = [],
      _rdcOnChangeReq = []
    }
  
  instance Semigroup (RadioCfg s e a) where
    (<>) t1 t2 = RadioCfg {
      _rdcWidth = _rdcWidth t2 <|> _rdcWidth t1,
      _rdcOnFocusReq = _rdcOnFocusReq t1 <> _rdcOnFocusReq t2,
      _rdcOnBlurReq = _rdcOnBlurReq t1 <> _rdcOnBlurReq t2,
      _rdcOnClickReq = _rdcOnClickReq t1 <> _rdcOnClickReq t2,
      _rdcOnChangeReq = _rdcOnChangeReq t1 <> _rdcOnChangeReq t2
    }
  
  instance Monoid (RadioCfg s e a) where
    mempty = def
  
  instance CmbWidth (RadioCfg s e a) where
    width w = def {
      _rdcWidth = Just w
    }
  
  instance WidgetEvent e => CmbOnFocus (RadioCfg s e a) e Path where
    onFocus fn = def {
      _rdcOnFocusReq = [RaiseEvent . fn]
    }
  
  instance CmbOnFocusReq (RadioCfg s e a) s e Path where
    onFocusReq req = def {
      _rdcOnFocusReq = [req]
    }
  
  instance WidgetEvent e => CmbOnBlur (RadioCfg s e a) e Path where
    onBlur fn = def {
      _rdcOnBlurReq = [RaiseEvent . fn]
    }
  
  instance CmbOnBlurReq (RadioCfg s e a) s e Path where
    onBlurReq req = def {
      _rdcOnBlurReq = [req]
    }
  
  instance WidgetEvent e => CmbOnClick (RadioCfg s e a) e where
    onClick fn = def {
      _rdcOnClickReq = [RaiseEvent fn]
    }
  
  instance CmbOnClickReq (RadioCfg s e a) s e where
    onClickReq req = def {
      _rdcOnClickReq = [req]
    }
  
  instance WidgetEvent e => CmbOnChange (RadioCfg s e a) a e where
    onChange fn = def {
      _rdcOnChangeReq = [RaiseEvent . fn]
    }
  
  instance CmbOnChangeReq (RadioCfg s e a) s e a where
    onChangeReq req = def {
      _rdcOnChangeReq = [req]
    }
  
  -- | Creates a radio using the given lens.
  radio
    :: (RadioValue a, WidgetEvent e)
    => a               -- ^ The option value.
    -> ALens' s a      -- ^ The lens into the model.
    -> WidgetNode s e  -- ^ The created radio.
  radio option field = radio_ option field def
  
  -- | Creates a radio using the given lens. Accepts config.
  radio_
    :: (RadioValue a, WidgetEvent e)
    => a                 -- ^ The option value.
    -> ALens' s a        -- ^ The lens into the model.
    -> [RadioCfg s e a]  -- ^ The config options.
    -> WidgetNode s e    -- ^ The created radio.
  radio_ option field configs = radioD_ option (WidgetLens field) configs
  
  -- | Creates a radio using the given value and 'onChange' event handler.
  radioV
    :: (RadioValue a, WidgetEvent e)
    => a               -- ^ The option value.
    -> a               -- ^ The current value.
    -> (a -> e)        -- ^ The event to raise on change.
    -> WidgetNode s e  -- ^ The created radio.
  radioV option value handler = radioV_ option value handler def
  
  -- | Creates a radio using the given value and 'onChange' event handler.
  --   Accepts config.
  radioV_
    :: (RadioValue a, WidgetEvent e)
    => a                 -- ^ The option value.
    -> a                 -- ^ The current value.
    -> (a -> e)          -- ^ The event to raise on change.
    -> [RadioCfg s e a]  -- ^ The config options.
    -> WidgetNode s e    -- ^ The created radio.
  radioV_ option value handler configs = newNode where
    widgetData = WidgetValue value
    newConfigs = onChange handler : configs
    newNode = radioD_ option widgetData newConfigs
  
  -- | Creates a radio providing a 'WidgetData' instance and config.
  radioD_
    :: (RadioValue a, WidgetEvent e)
    => a                 -- ^ The option value.
    -> WidgetData s a    -- ^ The 'WidgetData' to retrieve the value from.
    -> [RadioCfg s e a]  -- ^ The config options.
    -> WidgetNode s e    -- ^ The created radio.
  radioD_ option widgetData configs = radioNode where
    config = mconcat configs
    wtype = WidgetType ("radio-" <> showt (typeOf option))
    widget = makeRadio widgetData option config
    radioNode = defaultWidgetNode wtype widget
      & L.info . L.focusable .~ True
  
  makeRadio
    :: (RadioValue a, WidgetEvent e)
    => WidgetData s a
    -> a
    -> RadioCfg s e a
    -> Widget s e
  makeRadio !field !option !config = widget where
    widget = createSingle () def {
      singleGetBaseStyle = getBaseStyle,
      singleGetCurrentStyle = getCurrentStyle,
      singleHandleEvent = handleEvent,
      singleGetSizeReq = getSizeReq,
      singleRender = render
    }
  
    getBaseStyle wenv node = Just style where
      style = collectTheme wenv L.radioStyle
  
    getCurrentStyle wenv node = style where
      radioArea = getRadioArea wenv node config
      style = currentStyle_ (currentStyleConfig radioArea) wenv node
  
    handleEvent wenv node target evt = case evt of
      Focus prev -> handleFocusChange node prev (_rdcOnFocusReq config)
  
      Blur next -> handleFocusChange node next (_rdcOnBlurReq config)
  
      Click p _ _
        | pointInEllipse p rdArea -> Just $ resultReqs node reqs
  
      KeyAction mod code KeyPressed
        | isSelectKey code -> Just $ resultReqs node reqs
      _ -> Nothing
      where
        rdArea = getRadioArea wenv node config
        path = node ^. L.info . L.path
        isSelectKey code = isKeyReturn code || isKeySpace code
  
        currValue = widgetDataGet (wenv ^. L.model) field
        setValueReq = widgetDataSet field option
        clickReqs = _rdcOnClickReq config
        changeReqs
          | currValue /= option = fmap ($ option) (_rdcOnChangeReq config)
          | otherwise = []
        reqs = setValueReq ++ clickReqs ++ changeReqs
  
    getSizeReq wenv node = req where
      theme = currentTheme wenv node
      width = fromMaybe (theme ^. L.radioWidth) (_rdcWidth config)
      req = (fixedSize width, fixedSize width)
  
    render wenv node renderer = do
      renderRadio renderer radioBW radioArea fgColor
  
      when (value == option) $
        renderMark renderer radioBW radioArea hlColor
      where
        model = _weModel wenv
        value = widgetDataGet model field
        radioArea = getRadioArea wenv node config
        radioBW = max 1 (_rW radioArea * 0.1)
  
        style_ = currentStyle_ (currentStyleConfig radioArea) wenv node
        fgColor = styleFgColor style_
        hlColor = styleHlColor style_
  
  getRadioArea :: WidgetEnv s e -> WidgetNode s e -> RadioCfg s e a -> Rect
  getRadioArea wenv node config = radioArea where
    theme = currentTheme wenv node
    style = currentStyle wenv node
    rarea = getContentArea node style
  
    radioW = fromMaybe (theme ^. L.radioWidth) (_rdcWidth config)
    radioL = _rX rarea + (_rW rarea - radioW) / 2
    radioT = _rY rarea + (_rH rarea - radioW) / 2
    radioArea = Rect radioL radioT radioW radioW
  
  renderRadio :: Renderer -> Double -> Rect -> Color -> IO ()
  renderRadio renderer radioBW rect color = action where
    action = drawEllipseBorder renderer rect (Just color) radioBW
  
  renderMark :: Renderer -> Double -> Rect -> Color -> IO ()
  renderMark renderer radioBW rect color = action where
    w = radioBW * 2
    newRect = fromMaybe def (subtractFromRect rect w w w w)
    action = drawEllipse renderer newRect (Just color)
  
  currentStyleConfig :: Rect -> CurrentStyleCfg s e
  currentStyleConfig radioArea = def &
    L.isHovered .~ isNodeHoveredEllipse_ radioArea
  