content: {-|
  Module      : Monomer.Widgets.Containers.ZStack
  Copyright   : (c) 2018 Francisco Vallarino
  License     : BSD-3-Clause (see the LICENSE file)
  Maintainer  : fjvallarino@gmail.com
  Stability   : experimental
  Portability : non-portable
  
  Layered container, stacking children one on top of the other. Useful for
  handling widgets that need to be visible in certain contexts only, such as
  dialogs, or to overlay unrelated widgets (text on top of an image).
  
  The order of the widgets is from bottom to top.
  
  The container will request the largest combination of horizontal and vertical
  size requested by its child nodes.
  
  @
  zstack [
      image_ "assets/test-image.png" [fitFill],
      label "Image caption"
        \`styleBasic\` [textFont \"Bold\", textSize 20, textCenter]
    ]
  @
  -}
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE StrictData #-}
  
  module Monomer.Widgets.Containers.ZStack (
    -- * Configuration
    ZStackCfg,
    onlyTopActive,
    onlyTopActive_,
    -- * Constructors
    zstack,
    zstack_
  ) where
  
  import Control.Applicative ((<|>))
  import Control.Lens ((&), (^.), (^?), (.~), (%~), at, ix)
  import Control.Monad (void, when)
  import Data.Default
  import Data.Maybe
  import Data.List (foldl')
  import Data.Sequence (Seq(..), (|>))
  import GHC.Generics
  
  import qualified Data.Map.Strict as M
  import qualified Data.Sequence as Seq
  
  import Monomer.Widgets.Container
  
  import qualified Monomer.Lens as L
  
  {-|
  Configuration options for zstack:
  
  - 'onlyTopActive': whether the top visible node is the only node that may
    receive events.
  -}
  newtype ZStackCfg = ZStackCfg {
    _zscOnlyTopActive :: Maybe Bool
  }
  
  instance Default ZStackCfg where
    def = ZStackCfg Nothing
  
  instance Semigroup ZStackCfg where
    (<>) z1 z2 = ZStackCfg {
      _zscOnlyTopActive = _zscOnlyTopActive z2 <|> _zscOnlyTopActive z1
    }
  
  instance Monoid ZStackCfg where
    mempty = def
  
  -- | Makes the top visible node the only node that may receive events.
  onlyTopActive :: ZStackCfg
  onlyTopActive = onlyTopActive_ True
  
  -- | Whether the top visible node is the only node that may receive events.
  onlyTopActive_ :: Bool -> ZStackCfg
  onlyTopActive_ active = def {
    _zscOnlyTopActive = Just active
  }
  
  data ZStackState = ZStackState {
    _zssFocusMap :: M.Map PathStep WidgetId,
    _zssTopIdx :: Int
  } deriving (Eq, Show, Generic)
  
  -- | Creates a zstack container with the provided nodes.
  zstack
    :: (Traversable t)
    => t (WidgetNode s e)  -- ^ The list of child nodes.
    -> WidgetNode s e      -- ^ The created zstack container.
  zstack children = zstack_ def children
  
  -- | Creates a zstack container with the provided nodes. Accepts config.
  zstack_
    :: (Traversable t)
    => [ZStackCfg]         -- ^ The config options.
    -> t (WidgetNode s e)  -- ^ The list of child nodes.
    -> WidgetNode s e      -- ^ The created zstack container.
  zstack_ configs children = newNode where
    config = mconcat configs
    state = ZStackState M.empty 0
    newNode = defaultWidgetNode "zstack" (makeZStack config state)
      & L.children .~ Seq.reverse (foldl' (|>) Empty children)
  
  makeZStack :: ZStackCfg -> ZStackState -> Widget s e
  makeZStack config state = widget where
    baseWidget = createContainer state def {
      containerUseChildrenSizes = True,
      containerInit = init,
      containerMergePost = mergePost,
      containerFindNextFocus = findNextFocus,
      containerGetSizeReq = getSizeReq,
      containerResize = resize
    }
    widget = baseWidget {
      widgetFindByPoint = findByPoint,
      widgetRender = render
    }
  
    onlyTopActive = fromMaybe True (_zscOnlyTopActive config)
  
    init wenv node = resultNode newNode where
      children = node ^. L.children
      focusedPath = wenv ^. L.focusedPath
      newState = state {
        _zssTopIdx = fromMaybe 0 (Seq.findIndexL (^.L.info . L.visible) children)
      }
      newNode = node
        & L.widget .~ makeZStack config newState
  
    mergePost wenv node oldNode oldState newState result = newResult where
      ZStackState oldFocusMap oldTopIdx = oldState
      children = node ^. L.children
      focusedPath = wenv ^. L.focusedPath
      focusedWid = widgetIdFromPath wenv focusedPath
      isFocusParent = isNodeParentOfPath node focusedPath
  
      topLevel = isNodeTopLevel wenv node
      flagsChanged = childrenFlagsChanged oldNode node
      newTopIdx = fromMaybe 0 (Seq.findIndexL (^.L.info . L.visible) children)
      focusReq = isJust $ Seq.findIndexL isFocusRequest (result ^. L.requests)
      needsFocus = isFocusParent && topLevel && flagsChanged && not focusReq
  
      oldTopWid = M.lookup newTopIdx oldFocusMap
      fstTopWid = node ^? L.children . ix newTopIdx . L.info . L.widgetId
      newState = oldState {
        _zssFocusMap = oldFocusMap & at oldTopIdx .~ focusedWid,
        _zssTopIdx = newTopIdx
      }
  
      tmpResult = result
        & L.node . L.widget .~ makeZStack config newState
      newResult
        | needsFocus && isJust oldTopWid = tmpResult
            & L.requests %~ (|> SetFocus (fromJust oldTopWid))
        | needsFocus = tmpResult
            & L.requests %~ (|> MoveFocus fstTopWid FocusFwd)
        | isFocusParent = tmpResult
        | otherwise = result
  
    -- | Find instance matching point
    findByPoint wenv node start point = result where
      children = node ^. L.children
      vchildren
        | onlyTopActive = Seq.take 1 $ Seq.filter (_wniVisible . _wnInfo) children
        | otherwise = Seq.filter (_wniVisible . _wnInfo) children
  
      nextStep = nextTargetStep node start
      ch = Seq.index children (fromJust nextStep)
      visible = node ^. L.info . L.visible
      childVisible = ch ^. L.info . L.visible
      isNextValid = isJust nextStep && visible && childVisible
      result
        | isNextValid = widgetFindByPoint (ch ^. L.widget) wenv ch start point
        | visible = findFirstByPoint vchildren wenv start point
        | otherwise = Nothing
  
    findNextFocus wenv node direction start = result where
      children = node ^. L.children
      vchildren = Seq.filter (_wniVisible . _wnInfo) children
      result
        | onlyTopActive = Seq.take 1 vchildren
        | otherwise = vchildren
  
    getSizeReq wenv node children = (newSizeReqW, newSizeReqH) where
      vchildren = Seq.filter (_wniVisible . _wnInfo) children
      newSizeReqW = getDimSizeReq (_wniSizeReqW . _wnInfo) vchildren
      newSizeReqH = getDimSizeReq (_wniSizeReqH . _wnInfo) vchildren
  
    getDimSizeReq accessor vchildren
      | Seq.null vreqs = fixedSize 0
      | otherwise = foldl1 sizeReqMergeMax vreqs
      where
        vreqs = accessor <$> vchildren
  
    resize wenv node viewport children = resized where
      style = currentStyle wenv node
      vpChild = fromMaybe def (removeOuterBounds style viewport)
      assignedAreas = fmap (const vpChild) children
      resized = (resultNode node, assignedAreas)
  
    render wenv node renderer =
      drawInScissor renderer True viewport $
        drawStyledAction renderer viewport style $ \_ ->
          void $ Seq.traverseWithIndex renderChild children
      where
        style = currentStyle wenv node
        children = Seq.reverse $ node ^. L.children
        viewport = node ^. L.info . L.viewport
        isVisible c = c ^. L.info . L.visible
        topVisibleIdx = fromMaybe 0 (Seq.findIndexR (_wniVisible . _wnInfo) children)
  
        isPointEmpty point idx = not covered where
          prevs = Seq.drop (idx + 1) children
          target c = widgetFindByPoint (c ^. L.widget) wenv c emptyPath point
          isCovered c = isVisible c && isJust (target c)
          covered = any isCovered prevs
  
        isTopLayer idx child point = prevTopLayer && isValid where
          prevTopLayer = _weInTopLayer wenv point
          isValid
            | onlyTopActive = idx == topVisibleIdx
            | otherwise = isPointEmpty point idx
  
        cWenv idx child = wenv {
          _weInTopLayer = isTopLayer idx child
        }
        renderChild idx child = when (isVisible child) $
          widgetRender (child ^. L.widget) (cWenv idx child) child renderer
  
  findFirstByPoint
    :: Seq (WidgetNode s e)
    -> WidgetEnv s e
    -> Seq PathStep
    -> Point
    -> Maybe WidgetNodeInfo
  findFirstByPoint Empty _ _ _ = Nothing
  findFirstByPoint (ch :<| chs) wenv start point = result where
    isVisible = ch ^. L.info . L.visible
    newPath = widgetFindByPoint (ch ^. L.widget) wenv ch start point
    result
      | isVisible && isJust newPath = newPath
      | otherwise = findFirstByPoint chs wenv start point
  