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

Label widget, with support for multiline text.

Single line label:

@
label "This is a label"
@

Multi-line label:

@
label_ "This is a\\nmultiline label" [multiline]
@
-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE Strict #-}

module Monomer.Widgets.Singles.Label (
  -- * Configuration
  LabelCfg,
  labelCurrentStyle,
  -- * Constructors
  label,
  label_,
  labelS,
  labelS_
) where

import Control.Applicative ((<|>))
import Control.Lens ((&), (^.), (.~), (^?), non, ix)
import Control.Monad (forM_)
import Data.Default
import Data.Maybe
import Data.Sequence (Seq(..))
import Data.Text (Text)
import GHC.Generics

import qualified Data.Sequence as Seq
import qualified Data.Text as T

import Monomer.Widgets.Single

import qualified Monomer.Lens as L

{-|
Configuration options for label.

- 'trimSpaces': whether to remove leading/trailing spaces in the caption.
- 'ellipsis': if ellipsis should be used for overflown text.
- 'multiline': if text may be split in multiple lines.
- 'maxLines': maximum number of text lines to show.
- 'ignoreTheme': whether to load default style from theme or start empty.
- 'resizeFactor': flexibility to have more or less spaced assigned.
- 'resizeFactorW': flexibility to have more or less horizontal spaced assigned.
- 'resizeFactorH': flexibility to have more or less vertical spaced assigned.
-}
data LabelCfg s e = LabelCfg {
  forall s e. LabelCfg s e -> Maybe Bool
_lscIgnoreTheme :: Maybe Bool,
  forall s e. LabelCfg s e -> Maybe Bool
_lscTextTrim :: Maybe Bool,
  forall s e. LabelCfg s e -> Maybe Bool
_lscTextEllipsis :: Maybe Bool,
  forall s e. LabelCfg s e -> Maybe Bool
_lscTextMultiLine :: Maybe Bool,
  forall s e. LabelCfg s e -> Maybe Int
_lscTextMaxLines :: Maybe Int,
  forall s e. LabelCfg s e -> Maybe Double
_lscFactorW :: Maybe Double,
  forall s e. LabelCfg s e -> Maybe Double
_lscFactorH :: Maybe Double,
  forall s e.
LabelCfg s e
-> Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
_lscCurrentStyle :: Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
}

instance Default (LabelCfg s e) where
  def :: LabelCfg s e
def = LabelCfg {
    _lscIgnoreTheme :: Maybe Bool
_lscIgnoreTheme = forall a. Maybe a
Nothing,
    _lscTextTrim :: Maybe Bool
_lscTextTrim = forall a. Maybe a
Nothing,
    _lscTextEllipsis :: Maybe Bool
_lscTextEllipsis = forall a. Maybe a
Nothing,
    _lscTextMultiLine :: Maybe Bool
_lscTextMultiLine = forall a. Maybe a
Nothing,
    _lscTextMaxLines :: Maybe Int
_lscTextMaxLines = forall a. Maybe a
Nothing,
    _lscFactorW :: Maybe Double
_lscFactorW = forall a. Maybe a
Nothing,
    _lscFactorH :: Maybe Double
_lscFactorH = forall a. Maybe a
Nothing,
    _lscCurrentStyle :: Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
_lscCurrentStyle = forall a. Maybe a
Nothing
  }

instance Semigroup (LabelCfg s e) where
  <> :: LabelCfg s e -> LabelCfg s e -> LabelCfg s e
(<>) LabelCfg s e
l1 LabelCfg s e
l2 = LabelCfg {
    _lscIgnoreTheme :: Maybe Bool
_lscIgnoreTheme = forall s e. LabelCfg s e -> Maybe Bool
_lscIgnoreTheme LabelCfg s e
l2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. LabelCfg s e -> Maybe Bool
_lscIgnoreTheme LabelCfg s e
l1,
    _lscTextTrim :: Maybe Bool
_lscTextTrim = forall s e. LabelCfg s e -> Maybe Bool
_lscTextTrim LabelCfg s e
l2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. LabelCfg s e -> Maybe Bool
_lscTextTrim LabelCfg s e
l1,
    _lscTextEllipsis :: Maybe Bool
_lscTextEllipsis = forall s e. LabelCfg s e -> Maybe Bool
_lscTextEllipsis LabelCfg s e
l2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. LabelCfg s e -> Maybe Bool
_lscTextEllipsis LabelCfg s e
l1,
    _lscTextMultiLine :: Maybe Bool
_lscTextMultiLine = forall s e. LabelCfg s e -> Maybe Bool
_lscTextMultiLine LabelCfg s e
l2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. LabelCfg s e -> Maybe Bool
_lscTextMultiLine LabelCfg s e
l1,
    _lscTextMaxLines :: Maybe Int
_lscTextMaxLines = forall s e. LabelCfg s e -> Maybe Int
_lscTextMaxLines LabelCfg s e
l2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. LabelCfg s e -> Maybe Int
_lscTextMaxLines LabelCfg s e
l1,
    _lscFactorW :: Maybe Double
_lscFactorW = forall s e. LabelCfg s e -> Maybe Double
_lscFactorW LabelCfg s e
l2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. LabelCfg s e -> Maybe Double
_lscFactorW LabelCfg s e
l1,
    _lscFactorH :: Maybe Double
_lscFactorH = forall s e. LabelCfg s e -> Maybe Double
_lscFactorH LabelCfg s e
l2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. LabelCfg s e -> Maybe Double
_lscFactorH LabelCfg s e
l1,
    _lscCurrentStyle :: Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
_lscCurrentStyle = forall s e.
LabelCfg s e
-> Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
_lscCurrentStyle LabelCfg s e
l2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e.
LabelCfg s e
-> Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
_lscCurrentStyle LabelCfg s e
l1
  }

instance Monoid (LabelCfg s e) where
  mempty :: LabelCfg s e
mempty = forall a. Default a => a
def

instance CmbIgnoreTheme (LabelCfg s e) where
  ignoreTheme_ :: Bool -> LabelCfg s e
ignoreTheme_ Bool
ignore = forall a. Default a => a
def {
    _lscIgnoreTheme :: Maybe Bool
_lscIgnoreTheme = forall a. a -> Maybe a
Just Bool
ignore
  }

instance CmbTrimSpaces (LabelCfg s e) where
  trimSpaces_ :: Bool -> LabelCfg s e
trimSpaces_ Bool
trim = forall a. Default a => a
def {
    _lscTextTrim :: Maybe Bool
_lscTextTrim = forall a. a -> Maybe a
Just Bool
trim
  }

instance CmbEllipsis (LabelCfg s e) where
  ellipsis_ :: Bool -> LabelCfg s e
ellipsis_ Bool
ellipsis = forall a. Default a => a
def {
    _lscTextEllipsis :: Maybe Bool
_lscTextEllipsis = forall a. a -> Maybe a
Just Bool
ellipsis
  }

instance CmbMultiline (LabelCfg s e) where
  multiline_ :: Bool -> LabelCfg s e
multiline_ Bool
multi = forall a. Default a => a
def {
    _lscTextMultiLine :: Maybe Bool
_lscTextMultiLine = forall a. a -> Maybe a
Just Bool
multi
  }

instance CmbMaxLines (LabelCfg s e) where
  maxLines :: Int -> LabelCfg s e
maxLines Int
count = forall a. Default a => a
def {
    _lscTextMaxLines :: Maybe Int
_lscTextMaxLines = forall a. a -> Maybe a
Just Int
count
  }

instance CmbResizeFactor (LabelCfg s e) where
  resizeFactor :: Double -> LabelCfg s e
resizeFactor Double
s = forall a. Default a => a
def {
    _lscFactorW :: Maybe Double
_lscFactorW = forall a. a -> Maybe a
Just Double
s,
    _lscFactorH :: Maybe Double
_lscFactorH = forall a. a -> Maybe a
Just Double
s
  }

instance CmbResizeFactorDim (LabelCfg s e) where
  resizeFactorW :: Double -> LabelCfg s e
resizeFactorW Double
w = forall a. Default a => a
def {
    _lscFactorW :: Maybe Double
_lscFactorW = forall a. a -> Maybe a
Just Double
w
  }
  resizeFactorH :: Double -> LabelCfg s e
resizeFactorH Double
h = forall a. Default a => a
def {
    _lscFactorH :: Maybe Double
_lscFactorH = forall a. a -> Maybe a
Just Double
h
  }

-- | Custom current style to be used by the label widget. Useful for widgets
--   with an embedded label (for example, 'Monomer.Widgets.Singles.Button' and
--   'Monomer.Widgets.Singles.ExternalLink').
labelCurrentStyle
  :: (WidgetEnv s e -> WidgetNode s e -> StyleState)
  -> LabelCfg s e
labelCurrentStyle :: forall s e.
(WidgetEnv s e -> WidgetNode s e -> StyleState) -> LabelCfg s e
labelCurrentStyle WidgetEnv s e -> WidgetNode s e -> StyleState
styleFn = forall a. Default a => a
def {
  _lscCurrentStyle :: Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
_lscCurrentStyle = forall a. a -> Maybe a
Just WidgetEnv s e -> WidgetNode s e -> StyleState
styleFn
}

data LabelState = LabelState {
  LabelState -> Text
_lstCaption :: Text,
  LabelState -> StyleState
_lstStyle :: StyleState,
  LabelState -> Rect
_lstTextRect :: Rect,
  LabelState -> Seq TextLine
_lstTextLines :: Seq TextLine,
  LabelState -> (Millisecond, Bool)
_lstResizeStep :: (Millisecond, Bool)
} deriving (LabelState -> LabelState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LabelState -> LabelState -> Bool
$c/= :: LabelState -> LabelState -> Bool
== :: LabelState -> LabelState -> Bool
$c== :: LabelState -> LabelState -> Bool
Eq, Int -> LabelState -> ShowS
[LabelState] -> ShowS
LabelState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LabelState] -> ShowS
$cshowList :: [LabelState] -> ShowS
show :: LabelState -> String
$cshow :: LabelState -> String
showsPrec :: Int -> LabelState -> ShowS
$cshowsPrec :: Int -> LabelState -> ShowS
Show, forall x. Rep LabelState x -> LabelState
forall x. LabelState -> Rep LabelState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LabelState x -> LabelState
$cfrom :: forall x. LabelState -> Rep LabelState x
Generic)

-- | Creates a label using the provided 'Text'.
label
  :: Text            -- ^ The caption.
  -> WidgetNode s e  -- ^ The created label.
label :: forall s e. Text -> WidgetNode s e
label Text
caption = forall s e. Text -> [LabelCfg s e] -> WidgetNode s e
label_ Text
caption forall a. Default a => a
def

-- | Creates a label using the provided 'Text'. Accepts config.
label_
  :: Text            -- ^ The caption.
  -> [LabelCfg s e]  -- ^ The config options.
  -> WidgetNode s e  -- ^ The created label.
label_ :: forall s e. Text -> [LabelCfg s e] -> WidgetNode s e
label_ Text
caption [LabelCfg s e]
configs = forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"label" Widget s e
widget where
  config :: LabelCfg s e
config = forall a. Monoid a => [a] -> a
mconcat [LabelCfg s e]
configs
  state :: LabelState
state = Text
-> StyleState
-> Rect
-> Seq TextLine
-> (Millisecond, Bool)
-> LabelState
LabelState Text
caption forall a. Default a => a
def forall a. Default a => a
def forall a. Seq a
Seq.Empty (Millisecond
0, Bool
False)
  widget :: Widget s e
widget = forall s e. LabelCfg s e -> LabelState -> Widget s e
makeLabel LabelCfg s e
config LabelState
state

-- | Creates a label using the 'Show' instance of the type.
labelS
  :: Show a
  => a               -- ^ The value with a 'Show' instance.
  -> WidgetNode s e  -- ^ The created label.
labelS :: forall a s e. Show a => a -> WidgetNode s e
labelS a
caption = forall a s e. Show a => a -> [LabelCfg s e] -> WidgetNode s e
labelS_ a
caption forall a. Default a => a
def

-- | Creates a label using the 'Show' instance of the type. Accepts config.
labelS_
  :: Show a
  => a               -- ^ The value with a 'Show' instance.
  -> [LabelCfg s e]  -- ^ The config options.
  -> WidgetNode s e  -- ^ The created label.
labelS_ :: forall a s e. Show a => a -> [LabelCfg s e] -> WidgetNode s e
labelS_ a
caption [LabelCfg s e]
configs = forall s e. Text -> [LabelCfg s e] -> WidgetNode s e
label_ (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ a
caption) [LabelCfg s e]
configs

makeLabel :: LabelCfg s e -> LabelState -> Widget s e
makeLabel :: forall s e. LabelCfg s e -> LabelState -> Widget s e
makeLabel LabelCfg s e
config LabelState
state = Widget s e
widget where
  baseWidget :: Widget s e
baseWidget = forall a s e. WidgetModel a => a -> Single s e a -> Widget s e
createSingle LabelState
state forall a. Default a => a
def {
    singleGetBaseStyle :: SingleGetBaseStyle s e
singleGetBaseStyle = forall {s} {e} {p}. WidgetEnv s e -> p -> Maybe Style
getBaseStyle,
    singleInit :: SingleInitHandler s e
singleInit = SingleInitHandler s e
init,
    singleMerge :: SingleMergeHandler s e LabelState
singleMerge = forall {p}.
WidgetEnv s e
-> WidgetNode s e -> p -> LabelState -> WidgetResult s e
merge,
    singleGetSizeReq :: SingleGetSizeReqHandler s e
singleGetSizeReq = SingleGetSizeReqHandler s e
getSizeReq,
    singleResize :: SingleResizeHandler s e
singleResize = SingleResizeHandler s e
resize
  }
  widget :: Widget s e
widget = Widget s e
baseWidget {
    widgetRender :: WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
widgetRender = WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render
  }

  ignoreTheme :: Bool
ignoreTheme = forall s e. LabelCfg s e -> Maybe Bool
_lscIgnoreTheme LabelCfg s e
config forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True
  trim :: TextTrim
trim
    | forall s e. LabelCfg s e -> Maybe Bool
_lscTextTrim LabelCfg s e
config forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True = TextTrim
TrimSpaces
    | Bool
otherwise = TextTrim
KeepSpaces
  overflow :: TextOverflow
overflow
    | forall s e. LabelCfg s e -> Maybe Bool
_lscTextEllipsis LabelCfg s e
config forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True = TextOverflow
Ellipsis
    | Bool
otherwise = TextOverflow
ClipText
  mode :: TextMode
mode
    | forall s e. LabelCfg s e -> Maybe Bool
_lscTextMultiLine LabelCfg s e
config forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True = TextMode
MultiLine
    | Bool
otherwise = TextMode
SingleLine
  maxLines :: Maybe Int
maxLines = forall s e. LabelCfg s e -> Maybe Int
_lscTextMaxLines LabelCfg s e
config
  labelCurrentStyle :: WidgetEnv s e -> WidgetNode s e -> StyleState
labelCurrentStyle = forall a. a -> Maybe a -> a
fromMaybe forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle (forall s e.
LabelCfg s e
-> Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
_lscCurrentStyle LabelCfg s e
config)
  LabelState Text
caption StyleState
textStyle Rect
textRect Seq TextLine
textLines (Millisecond, Bool)
resizeStep = LabelState
state

  getBaseStyle :: WidgetEnv s e -> p -> Maybe Style
getBaseStyle WidgetEnv s e
wenv p
node
    | Bool
ignoreTheme = forall a. Maybe a
Nothing
    | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall s e. WidgetEnv s e -> Lens' ThemeState StyleState -> Style
collectTheme WidgetEnv s e
wenv forall s a. HasLabelStyle s a => Lens' s a
L.labelStyle

  init :: SingleInitHandler s e
init WidgetEnv s e
wenv WidgetNode s e
node = forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
newNode where
    style :: StyleState
style = WidgetEnv s e -> WidgetNode s e -> StyleState
labelCurrentStyle WidgetEnv s e
wenv WidgetNode s e
node
    newState :: LabelState
newState = LabelState
state {
      _lstStyle :: StyleState
_lstStyle = StyleState
style
    }
    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. LabelCfg s e -> LabelState -> Widget s e
makeLabel LabelCfg s e
config LabelState
newState

  merge :: WidgetEnv s e
-> WidgetNode s e -> p -> LabelState -> WidgetResult s e
merge WidgetEnv s e
wenv WidgetNode s e
newNode p
oldNode LabelState
oldState = WidgetResult s e
result where
    LabelState Text
prevCaption StyleState
prevStyle Rect
prevRect Seq TextLine
prevLines (Millisecond, Bool)
prevResize = LabelState
oldState
    (Millisecond
tsResized, Bool
alreadyResized) = (Millisecond, Bool)
prevResize

    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
    style :: StyleState
style = WidgetEnv s e -> WidgetNode s e -> StyleState
labelCurrentStyle WidgetEnv s e
wenv WidgetNode s e
newNode
    captionChanged :: Bool
captionChanged = Text
prevCaption forall a. Eq a => a -> a -> Bool
/= Text
caption
    styleChanged :: Bool
styleChanged = StyleState
prevStyle forall s a. s -> Getting a s a -> a
^. forall s a. HasText s a => Lens' s a
L.text forall a. Eq a => a -> a -> Bool
/= StyleState
style forall s a. s -> Getting a s a -> a
^. forall s a. HasText s a => Lens' s a
L.text
      Bool -> Bool -> Bool
|| StyleState
prevStyle forall s a. s -> Getting a s a -> a
^. forall s a. HasPadding s a => Lens' s a
L.padding forall a. Eq a => a -> a -> Bool
/= StyleState
style forall s a. s -> Getting a s a -> a
^. forall s a. HasPadding s a => Lens' s a
L.padding
      Bool -> Bool -> Bool
|| StyleState
prevStyle forall s a. s -> Getting a s a -> a
^. forall s a. HasBorder s a => Lens' s a
L.border forall a. Eq a => a -> a -> Bool
/= StyleState
style forall s a. s -> Getting a s a -> a
^. forall s a. HasBorder s a => Lens' s a
L.border
      Bool -> Bool -> Bool
|| StyleState
prevStyle forall s a. s -> Getting a s a -> a
^. forall s a. HasSizeReqH s a => Lens' s a
L.sizeReqH forall a. Eq a => a -> a -> Bool
/= StyleState
style forall s a. s -> Getting a s a -> a
^. forall s a. HasSizeReqH s a => Lens' s a
L.sizeReqH
      Bool -> Bool -> Bool
|| StyleState
prevStyle forall s a. s -> Getting a s a -> a
^. forall s a. HasSizeReqW s a => Lens' s a
L.sizeReqW forall a. Eq a => a -> a -> Bool
/= StyleState
style forall s a. s -> Getting a s a -> a
^. forall s a. HasSizeReqW s a => Lens' s a
L.sizeReqW

    changeReq :: Bool
changeReq = Bool
captionChanged Bool -> Bool -> Bool
|| Bool
styleChanged
    -- This is used in resize to know if glyphs have to be recalculated
    newRect :: Rect
newRect
      | Bool
changeReq = forall a. Default a => a
def
      | Bool
otherwise = Rect
prevRect
    newState :: LabelState
newState = LabelState {
      _lstCaption :: Text
_lstCaption = Text
caption,
      _lstStyle :: StyleState
_lstStyle = StyleState
style,
      _lstTextRect :: Rect
_lstTextRect = Rect
newRect,
      _lstTextLines :: Seq TextLine
_lstTextLines = Seq TextLine
prevLines,
      _lstResizeStep :: (Millisecond, Bool)
_lstResizeStep = (Millisecond
tsResized, Bool
alreadyResized Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
captionChanged)
    }

    reqs :: [WidgetRequest s e]
reqs = [ forall s e. WidgetId -> WidgetRequest s e
ResizeWidgets WidgetId
widgetId | Bool
changeReq ]
    resNode :: WidgetNode s e
resNode = WidgetNode s e
newNode
      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. LabelCfg s e -> LabelState -> Widget s e
makeLabel LabelCfg s e
config LabelState
newState
    result :: WidgetResult s e
result = forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
resNode forall {s} {e}. [WidgetRequest s e]
reqs

  getSizeReq :: SingleGetSizeReqHandler s e
getSizeReq WidgetEnv s e
wenv WidgetNode s e
node = (SizeReq
sizeW, SizeReq
sizeH) where
    ts :: Millisecond
ts = WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasTimestamp s a => Lens' s a
L.timestamp
    caption :: Text
caption = LabelState -> Text
_lstCaption LabelState
state
    prevResize :: (Millisecond, Bool)
prevResize = LabelState -> (Millisecond, Bool)
_lstResizeStep LabelState
state
    style :: StyleState
style = WidgetEnv s e -> WidgetNode s e -> StyleState
labelCurrentStyle WidgetEnv s e
wenv WidgetNode s e
node

    cw :: Double
cw = forall s e. WidgetNode s e -> StyleState -> Rect
getContentArea WidgetNode s e
node StyleState
style forall s a. s -> Getting a s a -> a
^. forall s a. HasW s a => Lens' s a
L.w
    defaultFactor :: Double
defaultFactor
      | TextMode
mode forall a. Eq a => a -> a -> Bool
== TextMode
MultiLine = Double
1
      | TextOverflow
overflow forall a. Eq a => a -> a -> Bool
== TextOverflow
Ellipsis = Double
0.01
      | Bool
otherwise = Double
0

    targetW :: Maybe Double
targetW
      | TextMode
mode forall a. Eq a => a -> a -> Bool
== TextMode
MultiLine Bool -> Bool -> Bool
&& (Millisecond, Bool)
prevResize forall a. Eq a => a -> a -> Bool
== (Millisecond
ts, Bool
True) = forall a. a -> Maybe a
Just Double
cw
      | Bool
otherwise = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SizeReq -> Double
sizeReqMaxBounded (StyleState
style forall s a. s -> Getting a s a -> a
^. forall s a. HasSizeReqW s a => Lens' s a
L.sizeReqW)
    Size Double
w Double
h = forall s e.
WidgetEnv s e
-> StyleState
-> TextMode
-> TextTrim
-> Maybe Double
-> Maybe Int
-> Text
-> Size
getTextSize_ WidgetEnv s e
wenv StyleState
style TextMode
mode TextTrim
trim Maybe Double
targetW Maybe Int
maxLines Text
caption

    factorW :: Double
factorW = forall a. a -> Maybe a -> a
fromMaybe Double
defaultFactor (forall s e. LabelCfg s e -> Maybe Double
_lscFactorW LabelCfg s e
config)
    factorH :: Double
factorH = forall a. a -> Maybe a -> a
fromMaybe Double
defaultFactor (forall s e. LabelCfg s e -> Maybe Double
_lscFactorH LabelCfg s e
config)

    sizeW :: SizeReq
sizeW
      | forall a. Num a => a -> a
abs Double
factorW forall a. Ord a => a -> a -> Bool
< Double
0.01 = Double -> SizeReq
fixedSize Double
w
      | Bool
otherwise = Double -> Double -> SizeReq
flexSize Double
w Double
factorW
    sizeH :: SizeReq
sizeH
      | forall a. Num a => a -> a
abs Double
factorH forall a. Ord a => a -> a -> Bool
< Double
0.01 = Double -> SizeReq
fixedSize Double
h
      | Bool
otherwise = Double -> Double -> SizeReq
flexSize Double
h Double
factorH

  resize :: SingleResizeHandler s e
resize WidgetEnv s e
wenv WidgetNode s e
node Rect
viewport = WidgetResult s e
result 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
    ts :: Millisecond
ts = WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasTimestamp s a => Lens' s a
L.timestamp
    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
    style :: StyleState
style = WidgetEnv s e -> WidgetNode s e -> StyleState
labelCurrentStyle WidgetEnv s e
wenv WidgetNode s e
node
    crect :: Rect
crect = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def (StyleState -> Rect -> Maybe Rect
removeOuterBounds StyleState
style Rect
viewport)

    Rect Double
px Double
py Double
pw Double
ph = Rect
textRect
    Rect Double
_ Double
_ Double
cw Double
ch = Rect
crect
    size :: Size
size = Double -> Double -> Size
Size Double
cw Double
ch
    alignRect :: Rect
alignRect = Double -> Double -> Double -> Double -> Rect
Rect Double
0 Double
0 Double
cw Double
ch

    fittedLines :: Seq TextLine
fittedLines
      = FontManager
-> StyleState
-> TextOverflow
-> TextMode
-> TextTrim
-> Maybe Int
-> Size
-> Text
-> Seq TextLine
fitTextToSize FontManager
fontMgr StyleState
style TextOverflow
overflow TextMode
mode TextTrim
trim Maybe Int
maxLines Size
size Text
caption
    newTextLines :: Seq TextLine
newTextLines = StyleState -> Rect -> Seq TextLine -> Seq TextLine
alignTextLines StyleState
style Rect
alignRect Seq TextLine
fittedLines

    rectEq :: Bool
rectEq = Rect
textRect forall a. Eq a => a -> a -> Bool
== Rect
crect
    (Millisecond
tsResized, Bool
alreadyResized) = (Millisecond, Bool)
resizeStep
    resizeAgain :: Bool
resizeAgain = TextMode
mode forall a. Eq a => a -> a -> Bool
== TextMode
MultiLine Bool -> Bool -> Bool
&& (Millisecond
tsResized forall a. Eq a => a -> a -> Bool
/= Millisecond
ts Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
alreadyResized)
    isResized :: Bool
isResized = (Bool
alreadyResized Bool -> Bool -> Bool
&& Bool
rectEq) Bool -> Bool -> Bool
|| (Bool
resizeAgain Bool -> Bool -> Bool
&& Millisecond
tsResized forall a. Eq a => a -> a -> Bool
== Millisecond
ts)

    newState :: LabelState
newState = LabelState
state {
      _lstStyle :: StyleState
_lstStyle = StyleState
style,
      _lstTextRect :: Rect
_lstTextRect = Rect
crect,
      _lstTextLines :: Seq TextLine
_lstTextLines = Seq TextLine
newTextLines,
      _lstResizeStep :: (Millisecond, Bool)
_lstResizeStep = (Millisecond
ts, Bool
isResized)
    }
    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. LabelCfg s e -> LabelState -> Widget s e
makeLabel LabelCfg s e
config LabelState
newState
    result :: WidgetResult s e
result = forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
newNode [forall s e. WidgetId -> WidgetRequest s e
ResizeWidgets WidgetId
widgetId | Bool
resizeAgain]

  render :: WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render WidgetEnv s e
wenv WidgetNode s e
node Renderer
renderer = do
    Renderer -> Bool -> Rect -> IO () -> IO ()
drawInScissor Renderer
renderer Bool
True Rect
scissorVp forall a b. (a -> b) -> a -> b
$
      Renderer -> Rect -> StyleState -> (Rect -> IO ()) -> IO ()
drawStyledAction Renderer
renderer Rect
viewport StyleState
style forall a b. (a -> b) -> a -> b
$ \(Rect Double
cx Double
cy Double
_ Double
_) ->
        Renderer -> Point -> IO () -> IO ()
drawInTranslation Renderer
renderer (Double -> Double -> Point
Point Double
cx Double
cy) forall a b. (a -> b) -> a -> b
$
          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
      style :: StyleState
style = WidgetEnv s e -> WidgetNode s e -> StyleState
labelCurrentStyle WidgetEnv s e
wenv WidgetNode s e
node
      viewport :: Rect
viewport = 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. HasViewport s a => Lens' s a
L.viewport
      textMetrics :: Maybe TextMetrics
textMetrics = Seq TextLine
textLines forall s a. s -> Getting (First a) s a -> Maybe a
^? forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasMetrics s a => Lens' s a
L.metrics
      desc :: Double
desc = forall a. Num a => a -> a
abs (Maybe TextMetrics
textMetrics 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 b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasDesc s a => Lens' s a
L.desc)
      scissorVp :: Rect
scissorVp = Rect
viewport
        forall a b. a -> (a -> b) -> b
& forall s a. HasY s a => Lens' s a
L.y forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Rect
viewport forall s a. s -> Getting a s a -> a
^. forall s a. HasY s a => Lens' s a
L.y forall a. Num a => a -> a -> a
- Double
desc)
        forall a b. a -> (a -> b) -> b
& forall s a. HasH s a => Lens' s a
L.h forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Rect
viewport forall s a. s -> Getting a s a -> a
^. forall s a. HasH s a => Lens' s a
L.h forall a. Num a => a -> a -> a
+ Double
desc)