ColorPopup.hs

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

Color popup, displayed inside its parent container as a colored square. When
clicked, it opens a color picker overlay.

Shows sliders for the color components.

@
colorPopup colorLens
@

Optionally shows a slider for the alpha channel.

@
colorPopup_ colorLens [showAlpha]
@
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TemplateHaskell #-}

module Monomer.Widgets.Singles.ColorPopup (
  -- * Constructors
  colorPopup,
  colorPopup_,
  colorPopupV,
  colorPopupV_
) where

import Control.Lens ((&), (^.), (.~), (?~), ALens', abbreviatedFields, makeLensesWith, non)
import Data.Default

import Monomer.Core.Combinators
import Monomer.Graphics.Types

import Monomer.Widgets.Composite
import Monomer.Widgets.Containers.BoxShadow
import Monomer.Widgets.Containers.Popup
import Monomer.Widgets.Singles.ColorPicker
import Monomer.Widgets.Singles.ToggleButton

import qualified Monomer.Lens as L

type ColorPopupEnv = WidgetEnv ColorPopupModel ColorPopupEvt
type ColorPopupNode = WidgetNode ColorPopupModel ColorPopupEvt

{-|
Configuration options for colorPopup:

- 'showAlpha': whether to allow modifying the alpha channel or not.
- '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 any of the values changes.
- 'onChangeReq': 'WidgetRequest' to generate when any of the values changes.
-}
data ColorPopupCfg s e = ColorPopupCfg {
  _cpcColorPickerCfg :: ColorPickerCfg ColorPopupModel ColorPopupEvt,
  _cpcOnFocusReq :: [Path -> WidgetRequest s e],
  _cpcOnBlurReq :: [Path -> WidgetRequest s e],
  _cpcOnChangeReq :: [Color -> WidgetRequest s e]
}

instance Default (ColorPopupCfg s e) where
  def = ColorPopupCfg {
    _cpcColorPickerCfg = def,
    _cpcOnFocusReq = [],
    _cpcOnBlurReq = [],
    _cpcOnChangeReq = []
  }

instance Semigroup (ColorPopupCfg s e) where
  (<>) a1 a2 = def {
    _cpcColorPickerCfg = _cpcColorPickerCfg a1 <> _cpcColorPickerCfg a2,
    _cpcOnFocusReq = _cpcOnFocusReq a1 <> _cpcOnFocusReq a2,
    _cpcOnBlurReq = _cpcOnBlurReq a1 <> _cpcOnBlurReq a2,
    _cpcOnChangeReq = _cpcOnChangeReq a1 <> _cpcOnChangeReq a2
  }

instance Monoid (ColorPopupCfg s e) where
  mempty = def

instance CmbShowAlpha (ColorPopupCfg s e) where
  showAlpha_ show = def {
    _cpcColorPickerCfg = showAlpha_ show
  }

instance WidgetEvent e => CmbOnFocus (ColorPopupCfg s e) e Path where
  onFocus fn = def {
    _cpcOnFocusReq = [RaiseEvent . fn]
  }

instance CmbOnFocusReq (ColorPopupCfg s e) s e Path where
  onFocusReq req = def {
    _cpcOnFocusReq = [req]
  }

instance WidgetEvent e => CmbOnBlur (ColorPopupCfg s e) e Path where
  onBlur fn = def {
    _cpcOnBlurReq = [RaiseEvent . fn]
  }

instance CmbOnBlurReq (ColorPopupCfg s e) s e Path where
  onBlurReq req = def {
    _cpcOnBlurReq = [req]
  }

instance WidgetEvent e => CmbOnChange (ColorPopupCfg s e) Color e where
  onChange fn = def {
    _cpcOnChangeReq = [RaiseEvent . fn]
  }

instance CmbOnChangeReq (ColorPopupCfg s e) s e Color where
  onChangeReq req = def {
    _cpcOnChangeReq = [req]
  }

data ColorPopupModel = ColorPopupModel {
  _cpmPopupShowColor :: Bool,
  _cpmPopupColor :: Color
} deriving (Eq, Show)

data ColorPopupEvt
  = ColorChanged Color
  | PopupFocus Path
  | PopupBlur Path

instance Default ColorPopupModel where
  def = ColorPopupModel {
    _cpmPopupShowColor = False,
    _cpmPopupColor = def
  }

makeLensesWith abbreviatedFields 'ColorPopupModel

-- | Creates a colorPopup using the given lens.
colorPopup
  :: (WidgetModel s, WidgetEvent e)
  => ALens' s Color  -- ^ The lens into the model.
  -> WidgetNode s e  -- ^ The created color popup.
colorPopup field = colorPopup_ field def

-- | Creates a colorPopup using the given lens. Accepts config.
colorPopup_
  :: (WidgetModel s, WidgetEvent e)
  => ALens' s Color       -- ^ The lens into the model.
  -> [ColorPopupCfg s e]  -- ^ The config options.
  -> WidgetNode s e       -- ^ The created color popup.
colorPopup_ field configs = colorPopupD_ (WidgetLens field) configs

-- | Creates a colorPopup using the given value and 'onChange' event handler.
colorPopupV
  :: (WidgetModel s, WidgetEvent e)
  => Color           -- ^ The current value.
  -> (Color -> e)    -- ^ The event to raise on change.
  -> WidgetNode s e  -- ^ The created color popup.
colorPopupV value handler = colorPopupV_ value handler def

-- | Creates a colorPopup using the given value and 'onChange' event handler.
--   Accepts config.
colorPopupV_
  :: (WidgetModel s, WidgetEvent e)
  => Color                -- ^ The current value.
  -> (Color -> e)         -- ^ The event to raise on change.
  -> [ColorPopupCfg s e]  -- ^ The config options.
  -> WidgetNode s e       -- ^ The created color popup.
colorPopupV_ value handler configs = newNode where
  newConfigs = onChange handler : configs
  newNode = colorPopupD_ (WidgetValue value) newConfigs

-- | Creates a colorPopup providing a 'WidgetData' instance and config.
colorPopupD_
  :: (WidgetModel s, WidgetEvent e)
  => WidgetData s Color   -- ^ The 'WidgetData' to retrieve the value from.
  -> [ColorPopupCfg s e]  -- ^ The config options.
  -> WidgetNode s e       -- ^ The created color popup.
colorPopupD_ wdata configs = newNode where
  config = mconcat configs
  model = WidgetValue def
  uiBuilder = buildUI config
  eventHandler = handleEvent wdata config
  mergeModel wenv parentModel oldModel newModel = oldModel
    & popupColor .~ widgetDataGet parentModel wdata
  compCfg = [compositeMergeModel mergeModel]
  newNode = compositeD_ "colorPopup" model uiBuilder eventHandler compCfg

buildUI
  :: WidgetModel sp
  => ColorPopupCfg sp ep
  -> ColorPopupEnv
  -> ColorPopupModel
  -> ColorPopupNode
buildUI config wenv model = widgetTree where
  containerStyle = collectTheme wenv L.colorPopupStyle
  selColor = model ^. popupColor

  toggleStyle = mergeBasicStyle $ def
    & L.basic . non def . L.sizeReqW ?~ width 30
    & L.basic . non def . L.sizeReqH ?~ height 30
    & L.basic . non def . L.bgColor ?~ selColor
    & L.basic . non def . L.border ?~ border 1 selColor

  toggleCfg = [toggleButtonOffStyle toggleStyle]
  toggle = toggleButton_ "" popupShowColor toggleCfg
    & L.info . L.style .~ toggleStyle

  pickerCfg = _cpcColorPickerCfg config
  picker = colorPicker_ popupColor [pickerCfg, onChange ColorChanged]
    & L.info . L.style .~ containerStyle

  content = boxShadow picker
  popupCfg = [popupAlignToOuterV, popupOffset (Point 0 10), alignBottom, alignLeft]
  widgetTree = popup_ popupShowColor (popupAnchor toggle : popupCfg) content

handleEvent
  :: WidgetModel sp
  => WidgetData sp Color
  -> ColorPopupCfg sp ep
  -> ColorPopupEnv
  -> ColorPopupNode
  -> ColorPopupModel
  -> ColorPopupEvt
  -> [EventResponse ColorPopupModel ColorPopupEvt sp ep]
handleEvent wdata cfg wenv node model evt = case evt of
  PopupFocus prev
    | not (isNodeParentOfPath node prev) -> reportFocus prev
  PopupBlur next
    | not (isNodeParentOfPath node next) -> reportBlur next
  ColorChanged col -> reportChange col
  _ -> []
  where
    parentColor pm = widgetDataGet pm wdata
    parentChanged pm = parentColor pm /= model ^. popupColor

    report reqs = RequestParent <$> reqs
    reportFocus prev = report (($ prev) <$> _cpcOnFocusReq cfg)
    reportBlur next = report (($ next) <$> _cpcOnBlurReq cfg)
    reportChange col = report (wdataReqs ++ changeReqs) where
      wdataReqs = widgetDataSet wdata col
      changeReqs =  ($ col) <$> _cpcOnChangeReq cfg