{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE Strict #-}
module Monomer.Widgets.Singles.Label (
LabelCfg,
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
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
}
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)
label
:: Text
-> WidgetNode s e
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
label_
:: Text
-> [LabelCfg s e]
-> WidgetNode s e
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
labelS
:: Show a
=> a
-> WidgetNode s e
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
labelS_
:: Show a
=> a
-> [LabelCfg s e]
-> WidgetNode s e
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
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)