{-|
Module      : Monomer.Widgets.Util.Style
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 style related operations.
-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Strict #-}

module Monomer.Widgets.Util.Style (
  collectStyleField,
  collectStyleField_,
  currentTheme,
  currentTheme_,
  currentStyle,
  currentStyle_,
  focusedStyle,
  styleStateChanged,
  initNodeStyle,
  mergeBasicStyle,
  handleStyleChange,
  childOfFocusedStyle
) where

import Control.Applicative ((<|>))
import Control.Lens (Lens', (&), (^.), (^?), (.~), (?~), (<>~), _Just, _1, non)

import Data.Bits (xor)
import Data.Default
import Data.Maybe
import Data.Sequence (Seq(..), (<|), (|>))

import qualified Data.Sequence as Seq

import Monomer.Core
import Monomer.Event
import Monomer.Helper
import Monomer.Widgets.Util.Focus
import Monomer.Widgets.Util.Hover
import Monomer.Widgets.Util.Types
import Monomer.Widgets.Util.Widget

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

instance Default (CurrentStyleCfg s e) where
  def :: CurrentStyleCfg s e
def = CurrentStyleCfg {
    _ascIsHovered :: IsHovered s e
_ascIsHovered = forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodeHovered,
    _ascIsFocused :: IsHovered s e
_ascIsFocused = forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodeFocused,
    _ascIsActive :: IsHovered s e
_ascIsActive = forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodeActive
  }

-- | Extracts/copies the field of a style into an empty style.
collectStyleField
  :: Lens' StyleState (Maybe t) -- ^ The field into the state.
  -> Style                      -- ^ The source style.
  -> Style                      -- ^ The new style.
collectStyleField :: forall t. Lens' StyleState (Maybe t) -> Style -> Style
collectStyleField Lens' StyleState (Maybe t)
fieldS Style
source = forall t. Lens' StyleState (Maybe t) -> Style -> Style -> Style
collectStyleField_ Lens' StyleState (Maybe t)
fieldS Style
source forall a. Default a => a
def

-- | Extracts/copies the field of a style into a provided style.
collectStyleField_
  :: Lens' StyleState (Maybe t) -- ^ The field into the state.
  -> Style                      -- ^ The source style.
  -> Style                      -- ^ The target style.
  -> Style                      -- ^ The updated style.
collectStyleField_ :: forall t. Lens' StyleState (Maybe t) -> Style -> Style -> Style
collectStyleField_ Lens' StyleState (Maybe t)
fieldS Style
source Style
target = Style
style where
  setValue :: Getting (Maybe StyleState) Style (Maybe StyleState)
-> Maybe StyleState
setValue Getting (Maybe StyleState) Style (Maybe StyleState)
stateLens = Maybe StyleState
result where
    sourceState :: Maybe StyleState
sourceState = Style
source forall s a. s -> Getting a s a -> a
^. Getting (Maybe StyleState) Style (Maybe StyleState)
stateLens
    targetState :: Maybe StyleState
targetState = Style
target forall s a. s -> Getting a s a -> a
^. Getting (Maybe StyleState) Style (Maybe StyleState)
stateLens
    value :: Maybe t
value = Maybe StyleState
sourceState forall s a. s -> Getting (First a) s a -> Maybe a
^? forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' StyleState (Maybe t)
fieldS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just
    setTarget :: t -> StyleState
setTarget t
val = Maybe StyleState
targetState forall s a. s -> Getting a s a -> a
^. forall a. Eq a => a -> Iso' (Maybe a) a
non forall a. Default a => a
def
      forall a b. a -> (a -> b) -> b
& Lens' StyleState (Maybe t)
fieldS forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ t
val
    resetTarget :: StyleState
resetTarget = Maybe StyleState
targetState forall s a. s -> Getting a s a -> a
^. forall a. Eq a => a -> Iso' (Maybe a) a
non forall a. Default a => a
def
      forall a b. a -> (a -> b) -> b
& Lens' StyleState (Maybe t)
fieldS forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Maybe a
Nothing
    result :: Maybe StyleState
result
      | forall a. Maybe a -> Bool
isJust Maybe t
value = t -> StyleState
setTarget forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe t
value
      | forall a. Maybe a -> Bool
isJust Maybe StyleState
targetState = forall a. a -> Maybe a
Just StyleState
resetTarget
      | Bool
otherwise = forall a. Maybe a
Nothing

  basic :: Maybe StyleState
basic = Getting (Maybe StyleState) Style (Maybe StyleState)
-> Maybe StyleState
setValue forall s a. HasBasic s a => Lens' s a
L.basic
  hover :: Maybe StyleState
hover = Getting (Maybe StyleState) Style (Maybe StyleState)
-> Maybe StyleState
setValue forall s a. HasHover s a => Lens' s a
L.hover
  focus :: Maybe StyleState
focus = Getting (Maybe StyleState) Style (Maybe StyleState)
-> Maybe StyleState
setValue forall s a. HasFocus s a => Lens' s a
L.focus
  focusHover :: Maybe StyleState
focusHover = Getting (Maybe StyleState) Style (Maybe StyleState)
-> Maybe StyleState
setValue forall s a. HasFocusHover s a => Lens' s a
L.focusHover
  active :: Maybe StyleState
active = Getting (Maybe StyleState) Style (Maybe StyleState)
-> Maybe StyleState
setValue forall s a. HasActive s a => Lens' s a
L.active
  disabled :: Maybe StyleState
disabled = Getting (Maybe StyleState) Style (Maybe StyleState)
-> Maybe StyleState
setValue forall s a. HasDisabled s a => Lens' s a
L.disabled
  style :: Style
style = Maybe StyleState
-> Maybe StyleState
-> Maybe StyleState
-> Maybe StyleState
-> Maybe StyleState
-> Maybe StyleState
-> Style
Style Maybe StyleState
basic Maybe StyleState
hover Maybe StyleState
focus Maybe StyleState
focusHover Maybe StyleState
active Maybe StyleState
disabled

-- | Returns the current style state for the given node.
currentStyle :: WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle :: forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle WidgetEnv s e
wenv WidgetNode s e
node = forall s e.
CurrentStyleCfg s e
-> WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle_ forall a. Default a => a
def WidgetEnv s e
wenv WidgetNode s e
node

{-|
Returns the current style state for the given node, using the provided functions
to determine hover, focus and active status.
-}
currentStyle_
  :: CurrentStyleCfg s e -> WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle_ :: forall s e.
CurrentStyleCfg s e
-> WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle_ CurrentStyleCfg s e
config WidgetEnv s e
wenv WidgetNode s e
node = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def Maybe StyleState
styleState where
  Style{Maybe StyleState
_styleDisabled :: Style -> Maybe StyleState
_styleActive :: Style -> Maybe StyleState
_styleFocusHover :: Style -> Maybe StyleState
_styleFocus :: Style -> Maybe StyleState
_styleHover :: Style -> Maybe StyleState
_styleBasic :: Style -> Maybe StyleState
_styleDisabled :: Maybe StyleState
_styleActive :: Maybe StyleState
_styleFocusHover :: Maybe StyleState
_styleFocus :: Maybe StyleState
_styleHover :: Maybe StyleState
_styleBasic :: Maybe StyleState
..} = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasStyle s a => Lens' s a
L.style
  mousePos :: Point
mousePos = WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasInputStatus s a => Lens' s a
L.inputStatus forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasMousePos s a => Lens' s a
L.mousePos
  isEnabled :: Bool
isEnabled = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasEnabled s a => Lens' s a
L.enabled

  isHover :: Bool
isHover = forall s e. CurrentStyleCfg s e -> IsHovered s e
_ascIsHovered CurrentStyleCfg s e
config WidgetEnv s e
wenv WidgetNode s e
node
  isFocus :: Bool
isFocus = forall s e. CurrentStyleCfg s e -> IsHovered s e
_ascIsFocused CurrentStyleCfg s e
config WidgetEnv s e
wenv WidgetNode s e
node
  isActive :: Bool
isActive = forall s e. CurrentStyleCfg s e -> IsHovered s e
_ascIsActive CurrentStyleCfg s e
config WidgetEnv s e
wenv WidgetNode s e
node

  styleState :: Maybe StyleState
styleState
    | Bool -> Bool
not Bool
isEnabled = Maybe StyleState
_styleDisabled
    | Bool
isActive = Maybe StyleState
_styleActive
    | Bool
isHover Bool -> Bool -> Bool
&& Bool
isFocus = Maybe StyleState
_styleFocusHover
    | Bool
isHover = Maybe StyleState
_styleHover
    | Bool
isFocus = Maybe StyleState
_styleFocus
    | Bool
otherwise = Maybe StyleState
_styleBasic

-- | Returns the correct focused style, depending if it's hovered or not.
focusedStyle :: WidgetEnv s e -> WidgetNode s e -> StyleState
focusedStyle :: forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
focusedStyle WidgetEnv s e
wenv WidgetNode s e
node = forall s e.
IsHovered s e -> WidgetEnv s e -> WidgetNode s e -> StyleState
focusedStyle_ forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodeHovered WidgetEnv s e
wenv WidgetNode s e
node

{-|
Returns the correct focused style, depending if it's hovered or not, using the
provided function.
-}
focusedStyle_ :: IsHovered s e -> WidgetEnv s e -> WidgetNode s e -> StyleState
focusedStyle_ :: forall s e.
IsHovered s e -> WidgetEnv s e -> WidgetNode s e -> StyleState
focusedStyle_ IsHovered s e
isHoveredFn WidgetEnv s e
wenv WidgetNode s e
node = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def Maybe StyleState
styleState where
  Style{Maybe StyleState
_styleDisabled :: Maybe StyleState
_styleActive :: Maybe StyleState
_styleFocusHover :: Maybe StyleState
_styleFocus :: Maybe StyleState
_styleHover :: Maybe StyleState
_styleBasic :: Maybe StyleState
_styleDisabled :: Style -> Maybe StyleState
_styleActive :: Style -> Maybe StyleState
_styleFocusHover :: Style -> Maybe StyleState
_styleFocus :: Style -> Maybe StyleState
_styleHover :: Style -> Maybe StyleState
_styleBasic :: Style -> Maybe StyleState
..} = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasStyle s a => Lens' s a
L.style
  isHover :: Bool
isHover = IsHovered s e
isHoveredFn WidgetEnv s e
wenv WidgetNode s e
node
  styleState :: Maybe StyleState
styleState
    | Bool
isHover = Maybe StyleState
_styleFocusHover
    | Bool
otherwise = Maybe StyleState
_styleFocus

-- | Returns the current theme for the node.
currentTheme :: WidgetEnv s e -> WidgetNode s e -> ThemeState
currentTheme :: forall s e. WidgetEnv s e -> WidgetNode s e -> ThemeState
currentTheme WidgetEnv s e
wenv WidgetNode s e
node = forall s e.
IsHovered s e -> WidgetEnv s e -> WidgetNode s e -> ThemeState
currentTheme_ forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodeHovered WidgetEnv s e
wenv WidgetNode s e
node

-- | Returns the current theme for the node.
currentTheme_ :: IsHovered s e -> WidgetEnv s e -> WidgetNode s e -> ThemeState
currentTheme_ :: forall s e.
IsHovered s e -> WidgetEnv s e -> WidgetNode s e -> ThemeState
currentTheme_ IsHovered s e
isHoveredFn WidgetEnv s e
wenv WidgetNode s e
node = ThemeState
themeState where
  theme :: Theme
theme = forall s e. WidgetEnv s e -> Theme
_weTheme WidgetEnv s e
wenv
  mousePos :: Point
mousePos = WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasInputStatus s a => Lens' s a
L.inputStatus forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasMousePos s a => Lens' s a
L.mousePos
  isEnabled :: Bool
isEnabled = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasEnabled s a => Lens' s a
L.enabled

  isHover :: Bool
isHover = IsHovered s e
isHoveredFn WidgetEnv s e
wenv WidgetNode s e
node
  isFocus :: Bool
isFocus = forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodeFocused WidgetEnv s e
wenv WidgetNode s e
node
  isActive :: Bool
isActive = forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodeActive WidgetEnv s e
wenv WidgetNode s e
node

  themeState :: ThemeState
themeState
    | Bool -> Bool
not Bool
isEnabled = Theme -> ThemeState
_themeDisabled Theme
theme
    | Bool
isActive = Theme -> ThemeState
_themeActive Theme
theme
    | Bool
isHover Bool -> Bool -> Bool
&& Bool
isFocus = Theme -> ThemeState
_themeFocusHover Theme
theme
    | Bool
isHover = Theme -> ThemeState
_themeHover Theme
theme
    | Bool
isFocus = Theme -> ThemeState
_themeFocus Theme
theme
    | Bool
otherwise = Theme -> ThemeState
_themeBasic Theme
theme

-- | Checks if hover or focus states changed between versions of the node.
styleStateChanged :: WidgetEnv s e -> WidgetNode s e -> SystemEvent -> Bool
styleStateChanged :: forall s e. WidgetEnv s e -> WidgetNode s e -> SystemEvent -> Bool
styleStateChanged WidgetEnv s e
wenv WidgetNode s e
node SystemEvent
evt = Bool
hoverChanged Bool -> Bool -> Bool
|| Bool
focusChanged where
  -- Hover
  hoverChanged :: Bool
hoverChanged = SystemEvent -> Bool
isOnEnter SystemEvent
evt Bool -> Bool -> Bool
|| SystemEvent -> Bool
isOnLeave SystemEvent
evt
  -- Focus
  focusChanged :: Bool
focusChanged = SystemEvent -> Bool
isOnFocus SystemEvent
evt Bool -> Bool -> Bool
|| SystemEvent -> Bool
isOnBlur SystemEvent
evt

{-|
Initializes the node style states. Mainly, it uses basic as the base of all the
other styles.
-}
initNodeStyle
  :: GetBaseStyle s e  -- ^ The function to get the base style.
  -> WidgetEnv s e     -- ^ The widget environment.
  -> WidgetNode s e    -- ^ The widget node.
  -> WidgetNode s e    -- ^ The updated widget node.
initNodeStyle :: forall s e.
GetBaseStyle s e
-> WidgetEnv s e -> WidgetNode s e -> WidgetNode s e
initNodeStyle GetBaseStyle s e
getBaseStyle WidgetEnv s e
wenv WidgetNode s e
node = WidgetNode s e
newNode where
  nodeStyle :: Style
nodeStyle = Style -> Style
mergeBasicStyle forall a b. (a -> b) -> a -> b
$ WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasStyle s a => Lens' s a
L.style
  baseStyle :: Style
baseStyle = Style -> Style
mergeBasicStyle forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def (GetBaseStyle s e
getBaseStyle WidgetEnv s e
wenv WidgetNode s e
node)
  newNode :: WidgetNode s e
newNode = WidgetNode s e
node
    forall a b. a -> (a -> b) -> b
& forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasStyle s a => Lens' s a
L.style forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Style
baseStyle forall a. Semigroup a => a -> a -> a
<> Style
nodeStyle)

-- | Uses the basic style state as the base for all the other style states.
mergeBasicStyle :: Style -> Style
mergeBasicStyle :: Style -> Style
mergeBasicStyle Style
st = Style
newStyle where
  focusHover :: Maybe StyleState
focusHover = Style -> Maybe StyleState
_styleHover Style
st forall a. Semigroup a => a -> a -> a
<> Style -> Maybe StyleState
_styleFocus Style
st forall a. Semigroup a => a -> a -> a
<> Style -> Maybe StyleState
_styleFocusHover Style
st
  active :: Maybe StyleState
active = Maybe StyleState
focusHover forall a. Semigroup a => a -> a -> a
<> Style -> Maybe StyleState
_styleActive Style
st
  newStyle :: Style
newStyle = Style {
    _styleBasic :: Maybe StyleState
_styleBasic = Style -> Maybe StyleState
_styleBasic Style
st,
    _styleHover :: Maybe StyleState
_styleHover = Style -> Maybe StyleState
_styleBasic Style
st forall a. Semigroup a => a -> a -> a
<> Style -> Maybe StyleState
_styleHover Style
st,
    _styleFocus :: Maybe StyleState
_styleFocus = Style -> Maybe StyleState
_styleBasic Style
st forall a. Semigroup a => a -> a -> a
<> Style -> Maybe StyleState
_styleFocus Style
st,
    _styleFocusHover :: Maybe StyleState
_styleFocusHover = Style -> Maybe StyleState
_styleBasic Style
st forall a. Semigroup a => a -> a -> a
<> Maybe StyleState
focusHover,
    _styleActive :: Maybe StyleState
_styleActive = Style -> Maybe StyleState
_styleBasic Style
st forall a. Semigroup a => a -> a -> a
<> Maybe StyleState
active,
    _styleDisabled :: Maybe StyleState
_styleDisabled = Style -> Maybe StyleState
_styleBasic Style
st forall a. Semigroup a => a -> a -> a
<> Style -> Maybe StyleState
_styleDisabled Style
st
  }

{-|
Checks for style changes between the old node and the provided result, in the
context of an event. Generates requests for resize, render and cursor change as
necessary.
-}
handleStyleChange
  :: WidgetEnv s e             -- ^ The widget environment.
  -> Path                      -- ^ The target of the event.
  -> StyleState                -- ^ The active style.
  -> Bool                      -- ^ Whether to check/update the cursor.
  -> WidgetNode s e            -- ^ The old node.
  -> SystemEvent               -- ^ The event.
  -> Maybe (WidgetResult s e)  -- ^ The result containing the new node.
  -> Maybe (WidgetResult s e)  -- ^ The updated result.
handleStyleChange :: forall s e.
WidgetEnv s e
-> Path
-> StyleState
-> Bool
-> WidgetNode s e
-> SystemEvent
-> Maybe (WidgetResult s e)
-> Maybe (WidgetResult s e)
handleStyleChange WidgetEnv s e
wenv Path
target StyleState
style Bool
doCursor WidgetNode s e
node SystemEvent
evt Maybe (WidgetResult s e)
result = Maybe (WidgetResult s e)
newResult where
  tmpResult :: Maybe (WidgetResult s e)
tmpResult = forall s e.
WidgetEnv s e
-> Path
-> SystemEvent
-> WidgetNode s e
-> Maybe (WidgetResult s e)
-> Maybe (WidgetResult s e)
handleSizeChange WidgetEnv s e
wenv Path
target SystemEvent
evt WidgetNode s e
node Maybe (WidgetResult s e)
result
  newResult :: Maybe (WidgetResult s e)
newResult
    | Bool
doCursor = forall s e.
WidgetEnv s e
-> Path
-> SystemEvent
-> StyleState
-> WidgetNode s e
-> Maybe (WidgetResult s e)
-> Maybe (WidgetResult s e)
handleCursorChange WidgetEnv s e
wenv Path
target SystemEvent
evt StyleState
style WidgetNode s e
node Maybe (WidgetResult s e)
tmpResult
    | Bool
otherwise = Maybe (WidgetResult s e)
tmpResult

{-|
Replacement of currentStyle for child widgets embedded in a focusable parent. It
selects the correct style state according to the situation.

Used, for example, in "Monomer.Widgets.Singles.Button" and
"Monomer.Widgets.Singles.ExternalLink", which are focusable but have an embedded
label. Since label is not focusable, that style would not be handled correctly.
-}
childOfFocusedStyle
  :: WidgetEnv s e   -- ^ The widget environment.
  -> WidgetNode s e  -- ^ The embedded child node.
  -> StyleState      -- ^ The currently active state.
childOfFocusedStyle :: forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
childOfFocusedStyle WidgetEnv s e
wenv WidgetNode s e
cnode = StyleState
newStyle where
  branch :: Seq WidgetNodeInfo
branch = WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasFindBranchByPath s a => Lens' s a
L.findBranchByPath forall a b. (a -> b) -> a -> b
$ forall s e. WidgetNode s e -> Path
parentPath WidgetNode s e
cnode
  pinfo :: WidgetNodeInfo
pinfo = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def (forall a. Int -> Seq a -> Maybe a
Seq.lookup (forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq WidgetNodeInfo
branch forall a. Num a => a -> a -> a
- Int
1) Seq WidgetNodeInfo
branch)
  cstyle :: Style
cstyle = WidgetNode s e
cnode forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasStyle s a => Lens' s a
L.style
  enabled :: Bool
enabled = WidgetNode s e
cnode forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasEnabled s a => Lens' s a
L.enabled

  activeC :: Bool
activeC = forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodeActive WidgetEnv s e
wenv WidgetNode s e
cnode
  activeP :: Bool
activeP = forall s e. Bool -> WidgetEnv s e -> WidgetNodeInfo -> Bool
isNodeInfoActive Bool
False WidgetEnv s e
wenv WidgetNodeInfo
pinfo

  hoverC :: Bool
hoverC = forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodeHovered WidgetEnv s e
wenv WidgetNode s e
cnode
  hoverP :: Bool
hoverP = forall s e. WidgetEnv s e -> WidgetNodeInfo -> Bool
isNodeInfoHovered WidgetEnv s e
wenv WidgetNodeInfo
pinfo
  focusP :: Bool
focusP = forall s e. WidgetEnv s e -> WidgetNodeInfo -> Bool
isNodeInfoFocused WidgetEnv s e
wenv WidgetNodeInfo
pinfo

  newStyle :: StyleState
newStyle
    | Bool -> Bool
not Bool
enabled = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def (Style -> Maybe StyleState
_styleDisabled Style
cstyle)
    | Bool
activeC Bool -> Bool -> Bool
|| Bool
activeP = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def (Style -> Maybe StyleState
_styleActive Style
cstyle)
    | (Bool
hoverC Bool -> Bool -> Bool
|| Bool
hoverP) Bool -> Bool -> Bool
&& Bool
focusP = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def (Style -> Maybe StyleState
_styleFocusHover Style
cstyle)
    | Bool
hoverC Bool -> Bool -> Bool
|| Bool
hoverP = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def (Style -> Maybe StyleState
_styleHover Style
cstyle)
    | Bool
focusP = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def (Style -> Maybe StyleState
_styleFocus Style
cstyle)
    | Bool
otherwise = forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle WidgetEnv s e
wenv WidgetNode s e
cnode

-- Helpers
handleSizeChange
  :: WidgetEnv s e
  -> Path
  -> SystemEvent
  -> WidgetNode s e
  -> Maybe (WidgetResult s e)
  -> Maybe (WidgetResult s e)
handleSizeChange :: forall s e.
WidgetEnv s e
-> Path
-> SystemEvent
-> WidgetNode s e
-> Maybe (WidgetResult s e)
-> Maybe (WidgetResult s e)
handleSizeChange WidgetEnv s e
wenv Path
target SystemEvent
evt WidgetNode s e
oldNode Maybe (WidgetResult s e)
result = Maybe (WidgetResult s e)
newResult where
  baseResult :: WidgetResult s e
baseResult = forall a. a -> Maybe a -> a
fromMaybe (forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
oldNode) Maybe (WidgetResult s e)
result
  newNode :: WidgetNode s e
newNode = WidgetResult s e
baseResult forall s a. s -> Getting a s a -> a
^. forall s a. HasNode s a => Lens' s a
L.node
  widgetId :: WidgetId
widgetId = WidgetNode s e
newNode forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidgetId s a => Lens' s a
L.widgetId
  path :: Path
path = WidgetNode s e
newNode forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasPath s a => Lens' s a
L.path
  -- Size
  oldSizeReqW :: SizeReq
oldSizeReqW = WidgetNode s e
oldNode forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasSizeReqW s a => Lens' s a
L.sizeReqW
  oldSizeReqH :: SizeReq
oldSizeReqH = WidgetNode s e
oldNode forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasSizeReqH s a => Lens' s a
L.sizeReqH
  newSizeReqW :: SizeReq
newSizeReqW = WidgetNode s e
newNode forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasSizeReqW s a => Lens' s a
L.sizeReqW
  newSizeReqH :: SizeReq
newSizeReqH = WidgetNode s e
newNode forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasSizeReqH s a => Lens' s a
L.sizeReqH
  sizeReqChanged :: Bool
sizeReqChanged = SizeReq
oldSizeReqW forall a. Eq a => a -> a -> Bool
/= SizeReq
newSizeReqW Bool -> Bool -> Bool
|| SizeReq
oldSizeReqH forall a. Eq a => a -> a -> Bool
/= SizeReq
newSizeReqH
  -- Hover drag changed (if dragging, Enter/Leave is not sent)
  prevInVp :: Bool
prevInVp = forall s e. WidgetNode s e -> Point -> Bool
isPointInNodeVp WidgetNode s e
newNode (WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasInputStatus s a => Lens' s a
L.inputStatus forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasMousePosPrev s a => Lens' s a
L.mousePosPrev)
  currInVp :: Bool
currInVp = forall s e. WidgetNode s e -> Point -> Bool
isPointInNodeVp WidgetNode s e
newNode (WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasInputStatus s a => Lens' s a
L.inputStatus forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasMousePos s a => Lens' s a
L.mousePos)
  pressedPath :: Maybe Path
pressedPath = WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasMainBtnPress s a => Lens' s a
L.mainBtnPress forall s a. s -> Getting (First a) s a -> Maybe a
^? forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1
  hoverDragChg :: Bool
hoverDragChg = forall a. a -> Maybe a
Just Path
path forall a. Eq a => a -> a -> Bool
== Maybe Path
pressedPath Bool -> Bool -> Bool
&& Bool
prevInVp forall a. Eq a => a -> a -> Bool
/= Bool
currInVp
  -- Result
  renderReq :: Bool
renderReq = SystemEvent -> Bool
isOnEnter SystemEvent
evt Bool -> Bool -> Bool
|| SystemEvent -> Bool
isOnLeave SystemEvent
evt Bool -> Bool -> Bool
|| Bool
hoverDragChg
  resizeReq :: [WidgetRequest s e]
resizeReq = [ forall s e. WidgetId -> WidgetRequest s e
ResizeWidgets WidgetId
widgetId | Bool
sizeReqChanged ]
  enterReq :: [WidgetRequest s e]
enterReq = [ forall s e. WidgetRequest s e
RenderOnce | Bool
renderReq ]
  reqs :: [WidgetRequest s e]
reqs = forall {s} {e}. [WidgetRequest s e]
resizeReq forall a. [a] -> [a] -> [a]
++ forall {s} {e}. [WidgetRequest s e]
enterReq
  newResult :: Maybe (WidgetResult s e)
newResult
    | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall {s} {e}. [WidgetRequest s e]
reqs) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ WidgetResult s e
baseResult
      forall a b. a -> (a -> b) -> b
& forall s a. HasRequests s a => Lens' s a
L.requests forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ forall a. [a] -> Seq a
Seq.fromList forall {s} {e}. [WidgetRequest s e]
reqs
    | Bool
otherwise = Maybe (WidgetResult s e)
result

handleCursorChange
  :: WidgetEnv s e
  -> Path
  -> SystemEvent
  -> StyleState
  -> WidgetNode s e
  -> Maybe (WidgetResult s e)
  -> Maybe (WidgetResult s e)
handleCursorChange :: forall s e.
WidgetEnv s e
-> Path
-> SystemEvent
-> StyleState
-> WidgetNode s e
-> Maybe (WidgetResult s e)
-> Maybe (WidgetResult s e)
handleCursorChange WidgetEnv s e
wenv Path
target SystemEvent
evt StyleState
style WidgetNode s e
oldNode Maybe (WidgetResult s e)
result = Maybe (WidgetResult s e)
newResult where
  baseResult :: WidgetResult s e
baseResult = forall a. a -> Maybe a -> a
fromMaybe (forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
oldNode) Maybe (WidgetResult s e)
result
  baseReqs :: Seq (WidgetRequest s e)
baseReqs = WidgetResult s e
baseResult forall s a. s -> Getting a s a -> a
^. forall s a. HasRequests s a => Lens' s a
L.requests
  node :: WidgetNode s e
node = WidgetResult s e
baseResult forall s a. s -> Getting a s a -> a
^. forall s a. HasNode s a => Lens' s a
L.node
  -- Cursor
  widgetId :: WidgetId
widgetId = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidgetId s a => Lens' s a
L.widgetId
  path :: Path
path = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasPath s a => Lens' s a
L.path
  isTarget :: Bool
isTarget = Path
path forall a. Eq a => a -> a -> Bool
== Path
target
  hasCursor :: Bool
hasCursor = forall a. Maybe a -> Bool
isJust (StyleState
style forall s a. s -> Getting a s a -> a
^. forall s a. HasCursorIcon s a => Lens' s a
L.cursorIcon)
  isPressed :: Bool
isPressed = forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodePressed WidgetEnv s e
wenv WidgetNode s e
node
  (Path
curPath, CursorIcon
curIcon) = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def (WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasCursor s a => Lens' s a
L.cursor)
  isParent :: Bool
isParent = forall a. Eq a => Seq a -> Seq a -> Bool
seqStartsWith Path
path Path
curPath Bool -> Bool -> Bool
&& Path
path forall a. Eq a => a -> a -> Bool
/= Path
curPath
  newIcon :: CursorIcon
newIcon = forall a. a -> Maybe a -> a
fromMaybe CursorIcon
CursorArrow (StyleState
style forall s a. s -> Getting a s a -> a
^. forall s a. HasCursorIcon s a => Lens' s a
L.cursorIcon)

  setCursor :: Bool
setCursor = Bool
hasCursor
    Bool -> Bool -> Bool
&& SystemEvent -> Bool
isCursorEvt SystemEvent
evt
    Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isParent
    Bool -> Bool -> Bool
&& CursorIcon
curIcon forall a. Eq a => a -> a -> Bool
/= CursorIcon
newIcon
  resetCursor :: Bool
resetCursor = Bool
isTarget
    Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
hasCursor
    Bool -> Bool -> Bool
&& SystemEvent -> Bool
isCursorEvt SystemEvent
evt
    Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isPressed
    Bool -> Bool -> Bool
&& Path
curPath forall a. Eq a => a -> a -> Bool
== Path
path
  -- Result
  newResult :: Maybe (WidgetResult s e)
newResult
    | Bool
setCursor = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ WidgetResult s e
baseResult
      forall a b. a -> (a -> b) -> b
& forall s a. HasRequests s a => Lens' s a
L.requests forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall s e. WidgetId -> CursorIcon -> WidgetRequest s e
SetCursorIcon WidgetId
widgetId CursorIcon
newIcon forall a. a -> Seq a -> Seq a
<| Seq (WidgetRequest s e)
baseReqs
    | Bool
resetCursor = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ WidgetResult s e
baseResult
      forall a b. a -> (a -> b) -> b
& forall s a. HasRequests s a => Lens' s a
L.requests forall s t a b. ASetter s t a b -> b -> s -> t
.~ Seq (WidgetRequest s e)
baseReqs forall a. Seq a -> a -> Seq a
|> forall s e. WidgetId -> WidgetRequest s e
ResetCursorIcon WidgetId
widgetId
    | Bool
otherwise = Maybe (WidgetResult s e)
result

isCursorEvt :: SystemEvent -> Bool
isCursorEvt :: SystemEvent -> Bool
isCursorEvt Enter{} = Bool
True
isCursorEvt Click{} = Bool
True
isCursorEvt ButtonAction{} = Bool
True
isCursorEvt Move{} = Bool
True
isCursorEvt SystemEvent
_ = Bool
False