{-|
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.
-}
{-# LANGUAGE DeriveGeneric #-}

module Monomer.Widgets.Singles.Label (
  -- * Configuration
  LabelCfg,
  -- * Constructors
  labelCurrentStyle,
  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 {
  LabelCfg s e -> Maybe Bool
_lscIgnoreTheme :: Maybe Bool,
  LabelCfg s e -> Maybe Bool
_lscTextTrim :: Maybe Bool,
  LabelCfg s e -> Maybe Bool
_lscTextEllipsis :: Maybe Bool,
  LabelCfg s e -> Maybe Bool
_lscTextMultiLine :: Maybe Bool,
  LabelCfg s e -> Maybe Int
_lscTextMaxLines :: Maybe Int,
  LabelCfg s e -> Maybe Double
_lscFactorW :: Maybe Double,
  LabelCfg s e -> Maybe Double
_lscFactorH :: Maybe Double,
  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 :: forall s e.
Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe Int
-> Maybe Double
-> Maybe Double
-> Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
-> LabelCfg s e
LabelCfg {
    _lscIgnoreTheme :: Maybe Bool
_lscIgnoreTheme = Maybe Bool
forall a. Maybe a
Nothing,
    _lscTextTrim :: Maybe Bool
_lscTextTrim = Maybe Bool
forall a. Maybe a
Nothing,
    _lscTextEllipsis :: Maybe Bool
_lscTextEllipsis = Maybe Bool
forall a. Maybe a
Nothing,
    _lscTextMultiLine :: Maybe Bool
_lscTextMultiLine = Maybe Bool
forall a. Maybe a
Nothing,
    _lscTextMaxLines :: Maybe Int
_lscTextMaxLines = Maybe Int
forall a. Maybe a
Nothing,
    _lscFactorW :: Maybe Double
_lscFactorW = Maybe Double
forall a. Maybe a
Nothing,
    _lscFactorH :: Maybe Double
_lscFactorH = Maybe Double
forall a. Maybe a
Nothing,
    _lscCurrentStyle :: Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
_lscCurrentStyle = Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
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 :: forall s e.
Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe Int
-> Maybe Double
-> Maybe Double
-> Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
-> LabelCfg s e
LabelCfg {
    _lscIgnoreTheme :: Maybe Bool
_lscIgnoreTheme = LabelCfg s e -> Maybe Bool
forall s e. LabelCfg s e -> Maybe Bool
_lscIgnoreTheme LabelCfg s e
l2 Maybe Bool -> Maybe Bool -> Maybe Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> LabelCfg s e -> Maybe Bool
forall s e. LabelCfg s e -> Maybe Bool
_lscIgnoreTheme LabelCfg s e
l1,
    _lscTextTrim :: Maybe Bool
_lscTextTrim = LabelCfg s e -> Maybe Bool
forall s e. LabelCfg s e -> Maybe Bool
_lscTextTrim LabelCfg s e
l2 Maybe Bool -> Maybe Bool -> Maybe Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> LabelCfg s e -> Maybe Bool
forall s e. LabelCfg s e -> Maybe Bool
_lscTextTrim LabelCfg s e
l1,
    _lscTextEllipsis :: Maybe Bool
_lscTextEllipsis = LabelCfg s e -> Maybe Bool
forall s e. LabelCfg s e -> Maybe Bool
_lscTextEllipsis LabelCfg s e
l2 Maybe Bool -> Maybe Bool -> Maybe Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> LabelCfg s e -> Maybe Bool
forall s e. LabelCfg s e -> Maybe Bool
_lscTextEllipsis LabelCfg s e
l1,
    _lscTextMultiLine :: Maybe Bool
_lscTextMultiLine = LabelCfg s e -> Maybe Bool
forall s e. LabelCfg s e -> Maybe Bool
_lscTextMultiLine LabelCfg s e
l2 Maybe Bool -> Maybe Bool -> Maybe Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> LabelCfg s e -> Maybe Bool
forall s e. LabelCfg s e -> Maybe Bool
_lscTextMultiLine LabelCfg s e
l1,
    _lscTextMaxLines :: Maybe Int
_lscTextMaxLines = LabelCfg s e -> Maybe Int
forall s e. LabelCfg s e -> Maybe Int
_lscTextMaxLines LabelCfg s e
l2 Maybe Int -> Maybe Int -> Maybe Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> LabelCfg s e -> Maybe Int
forall s e. LabelCfg s e -> Maybe Int
_lscTextMaxLines LabelCfg s e
l1,
    _lscFactorW :: Maybe Double
_lscFactorW = LabelCfg s e -> Maybe Double
forall s e. LabelCfg s e -> Maybe Double
_lscFactorW LabelCfg s e
l2 Maybe Double -> Maybe Double -> Maybe Double
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> LabelCfg s e -> Maybe Double
forall s e. LabelCfg s e -> Maybe Double
_lscFactorW LabelCfg s e
l1,
    _lscFactorH :: Maybe Double
_lscFactorH = LabelCfg s e -> Maybe Double
forall s e. LabelCfg s e -> Maybe Double
_lscFactorH LabelCfg s e
l2 Maybe Double -> Maybe Double -> Maybe Double
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> LabelCfg s e -> Maybe Double
forall s e. LabelCfg s e -> Maybe Double
_lscFactorH LabelCfg s e
l1,
    _lscCurrentStyle :: Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
_lscCurrentStyle = LabelCfg s e
-> Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
forall s e.
LabelCfg s e
-> Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
_lscCurrentStyle LabelCfg s e
l2 Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
-> Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
-> Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> LabelCfg s e
-> Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
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 = LabelCfg s e
forall a. Default a => a
def

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

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

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

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

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

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

instance CmbResizeFactorDim (LabelCfg s e) where
  resizeFactorW :: Double -> LabelCfg s e
resizeFactorW Double
w = LabelCfg s e
forall a. Default a => a
def {
    _lscFactorW :: Maybe Double
_lscFactorW = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
w
  }
  resizeFactorH :: Double -> LabelCfg s e
resizeFactorH Double
h = LabelCfg s e
forall a. Default a => a
def {
    _lscFactorH :: Maybe Double
_lscFactorH = Double -> Maybe Double
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 :: (WidgetEnv s e -> WidgetNode s e -> StyleState) -> LabelCfg s e
labelCurrentStyle WidgetEnv s e -> WidgetNode s e -> StyleState
style = LabelCfg Any Any
forall a. Default a => a
def {
  _lscCurrentStyle :: Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
_lscCurrentStyle = (WidgetEnv s e -> WidgetNode s e -> StyleState)
-> Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
forall a. a -> Maybe a
Just WidgetEnv s e -> WidgetNode s e -> StyleState
style
}

data LabelState = LabelState {
  LabelState -> Text
_lstCaption :: Text,
  LabelState -> Maybe TextStyle
_lstTextStyle :: Maybe TextStyle,
  LabelState -> Rect
_lstTextRect :: Rect,
  LabelState -> Seq TextLine
_lstTextLines :: Seq TextLine,
  LabelState -> (Int, Bool)
_lstPrevResize :: (Int, Bool)
} deriving (LabelState -> LabelState -> Bool
(LabelState -> LabelState -> Bool)
-> (LabelState -> LabelState -> Bool) -> Eq LabelState
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
(Int -> LabelState -> ShowS)
-> (LabelState -> String)
-> ([LabelState] -> ShowS)
-> Show LabelState
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. LabelState -> Rep LabelState x)
-> (forall x. Rep LabelState x -> LabelState) -> Generic LabelState
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 -> WidgetNode s e
label :: Text -> WidgetNode s e
label Text
caption = Text -> [LabelCfg s e] -> WidgetNode s e
forall s e. Text -> [LabelCfg s e] -> WidgetNode s e
label_ Text
caption [LabelCfg s e]
forall a. Default a => a
def

-- | Creates a label using the provided 'Text'. Accepts config.
label_ :: Text -> [LabelCfg s e] -> WidgetNode s e
label_ :: Text -> [LabelCfg s e] -> WidgetNode s e
label_ Text
caption [LabelCfg s e]
configs = WidgetType -> Widget s e -> WidgetNode s e
forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"label" Widget s e
widget where
  config :: LabelCfg s e
config = [LabelCfg s e] -> LabelCfg s e
forall a. Monoid a => [a] -> a
mconcat [LabelCfg s e]
configs
  state :: LabelState
state = Text
-> Maybe TextStyle
-> Rect
-> Seq TextLine
-> (Int, Bool)
-> LabelState
LabelState Text
caption Maybe TextStyle
forall a. Maybe a
Nothing Rect
forall a. Default a => a
def Seq TextLine
forall a. Seq a
Seq.Empty (Int
0, Bool
False)
  widget :: Widget s e
widget = LabelCfg s e -> LabelState -> Widget s e
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 -> WidgetNode s e
labelS :: a -> WidgetNode s e
labelS a
caption = a -> [LabelCfg s e] -> WidgetNode s e
forall a s e. Show a => a -> [LabelCfg s e] -> WidgetNode s e
labelS_ a
caption [LabelCfg s e]
forall a. Default a => a
def

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

makeLabel :: LabelCfg s e -> LabelState -> Widget s e
makeLabel :: LabelCfg s e -> LabelState -> Widget s e
makeLabel LabelCfg s e
config LabelState
state = Widget s e
widget where
  baseWidget :: Widget s e
baseWidget = LabelState -> Single s e LabelState -> Widget s e
forall a s e. WidgetModel a => a -> Single s e a -> Widget s e
createSingle LabelState
state Single s e Any
forall a. Default a => a
def {
    singleGetBaseStyle :: SingleGetBaseStyle s e
singleGetBaseStyle = SingleGetBaseStyle s e
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 = SingleMergeHandler s e LabelState
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 = LabelCfg s e -> Maybe Bool
forall s e. LabelCfg s e -> Maybe Bool
_lscIgnoreTheme LabelCfg s e
config Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
  trim :: TextTrim
trim
    | LabelCfg s e -> Maybe Bool
forall s e. LabelCfg s e -> Maybe Bool
_lscTextTrim LabelCfg s e
config Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True = TextTrim
TrimSpaces
    | Bool
otherwise = TextTrim
KeepSpaces
  overflow :: TextOverflow
overflow
    | LabelCfg s e -> Maybe Bool
forall s e. LabelCfg s e -> Maybe Bool
_lscTextEllipsis LabelCfg s e
config Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True = TextOverflow
Ellipsis
    | Bool
otherwise = TextOverflow
ClipText
  mode :: TextMode
mode
    | LabelCfg s e -> Maybe Bool
forall s e. LabelCfg s e -> Maybe Bool
_lscTextMultiLine LabelCfg s e
config Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True = TextMode
MultiLine
    | Bool
otherwise = TextMode
SingleLine
  maxLines :: Maybe Int
maxLines = LabelCfg s e -> Maybe Int
forall s e. LabelCfg s e -> Maybe Int
_lscTextMaxLines LabelCfg s e
config
  labelCurrentStyle :: WidgetEnv s e -> WidgetNode s e -> StyleState
labelCurrentStyle = (WidgetEnv s e -> WidgetNode s e -> StyleState)
-> Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
-> WidgetEnv s e
-> WidgetNode s e
-> StyleState
forall a. a -> Maybe a -> a
fromMaybe WidgetEnv s e -> WidgetNode s e -> StyleState
forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle (LabelCfg s e
-> Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
forall s e.
LabelCfg s e
-> Maybe (WidgetEnv s e -> WidgetNode s e -> StyleState)
_lscCurrentStyle LabelCfg s e
config)
  LabelState Text
caption Maybe TextStyle
textStyle Rect
textRect Seq TextLine
textLines (Int, Bool)
prevResize = LabelState
state

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

  init :: SingleInitHandler s e
init WidgetEnv s e
wenv WidgetNode s e
node = WidgetNode s e -> WidgetResult s e
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 {
      _lstTextStyle :: Maybe TextStyle
_lstTextStyle = StyleState
style StyleState
-> Getting (Maybe TextStyle) StyleState (Maybe TextStyle)
-> Maybe TextStyle
forall s a. s -> Getting a s a -> a
^. Getting (Maybe TextStyle) StyleState (Maybe TextStyle)
forall s a. HasText s a => Lens' s a
L.text
    }
    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
.~ LabelCfg s e -> LabelState -> Widget s e
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
    widgetId :: WidgetId
widgetId = WidgetNode s e
newNode 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
    style :: StyleState
style = WidgetEnv s e -> WidgetNode s e -> StyleState
labelCurrentStyle WidgetEnv s e
wenv WidgetNode s e
newNode
    newTextStyle :: Maybe TextStyle
newTextStyle = StyleState
style StyleState
-> Getting (Maybe TextStyle) StyleState (Maybe TextStyle)
-> Maybe TextStyle
forall s a. s -> Getting a s a -> a
^. Getting (Maybe TextStyle) StyleState (Maybe TextStyle)
forall s a. HasText s a => Lens' s a
L.text

    captionChanged :: Bool
captionChanged = LabelState -> Text
_lstCaption LabelState
oldState Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
caption
    styleChanged :: Bool
styleChanged = LabelState -> Maybe TextStyle
_lstTextStyle LabelState
oldState Maybe TextStyle -> Maybe TextStyle -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe TextStyle
newTextStyle
    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 = Rect
forall a. Default a => a
def
      | Bool
otherwise = LabelState -> Rect
_lstTextRect LabelState
oldState
    newState :: LabelState
newState = LabelState
oldState {
      _lstCaption :: Text
_lstCaption = Text
caption,
      _lstTextRect :: Rect
_lstTextRect = Rect
newRect,
      _lstTextStyle :: Maybe TextStyle
_lstTextStyle = Maybe TextStyle
newTextStyle
    }

    reqs :: [WidgetRequest s e]
reqs = [ WidgetId -> WidgetRequest s e
forall s e. WidgetId -> WidgetRequest s e
ResizeWidgets WidgetId
widgetId | Bool
changeReq ]
    resNode :: WidgetNode s e
resNode = WidgetNode s e
newNode
      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
.~ LabelCfg s e -> LabelState -> Widget s e
forall s e. LabelCfg s e -> LabelState -> Widget s e
makeLabel LabelCfg s e
config LabelState
newState
    result :: WidgetResult s e
result = 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
resNode [WidgetRequest s e]
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 :: Int
ts = WidgetEnv s e
wenv WidgetEnv s e -> Getting Int (WidgetEnv s e) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (WidgetEnv s e) Int
forall s a. HasTimestamp s a => Lens' s a
L.timestamp
    caption :: Text
caption = LabelState -> Text
_lstCaption LabelState
state
    prevResize :: (Int, Bool)
prevResize = LabelState -> (Int, Bool)
_lstPrevResize LabelState
state
    style :: StyleState
style = WidgetEnv s e -> WidgetNode s e -> StyleState
labelCurrentStyle WidgetEnv s e
wenv WidgetNode s e
node

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

    targetW :: Maybe Double
targetW
      | TextMode
mode TextMode -> TextMode -> Bool
forall a. Eq a => a -> a -> Bool
== TextMode
MultiLine Bool -> Bool -> Bool
&& (Int, Bool)
prevResize (Int, Bool) -> (Int, Bool) -> Bool
forall a. Eq a => a -> a -> Bool
== (Int
ts, Bool
True) = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
cw
      | Bool
otherwise = (SizeReq -> Double) -> Maybe SizeReq -> Maybe Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SizeReq -> Double
sizeReqMaxBounded (StyleState
style StyleState
-> Getting (Maybe SizeReq) StyleState (Maybe SizeReq)
-> Maybe SizeReq
forall s a. s -> Getting a s a -> a
^. Getting (Maybe SizeReq) StyleState (Maybe SizeReq)
forall s a. HasSizeReqW s a => Lens' s a
L.sizeReqW)
    Size Double
w Double
h = WidgetEnv s e
-> StyleState
-> TextMode
-> TextTrim
-> Maybe Double
-> Maybe Int
-> Text
-> Size
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 = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
defaultFactor (LabelCfg s e -> Maybe Double
forall s e. LabelCfg s e -> Maybe Double
_lscFactorW LabelCfg s e
config)
    factorH :: Double
factorH = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
defaultFactor (LabelCfg s e -> Maybe Double
forall s e. LabelCfg s e -> Maybe Double
_lscFactorH LabelCfg s e
config)

    sizeW :: SizeReq
sizeW
      | Double -> Double
forall a. Num a => a -> a
abs Double
factorW Double -> Double -> Bool
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
      | Double -> Double
forall a. Num a => a -> a
abs Double
factorH Double -> Double -> Bool
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 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
    ts :: Int
ts = WidgetEnv s e
wenv WidgetEnv s e -> Getting Int (WidgetEnv s e) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (WidgetEnv s e) Int
forall s a. HasTimestamp s a => Lens' s a
L.timestamp
    widgetId :: WidgetId
widgetId = WidgetNode s e
newNode 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
    style :: StyleState
style = WidgetEnv s e -> WidgetNode s e -> StyleState
labelCurrentStyle WidgetEnv s e
wenv WidgetNode s e
node
    crect :: Rect
crect = Rect -> Maybe Rect -> Rect
forall a. a -> Maybe a -> a
fromMaybe Rect
forall a. Default a => a
def (StyleState -> Rect -> Maybe Rect
removeOuterBounds StyleState
style Rect
viewport)
    newTextStyle :: Maybe TextStyle
newTextStyle = StyleState
style StyleState
-> Getting (Maybe TextStyle) StyleState (Maybe TextStyle)
-> Maybe TextStyle
forall s a. s -> Getting a s a -> a
^. Getting (Maybe TextStyle) StyleState (Maybe TextStyle)
forall s a. HasText s a => Lens' s a
L.text

    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

    newGlyphsReq :: Bool
newGlyphsReq = Double
pw Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
cw Bool -> Bool -> Bool
|| Double
ph Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
ch Bool -> Bool -> Bool
|| Maybe TextStyle
textStyle Maybe TextStyle -> Maybe TextStyle -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe TextStyle
newTextStyle
    newLines :: Seq TextLine
newLines
      | Bool -> Bool
not Bool
newGlyphsReq = Seq TextLine
textLines
      | Bool
otherwise = Seq TextLine
newTextLines

    (Int
prevTs, Bool
prevStep) = (Int, Bool)
prevResize
    needsSndResize :: Bool
needsSndResize = TextMode
mode TextMode -> TextMode -> Bool
forall a. Eq a => a -> a -> Bool
== TextMode
MultiLine Bool -> Bool -> Bool
&& (Int
prevTs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
ts Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
prevStep)

    newState :: LabelState
newState = LabelState
state {
      _lstTextStyle :: Maybe TextStyle
_lstTextStyle = Maybe TextStyle
newTextStyle,
      _lstTextRect :: Rect
_lstTextRect = Rect
crect,
      _lstTextLines :: Seq TextLine
_lstTextLines = Seq TextLine
newLines,
      _lstPrevResize :: (Int, Bool)
_lstPrevResize = (Int
ts, Bool
needsSndResize Bool -> Bool -> Bool
&& Int
prevTs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ts)
    }
    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
.~ LabelCfg s e -> LabelState -> Widget s e
forall s e. LabelCfg s e -> LabelState -> Widget s e
makeLabel LabelCfg s e
config LabelState
newState
    result :: WidgetResult s e
result = 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 [WidgetId -> WidgetRequest s e
forall s e. WidgetId -> WidgetRequest s e
ResizeWidgets WidgetId
widgetId | Bool
needsSndResize]

  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 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Renderer -> Rect -> StyleState -> (Rect -> IO ()) -> IO ()
drawStyledAction Renderer
renderer Rect
viewport StyleState
style ((Rect -> IO ()) -> IO ()) -> (Rect -> IO ()) -> IO ()
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) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          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
      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 WidgetNode s e -> Getting Rect (WidgetNode s e) Rect -> Rect
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const Rect WidgetNodeInfo)
-> WidgetNode s e -> Const Rect (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const Rect WidgetNodeInfo)
 -> WidgetNode s e -> Const Rect (WidgetNode s e))
-> ((Rect -> Const Rect Rect)
    -> WidgetNodeInfo -> Const Rect WidgetNodeInfo)
-> Getting Rect (WidgetNode s e) Rect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rect -> Const Rect Rect)
-> WidgetNodeInfo -> Const Rect WidgetNodeInfo
forall s a. HasViewport s a => Lens' s a
L.viewport
      textMetrics :: Maybe TextMetrics
textMetrics = Seq TextLine
textLines Seq TextLine
-> Getting (First TextMetrics) (Seq TextLine) TextMetrics
-> Maybe TextMetrics
forall s a. s -> Getting (First a) s a -> Maybe a
^? Index (Seq TextLine)
-> Traversal' (Seq TextLine) (IxValue (Seq TextLine))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (Seq TextLine)
0 ((TextLine -> Const (First TextMetrics) TextLine)
 -> Seq TextLine -> Const (First TextMetrics) (Seq TextLine))
-> ((TextMetrics -> Const (First TextMetrics) TextMetrics)
    -> TextLine -> Const (First TextMetrics) TextLine)
-> Getting (First TextMetrics) (Seq TextLine) TextMetrics
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextMetrics -> Const (First TextMetrics) TextMetrics)
-> TextLine -> Const (First TextMetrics) TextLine
forall s a. HasMetrics s a => Lens' s a
L.metrics
      desc :: Double
desc = Double -> Double
forall a. Num a => a -> a
abs (Maybe TextMetrics
textMetrics Maybe TextMetrics
-> Getting Double (Maybe TextMetrics) Double -> Double
forall s a. s -> Getting a s a -> a
^. TextMetrics -> Iso' (Maybe TextMetrics) TextMetrics
forall a. Eq a => a -> Iso' (Maybe a) a
non TextMetrics
forall a. Default a => a
def ((TextMetrics -> Const Double TextMetrics)
 -> Maybe TextMetrics -> Const Double (Maybe TextMetrics))
-> ((Double -> Const Double Double)
    -> TextMetrics -> Const Double TextMetrics)
-> Getting Double (Maybe TextMetrics) Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Const Double Double)
-> TextMetrics -> Const Double TextMetrics
forall s a. HasDesc s a => Lens' s a
L.desc)
      scissorVp :: Rect
scissorVp = Rect
viewport
        Rect -> (Rect -> Rect) -> Rect
forall a b. a -> (a -> b) -> b
& (Double -> Identity Double) -> Rect -> Identity Rect
forall s a. HasY s a => Lens' s a
L.y ((Double -> Identity Double) -> Rect -> Identity Rect)
-> Double -> Rect -> Rect
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Rect
viewport Rect -> Getting Double Rect Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double Rect Double
forall s a. HasY s a => Lens' s a
L.y Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
desc)
        Rect -> (Rect -> Rect) -> Rect
forall a b. a -> (a -> b) -> b
& (Double -> Identity Double) -> Rect -> Identity Rect
forall s a. HasH s a => Lens' s a
L.h ((Double -> Identity Double) -> Rect -> Identity Rect)
-> Double -> Rect -> Rect
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Rect
viewport Rect -> Getting Double Rect Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double Rect Double
forall s a. HasH s a => Lens' s a
L.h Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
desc)