content: {-|
  Module      : Monomer.Widgets.Single
  Copyright   : (c) 2018 Francisco Vallarino
  License     : BSD-3-Clause (see the LICENSE file)
  Maintainer  : fjvallarino@gmail.com
  Stability   : experimental
  Portability : non-portable
  
  Helper for creating widgets without children elements.
  -}
  {-# LANGUAGE ExistentialQuantification #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE Strict #-}
  
  module Monomer.Widgets.Single (
    -- * Re-exported modules
    module Monomer.Core,
    module Monomer.Core.Combinators,
    module Monomer.Event,
    module Monomer.Graphics,
    module Monomer.Widgets.Util,
  
    -- * Configuration
    SingleGetBaseStyle,
    SingleGetCurrentStyle,
    SingleInitHandler,
    SingleMergeHandler,
    SingleDisposeHandler,
    SingleFindNextFocusHandler,
    SingleFindByPointHandler,
    SingleEventHandler,
    SingleMessageHandler,
    SingleGetSizeReqHandler,
    SingleResizeHandler,
    SingleRenderHandler,
    Single(..),
  
    -- * Constructors
    createSingle
  ) where
  
  import Control.Lens ((&), (^.), (.~), (%~))
  import Control.Monad (when)
  import Data.Default
  import Data.Maybe
  import Data.Sequence (Seq(..), (|>))
  import Data.Typeable (Typeable)
  
  import qualified Data.Sequence as Seq
  
  import Monomer.Core
  import Monomer.Core.Combinators
  import Monomer.Event
  import Monomer.Graphics
  import Monomer.Helper
  import Monomer.Widgets.Util
  
  import qualified Monomer.Core.Lens as L
  
  {-|
  Returns the base style for this type of widget.
  
  Usually this style comes from the active theme.
  -}
  type SingleGetBaseStyle s e
    = GetBaseStyle s e  -- ^ The base style for a new node.
  
  {-|
  Returns the current style for this type of widget. It depends on the state of
  the widget, which can be:
  
  - Basic
  - Hovered
  - Focused
  - Hovered and Focused
  - Active
  - Disabled
  
  In general there's no needed to override it, except when the widget does not use
  the full content rect. An example can be found in "Monomer.Widgets.Singles.Radio".
  -}
  type SingleGetCurrentStyle s e
    = WidgetEnv s e      -- ^ The widget environment.
    -> WidgetNode s e    -- ^ The widget node.
    -> StyleState        -- ^ The active style for the node.
  
  {-|
  Initializes the given node. This could include rebuilding the widget in case
  internal state needs to use model/environment information, generate user
  events or make requests to the runtime.
  
  An examples can be found in "Monomer.Widgets.Singles.Label" and
  "Monomer.Widgets.Singles.Image". On the other hand, "Monomer.Widgets.Radio" does
  not need to override /init/.
  -}
  type SingleInitHandler s e
    = WidgetEnv s e        -- ^ The widget environment.
    -> WidgetNode s e      -- ^ The widget node.
    -> WidgetResult s e    -- ^ The result of the init operation.
  
  {-|
  Merges the current node with the node it matched with during the merge process.
  Receives the newly created node (whose *init* function is not called), the
  previous node and the state extracted from that node. This process is widget
  dependent, and may use or ignore the previous state depending on newly available
  information.
  
  In general, you want to at least keep the previous state unless the widget is
  stateless or only consumes model/environment information.
  
  Examples can be found in "Monomer.Widgets.Singles.Label" and
  "Monomer.Widgets.Singles.Image". On the other hand,
  "Monomer.Widgets.Singles.Radio" does not need to override merge since it's
  stateless.
  -}
  type SingleMergeHandler s e a
    = WidgetEnv s e        -- ^ The widget environment.
    -> WidgetNode s e      -- ^ The widget node.
    -> WidgetNode s e      -- ^ The previous widget node.
    -> a                   -- ^ The state of the previous widget node.
    -> WidgetResult s e    -- ^ The result of the merge operation.
  
  {-|
  Disposes the current node. Only used by widgets which allocate resources during
  /init/ or /merge/, and will usually involve requests to the runtime.
  
  An example can be found in "Monomer.Widgets.Singles.Image".
  -}
  type SingleDisposeHandler s e
    = WidgetEnv s e        -- ^ The widget environment.
    -> WidgetNode s e      -- ^ The widget node.
    -> WidgetResult s e    -- ^ The result of the dispose operation.
  
  {-|
  Returns the next focusable node. Since this type of widget does not have
  children, there is not need to override this function, as there are only
  two options:
  
  - The node is focusable and target is valid: the node is returned
  - The node is not focusable: Nothing is returned
  -}
  type SingleFindNextFocusHandler s e
    = WidgetEnv s e            -- ^ The widget environment.
    -> WidgetNode s e          -- ^ The widget node.
    -> FocusDirection          -- ^ The direction in which focus is moving.
    -> Path                    -- ^ The start path from which to search.
    -> Maybe WidgetNodeInfo    -- ^ The next focusable node info.
  
  {-|
  Returns the currently hovered widget, if any. If the widget is rectangular and
  uses the full content area, there is not need to override this function.
  
  An example can be found in "Monomer.Widgets.Singles.Radio".
  -}
  type SingleFindByPointHandler s e
    = WidgetEnv s e           -- ^ The widget environment.
    -> WidgetNode s e         -- ^ The widget node.
    -> Path                   -- ^ The start path from which to search.
    -> Point                  -- ^ The point to test for.
    -> Maybe WidgetNodeInfo   -- ^ The hovered node info, if any.
  
  {-|
  Receives a System event and, optionally, returns a result. This can include an
  updated version of the widget (in case it has internal state), user events or
  requests to the runtime.
  
  Examples can be found in "Monomer.Widgets.Singles.Button" and
  "Monomer.Widgets.Singles.Slider".
  -}
  type SingleEventHandler s e
    = WidgetEnv s e                -- ^ The widget environment.
    -> WidgetNode s e              -- ^ The widget node.
    -> Path                        -- ^ The target path of the event.
    -> SystemEvent                 -- ^ The SystemEvent to handle.
    -> Maybe (WidgetResult s e)    -- ^ The result of handling the event, if any.
  
  {-|
  Receives a message and, optionally, returns a result. This can include an
  updated version of the widget (in case it has internal state), user events or
  requests to the runtime. There is no validation regarding the message type, and
  the widget should take care of _casting_ to the correct type using
  "Data.Typeable.cast"
  
  An example can be found in "Monomer.Widgets.Singles.Image".
  -}
  type SingleMessageHandler s e
    = forall i . Typeable i
    => WidgetEnv s e              -- ^ The widget environment.
    -> WidgetNode s e             -- ^ The widget node.
    -> Path                       -- ^ The target path of the message.
    -> i                          -- ^ The message to handle.
    -> Maybe (WidgetResult s e)   -- ^ The result of handling the message, if any.
  
  {-|
  Returns the preferred size for the widget. This size should not include border
  and padding; those are added automatically by Single.
  
  This is called to update WidgetNodeInfo only at specific times.
  
  Examples can be found in "Monomer.Widgets.Singles.Checkbox" and
  "Monomer.Widgets.Singles.Label".
  -}
  type SingleGetSizeReqHandler s e
    = WidgetEnv s e          -- ^ The widget environment.
    -> WidgetNode s e        -- ^ The widget node.
    -> (SizeReq, SizeReq)    -- ^ The horizontal and vertical requirements.
  
  {-|
  Resizes the widget to the provided size. If the widget state does not depend
  on the viewport size, this function does not need to be overridden.
  
  Examples can be found in "Monomer.Widgets.Singles.Label".
  -}
  type SingleResizeHandler s e
    = WidgetEnv s e        -- ^ The widget environment.
    -> WidgetNode s e      -- ^ The widget node.
    -> Rect                -- ^ The new viewport.
    -> WidgetResult s e    -- ^ The result of resizing the widget.
  
  {-|
  Renders the widget's content using the given Renderer. In general, this method
  needs to be overridden.
  
  Examples can be found in "Monomer.Widgets.Singles.Checkbox" and
  "Monomer.Widgets.Singles.Slider".
  -}
  type SingleRenderHandler s e
    = WidgetEnv s e      -- ^ The widget environment.
    -> WidgetNode s e    -- ^ The widget node.
    -> Renderer          -- ^ The renderer, providing low level drawing functions.
    -> IO ()             -- ^ The IO action with rendering instructions.
  
  -- | Interface for Single widgets.
  data Single s e a = Single {
    -- | True if border and padding should be added to size requirement. Defaults
    --   to True.
    singleAddStyleReq :: Bool,
    -- | If True, the widget will render its background and border. Defaults to
    --   True.
    singleDrawDecorations :: Bool,
    -- | True if focus should be requested when mouse button is pressed (before
    --   click). Defaults to True.
    singleFocusOnBtnPressed :: Bool,
    -- | True if style cursor should be ignored. If it's False, cursor changes
    --   need to be handled in custom code. Defaults to False.
    singleUseCustomCursor :: Bool,
    -- | If true, it will ignore extra space assigned by the parent container, but
    --   it will not use more space than assigned. Defaults to False.
    singleUseCustomSize :: Bool,
    -- | True if automatic scissoring needs to be applied. Defaults to False.
    singleUseScissor :: Bool,
    -- | Returns the base style for this type of widget.
    singleGetBaseStyle :: SingleGetBaseStyle s e,
    -- | Returns the active style, depending on the status of the widget.
    singleGetCurrentStyle :: SingleGetCurrentStyle s e,
    -- | Initializes the given node.
    singleInit :: SingleInitHandler s e,
    -- | Merges the node with the node it matched with during the merge process.
    singleMerge :: SingleMergeHandler s e a,
    -- | Disposes the current node.
    singleDispose :: SingleDisposeHandler s e,
    -- | Returns the next focusable node.
    singleFindNextFocus :: SingleFindNextFocusHandler s e,
    -- | Returns the currently hovered widget, if any.
    singleFindByPoint :: SingleFindByPointHandler s e,
    -- | Receives a System event and, optionally, returns a result.
    singleHandleEvent :: SingleEventHandler s e,
    -- | Receives a message and, optionally, returns a result.
    singleHandleMessage :: SingleMessageHandler s e,
    -- | Returns the preferred size for the widget.
    singleGetSizeReq :: SingleGetSizeReqHandler s e,
    -- | Resizes the widget to the provided size.
    singleResize :: SingleResizeHandler s e,
    -- | Renders the widget's content.
    singleRender :: SingleRenderHandler s e
  }
  
  instance Default (Single s e a) where
    def = Single {
      singleAddStyleReq = True,
      singleFocusOnBtnPressed = True,
      singleDrawDecorations = True,
      singleUseCustomCursor = False,
      singleUseCustomSize = False,
      singleUseScissor = False,
      singleGetBaseStyle = defaultGetBaseStyle,
      singleGetCurrentStyle = defaultGetCurrentStyle,
      singleInit = defaultInit,
      singleMerge = defaultMerge,
      singleDispose = defaultDispose,
      singleFindNextFocus = defaultFindNextFocus,
      singleFindByPoint = defaultFindByPoint,
      singleHandleEvent = defaultHandleEvent,
      singleHandleMessage = defaultHandleMessage,
      singleGetSizeReq = defaultGetSizeReq,
      singleResize = defaultResize,
      singleRender = defaultRender
    }
  
  {-|
  Creates a widget based on the Single infrastructure. An initial state and the
  Single definition need to be provided. In case internal state is not needed,
  __()__ can be provided. Using the __def__ instance as a starting point is
  recommended to focus on overriding only what is needed:
  
  @
  widget = createSingle () def {
    singleRender = ...
  }
  @
  -}
  createSingle :: WidgetModel a => a -> Single s e a -> Widget s e
  createSingle state single = Widget {
    widgetInit = initWrapper single,
    widgetMerge = mergeWrapper single,
    widgetDispose = disposeWrapper single,
    widgetGetState = makeState state,
    widgetGetInstanceTree = getInstanceTreeWrapper single,
    widgetFindNextFocus = singleFindNextFocus single,
    widgetFindByPoint = singleFindByPoint single,
    widgetFindBranchByPath = singleFindBranchByPath,
    widgetHandleEvent = handleEventWrapper single,
    widgetHandleMessage = handleMessageWrapper single,
    widgetGetSizeReq = getSizeReqWrapper single,
    widgetResize = resizeHandlerWrapper single,
    widgetRender = renderWrapper single
  }
  
  defaultGetBaseStyle :: SingleGetBaseStyle s e
  defaultGetBaseStyle wenv node = Nothing
  
  defaultGetCurrentStyle :: SingleGetCurrentStyle s e
  defaultGetCurrentStyle wenv node = currentStyle wenv node
  
  defaultInit :: SingleInitHandler s e
  defaultInit wenv node = resultNode node
  
  initWrapper
    :: WidgetModel a
    => Single s e a
    -> WidgetEnv s e
    -> WidgetNode s e
    -> WidgetResult s e
  initWrapper single wenv node = newResult where
    initHandler = singleInit single
    getBaseStyle = singleGetBaseStyle single
    styledNode = initNodeStyle getBaseStyle wenv node
    tmpResult = initHandler wenv styledNode
    newResult = tmpResult
      & L.node .~ updateSizeReq wenv (tmpResult ^. L.node)
  
  defaultMerge :: SingleMergeHandler s e a
  defaultMerge wenv newNode oldState oldNode = resultNode newNode
  
  mergeWrapper
    :: WidgetModel a
    => Single s e a
    -> WidgetEnv s e
    -> WidgetNode s e
    -> WidgetNode s e
    -> WidgetResult s e
  mergeWrapper single wenv newNode oldNode = newResult where
    mergeHandler = singleMerge single
    oldState = widgetGetState (oldNode ^. L.widget) wenv oldNode
    oldInfo = oldNode ^. L.info
  
    nodeHandler wenv styledNode = case useState oldState of
      Just state -> mergeHandler wenv styledNode oldNode state
      _ -> resultNode styledNode
    tmpResult = runNodeHandler single wenv newNode oldNode nodeHandler
    newResult = handleWidgetIdChange oldNode tmpResult
  
  runNodeHandler
    :: WidgetModel a
    => Single s e a
    -> WidgetEnv s e
    -> WidgetNode s e
    -> WidgetNode s e
    -> (WidgetEnv s e -> WidgetNode s e -> WidgetResult s e)
    -> WidgetResult s e
  runNodeHandler single wenv newNode oldNode nodeHandler = newResult where
    oldInfo = oldNode ^. L.info
    getBaseStyle = singleGetBaseStyle single
    tempNode = newNode
      & L.info . L.widgetId .~ oldInfo ^. L.widgetId
      & L.info . L.viewport .~ oldInfo ^. L.viewport
      & L.info . L.sizeReqW .~ oldInfo ^. L.sizeReqW
      & L.info . L.sizeReqH .~ oldInfo ^. L.sizeReqH
    styledNode = initNodeStyle getBaseStyle wenv tempNode
  
    tmpResult = nodeHandler wenv styledNode
      & handleUserSizeReqChange wenv oldNode
      & handleWidgetIdChange oldNode
  
    newResult
      | isResizeAnyResult (Just tmpResult) = tmpResult
          & L.node .~ updateSizeReq wenv (tmpResult ^. L.node)
      | otherwise = tmpResult
  
  getInstanceTreeWrapper
    :: WidgetModel a
    => Single s e a
    -> WidgetEnv s e
    -> WidgetNode s e
    -> WidgetInstanceNode
  getInstanceTreeWrapper container wenv node = instNode where
    instNode = WidgetInstanceNode {
      _winInfo = node ^. L.info,
      _winState = widgetGetState (node ^. L.widget) wenv node,
      _winChildren = fmap (getChildTree wenv) (node ^. L.children)
    }
    getChildTree wenv child = widgetGetInstanceTree (child ^. L.widget) wenv child
  
  defaultDispose :: SingleDisposeHandler s e
  defaultDispose wenv node = resultNode node
  
  disposeWrapper
    :: Single s e a
    -> WidgetEnv s e
    -> WidgetNode s e
    -> WidgetResult s e
  disposeWrapper single wenv node = result where
    disposeHandler = singleDispose single
    WidgetResult newNode reqs = disposeHandler wenv node
    widgetId = node ^. L.info . L.widgetId
    newReqs = reqs |> ResetWidgetPath widgetId
    result = WidgetResult newNode newReqs
  
  defaultFindNextFocus :: SingleFindNextFocusHandler s e
  defaultFindNextFocus wenv node direction startFrom
    | isFocusCandidate node startFrom direction = Just (node ^. L.info)
    | otherwise = Nothing
  
  defaultFindByPoint :: SingleFindByPointHandler s e
  defaultFindByPoint wenv node start point
    | visible && validPath && isPointInNodeVp node point = Just info
    | otherwise = Nothing
    where
      info = node ^. L.info
      visible = info ^. L.visible
      path = node ^. L.info . L.path
      validPath = seqStartsWith start path
  
  singleFindBranchByPath
    :: WidgetEnv s e
    -> WidgetNode s e
    -> Path
    -> Seq WidgetNodeInfo
  singleFindBranchByPath wenv node path
    | info ^. L.path == path = Seq.singleton info
    | otherwise = Seq.empty
    where
      info = node ^. L.info
  
  defaultHandleEvent :: SingleEventHandler s e
  defaultHandleEvent wenv node target evt = Nothing
  
  handleEventWrapper
    :: WidgetModel a
    => Single s e a
    -> WidgetEnv s e
    -> WidgetNode s e
    -> Path
    -> SystemEvent
    -> Maybe (WidgetResult s e)
  handleEventWrapper single wenv node target evt
    | not (node ^. L.info . L.visible) = Nothing
    | otherwise = handleStyleChange wenv target style handleCursor node evt result
    where
      style = singleGetCurrentStyle single wenv node
      handleCursor = not (singleUseCustomCursor single)
      focusOnPressed = singleFocusOnBtnPressed single
      handler = singleHandleEvent single
      handlerRes = handler wenv node target evt
      sizeResult = handleSizeReqChange single wenv node (Just evt) handlerRes
      result
        | focusOnPressed = handleFocusRequest wenv node evt sizeResult
        | otherwise = sizeResult
  
  handleFocusRequest
    :: WidgetEnv s e
    -> WidgetNode s e
    -> SystemEvent
    -> Maybe (WidgetResult s e)
    -> Maybe (WidgetResult s e)
  handleFocusRequest wenv oldNode evt mResult = newResult where
    node = maybe oldNode (^. L.node) mResult
    prevReqs = maybe Empty (^. L.requests) mResult
    isFocusable = node ^. L.info . L.focusable
    btnPressed = case evt of
      ButtonAction _ btn BtnPressed _ -> Just btn
      _ -> Nothing
    isFocusReq = btnPressed == Just (wenv ^. L.mainButton)
      && isFocusable
      && not (isNodeFocused wenv node)
      && isNodeTopLevel wenv node
      && isNothing (Seq.findIndexL isFocusRequest prevReqs)
  
    newReq = SetFocus (node ^. L.info . L.widgetId)
    newResult
      | isFocusReq && isJust mResult = (L.requests %~ (|> newReq)) <$> mResult
      | isFocusReq = Just $ resultReqs node [newReq]
      | otherwise = mResult
  
  defaultHandleMessage :: SingleMessageHandler s e
  defaultHandleMessage wenv node target message = Nothing
  
  handleMessageWrapper :: forall s e a i . (WidgetModel a, Typeable i)
    => Single s e a
    -> WidgetEnv s e
    -> WidgetNode s e
    -> Path
    -> i
    -> Maybe (WidgetResult s e)
  handleMessageWrapper single wenv node target msg = result where
    handler = singleHandleMessage single
    result = handleSizeReqChange single wenv node Nothing
      $ handler wenv node target msg
  
  defaultGetSizeReq :: SingleGetSizeReqHandler s e
  defaultGetSizeReq wenv node = def
  
  getSizeReqWrapper
    :: WidgetModel a
    => Single s e a
    -> WidgetEnv s e
    -> WidgetNode s e
    -> (SizeReq, SizeReq)
  getSizeReqWrapper single wenv node = (newReqW, newReqH) where
    addStyleReq = singleAddStyleReq single
    handler = singleGetSizeReq single
    style = singleGetCurrentStyle single wenv node
  
    reqs = handler wenv node
    (tmpReqW, tmpReqH)
      | addStyleReq = sizeReqAddStyle style reqs
      | otherwise = reqs
    -- User settings take precedence
    newReqW = fromMaybe tmpReqW (style ^. L.sizeReqW)
    newReqH = fromMaybe tmpReqH (style ^. L.sizeReqH)
  
  updateSizeReq
    :: WidgetEnv s e
    -> WidgetNode s e
    -> WidgetNode s e
  updateSizeReq wenv node = newNode where
    (newReqW, newReqH) = widgetGetSizeReq (node ^. L.widget) wenv node
    newNode = node
      & L.info . L.sizeReqW .~ newReqW
      & L.info . L.sizeReqH .~ newReqH
  
  handleSizeReqChange
    :: WidgetModel a
    => Single s e a
    -> WidgetEnv s e
    -> WidgetNode s e
    -> Maybe SystemEvent
    -> Maybe (WidgetResult s e)
    -> Maybe (WidgetResult s e)
  handleSizeReqChange single wenv node evt mResult = result where
    baseResult = fromMaybe (resultNode node) mResult
    newNode = baseResult ^. L.node
    resizeReq = isResizeAnyResult mResult
    styleChanged = isJust evt && styleStateChanged wenv newNode (fromJust evt)
    result
      | styleChanged || resizeReq = Just $ baseResult
        & L.node .~ updateSizeReq wenv newNode
      | otherwise = mResult
  
  defaultResize :: SingleResizeHandler s e
  defaultResize wenv node viewport = resultNode node
  
  resizeHandlerWrapper
    :: WidgetModel a
    => Single s e a
    -> WidgetEnv s e
    -> WidgetNode s e
    -> Rect
    -> (Path -> Bool)
    -> WidgetResult s e
  resizeHandlerWrapper single wenv node viewport resizeReq = result where
    useCustomSize = singleUseCustomSize single
    handler = singleResize single
  
    tmpRes = handler wenv node viewport
    lensVp = L.info . L.viewport
    newVp
      | useCustomSize = tmpRes ^. L.node . lensVp
      | otherwise = viewport
    tmpResult = Just $ tmpRes
      & L.node . L.info . L.viewport .~ newVp
  
    newNode = tmpRes ^. L.node
    result = fromJust $ handleSizeReqChange single wenv newNode Nothing tmpResult
  
  defaultRender :: SingleRenderHandler s e
  defaultRender wenv node renderer = return ()
  
  renderWrapper
    :: Single s e a
    -> WidgetEnv s e
    -> WidgetNode s e
    -> Renderer
    -> IO ()
  renderWrapper single wenv node renderer =
    when (isWidgetVisible wenv node) $
      drawInScissor renderer useScissor viewport $
        drawStyledAction_ renderer drawDecorations viewport style $ \_ ->
          handler wenv node renderer
    where
      handler = singleRender single
      drawDecorations = singleDrawDecorations single
      useScissor = singleUseScissor single
      style = singleGetCurrentStyle single wenv node
      viewport = node ^. L.info . L.viewport
  