{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StrictData #-}
module Monomer.Widgets.Containers.Tooltip (
TooltipCfg,
tooltipDelay,
tooltipFollow,
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
data TooltipCfg = TooltipCfg {
TooltipCfg -> Maybe Millisecond
_ttcDelay :: Maybe Millisecond,
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 {
_ttcDelay :: Maybe Millisecond
_ttcDelay = forall a. Maybe a
Nothing,
_ttcFollowCursor :: Maybe Bool
_ttcFollowCursor = forall a. Maybe a
Nothing,
_ttcMaxWidth :: Maybe Double
_ttcMaxWidth = forall a. Maybe a
Nothing,
_ttcMaxHeight :: Maybe Double
_ttcMaxHeight = forall a. Maybe a
Nothing
}
instance Semigroup TooltipCfg where
<> :: TooltipCfg -> TooltipCfg -> TooltipCfg
(<>) TooltipCfg
s1 TooltipCfg
s2 = TooltipCfg {
_ttcDelay :: Maybe Millisecond
_ttcDelay = TooltipCfg -> Maybe Millisecond
_ttcDelay TooltipCfg
s2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TooltipCfg -> Maybe Millisecond
_ttcDelay TooltipCfg
s1,
_ttcFollowCursor :: Maybe Bool
_ttcFollowCursor = TooltipCfg -> Maybe Bool
_ttcFollowCursor TooltipCfg
s2 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 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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TooltipCfg -> Maybe Double
_ttcMaxHeight TooltipCfg
s1
}
instance Monoid TooltipCfg where
mempty :: TooltipCfg
mempty = forall a. Default a => a
def
instance CmbMaxWidth TooltipCfg where
maxWidth :: Double -> TooltipCfg
maxWidth Double
w = forall a. Default a => a
def {
_ttcMaxWidth :: Maybe Double
_ttcMaxWidth = forall a. a -> Maybe a
Just Double
w
}
instance CmbMaxHeight TooltipCfg where
maxHeight :: Double -> TooltipCfg
maxHeight Double
h = forall a. Default a => a
def {
_ttcMaxHeight :: Maybe Double
_ttcMaxHeight = forall a. a -> Maybe a
Just Double
h
}
tooltipDelay :: Millisecond -> TooltipCfg
tooltipDelay :: Millisecond -> TooltipCfg
tooltipDelay Millisecond
ms = forall a. Default a => a
def {
_ttcDelay :: Maybe Millisecond
_ttcDelay = forall a. a -> Maybe a
Just Millisecond
ms
}
tooltipFollow :: TooltipCfg
tooltipFollow :: TooltipCfg
tooltipFollow = forall a. Default a => a
def {
_ttcFollowCursor :: Maybe Bool
_ttcFollowCursor = forall a. a -> Maybe a
Just Bool
True
}
data TooltipState = TooltipState {
TooltipState -> Point
_ttsLastPos :: Point,
TooltipState -> Millisecond
_ttsLastPosTs :: Millisecond
} deriving (TooltipState -> TooltipState -> Bool
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
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. 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)
tooltip :: Text -> WidgetNode s e -> WidgetNode s e
tooltip :: forall s e. Text -> WidgetNode s e -> WidgetNode s e
tooltip Text
caption WidgetNode s e
managed = forall s e.
Text -> [TooltipCfg] -> WidgetNode s e -> WidgetNode s e
tooltip_ Text
caption forall a. Default a => a
def WidgetNode s e
managed
tooltip_ :: Text -> [TooltipCfg] -> WidgetNode s e -> WidgetNode s e
tooltip_ :: forall s e.
Text -> [TooltipCfg] -> WidgetNode s e -> WidgetNode s e
tooltip_ Text
caption [TooltipCfg]
configs WidgetNode s e
managed = forall s e. Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode forall {s} {e}. Widget s e
widget WidgetNode s e
managed where
config :: TooltipCfg
config = forall a. Monoid a => [a] -> a
mconcat [TooltipCfg]
configs
state :: TooltipState
state = Point -> Millisecond -> TooltipState
TooltipState forall a. Default a => a
def forall a. Bounded a => a
maxBound
widget :: Widget s e
widget = 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 :: forall s e. Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode Widget s e
widget WidgetNode s e
managedWidget = forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"tooltip" Widget s e
widget
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. HasFocusable s a => Lens' s a
L.focusable forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False
forall a b. a -> (a -> b) -> b
& forall s a. HasChildren s a => Lens' s a
L.children forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Seq a
Seq.singleton WidgetNode s e
managedWidget
makeTooltip :: Text -> TooltipCfg -> TooltipState -> Widget s e
makeTooltip :: forall s e. Text -> TooltipCfg -> TooltipState -> Widget s e
makeTooltip Text
caption TooltipCfg
config TooltipState
state = forall {s} {e}. Widget s e
widget where
baseWidget :: Widget s e
baseWidget = forall a s e. WidgetModel a => a -> Container s e a -> Widget s e
createContainer TooltipState
state forall a. Default a => a
def {
containerAddStyleReq :: Bool
containerAddStyleReq = Bool
False,
containerGetBaseStyle :: ContainerGetBaseStyle s e
containerGetBaseStyle = forall {s} {e} {p}. WidgetEnv s e -> p -> Maybe Style
getBaseStyle,
containerMerge :: ContainerMergeHandler s e TooltipState
containerMerge = forall {p} {s} {e} {p}.
p -> WidgetNode s e -> p -> TooltipState -> WidgetResult s e
merge,
containerHandleEvent :: ContainerEventHandler s e
containerHandleEvent = forall {p} {s} {e} {p}.
HasTimestamp p Millisecond =>
p -> WidgetNode s e -> p -> SystemEvent -> Maybe (WidgetResult s e)
handleEvent,
containerResize :: ContainerResizeHandler s e
containerResize = forall {p} {s} {e} {p} {p}.
p -> WidgetNode s e -> p -> p -> (WidgetResult s e, Seq p)
resize
}
widget :: Widget s e
widget = forall {s} {e}. Widget s e
baseWidget {
widgetRender :: WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
widgetRender = forall {s} {e}.
WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render
}
delay :: Millisecond
delay = forall a. a -> Maybe a -> a
fromMaybe Millisecond
1000 (TooltipCfg -> Maybe Millisecond
_ttcDelay TooltipCfg
config)
followCursor :: Bool
followCursor = 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 = forall a. a -> Maybe a
Just Style
style where
style :: Style
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
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
forall a b. a -> (a -> b) -> b
& forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall s e. Text -> TooltipCfg -> TooltipState -> Widget s e
makeTooltip Text
caption TooltipCfg
config TooltipState
oldState
result :: WidgetResult s e
result = forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
newNode
handleEvent :: p -> WidgetNode s e -> p -> SystemEvent -> Maybe (WidgetResult s e)
handleEvent p
wenv WidgetNode s e
node p
target SystemEvent
evt = case SystemEvent
evt of
ButtonAction{} -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
newNode [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 :: Millisecond
_ttsLastPosTs = forall a. Bounded a => a
maxBound
}
newNode :: WidgetNode s e
newNode = WidgetNode s e
node
forall a b. a -> (a -> b) -> b
& forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall s e. Text -> TooltipCfg -> TooltipState -> Widget s e
makeTooltip Text
caption TooltipCfg
config TooltipState
newState
Leave Point
point -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
newNode [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 :: Millisecond
_ttsLastPosTs = forall a. Bounded a => a
maxBound
}
newNode :: WidgetNode s e
newNode = WidgetNode s e
node
forall a b. a -> (a -> b) -> b
& forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall s e. Text -> TooltipCfg -> TooltipState -> Widget s e
makeTooltip Text
caption TooltipCfg
config TooltipState
newState
Move Point
point
| forall s e. WidgetNode s e -> Point -> Bool
isPointInNodeVp WidgetNode s e
node Point
point -> forall a. a -> Maybe a
Just WidgetResult s e
result where
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
prevDisplayed :: Bool
prevDisplayed = forall {p} {a} {p}.
(HasInfo p a, HasViewport a Rect, HasTimestamp p Millisecond) =>
p -> p -> Bool
tooltipDisplayed p
wenv WidgetNode s e
node
newState :: TooltipState
newState = TooltipState
state {
_ttsLastPos :: Point
_ttsLastPos = Point
point,
_ttsLastPosTs :: Millisecond
_ttsLastPosTs = p
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasTimestamp s a => Lens' s a
L.timestamp
}
newNode :: WidgetNode s e
newNode = WidgetNode s e
node
forall a b. a -> (a -> b) -> b
& forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall s e. Text -> TooltipCfg -> TooltipState -> Widget s e
makeTooltip Text
caption TooltipCfg
config TooltipState
newState
delayedRender :: WidgetRequest s e
delayedRender = forall s e.
WidgetId -> Millisecond -> Maybe Int -> WidgetRequest s e
RenderEvery WidgetId
widgetId Millisecond
delay (forall a. a -> Maybe a
Just Int
1)
result :: WidgetResult s e
result
| Bool -> Bool
not Bool
prevDisplayed = forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
newNode [forall s e. WidgetRequest s e
delayedRender]
| Bool
prevDisplayed Bool -> Bool -> Bool
&& Bool
followCursor = forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
node [forall s e. WidgetRequest s e
RenderOnce]
| Bool
otherwise = forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
node
SystemEvent
_ -> forall a. Maybe a
Nothing
resize :: p -> WidgetNode s e -> p -> p -> (WidgetResult s e, Seq p)
resize p
wenv WidgetNode s e
node p
viewport p
children = (WidgetResult s e, Seq p)
resized where
resized :: (WidgetResult s e, Seq p)
resized = (forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
node, forall a. a -> Seq a
Seq.singleton p
viewport)
render :: WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render WidgetEnv s e
wenv WidgetNode s e
node Renderer
renderer = do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Seq (WidgetNode s e)
children forall a b. (a -> b) -> a -> b
$ \WidgetNode s e
child ->
forall s e.
Widget s e -> WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
widgetRender (WidgetNode s e
child forall s a. s -> Getting a s a -> a
^. forall s a. HasWidget s a => Lens' s a
L.widget) WidgetEnv s e
wenv WidgetNode s e
child Renderer
renderer
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tooltipVisible forall a b. (a -> b) -> a -> b
$
Renderer -> IO () -> IO ()
createOverlay Renderer
renderer forall a b. (a -> b) -> a -> b
$ do
Renderer -> Rect -> StyleState -> (Rect -> IO ()) -> IO ()
drawStyledAction Renderer
renderer Rect
rect StyleState
style 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
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 forall s a. s -> Getting a s a -> a
^. forall s a. HasFontManager s a => Lens' s a
L.fontManager
style :: StyleState
style = 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 forall s a. s -> Getting a s a -> a
^. forall s a. HasChildren s a => Lens' s a
L.children
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
scOffset :: Point
scOffset = WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasOffset s a => Lens' s a
L.offset
isDragging :: Bool
isDragging = forall a. Maybe a -> Bool
isJust (WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasDragStatus s a => Lens' s a
L.dragStatus)
maxW :: Double
maxW = WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasWindowSize s a => Lens' s a
L.windowSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasW s a => Lens' s a
L.w
maxH :: Double
maxH = WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasWindowSize s a => Lens' s a
L.windowSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasH s a => Lens' s a
L.h
targetW :: Double
targetW = forall a. a -> Maybe a -> a
fromMaybe Double
maxW (TooltipCfg -> Maybe Double
_ttcMaxWidth TooltipCfg
config)
targetH :: Double
targetH = 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
forall a. Maybe a
Nothing Size
targetSize Text
caption
textSize :: Size
textSize = Seq TextLine -> Size
getTextLinesSize Seq TextLine
fittedLines
Size Double
tw Double
th = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def (StyleState -> Size -> Maybe Size
addOuterSize StyleState
style Size
textSize)
TooltipState Point
lastPos Millisecond
_ = 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 forall s a. s -> Getting a s a -> a
^. forall s a. HasWindowSize s a => Lens' s a
L.windowSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasW s a => Lens' s a
L.w forall a. Num a => a -> a -> a
- Double
mx forall a. Ord a => a -> a -> Bool
> Double
tw = Double
mx
| Bool
otherwise = WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasWindowSize s a => Lens' s a
L.windowSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasW s a => Lens' s a
L.w forall a. Num a => a -> a -> a
- Double
tw
ry :: Double
ry
| WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasWindowSize s a => Lens' s a
L.windowSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasH s a => Lens' s a
L.h forall a. Num a => a -> a -> a
- (Double
my forall a. Num a => a -> a -> a
+ Double
50) forall a. Ord a => a -> a -> Bool
> Double
th = Double
my forall a. Num a => a -> a -> a
+ Double
20
| Bool
otherwise = Double
my forall a. Num a => a -> a -> a
- Double
th 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 = forall {p} {a} {p}.
(HasInfo p a, HasViewport a Rect, HasTimestamp p Millisecond) =>
p -> p -> Bool
tooltipDisplayed WidgetEnv s e
wenv WidgetNode s e
node Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isDragging
tooltipDisplayed :: p -> p -> Bool
tooltipDisplayed p
wenv p
node = Bool
displayed where
TooltipState Point
lastPos Millisecond
lastPosTs = TooltipState
state
ts :: Millisecond
ts = p
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasTimestamp s a => Lens' s a
L.timestamp
viewport :: Rect
viewport = p
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. HasViewport s a => Lens' s a
L.viewport
inViewport :: Bool
inViewport = Point -> Rect -> Bool
pointInRect Point
lastPos Rect
viewport
delayEllapsed :: Bool
delayEllapsed = Millisecond
ts forall a. Num a => a -> a -> a
- Millisecond
lastPosTs forall a. Ord a => a -> a -> Bool
>= Millisecond
delay
displayed :: Bool
displayed = Bool
inViewport Bool -> Bool -> Bool
&& Bool
delayEllapsed