monomer-1.6.0.0: src/Monomer/Widgets/Containers/Dropdown.hs

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

Dropdown widget, allowing selection of a single item from a collapsable list.
Both header and list content are customizable, and so is their styling.

In case only 'Text' content is needed, "Monomer.Widgets.Singles.TextDropdown" is
easier to use.

@
makeSelected username = hstack [
    label "Selected: ",
    spacer,
    label username
  ]
makeRow username = label username

customDropdown = dropdown userLens usernames makeSelected makeRow
@

Note: the content of the dropdown list will only be updated when the provided
items change, based on their 'Eq' instance. In case data external to the items
is used for building the row nodes, 'mergeRequired' may be needed to avoid stale
content.
-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}

module Monomer.Widgets.Containers.Dropdown (
  -- * Configuration
  DropdownCfg,
  DropdownItem,
  -- * Constructors
  dropdown,
  dropdown_,
  dropdownV,
  dropdownV_,
  dropdownD_
) where

import Control.Applicative ((<|>))
import Control.Lens (ALens', (&), (^.), (^?!), (.~), (%~), (<>~), ix, non)
import Control.Monad
import Data.Default
import Data.List (foldl')
import Data.Maybe
import Data.Sequence (Seq(..), (|>))
import Data.Typeable (Proxy, cast, typeRep)
import GHC.Generics
import TextShow

import qualified Data.Sequence as Seq

import Monomer.Helper
import Monomer.Widgets.Container
import Monomer.Widgets.Containers.SelectList

import qualified Monomer.Lens as L

-- | Constraints for an item handled by dropdown.
type DropdownItem a = SelectListItem a

{-|
Configuration options for dropdown:

- '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 selected item changes.
- 'onChangeReq': 'WidgetRequest' to generate when selected item changes.
- 'onChangeIdx': event to raise when selected item changes. Includes index.
- 'onChangeIdxReq': 'WidgetRequest' to generate when selected item changes.
  Includes index.
- 'maxHeight': maximum height of the list when dropdown is expanded.
- 'itemBasicStyle': 'Style' of an item in the list when not selected.
- 'itemSelectedStyle': 'Style' of the selected item in the list.
- 'mergeRequired': whether merging the items in the list is required. Useful
  when the content displayed depends on external data, since changes to data
  outside the provided list cannot be detected. In general it is recommended to
  only depend on data contained in the list itself, making sure the 'Eq'
  instance of the item type is correct.
-}
data DropdownCfg s e a = DropdownCfg {
  _ddcMaxHeight :: Maybe Double,
  _ddcItemStyle :: Maybe Style,
  _ddcItemSelectedStyle :: Maybe Style,
  _ddcMergeRequired :: Maybe (WidgetEnv s e -> Seq a -> Seq a -> Bool),
  _ddcOnFocusReq :: [Path -> WidgetRequest s e],
  _ddcOnBlurReq :: [Path -> WidgetRequest s e],
  _ddcOnChangeReq :: [a -> WidgetRequest s e],
  _ddcOnChangeIdxReq :: [Int -> a -> WidgetRequest s e]
}

instance Default (DropdownCfg s e a) where
  def = DropdownCfg {
    _ddcMaxHeight = Nothing,
    _ddcItemStyle = Nothing,
    _ddcItemSelectedStyle = Nothing,
    _ddcMergeRequired = Nothing,
    _ddcOnFocusReq = [],
    _ddcOnBlurReq = [],
    _ddcOnChangeReq = [],
    _ddcOnChangeIdxReq = []
  }

instance Semigroup (DropdownCfg s e a) where
  (<>) t1 t2 = DropdownCfg {
    _ddcMaxHeight = _ddcMaxHeight t2 <|> _ddcMaxHeight t1,
    _ddcItemStyle = _ddcItemStyle t2 <|> _ddcItemStyle t1,
    _ddcItemSelectedStyle = _ddcItemSelectedStyle t2 <|> _ddcItemSelectedStyle t1,
    _ddcMergeRequired = _ddcMergeRequired t2 <|> _ddcMergeRequired t1,
    _ddcOnFocusReq = _ddcOnFocusReq t1 <> _ddcOnFocusReq t2,
    _ddcOnBlurReq = _ddcOnBlurReq t1 <> _ddcOnBlurReq t2,
    _ddcOnChangeReq = _ddcOnChangeReq t1 <> _ddcOnChangeReq t2,
    _ddcOnChangeIdxReq = _ddcOnChangeIdxReq t1 <> _ddcOnChangeIdxReq t2
  }

instance Monoid (DropdownCfg s e a) where
  mempty = def

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

instance CmbOnFocusReq (DropdownCfg s e a) s e Path where
  onFocusReq req = def {
    _ddcOnFocusReq = [req]
  }

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

instance CmbOnBlurReq (DropdownCfg s e a) s e Path where
  onBlurReq req = def {
    _ddcOnBlurReq = [req]
  }

instance WidgetEvent e => CmbOnChange (DropdownCfg s e a) a e where
  onChange fn = def {
    _ddcOnChangeReq = [RaiseEvent . fn]
  }

instance CmbOnChangeReq (DropdownCfg s e a) s e a where
  onChangeReq req = def {
    _ddcOnChangeReq = [req]
  }

instance WidgetEvent e => CmbOnChangeIdx (DropdownCfg s e a) e a where
  onChangeIdx fn = def {
    _ddcOnChangeIdxReq = [(RaiseEvent .) . fn]
  }

instance CmbOnChangeIdxReq (DropdownCfg s e a) s e a where
  onChangeIdxReq req = def {
    _ddcOnChangeIdxReq = [req]
  }

instance CmbMaxHeight (DropdownCfg s e a) where
  maxHeight h = def {
    _ddcMaxHeight = Just h
  }

instance CmbItemBasicStyle (DropdownCfg s e a) Style where
  itemBasicStyle style = def {
    _ddcItemStyle = Just style
  }

instance CmbItemSelectedStyle (DropdownCfg s e a) Style where
  itemSelectedStyle style = def {
    _ddcItemSelectedStyle = Just style
  }

instance CmbMergeRequired (DropdownCfg s e a) (WidgetEnv s e) (Seq a) where
  mergeRequired fn = def {
    _ddcMergeRequired = Just fn
  }

data DropdownState = DropdownState {
  _ddsOpen :: Bool,
  _ddsOffset :: Point
} deriving (Eq, Show, Generic)

data DropdownMessage
  = forall a . DropdownItem a => OnChangeMessage Int a
  | OnListBlur

-- | Creates a dropdown using the given lens.
dropdown
  :: (WidgetModel s, WidgetEvent e, Traversable t, DropdownItem a)
  => ALens' s a             -- ^ The lens into the model.
  -> t a                    -- ^ The list of selectable items.
  -> (a -> WidgetNode s e)  -- ^ Function to create the header (always visible).
  -> (a -> WidgetNode s e)  -- ^ Function to create the list (collapsable).
  -> WidgetNode s e         -- ^ The created dropdown.
dropdown field items makeMain makeRow = newNode where
  newNode = dropdown_ field items makeMain makeRow def

-- | Creates a dropdown using the given lens. Accepts config.
dropdown_
  :: (WidgetModel s, WidgetEvent e, Traversable t, DropdownItem a)
  => ALens' s a             -- ^ The lens into the model.
  -> t a                    -- ^ The list of selectable items.
  -> (a -> WidgetNode s e)  -- ^ Function to create the header (always visible).
  -> (a -> WidgetNode s e)  -- ^ Function to create the list (collapsable).
  -> [DropdownCfg s e a]    -- ^ The config options.
  -> WidgetNode s e         -- ^ The created dropdown.
dropdown_ field items makeMain makeRow configs = newNode where
  widgetData = WidgetLens field
  newNode = dropdownD_ widgetData items makeMain makeRow configs

-- | Creates a dropdown using the given value and 'onChange' event handler.
dropdownV
  :: (WidgetModel s, WidgetEvent e, Traversable t, DropdownItem a)
  => a                      -- ^ The current value.
  -> (Int -> a -> e)        -- ^ The event to raise on change.
  -> t a                    -- ^ The list of selectable items.
  -> (a -> WidgetNode s e)  -- ^ Function to create the header (always visible).
  -> (a -> WidgetNode s e)  -- ^ Function to create the list (collapsable).
  -> WidgetNode s e         -- ^ The created dropdown.
dropdownV value handler items makeMain makeRow = newNode where
  newNode = dropdownV_ value handler items makeMain makeRow def

-- | Creates a dropdown using the given value and 'onChange' event handler.
-- | Accepts config.
dropdownV_
  :: (WidgetModel s, WidgetEvent e, Traversable t, DropdownItem a)
  => a                      -- ^ The current value.
  -> (Int -> a -> e)        -- ^ The event to raise on change.
  -> t a                    -- ^ The list of selectable items.
  -> (a -> WidgetNode s e)  -- ^ Function to create the header (always visible).
  -> (a -> WidgetNode s e)  -- ^ Function to create the list (collapsable).
  -> [DropdownCfg s e a]    -- ^ The config options.
  -> WidgetNode s e         -- ^ The created dropdown.
dropdownV_ value handler items makeMain makeRow configs = newNode where
  newConfigs = onChangeIdx handler : configs
  newNode = dropdownD_ (WidgetValue value) items makeMain makeRow newConfigs

-- | Creates a dropdown providing a WidgetData instance and config.
dropdownD_
  :: forall s e t a . (WidgetModel s, WidgetEvent e, Traversable t, DropdownItem a)
  => WidgetData s a         -- ^ The 'WidgetData' to retrieve the value from.
  -> t a                    -- ^ The list of selectable items.
  -> (a -> WidgetNode s e)  -- ^ Function to create the header (always visible).
  -> (a -> WidgetNode s e)  -- ^ Function to create the list (collapsable).
  -> [DropdownCfg s e a]    -- ^ The config options.
  -> WidgetNode s e         -- ^ The created dropdown.
dropdownD_ widgetData items makeMain makeRow configs = newNode where
  config = mconcat configs
  newState = DropdownState False def
  newItems = foldl' (|>) Empty items
  wtype = WidgetType ("dropdown-" <> showt (typeRep (undefined :: Proxy a)))
  widget = makeDropdown widgetData newItems makeMain makeRow config newState
  newNode = defaultWidgetNode wtype widget
    & L.info . L.focusable .~ True

makeDropdown
  :: forall s e a. (WidgetModel s, WidgetEvent e, DropdownItem a)
  => WidgetData s a
  -> Seq a
  -> (a -> WidgetNode s e)
  -> (a -> WidgetNode s e)
  -> DropdownCfg s e a
  -> DropdownState
  -> Widget s e
makeDropdown widgetData items makeMain makeRow config state = widget where
  container = def {
    containerAddStyleReq = False,
    containerChildrenOffset = Just (_ddsOffset state),
    containerGetBaseStyle = getBaseStyle,
    containerInit = init,
    containerFindNextFocus = findNextFocus,
    containerFindByPoint = findByPoint,
    containerMerge = merge,
    containerDispose = dispose,
    containerHandleEvent = handleEvent,
    containerHandleMessage = handleMessage,
    containerGetSizeReq = getSizeReq,
    containerResize = resize
  }
  baseWidget = createContainer state container
  widget = baseWidget {
    widgetRender = render
  }

  mainIdx = 0
  listIdx = 1
  isOpen = _ddsOpen state
  currentValue wenv = widgetDataGet (_weModel wenv) widgetData

  createDropdown wenv node newState = newNode where
    selected = currentValue wenv
    nodeStyle = _wnInfo node ^. L.style
    mainNode = makeMain selected
      & L.info . L.style .~ nodeStyle
    widgetId = node ^. L.info . L.widgetId
    selectListNode = makeSelectList wenv widgetData items makeRow config widgetId
    newWidget = makeDropdown widgetData items makeMain makeRow config newState
    newNode = node
      & L.widget .~ newWidget
      & L.children .~ Seq.fromList [mainNode, selectListNode]

  getBaseStyle wenv node = Just style where
    style = collectTheme wenv L.dropdownStyle

  init wenv node = resultNode $ createDropdown wenv node state

  merge wenv newNode oldNode oldState = result where
    result = resultNode $ createDropdown wenv newNode oldState

  dispose wenv node = resultReqs node reqs where
    widgetId = node ^. L.info . L.widgetId
    reqs = [ ResetOverlay widgetId | isOpen ]

  findNextFocus wenv node direction start
    | isOpen = node ^. L.children
    | otherwise = Empty

  findByPoint wenv node start point = result where
    children = node ^. L.children
    mainNode = Seq.index children mainIdx
    listNode = Seq.index children listIdx
    result
      | isOpen && isPointInNodeVp listNode point = Just listIdx
      | not isOpen && isPointInNodeVp mainNode point = Just mainIdx
      | otherwise = Nothing

  ddFocusChange node prev reqs = Just newResult where
    tmpResult = handleFocusChange node prev reqs
    newResult = fromMaybe (resultNode node) tmpResult
      & L.requests %~ (|> IgnoreChildrenEvents)

  handleEvent wenv node target evt = case evt of
    Focus prev
      | not isOpen -> ddFocusChange node prev (_ddcOnFocusReq config)

    Blur next
      | not isOpen && not (seqStartsWith path focusedPath)
        -> ddFocusChange node next (_ddcOnBlurReq config)

    Move point -> result where
      mainNode = Seq.index (node ^. L.children) mainIdx
      listNode = Seq.index (node ^. L.children) listIdx
      slPoint = addPoint (negPoint (_ddsOffset state)) point

      validMainPos = not isOpen && isPointInNodeVp mainNode point
      validListPos = isOpen && isPointInNodeVp listNode slPoint
      validPos = validMainPos || validListPos

      isArrow = Just CursorArrow == (snd <$> wenv ^. L.cursor)
      resetRes = resultReqs node [SetCursorIcon widgetId CursorArrow]
      result
        | not validPos && not isArrow = Just resetRes
        | otherwise = Nothing

    ButtonAction _ btn BtnPressed _
      | btn == wenv ^. L.mainButton && not isOpen -> result where
        result = Just $ resultReqs node [SetFocus (node ^. L.info . L.widgetId)]

    Click point _ _
      | openRequired point node -> Just resultOpen
      | closeRequired point node -> Just resultClose
      where
        inVp = isPointInNodeVp node point
        resultOpen = openDropdown wenv node
          & L.requests <>~ Seq.fromList [SetCursorIcon widgetId CursorArrow]
        resultClose = closeDropdown wenv node
          & L.requests <>~ Seq.fromList [ResetCursorIcon widgetId | not inVp]

    KeyAction mode code KeyPressed
      | isKeyOpenDropdown && not isOpen -> Just $ openDropdown wenv node
      | isKeyEscape code && isOpen -> Just $ closeDropdown wenv node
      where
        activationKeys = [isKeyDown, isKeyUp, isKeySpace, isKeyReturn]
        isKeyOpenDropdown = or (fmap ($ code) activationKeys)

    _
      | not isOpen -> Just $ resultReqs node [IgnoreChildrenEvents]
      | otherwise -> Nothing
    where
      style = currentStyle wenv node
      widgetId = node ^. L.info . L.widgetId
      path = node ^. L.info . L.path
      focusedPath = wenv ^. L.focusedPath
      overlayPath = wenv ^. L.overlayPath

      overlayParent = isNodeParentOfPath node (fromJust overlayPath)
      nodeValid = isNothing overlayPath || overlayParent

  openRequired point node = not isOpen && inViewport where
    inViewport = pointInRect point (node ^. L.info . L.viewport)

  closeRequired point node = isOpen && not inOverlay where
    offset = _ddsOffset state
    listNode = Seq.index (node ^. L.children) listIdx
    listVp = moveRect offset (listNode ^. L.info . L.viewport)
    inOverlay = pointInRect point listVp

  openDropdown wenv node = resultReqs newNode requests where
    newState = state {
      _ddsOpen = True,
      _ddsOffset = listOffset wenv node
    }
    newNode = node
      & L.widget .~ makeDropdown widgetData items makeMain makeRow config newState
    -- selectList is wrapped by a scroll widget
    (slWid, slPath) = scrollListInfo node
    (listWid, _) = selectListInfo node
    scrollMsg = SendMessage listWid SelectListShowSelected
    requests = [SetOverlay slWid slPath, SetFocus listWid, scrollMsg]

  closeDropdown wenv node = resultReqs newNode requests where
    widgetId = node ^. L.info . L.widgetId
    (slWid, _) = scrollListInfo node
    (listWid, _) = selectListInfo node
    newState = state {
      _ddsOpen = False,
      _ddsOffset = def
    }
    newNode = node
      & L.widget .~ makeDropdown widgetData items makeMain makeRow config newState
    requests = [ResetOverlay slWid, SetFocus widgetId]

  scrollListInfo :: WidgetNode s e -> (WidgetId, Path)
  scrollListInfo node = (scrollInfo ^. L.widgetId, scrollInfo ^. L.path) where
    scrollInfo = node ^?! L.children . ix listIdx . L.info

  selectListInfo :: WidgetNode s e -> (WidgetId, Path)
  selectListInfo node = (listInfo ^. L.widgetId, listInfo ^. L.path) where
    listInfo = node ^?! L.children . ix listIdx . L.children . ix 0 . L.info

  handleMessage wenv node target msg =
    cast msg >>= handleLvMsg wenv node

  handleLvMsg wenv node (OnChangeMessage idx _) =
    Seq.lookup idx items >>= \value -> Just $ onChange wenv node idx value
  handleLvMsg wenv node OnListBlur = Just result where
    tempResult = closeDropdown wenv node
    result = tempResult & L.requests %~ (|> createMoveFocusReq wenv)

  onChange wenv node idx item = result where
    WidgetResult newNode reqs = closeDropdown wenv node
    newReqs = Seq.fromList $ widgetDataSet widgetData item
      ++ fmap ($ item) (_ddcOnChangeReq config)
      ++ fmap (\fn -> fn idx item) (_ddcOnChangeIdxReq config)
    result = WidgetResult newNode (reqs <> newReqs)

  getSizeReq :: ContainerGetSizeReqHandler s e
  getSizeReq wenv node children = (newReqW, newReqH) where
    -- Main section reqs
    mainC = Seq.index children 0
    mainReqW = mainC ^. L.info . L.sizeReqW
    mainReqH = mainC ^. L.info . L.sizeReqH
    -- List items reqs
    listC = Seq.index children 1
    listReqW = listC ^. L.info . L.sizeReqW
    -- Items other than main could be wider
    -- Height only matters for the selected item, since the rest is in a scroll
    newReqW = sizeReqMergeMax mainReqW listReqW
    newReqH = mainReqH

  listHeight wenv node = maxHeight where
    Size _ winH = _weWindowSize wenv
    theme = currentTheme wenv node
    maxHeightTheme = theme ^. L.dropdownMaxHeight
    cfgMaxHeight = _ddcMaxHeight config
    -- Avoid having an invisible list if style/theme is not set
    maxHeightStyle = max 20 $ fromMaybe maxHeightTheme cfgMaxHeight
    reqHeight = case Seq.lookup 1 (node ^. L.children) of
      Just child -> sizeReqMaxBounded $ child ^. L.info . L.sizeReqH
      _ -> 0
    maxHeight = min winH (min reqHeight maxHeightStyle)

  listOffset wenv node = Point 0 newOffset where
    Size _ winH = _weWindowSize wenv
    viewport = node ^. L.info . L.viewport
    scOffset = wenv ^. L.offset
    Rect rx ry rw rh = moveRect scOffset viewport
    lh = listHeight wenv node
    newOffset
      | ry + rh + lh > winH = - (rh + lh)
      | otherwise = 0

  resize wenv node viewport children = resized where
    style = currentStyle wenv node
    Rect rx ry rw rh = viewport
    !mainArea = viewport
    !listArea = viewport {
      _rY = ry + rh,
      _rH = listHeight wenv node
    }
    assignedAreas = Seq.fromList [mainArea, listArea]
    resized = (resultNode node, assignedAreas)

  render wenv node renderer = do
    drawInScissor renderer True viewport $
      drawStyledAction renderer viewport style $ \contentArea -> do
        widgetRender (mainNode ^. L.widget) wenv mainNode renderer
        renderArrow renderer style contentArea

    when isOpen $
      createOverlay renderer $
        drawInTranslation renderer totalOffset $ do
          renderOverlay renderer cwenv listOverlay
    where
      style = currentStyle wenv node
      viewport = node ^. L.info . L.viewport
      mainNode = Seq.index (node ^. L.children) mainIdx
      -- List view is rendered with an offset to accommodate for window height
      listOverlay = Seq.index (node ^. L.children) listIdx
      listOverlayVp = listOverlay ^. L.info . L.viewport
      scOffset = wenv ^. L.offset
      offset = _ddsOffset state
      totalOffset = addPoint scOffset offset
      cwenv = updateWenvOffset container wenv node listOverlayVp
        & L.viewport .~ listOverlayVp

  renderArrow renderer style contentArea =
    drawArrowDown renderer arrowRect (_sstFgColor style)
    where
      Rect x y w h = contentArea
      size = style ^. L.text . non def . L.fontSize . non def
      arrowW = unFontSize size / 2
      arrowRect = Rect (x + w - arrowW) (y + h / 2 - arrowW / 3) arrowW (arrowW / 2)

  renderOverlay renderer wenv overlayNode = renderAction where
    widget = overlayNode ^. L.widget
    renderAction = widgetRender widget wenv overlayNode renderer

makeSelectList
  :: (WidgetModel s, WidgetEvent e, DropdownItem a)
  => WidgetEnv s e
  -> WidgetData s a
  -> Seq a
  -> (a -> WidgetNode s e)
  -> DropdownCfg s e a
  -> WidgetId
  -> WidgetNode s e
makeSelectList wenv value items makeRow config widgetId = selectListNode where
  normalTheme = collectTheme wenv L.dropdownItemStyle
  selectedTheme = collectTheme wenv L.dropdownItemSelectedStyle

  itemStyle = fromJust (Just normalTheme <> _ddcItemStyle config)
  itemSelStyle = fromJust (Just selectedTheme <> _ddcItemSelectedStyle config)

  mergeReqFn = maybe def mergeRequired (_ddcMergeRequired config)

  slConfig = [
      selectOnBlur,
      onBlurReq (const $ SendMessage widgetId OnListBlur),
      onChangeIdxReq (\idx it -> SendMessage widgetId (OnChangeMessage idx it)),
      itemBasicStyle itemStyle,
      itemSelectedStyle itemSelStyle,
      mergeReqFn
    ]
  slStyle = collectTheme wenv L.dropdownListStyle
  selectListNode = selectListD_ value items makeRow slConfig
    & L.info . L.style .~ slStyle

createMoveFocusReq :: WidgetEnv s e -> WidgetRequest s e
createMoveFocusReq wenv = MoveFocus Nothing direction where
  direction
    | wenv ^. L.inputStatus . L.keyMod . L.leftShift = FocusBwd
    | otherwise = FocusFwd