content: {-|
  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
  