content: {-|
  Module      : Monomer.Widgets.Containers.Box
  Copyright   : (c) 2018 Francisco Vallarino
  License     : BSD-3-Clause (see the LICENSE file)
  Maintainer  : fjvallarino@gmail.com
  Stability   : experimental
  Portability : non-portable
  
  Container for a single item, providing functionalities that may not be available
  in other widgets.
  
  Useful in different layout situations, since it provides alignment options. This
  allows for the inner widget to keep its size while being positioned more
  explicitly, while the box takes up the complete space assigned by its parent (in
  particular for containers which do not follow SizeReq restrictions, such as
  Grid).
  
  @
  box_ [alignRight, alignBottom] $
    image "assets/test-image.jpg"
      \`styleBasic\` [width 100, height 100]
  @
  
  Can be used to add padding to an inner widget with a border. This is equivalent
  to the margin property in CSS.
  
  @
  -- Padding is inside the border
  content = label \"Message\"
    \`styleBasic\` [padding 5, border 1 black]
  -- Padding in the wrapper box acts as margin
  container = box content
    \`styleBasic\` [padding 5]
  @
  
  Also useful to handle click events in complex widget structures (for example, a
  label with an image at its side).
  
  @
  content = vstack [
      label "All the content widget is clickable",
      spacer,
      image "assets/test-image.jpg"
    ]
  clickableItem = box_ [onClick ItemClicked] content
    \`styleBasic\' [cursorHand]
  @
  -}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE Strict #-}
  
  module Monomer.Widgets.Containers.Box (
    -- * Configuration
    BoxCfg,
    expandContent,
    boxFilterEvent,
    -- * Constructors
    box,
    box_
  ) where
  
  import Control.Applicative ((<|>))
  import Control.Lens ((&), (^.), (.~))
  import Data.Default
  import Data.Maybe
  
  import qualified Data.Sequence as Seq
  
  import Monomer.Helper (applyFnList)
  import Monomer.Widgets.Container
  import Monomer.Widgets.Containers.Stack
  
  import qualified Monomer.Lens as L
  
  {-|
  Configuration options for box:
  
  - 'mergeRequired': function called during merge that receives the old and new
    model, returning True in case the child widget needs to be merged. Since by
    default merge is required, this function can be used to restrict merging when
    it would be expensive and it is not necessary. For example, a list of widgets
    representing search result only needs to be updated when the list of results
    changes, not while the user inputs new search criteria (which also triggers a
    model change and, hence, the merge process).
  - 'ignoreEmptyArea': when the inner widget does not use all the available space,
    ignoring the unassigned space allows for mouse events to pass through. This is
    useful in zstack layers.
  - 'sizeReqUpdater': allows modifying the 'SizeReq' generated by the inner
    widget.
  - 'alignLeft': aligns the inner widget to the left.
  - 'alignCenter': aligns the inner widget to the horizontal center.
  - 'alignRight': aligns the inner widget to the right.
  - 'alignTop': aligns the inner widget to the top.
  - 'alignMiddle': aligns the inner widget to the vertical middle.
  - 'alignBottom': aligns the inner widget to the bottom.
  - '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.
  - 'onEnter': on mouse enter event.
  - 'onEnterReq': generates a WidgetRequest on mouse enter.
  - 'onLeave': on mouse leave event.
  - 'onLeaveReq': generates a WidgetRequest on mouse leave.
  - 'onClick': click event.
  - 'onClickReq': generates a WidgetRequest on click.
  - 'onClickEmpty': click event on empty area.
  - 'onClickEmptyReq': generates a WidgetRequest on click in empty area.
  - 'onBtnPressed': on button pressed event.
  - 'onBtnPressedReq': generates a WidgetRequest when button is pressed.
  - 'onBtnReleased': on button released event.
  - 'onBtnReleasedReq': generates a WidgetRequest when button is released.
  - 'expandContent': if the inner widget should use all the available space. To be
    able to use alignment options, this must be False (the default).
  - 'boxFilterEvent': allows filtering or modifying a 'SystemEvent'.
  -}
  data BoxCfg s e = BoxCfg {
    _boxExpandContent :: Maybe Bool,
    _boxIgnoreEmptyArea :: Maybe Bool,
    _boxSizeReqUpdater :: [SizeReqUpdater],
    _boxFilterEvent :: Maybe (ContainerFilterHandler s e),
    _boxMergeRequired :: Maybe (WidgetEnv s e -> s -> s -> Bool),
    _boxAlignH :: Maybe AlignH,
    _boxAlignV :: Maybe AlignV,
    _boxOnFocusReq :: [Path -> WidgetRequest s e],
    _boxOnBlurReq :: [Path -> WidgetRequest s e],
    _boxOnEnterReq :: [WidgetRequest s e],
    _boxOnLeaveReq :: [WidgetRequest s e],
    _boxOnClickReq :: [WidgetRequest s e],
    _boxOnClickEmptyReq :: [WidgetRequest s e],
    _boxOnBtnPressedReq :: [Button -> Int -> WidgetRequest s e],
    _boxOnBtnReleasedReq :: [Button -> Int -> WidgetRequest s e]
  }
  
  instance Default (BoxCfg s e) where
    def = BoxCfg {
      _boxExpandContent = Nothing,
      _boxIgnoreEmptyArea = Nothing,
      _boxSizeReqUpdater = [],
      _boxFilterEvent = Nothing,
      _boxMergeRequired = Nothing,
      _boxAlignH = Nothing,
      _boxAlignV = Nothing,
      _boxOnFocusReq = [],
      _boxOnBlurReq = [],
      _boxOnEnterReq = [],
      _boxOnLeaveReq = [],
      _boxOnClickReq = [],
      _boxOnClickEmptyReq = [],
      _boxOnBtnPressedReq = [],
      _boxOnBtnReleasedReq = []
    }
  
  instance Semigroup (BoxCfg s e) where
    (<>) t1 t2 = BoxCfg {
      _boxExpandContent = _boxExpandContent t2 <|> _boxExpandContent t1,
      _boxIgnoreEmptyArea = _boxIgnoreEmptyArea t2 <|> _boxIgnoreEmptyArea t1,
      _boxSizeReqUpdater = _boxSizeReqUpdater t1 <> _boxSizeReqUpdater t2,
      _boxFilterEvent = _boxFilterEvent t2 <|> _boxFilterEvent t1,
      _boxMergeRequired = _boxMergeRequired t2 <|> _boxMergeRequired t1,
      _boxAlignH = _boxAlignH t2 <|> _boxAlignH t1,
      _boxAlignV = _boxAlignV t2 <|> _boxAlignV t1,
      _boxOnFocusReq = _boxOnFocusReq t1 <> _boxOnFocusReq t2,
      _boxOnBlurReq = _boxOnBlurReq t1 <> _boxOnBlurReq t2,
      _boxOnEnterReq = _boxOnEnterReq t1 <> _boxOnEnterReq t2,
      _boxOnLeaveReq = _boxOnLeaveReq t1 <> _boxOnLeaveReq t2,
      _boxOnClickReq = _boxOnClickReq t1 <> _boxOnClickReq t2,
      _boxOnClickEmptyReq = _boxOnClickEmptyReq t1 <> _boxOnClickEmptyReq t2,
      _boxOnBtnPressedReq = _boxOnBtnPressedReq t1 <> _boxOnBtnPressedReq t2,
      _boxOnBtnReleasedReq = _boxOnBtnReleasedReq t1 <> _boxOnBtnReleasedReq t2
    }
  
  instance Monoid (BoxCfg s e) where
    mempty = def
  
  instance CmbIgnoreEmptyArea (BoxCfg s e) where
    ignoreEmptyArea_ ignore = def {
      _boxIgnoreEmptyArea = Just ignore
    }
  
  instance CmbSizeReqUpdater (BoxCfg s e) where
    sizeReqUpdater updater = def {
      _boxSizeReqUpdater = [updater]
    }
  
  instance CmbMergeRequired (BoxCfg s e) (WidgetEnv s e) s where
    mergeRequired fn = def {
      _boxMergeRequired = Just fn
    }
  
  instance CmbAlignLeft (BoxCfg s e) where
    alignLeft_ False = def
    alignLeft_ True = def {
      _boxAlignH = Just ALeft
    }
  
  instance CmbAlignCenter (BoxCfg s e) where
    alignCenter_ False = def
    alignCenter_ True = def {
      _boxAlignH = Just ACenter
    }
  
  instance CmbAlignRight (BoxCfg s e) where
    alignRight_ False = def
    alignRight_ True = def {
      _boxAlignH = Just ARight
    }
  
  instance CmbAlignTop (BoxCfg s e) where
    alignTop_ False = def
    alignTop_ True = def {
      _boxAlignV = Just ATop
    }
  
  instance CmbAlignMiddle (BoxCfg s e) where
    alignMiddle_ False = def
    alignMiddle_ True = def {
      _boxAlignV = Just AMiddle
    }
  
  instance CmbAlignBottom (BoxCfg s e) where
    alignBottom_ False = def
    alignBottom_ True = def {
      _boxAlignV = Just ABottom
    }
  
  instance WidgetEvent e => CmbOnFocus (BoxCfg s e) e Path where
    onFocus handler = def {
      _boxOnFocusReq = [RaiseEvent . handler]
    }
  
  instance CmbOnFocusReq (BoxCfg s e) s e Path where
    onFocusReq req = def {
      _boxOnFocusReq = [req]
    }
  
  instance WidgetEvent e => CmbOnBlur (BoxCfg s e) e Path where
    onBlur handler = def {
      _boxOnBlurReq = [RaiseEvent . handler]
    }
  
  instance CmbOnBlurReq (BoxCfg s e) s e Path where
    onBlurReq req = def {
      _boxOnBlurReq = [req]
    }
  
  instance WidgetEvent e => CmbOnBtnPressed (BoxCfg s e) e where
    onBtnPressed handler = def {
      _boxOnBtnPressedReq = [(RaiseEvent .) . handler]
    }
  
  instance CmbOnBtnPressedReq (BoxCfg s e) s e where
    onBtnPressedReq req = def {
      _boxOnBtnPressedReq = [req]
    }
  
  instance WidgetEvent e => CmbOnBtnReleased (BoxCfg s e) e where
    onBtnReleased handler = def {
      _boxOnBtnReleasedReq = [(RaiseEvent .) . handler]
    }
  
  instance CmbOnBtnReleasedReq (BoxCfg s e) s e where
    onBtnReleasedReq req = def {
      _boxOnBtnReleasedReq = [req]
    }
  
  instance WidgetEvent e => CmbOnClick (BoxCfg s e) e where
    onClick handler = def {
      _boxOnClickReq = [RaiseEvent handler]
    }
  
  instance CmbOnClickReq (BoxCfg s e) s e where
    onClickReq req = def {
      _boxOnClickReq = [req]
    }
  
  instance WidgetEvent e => CmbOnClickEmpty (BoxCfg s e) e where
    onClickEmpty handler = def {
      _boxOnClickEmptyReq = [RaiseEvent handler]
    }
  
  instance CmbOnClickEmptyReq (BoxCfg s e) s e where
    onClickEmptyReq req = def {
      _boxOnClickEmptyReq = [req]
    }
  
  instance WidgetEvent e => CmbOnEnter (BoxCfg s e) e where
    onEnter handler = def {
      _boxOnEnterReq = [RaiseEvent handler]
    }
  
  instance CmbOnEnterReq (BoxCfg s e) s e where
    onEnterReq req = def {
      _boxOnEnterReq = [req]
    }
  
  instance WidgetEvent e => CmbOnLeave (BoxCfg s e) e where
    onLeave handler = def {
      _boxOnLeaveReq = [RaiseEvent handler]
    }
  
  instance CmbOnLeaveReq (BoxCfg s e) s e where
    onLeaveReq req = def {
      _boxOnLeaveReq = [req]
    }
  
  -- | Assigns all the available space to its contained child.
  expandContent :: BoxCfg s e
  expandContent = def {
    _boxExpandContent = Just True
  }
  
  {-|
  Receives a System event and, optionally, modifies the event, its target, or
  stops the event propagation by returning Nothing.
  -}
  boxFilterEvent :: ContainerFilterHandler s e -> BoxCfg  s e
  boxFilterEvent handler = def {
    _boxFilterEvent = Just handler
  }
  
  newtype BoxState s = BoxState {
    _bxsModel :: Maybe s
  } deriving (Show)
  
  -- | Creates a box widget with a single node as child.
  box
    :: (WidgetModel s, WidgetEvent e)
    => WidgetNode s e  -- ^ The child node.
    -> WidgetNode s e  -- ^ The created box container.
  box managed = box_ def managed
  
  -- | Creates a box widget with a single node as child. Accepts config.
  box_
    :: (WidgetModel s, WidgetEvent e)
    => [BoxCfg s e]    -- ^ The config options.
    -> WidgetNode s e  -- ^ The child node.
    -> WidgetNode s e  -- ^ The created box container.
  box_ configs managed = makeNode (makeBox config state) managed where
    config = mconcat configs
    state = BoxState Nothing
  
  makeNode :: Widget s e -> WidgetNode s e -> WidgetNode s e
  makeNode widget managedWidget = defaultWidgetNode "box" widget
    & L.info . L.focusable .~ False
    & L.children .~ Seq.singleton managedWidget
  
  makeBox
    :: (WidgetModel s, WidgetEvent e)
    => BoxCfg s e
    -> BoxState s
    -> Widget s e
  makeBox config state = widget where
    widget = createContainer state def {
      containerIgnoreEmptyArea = ignoreEmptyArea && emptyHandlersCount == 0,
      containerGetCurrentStyle = getCurrentStyle,
      containerInit = init,
      containerMergeChildrenReq = mergeChildrenReq,
      containerMerge = merge,
      containerFilterEvent = filterEvent,
      containerHandleEvent = handleEvent,
      containerGetSizeReq = getSizeReq,
      containerResize = resize
    }
  
    ignoreEmptyArea = Just True == _boxIgnoreEmptyArea config
    emptyHandlersCount = length (_boxOnClickEmptyReq config)
  
    init wenv node = resultNode newNode where
      newState = BoxState (Just $ wenv ^. L.model)
      newNode = node
        & L.widget .~ makeBox config newState
  
    mergeChildrenReq wenv node oldNode oldState = required where
      newModel = wenv ^. L.model
      isReload = isWidgetReload wenv
      required = case (_boxMergeRequired config, _bxsModel oldState) of
        (Just mergeReqFn, Just oldModel)
          -> isReload || mergeReqFn wenv oldModel newModel
        _ -> True
  
    merge wenv node oldNode oldState = resultNode newNode where
      newState = BoxState (Just $ wenv ^. L.model)
      newNode = node
        & L.widget .~ makeBox config newState
  
    getCurrentStyle = currentStyle_ currentStyleConfig where
      currentStyleConfig = def
        & L.isActive .~ isNodeTreeActive
  
    filterEvent = case _boxFilterEvent config of
      Just handler -> handler
      _ -> \wenv node target evt -> Just (target, evt)
  
    handleEvent wenv node target evt = case evt of
      Focus prev -> handleFocusChange node prev (_boxOnFocusReq config)
      Blur next -> handleFocusChange node next (_boxOnBlurReq config)
  
      Enter point
        | not (null reqs) && inChildVp point -> result where
          reqs = _boxOnEnterReq config
          result = Just (resultReqs node reqs)
  
      Leave point
        | not (null reqs) -> result where
          reqs = _boxOnLeaveReq config
          result = Just (resultReqs node reqs)
  
      Click point btn _
        | not (null reqs) && inChildVp point -> result where
          reqs = _boxOnClickReq config
          result = Just (resultReqs node reqs)
  
      Click point btn _
        | not (null reqs) && not (inChildVp point) -> result where
          reqs = _boxOnClickEmptyReq config
          result = Just (resultReqs node reqs)
  
      ButtonAction point btn BtnPressed clicks
        | not (null reqs) && inChildVp point -> result where
          reqs = _boxOnBtnPressedReq config <*> pure btn <*> pure clicks
          result = Just (resultReqs node reqs)
  
      ButtonAction point btn BtnReleased clicks
        | clicks == 1 && not (null reqs) && inChildVp point -> result where
          reqs = _boxOnBtnReleasedReq config <*> pure btn <*> pure clicks
          result = Just (resultReqs node reqs)
  
      ButtonAction point btn BtnReleased clicks
        | clicks > 1 && not (null reqs) && inChildVp point -> result where
          reqs = _boxOnBtnReleasedReq config <*> pure btn <*> pure clicks
          result = Just (resultReqs node reqs)
  
      ButtonAction point btn BtnReleased clicks
        | clicks > 1 && not (null reqs) && not (inChildVp point) -> result where
          reqs = _boxOnClickEmptyReq config
          result = Just (resultReqs node reqs)
  
      _ -> Nothing
      where
        child = Seq.index (node ^. L.children) 0
        inChildVp point  = pointInRect point (child ^. L.info . L.viewport)
  
    getSizeReq :: ContainerGetSizeReqHandler s e
    getSizeReq wenv node children = newSizeReq where
      sizeReqFns = _boxSizeReqUpdater config
      child = Seq.index children 0
      newReqW = child ^. L.info . L.sizeReqW
      newReqH = child ^. L.info . L.sizeReqH
      newSizeReq = applyFnList sizeReqFns (newReqW, newReqH)
  
    resize wenv node viewport children = resized where
      style = getCurrentStyle wenv node
      child = Seq.index children 0
      contentArea = fromMaybe def (removeOuterBounds style viewport)
      Rect cx cy cw ch = contentArea
  
      contentW = snd $ assignStackAreas True contentArea 0 children
      contentH = snd $ assignStackAreas False contentArea 0 children
  
      raChild = Rect cx cy (min cw contentW) (min ch contentH)
      ah = fromMaybe ACenter (_boxAlignH config)
      av = fromMaybe AMiddle (_boxAlignV config)
      raAligned = alignInRect contentArea raChild ah av
  
      expand = fromMaybe False (_boxExpandContent config)
      resized
        | expand = (resultNode node, Seq.singleton contentArea)
        | otherwise = (resultNode node, Seq.singleton raAligned)
  