Util.hs

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

Helper functions for the Main module.
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE Strict #-}

module Monomer.Main.Util where

import Control.Concurrent.STM.TChan
import Control.Lens ((^.), (.=), at, non, use)
import Data.Default

import qualified Data.Sequence as Seq
import qualified Data.Map as Map
import qualified SDL

import Monomer.Core
import Monomer.Event
import Monomer.Helper (headMay)
import Monomer.Main.Types

import qualified Monomer.Core.Lens as L
import qualified Monomer.Main.Lens as L

-- | Initializes the Monomer context with the provided information.
initMonomerCtx
  :: SDL.Window
  -> TChan (RenderMsg s e)
  -> Size
  -> Double
  -> Double
  -> s
  -> MonomerCtx s e
initMonomerCtx ~win channel winSize dpr epr model = MonomerCtx {
  _mcMainModel = model,
  _mcWindow = win,
  _mcWindowSize = winSize,
  _mcDpr = dpr,
  _mcEpr = epr,
  _mcRenderMethod = Right channel,
  _mcInputStatus = def,
  _mcCursorStack = [],
  _mcFocusedWidgetId = def,
  _mcHoveredWidgetId = Nothing,
  _mcOverlayWidgetId = Nothing,
  _mcDragAction = Nothing,
  _mcMainBtnPress = Nothing,
  _mcWidgetTasks = Seq.empty,
  _mcWidgetPaths = Map.empty,
  _mcCursorIcons = Map.empty,
  _mcLeaveEnterPair = False,
  _mcResizeRequests = Seq.empty,
  _mcRenderRequested = False,
  _mcRenderSchedule = Map.empty,
  _mcExitApplication = False
}

-- | Returns the path of the provided "WidgetId".
getWidgetIdPath :: (MonomerM s e m) => WidgetId -> m Path
getWidgetIdPath widgetId =
  use $ L.widgetPaths . at widgetId . non (widgetId ^. L.path)

-- | Updates the path associated to a "WidgetId".
setWidgetIdPath :: (MonomerM s e m) => WidgetId -> Path -> m ()
setWidgetIdPath widgetId path = L.widgetPaths . at widgetId .= Just path

-- | Removes the association of a path to a "WidgetId".
delWidgetIdPath :: (MonomerM s e m) => WidgetId -> m ()
delWidgetIdPath widgetId = L.widgetPaths . at widgetId .= Nothing

-- | Returns the path of the currently hovered node, if any.
getHoveredPath :: (MonomerM s e m) => m (Maybe Path)
getHoveredPath = do
  hoveredWidgetId <- use L.hoveredWidgetId
  case hoveredWidgetId of
    Just wid -> Just <$> getWidgetIdPath wid
    Nothing -> return Nothing

-- | Returns the path of the currently focused node.
getFocusedPath :: (MonomerM s e m) => m Path
getFocusedPath = getWidgetIdPath =<< use L.focusedWidgetId

-- | Returns the path of the current overlay node, if any.
getOverlayPath :: (MonomerM s e m) => m (Maybe Path)
getOverlayPath = do
  overlayWidgetId <- use L.overlayWidgetId
  case overlayWidgetId of
    Just wid -> Just <$> getWidgetIdPath wid
    Nothing -> return Nothing

-- | Returns the current drag message and path, if any.
getDraggedMsgInfo :: (MonomerM s e m) => m (Maybe (Path, WidgetDragMsg))
getDraggedMsgInfo = do
  dragAction <- use L.dragAction
  case dragAction of
    Just (DragAction wid msg) -> Just . (, msg) <$> getWidgetIdPath wid
    Nothing -> return Nothing

-- | Returns the current cursor and path that set it, if any.
getCurrentCursorIcon :: (MonomerM s e m) => m (Maybe (Path, CursorIcon))
getCurrentCursorIcon = do
  cursorHead <- fmap headMay (use L.cursorStack)
  case cursorHead of
    Just (wid, icon) -> do
      path <- getWidgetIdPath wid
      return $ Just (path, icon)
    otherwhise -> return Nothing