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

Displays a text message above its child node when the pointer is on top and
the delay, if any, has ellapsed.

Tooltip styling is a bit unusual, since it only applies to the overlaid element.
This means, padding will not be shown for the contained child element, but only
on the message when the tooltip is active. If you need padding around the child
element, you may want to use a box.
-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StrictData #-}

module Monomer.Widgets.Containers.Tooltip (
  -- * Configuration
  TooltipCfg,
  tooltipDelay,
  tooltipFollow,
  -- * Constructors
  tooltip,
  tooltip_
) where

import Control.Applicative ((<|>))
import Control.Lens ((&), (^.), (.~), (%~), at)
import Control.Monad (forM_, when)
import Data.Default
import Data.Maybe
import Data.Text (Text)
import GHC.Generics

import qualified Data.Sequence as Seq

import Monomer.Widgets.Container

import qualified Monomer.Lens as L

{-|
Configuration options for tooltip:

- 'width': the maximum width of the tooltip. Used for multiline.
- 'height': the maximum height of the tooltip. Used for multiline.
- 'tooltipDelay': the delay in ms before the tooltip is displayed.
- 'tooltipFollow': if, after tooltip is displayed, it should follow the mouse.
-}
data TooltipCfg = TooltipCfg {
  TooltipCfg -> Maybe Int
_ttcDelay :: Maybe Int,
  TooltipCfg -> Maybe Bool
_ttcFollowCursor :: Maybe Bool,
  TooltipCfg -> Maybe Double
_ttcMaxWidth :: Maybe Double,
  TooltipCfg -> Maybe Double
_ttcMaxHeight :: Maybe Double
}

instance Default TooltipCfg where
  def :: TooltipCfg
def = TooltipCfg :: Maybe Int
-> Maybe Bool -> Maybe Double -> Maybe Double -> TooltipCfg
TooltipCfg {
    _ttcDelay :: Maybe Int
_ttcDelay = Maybe Int
forall a. Maybe a
Nothing,
    _ttcFollowCursor :: Maybe Bool
_ttcFollowCursor = Maybe Bool
forall a. Maybe a
Nothing,
    _ttcMaxWidth :: Maybe Double
_ttcMaxWidth = Maybe Double
forall a. Maybe a
Nothing,
    _ttcMaxHeight :: Maybe Double
_ttcMaxHeight = Maybe Double
forall a. Maybe a
Nothing
  }

instance Semigroup TooltipCfg where
  <> :: TooltipCfg -> TooltipCfg -> TooltipCfg
(<>) TooltipCfg
s1 TooltipCfg
s2 = TooltipCfg :: Maybe Int
-> Maybe Bool -> Maybe Double -> Maybe Double -> TooltipCfg
TooltipCfg {
    _ttcDelay :: Maybe Int
_ttcDelay = TooltipCfg -> Maybe Int
_ttcDelay TooltipCfg
s2 Maybe Int -> Maybe Int -> Maybe Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TooltipCfg -> Maybe Int
_ttcDelay TooltipCfg
s1,
    _ttcFollowCursor :: Maybe Bool
_ttcFollowCursor = TooltipCfg -> Maybe Bool
_ttcFollowCursor TooltipCfg
s2 Maybe Bool -> Maybe Bool -> Maybe Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TooltipCfg -> Maybe Bool
_ttcFollowCursor TooltipCfg
s1,
    _ttcMaxWidth :: Maybe Double
_ttcMaxWidth = TooltipCfg -> Maybe Double
_ttcMaxWidth TooltipCfg
s2 Maybe Double -> Maybe Double -> Maybe Double
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TooltipCfg -> Maybe Double
_ttcMaxWidth TooltipCfg
s1,
    _ttcMaxHeight :: Maybe Double
_ttcMaxHeight = TooltipCfg -> Maybe Double
_ttcMaxHeight TooltipCfg
s2 Maybe Double -> Maybe Double -> Maybe Double
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TooltipCfg -> Maybe Double
_ttcMaxHeight TooltipCfg
s1
  }

instance Monoid TooltipCfg where
  mempty :: TooltipCfg
mempty = TooltipCfg
forall a. Default a => a
def

instance CmbMaxWidth TooltipCfg where
  maxWidth :: Double -> TooltipCfg
maxWidth Double
w = TooltipCfg
forall a. Default a => a
def {
    _ttcMaxWidth :: Maybe Double
_ttcMaxWidth = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
w
  }

instance CmbMaxHeight TooltipCfg where
  maxHeight :: Double -> TooltipCfg
maxHeight Double
h = TooltipCfg
forall a. Default a => a
def {
    _ttcMaxHeight :: Maybe Double
_ttcMaxHeight = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
h
  }

-- | Delay before the tooltip is displayed when child widget is hovered.
tooltipDelay :: Int -> TooltipCfg
tooltipDelay :: Int -> TooltipCfg
tooltipDelay Int
ms = TooltipCfg
forall a. Default a => a
def {
  _ttcDelay :: Maybe Int
_ttcDelay = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
ms
}

-- | Whether the tooltip should move with the mouse after being displayed.
tooltipFollow :: TooltipCfg
tooltipFollow :: TooltipCfg
tooltipFollow = TooltipCfg
forall a. Default a => a
def {
  _ttcFollowCursor :: Maybe Bool
_ttcFollowCursor = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
}

data TooltipState = TooltipState {
  TooltipState -> Point
_ttsLastPos :: Point,
  TooltipState -> Int
_ttsLastPosTs :: Int
} deriving (TooltipState -> TooltipState -> Bool
(TooltipState -> TooltipState -> Bool)
-> (TooltipState -> TooltipState -> Bool) -> Eq TooltipState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TooltipState -> TooltipState -> Bool
$c/= :: TooltipState -> TooltipState -> Bool
== :: TooltipState -> TooltipState -> Bool
$c== :: TooltipState -> TooltipState -> Bool
Eq, Int -> TooltipState -> ShowS
[TooltipState] -> ShowS
TooltipState -> String
(Int -> TooltipState -> ShowS)
-> (TooltipState -> String)
-> ([TooltipState] -> ShowS)
-> Show TooltipState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TooltipState] -> ShowS
$cshowList :: [TooltipState] -> ShowS
show :: TooltipState -> String
$cshow :: TooltipState -> String
showsPrec :: Int -> TooltipState -> ShowS
$cshowsPrec :: Int -> TooltipState -> ShowS
Show, (forall x. TooltipState -> Rep TooltipState x)
-> (forall x. Rep TooltipState x -> TooltipState)
-> Generic TooltipState
forall x. Rep TooltipState x -> TooltipState
forall x. TooltipState -> Rep TooltipState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TooltipState x -> TooltipState
$cfrom :: forall x. TooltipState -> Rep TooltipState x
Generic)

-- | Creates a tooltip for the child widget.
tooltip :: Text -> WidgetNode s e -> WidgetNode s e
tooltip :: Text -> WidgetNode s e -> WidgetNode s e
tooltip Text
caption WidgetNode s e
managed = Text -> [TooltipCfg] -> WidgetNode s e -> WidgetNode s e
forall s e.
Text -> [TooltipCfg] -> WidgetNode s e -> WidgetNode s e
tooltip_ Text
caption [TooltipCfg]
forall a. Default a => a
def WidgetNode s e
managed

-- | Creates a tooltip for the child widget. Accepts config.
tooltip_ :: Text -> [TooltipCfg] -> WidgetNode s e -> WidgetNode s e
tooltip_ :: Text -> [TooltipCfg] -> WidgetNode s e -> WidgetNode s e
tooltip_ Text
caption [TooltipCfg]
configs WidgetNode s e
managed = Widget s e -> WidgetNode s e -> WidgetNode s e
forall s e. Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode Widget s e
forall s e. Widget s e
widget WidgetNode s e
managed where
  config :: TooltipCfg
config = [TooltipCfg] -> TooltipCfg
forall a. Monoid a => [a] -> a
mconcat [TooltipCfg]
configs
  state :: TooltipState
state = Point -> Int -> TooltipState
TooltipState Point
forall a. Default a => a
def Int
forall a. Bounded a => a
maxBound
  widget :: Widget s e
widget = Text -> TooltipCfg -> TooltipState -> Widget s e
forall s e. Text -> TooltipCfg -> TooltipState -> Widget s e
makeTooltip Text
caption TooltipCfg
config TooltipState
state

makeNode :: Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode :: Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode Widget s e
widget WidgetNode s e
managedWidget = WidgetType -> Widget s e -> WidgetNode s e
forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"tooltip" Widget s e
widget
  WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (WidgetNodeInfo -> Identity WidgetNodeInfo)
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Identity WidgetNodeInfo)
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> ((Bool -> Identity Bool)
    -> WidgetNodeInfo -> Identity WidgetNodeInfo)
-> (Bool -> Identity Bool)
-> WidgetNode s e
-> Identity (WidgetNode s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> WidgetNodeInfo -> Identity WidgetNodeInfo
forall s a. HasFocusable s a => Lens' s a
L.focusable ((Bool -> Identity Bool)
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Bool -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False
  WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Seq (WidgetNode s e) -> Identity (Seq (WidgetNode s e)))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasChildren s a => Lens' s a
L.children ((Seq (WidgetNode s e) -> Identity (Seq (WidgetNode s e)))
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Seq (WidgetNode s e) -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ WidgetNode s e -> Seq (WidgetNode s e)
forall a. a -> Seq a
Seq.singleton WidgetNode s e
managedWidget

makeTooltip :: Text -> TooltipCfg -> TooltipState -> Widget s e
makeTooltip :: Text -> TooltipCfg -> TooltipState -> Widget s e
makeTooltip Text
caption TooltipCfg
config TooltipState
state = Widget s e
forall s e. Widget s e
widget where
  baseWidget :: Widget s e
baseWidget = TooltipState -> Container s e TooltipState -> Widget s e
forall a s e. WidgetModel a => a -> Container s e a -> Widget s e
createContainer TooltipState
state Container s e TooltipState
forall a. Default a => a
def {
    containerAddStyleReq :: Bool
containerAddStyleReq = Bool
False,
    containerGetBaseStyle :: ContainerGetBaseStyle s e
containerGetBaseStyle = ContainerGetBaseStyle s e
forall s e p. WidgetEnv s e -> p -> Maybe Style
getBaseStyle,
    containerMerge :: ContainerMergeHandler s e TooltipState
containerMerge = ContainerMergeHandler s e TooltipState
forall p s e p.
p -> WidgetNode s e -> p -> TooltipState -> WidgetResult s e
merge,
    containerHandleEvent :: ContainerEventHandler s e
containerHandleEvent = ContainerEventHandler s e
forall s s e p.
HasTimestamp s Int =>
s -> WidgetNode s e -> p -> SystemEvent -> Maybe (WidgetResult s e)
handleEvent,
    containerResize :: ContainerResizeHandler s e
containerResize = ContainerResizeHandler s e
forall p s e a p.
p -> WidgetNode s e -> a -> p -> (WidgetResult s e, Seq a)
resize
  }
  widget :: Widget s e
widget = Widget s e
forall s e. Widget s e
baseWidget {
    widgetRender :: WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
widgetRender = WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
forall s e. WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render
  }

  delay :: Int
delay = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1000 (TooltipCfg -> Maybe Int
_ttcDelay TooltipCfg
config)
  followCursor :: Bool
followCursor = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (TooltipCfg -> Maybe Bool
_ttcFollowCursor TooltipCfg
config)

  getBaseStyle :: WidgetEnv s e -> p -> Maybe Style
getBaseStyle WidgetEnv s e
wenv p
node = Style -> Maybe Style
forall a. a -> Maybe a
Just Style
style where
    style :: Style
style = WidgetEnv s e -> Lens' ThemeState StyleState -> Style
forall s e. WidgetEnv s e -> Lens' ThemeState StyleState -> Style
collectTheme WidgetEnv s e
wenv forall s a. HasTooltipStyle s a => Lens' s a
Lens' ThemeState StyleState
L.tooltipStyle

  merge :: p -> WidgetNode s e -> p -> TooltipState -> WidgetResult s e
merge p
wenv WidgetNode s e
node p
oldNode TooltipState
oldState = WidgetResult s e
result where
    newNode :: WidgetNode s e
newNode = WidgetNode s e
node
      WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasWidget s a => Lens' s a
L.widget ((Widget s e -> Identity (Widget s e))
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Widget s e -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text -> TooltipCfg -> TooltipState -> Widget s e
forall s e. Text -> TooltipCfg -> TooltipState -> Widget s e
makeTooltip Text
caption TooltipCfg
config TooltipState
oldState
    result :: WidgetResult s e
result = WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
newNode

  handleEvent :: s -> WidgetNode s e -> p -> SystemEvent -> Maybe (WidgetResult s e)
handleEvent s
wenv WidgetNode s e
node p
target SystemEvent
evt = case SystemEvent
evt of
    Leave Point
point -> WidgetResult s e -> Maybe (WidgetResult s e)
forall a. a -> Maybe a
Just (WidgetResult s e -> Maybe (WidgetResult s e))
-> WidgetResult s e -> Maybe (WidgetResult s e)
forall a b. (a -> b) -> a -> b
$ WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
newNode [WidgetRequest s e
forall s e. WidgetRequest s e
RenderOnce] where
      newState :: TooltipState
newState = TooltipState
state {
        _ttsLastPos :: Point
_ttsLastPos = Double -> Double -> Point
Point (-Double
1) (-Double
1),
        _ttsLastPosTs :: Int
_ttsLastPosTs = Int
forall a. Bounded a => a
maxBound
      }
      newNode :: WidgetNode s e
newNode = WidgetNode s e
node
        WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasWidget s a => Lens' s a
L.widget ((Widget s e -> Identity (Widget s e))
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Widget s e -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text -> TooltipCfg -> TooltipState -> Widget s e
forall s e. Text -> TooltipCfg -> TooltipState -> Widget s e
makeTooltip Text
caption TooltipCfg
config TooltipState
newState

    Move Point
point
      | WidgetNode s e -> Point -> Bool
forall s e. WidgetNode s e -> Point -> Bool
isPointInNodeVp WidgetNode s e
node Point
point -> WidgetResult s e -> Maybe (WidgetResult s e)
forall a. a -> Maybe a
Just WidgetResult s e
result where
        widgetId :: WidgetId
widgetId = WidgetNode s e
node WidgetNode s e
-> Getting WidgetId (WidgetNode s e) WidgetId -> WidgetId
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> WidgetNode s e -> Const WidgetId (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
 -> WidgetNode s e -> Const WidgetId (WidgetNode s e))
-> ((WidgetId -> Const WidgetId WidgetId)
    -> WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> Getting WidgetId (WidgetNode s e) WidgetId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetId -> Const WidgetId WidgetId)
-> WidgetNodeInfo -> Const WidgetId WidgetNodeInfo
forall s a. HasWidgetId s a => Lens' s a
L.widgetId
        prevDisplayed :: Bool
prevDisplayed = s -> WidgetNode s e -> Bool
forall s a s.
(HasInfo s a, HasViewport a Rect, HasTimestamp s Int) =>
s -> s -> Bool
tooltipDisplayed s
wenv WidgetNode s e
node
        newState :: TooltipState
newState = TooltipState
state {
          _ttsLastPos :: Point
_ttsLastPos = Point
point,
          _ttsLastPosTs :: Int
_ttsLastPosTs = s
wenv s -> Getting Int s Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int s Int
forall s a. HasTimestamp s a => Lens' s a
L.timestamp
        }
        newNode :: WidgetNode s e
newNode = WidgetNode s e
node
          WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasWidget s a => Lens' s a
L.widget ((Widget s e -> Identity (Widget s e))
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Widget s e -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text -> TooltipCfg -> TooltipState -> Widget s e
forall s e. Text -> TooltipCfg -> TooltipState -> Widget s e
makeTooltip Text
caption TooltipCfg
config TooltipState
newState
        delayedRender :: WidgetRequest s e
delayedRender = WidgetId -> Int -> Maybe Int -> WidgetRequest s e
forall s e. WidgetId -> Int -> Maybe Int -> WidgetRequest s e
RenderEvery WidgetId
widgetId Int
delay (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1)
        result :: WidgetResult s e
result
          | Bool -> Bool
not Bool
prevDisplayed = WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
newNode [WidgetRequest s e
forall s e. WidgetRequest s e
delayedRender]
          | Bool
prevDisplayed Bool -> Bool -> Bool
&& Bool
followCursor = WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
node [WidgetRequest s e
forall s e. WidgetRequest s e
RenderOnce]
          | Bool
otherwise = WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
node

    SystemEvent
_ -> Maybe (WidgetResult s e)
forall a. Maybe a
Nothing

  -- Padding/border is not removed. Styles are only considerer for the overlay
  resize :: p -> WidgetNode s e -> a -> p -> (WidgetResult s e, Seq a)
resize p
wenv WidgetNode s e
node a
viewport p
children = (WidgetResult s e, Seq a)
resized where
    resized :: (WidgetResult s e, Seq a)
resized = (WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
node, a -> Seq a
forall a. a -> Seq a
Seq.singleton a
viewport)

  render :: WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render WidgetEnv s e
wenv WidgetNode s e
node Renderer
renderer = do
    Seq (WidgetNode s e) -> (WidgetNode s e -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Seq (WidgetNode s e)
children ((WidgetNode s e -> IO ()) -> IO ())
-> (WidgetNode s e -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WidgetNode s e
child ->
      Widget s e -> WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
forall s e.
Widget s e -> WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
widgetRender (WidgetNode s e
child WidgetNode s e
-> Getting (Widget s e) (WidgetNode s e) (Widget s e) -> Widget s e
forall s a. s -> Getting a s a -> a
^. Getting (Widget s e) (WidgetNode s e) (Widget s e)
forall s a. HasWidget s a => Lens' s a
L.widget) WidgetEnv s e
wenv WidgetNode s e
child Renderer
renderer

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tooltipVisible (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Renderer -> IO () -> IO ()
createOverlay Renderer
renderer (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Renderer -> Rect -> StyleState -> (Rect -> IO ()) -> IO ()
drawStyledAction Renderer
renderer Rect
rect StyleState
style ((Rect -> IO ()) -> IO ()) -> (Rect -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Rect
textRect -> do
          let textLines :: Seq TextLine
textLines = StyleState -> Rect -> Seq TextLine -> Seq TextLine
alignTextLines StyleState
style Rect
textRect Seq TextLine
fittedLines
          Seq TextLine -> (TextLine -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Seq TextLine
textLines (Renderer -> StyleState -> TextLine -> IO ()
drawTextLine Renderer
renderer StyleState
style)
    where
      fontMgr :: FontManager
fontMgr = WidgetEnv s e
wenv WidgetEnv s e
-> Getting FontManager (WidgetEnv s e) FontManager -> FontManager
forall s a. s -> Getting a s a -> a
^. Getting FontManager (WidgetEnv s e) FontManager
forall s a. HasFontManager s a => Lens' s a
L.fontManager
      style :: StyleState
style = WidgetEnv s e -> WidgetNode s e -> StyleState
forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle WidgetEnv s e
wenv WidgetNode s e
node
      children :: Seq (WidgetNode s e)
children = WidgetNode s e
node WidgetNode s e
-> Getting
     (Seq (WidgetNode s e)) (WidgetNode s e) (Seq (WidgetNode s e))
-> Seq (WidgetNode s e)
forall s a. s -> Getting a s a -> a
^. Getting
  (Seq (WidgetNode s e)) (WidgetNode s e) (Seq (WidgetNode s e))
forall s a. HasChildren s a => Lens' s a
L.children
      mousePos :: Point
mousePos = WidgetEnv s e
wenv WidgetEnv s e -> Getting Point (WidgetEnv s e) Point -> Point
forall s a. s -> Getting a s a -> a
^. (InputStatus -> Const Point InputStatus)
-> WidgetEnv s e -> Const Point (WidgetEnv s e)
forall s a. HasInputStatus s a => Lens' s a
L.inputStatus ((InputStatus -> Const Point InputStatus)
 -> WidgetEnv s e -> Const Point (WidgetEnv s e))
-> ((Point -> Const Point Point)
    -> InputStatus -> Const Point InputStatus)
-> Getting Point (WidgetEnv s e) Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point -> Const Point Point)
-> InputStatus -> Const Point InputStatus
forall s a. HasMousePos s a => Lens' s a
L.mousePos

      scOffset :: Point
scOffset = WidgetEnv s e
wenv WidgetEnv s e -> Getting Point (WidgetEnv s e) Point -> Point
forall s a. s -> Getting a s a -> a
^. Getting Point (WidgetEnv s e) Point
forall s a. HasOffset s a => Lens' s a
L.offset
      isDragging :: Bool
isDragging = Maybe (Path, WidgetDragMsg) -> Bool
forall a. Maybe a -> Bool
isJust (WidgetEnv s e
wenv WidgetEnv s e
-> Getting
     (Maybe (Path, WidgetDragMsg))
     (WidgetEnv s e)
     (Maybe (Path, WidgetDragMsg))
-> Maybe (Path, WidgetDragMsg)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (Path, WidgetDragMsg))
  (WidgetEnv s e)
  (Maybe (Path, WidgetDragMsg))
forall s a. HasDragStatus s a => Lens' s a
L.dragStatus)
      maxW :: Double
maxW = WidgetEnv s e
wenv WidgetEnv s e -> Getting Double (WidgetEnv s e) Double -> Double
forall s a. s -> Getting a s a -> a
^. (Size -> Const Double Size)
-> WidgetEnv s e -> Const Double (WidgetEnv s e)
forall s a. HasWindowSize s a => Lens' s a
L.windowSize ((Size -> Const Double Size)
 -> WidgetEnv s e -> Const Double (WidgetEnv s e))
-> ((Double -> Const Double Double) -> Size -> Const Double Size)
-> Getting Double (WidgetEnv s e) Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Const Double Double) -> Size -> Const Double Size
forall s a. HasW s a => Lens' s a
L.w
      maxH :: Double
maxH = WidgetEnv s e
wenv WidgetEnv s e -> Getting Double (WidgetEnv s e) Double -> Double
forall s a. s -> Getting a s a -> a
^. (Size -> Const Double Size)
-> WidgetEnv s e -> Const Double (WidgetEnv s e)
forall s a. HasWindowSize s a => Lens' s a
L.windowSize ((Size -> Const Double Size)
 -> WidgetEnv s e -> Const Double (WidgetEnv s e))
-> ((Double -> Const Double Double) -> Size -> Const Double Size)
-> Getting Double (WidgetEnv s e) Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Const Double Double) -> Size -> Const Double Size
forall s a. HasH s a => Lens' s a
L.h

      targetW :: Double
targetW = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
maxW (TooltipCfg -> Maybe Double
_ttcMaxWidth TooltipCfg
config)
      targetH :: Double
targetH = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
maxH (TooltipCfg -> Maybe Double
_ttcMaxHeight TooltipCfg
config)
      targetSize :: Size
targetSize = Double -> Double -> Size
Size Double
targetW Double
targetH
      fittedLines :: Seq TextLine
fittedLines = FontManager
-> StyleState
-> TextOverflow
-> TextMode
-> TextTrim
-> Maybe Int
-> Size
-> Text
-> Seq TextLine
fitTextToSize FontManager
fontMgr StyleState
style TextOverflow
Ellipsis TextMode
MultiLine TextTrim
TrimSpaces
        Maybe Int
forall a. Maybe a
Nothing Size
targetSize Text
caption
      textSize :: Size
textSize = Seq TextLine -> Size
getTextLinesSize Seq TextLine
fittedLines

      Size Double
tw Double
th = Size -> Maybe Size -> Size
forall a. a -> Maybe a -> a
fromMaybe Size
forall a. Default a => a
def (StyleState -> Size -> Maybe Size
addOuterSize StyleState
style Size
textSize)
      TooltipState Point
lastPos Int
_ = TooltipState
state
      Point Double
mx Double
my
        | Bool
followCursor = Point -> Point -> Point
addPoint Point
scOffset Point
mousePos
        | Bool
otherwise = Point -> Point -> Point
addPoint Point
scOffset Point
lastPos
      rx :: Double
rx
        | WidgetEnv s e
wenv WidgetEnv s e -> Getting Double (WidgetEnv s e) Double -> Double
forall s a. s -> Getting a s a -> a
^. (Size -> Const Double Size)
-> WidgetEnv s e -> Const Double (WidgetEnv s e)
forall s a. HasWindowSize s a => Lens' s a
L.windowSize ((Size -> Const Double Size)
 -> WidgetEnv s e -> Const Double (WidgetEnv s e))
-> ((Double -> Const Double Double) -> Size -> Const Double Size)
-> Getting Double (WidgetEnv s e) Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Const Double Double) -> Size -> Const Double Size
forall s a. HasW s a => Lens' s a
L.w Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
mx Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
tw = Double
mx
        | Bool
otherwise = WidgetEnv s e
wenv WidgetEnv s e -> Getting Double (WidgetEnv s e) Double -> Double
forall s a. s -> Getting a s a -> a
^. (Size -> Const Double Size)
-> WidgetEnv s e -> Const Double (WidgetEnv s e)
forall s a. HasWindowSize s a => Lens' s a
L.windowSize ((Size -> Const Double Size)
 -> WidgetEnv s e -> Const Double (WidgetEnv s e))
-> ((Double -> Const Double Double) -> Size -> Const Double Size)
-> Getting Double (WidgetEnv s e) Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Const Double Double) -> Size -> Const Double Size
forall s a. HasW s a => Lens' s a
L.w Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
tw
      -- Add offset to have space between the tooltip and the cursor
      ry :: Double
ry
        | WidgetEnv s e
wenv WidgetEnv s e -> Getting Double (WidgetEnv s e) Double -> Double
forall s a. s -> Getting a s a -> a
^. (Size -> Const Double Size)
-> WidgetEnv s e -> Const Double (WidgetEnv s e)
forall s a. HasWindowSize s a => Lens' s a
L.windowSize ((Size -> Const Double Size)
 -> WidgetEnv s e -> Const Double (WidgetEnv s e))
-> ((Double -> Const Double Double) -> Size -> Const Double Size)
-> Getting Double (WidgetEnv s e) Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Const Double Double) -> Size -> Const Double Size
forall s a. HasH s a => Lens' s a
L.h Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
my Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
50) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
th = Double
my Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
20
        | Bool
otherwise = Double
my Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
th Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
5
      rect :: Rect
rect = Double -> Double -> Double -> Double -> Rect
Rect Double
rx Double
ry Double
tw Double
th
      tooltipVisible :: Bool
tooltipVisible = WidgetEnv s e -> WidgetNode s e -> Bool
forall s a s.
(HasInfo s a, HasViewport a Rect, HasTimestamp s Int) =>
s -> s -> Bool
tooltipDisplayed WidgetEnv s e
wenv WidgetNode s e
node Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isDragging

  tooltipDisplayed :: s -> s -> Bool
tooltipDisplayed s
wenv s
node = Bool
displayed where
    TooltipState Point
lastPos Int
lastPosTs = TooltipState
state
    ts :: Int
ts = s
wenv s -> Getting Int s Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int s Int
forall s a. HasTimestamp s a => Lens' s a
L.timestamp
    viewport :: Rect
viewport = s
node s -> Getting Rect s Rect -> Rect
forall s a. s -> Getting a s a -> a
^. (a -> Const Rect a) -> s -> Const Rect s
forall s a. HasInfo s a => Lens' s a
L.info ((a -> Const Rect a) -> s -> Const Rect s)
-> ((Rect -> Const Rect Rect) -> a -> Const Rect a)
-> Getting Rect s Rect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rect -> Const Rect Rect) -> a -> Const Rect a
forall s a. HasViewport s a => Lens' s a
L.viewport
    inViewport :: Bool
inViewport = Point -> Rect -> Bool
pointInRect Point
lastPos Rect
viewport
    delayEllapsed :: Bool
delayEllapsed = Int
ts Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lastPosTs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
delay
    displayed :: Bool
displayed = Bool
inViewport Bool -> Bool -> Bool
&& Bool
delayEllapsed