{-# 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 = 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 {
_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 a. Maybe a -> Maybe a -> Maybe a
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 a. Maybe a -> Maybe a -> Maybe a
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 a. Maybe a -> Maybe a -> Maybe a
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 a. Maybe a -> Maybe a -> Maybe a
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 a. Maybe a -> Maybe a -> Maybe a
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 a. Maybe a -> Maybe a -> Maybe a
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 a. Maybe a -> Maybe a -> Maybe a
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 a. Maybe a -> Maybe a -> Maybe a
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 = Just 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 = Just 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 = Just 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 = Just 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 = Just 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 = Just s,
_lscFactorH = Just 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 = Just w
}
resizeFactorH :: Double -> LabelCfg s e
resizeFactorH Double
h = LabelCfg s e
forall a. Default a => a
def {
_lscFactorH = Just 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 = LabelCfg Any Any
forall a. Default a => a
def {
_lscCurrentStyle = Just 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
(LabelState -> LabelState -> Bool)
-> (LabelState -> LabelState -> Bool) -> Eq LabelState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LabelState -> LabelState -> Bool
== :: LabelState -> LabelState -> Bool
$c/= :: LabelState -> LabelState -> Bool
/= :: 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
$cshowsPrec :: Int -> LabelState -> ShowS
showsPrec :: Int -> LabelState -> ShowS
$cshow :: LabelState -> String
show :: LabelState -> String
$cshowList :: [LabelState] -> ShowS
showList :: [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
$cfrom :: forall x. LabelState -> Rep LabelState x
from :: forall x. LabelState -> Rep LabelState x
$cto :: forall x. Rep LabelState x -> LabelState
to :: forall x. Rep LabelState x -> LabelState
Generic)
label
:: Text
-> WidgetNode s e
label :: forall s e. 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
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 = 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
-> StyleState
-> Rect
-> Seq TextLine
-> (Millisecond, Bool)
-> LabelState
LabelState Text
caption StyleState
forall a. Default a => a
def Rect
forall a. Default a => a
def Seq TextLine
forall a. Seq a
Seq.Empty (Millisecond
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
labelS
:: Show a
=> a
-> WidgetNode s e
labelS :: forall a s e. Show a => 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
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 = 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 :: 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 = 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 = getBaseStyle,
singleInit = init,
singleMerge = merge,
singleGetSizeReq = getSizeReq,
singleResize = resize
}
widget :: Widget s e
widget = Widget s e
baseWidget {
widgetRender = 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 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 = 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 (StyleState -> f StyleState) -> ThemeState -> f ThemeState
forall s a. HasLabelStyle s a => Lens' s a
Lens' ThemeState StyleState
L.labelStyle
init :: WidgetEnv s e -> WidgetNode s e -> WidgetResult 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 {
_lstStyle = style
}
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
Lens' (WidgetNode s e) (Widget s e)
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
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 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
Lens' (WidgetNode s e) WidgetNodeInfo
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
Lens' WidgetNodeInfo WidgetId
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 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
caption
styleChanged :: Bool
styleChanged = StyleState
prevStyle 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
Lens' StyleState (Maybe TextStyle)
L.text Maybe TextStyle -> Maybe TextStyle -> Bool
forall a. Eq a => a -> a -> Bool
/= 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
Lens' StyleState (Maybe TextStyle)
L.text
Bool -> Bool -> Bool
|| StyleState
prevStyle StyleState
-> Getting (Maybe Padding) StyleState (Maybe Padding)
-> Maybe Padding
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Padding) StyleState (Maybe Padding)
forall s a. HasPadding s a => Lens' s a
Lens' StyleState (Maybe Padding)
L.padding Maybe Padding -> Maybe Padding -> Bool
forall a. Eq a => a -> a -> Bool
/= StyleState
style StyleState
-> Getting (Maybe Padding) StyleState (Maybe Padding)
-> Maybe Padding
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Padding) StyleState (Maybe Padding)
forall s a. HasPadding s a => Lens' s a
Lens' StyleState (Maybe Padding)
L.padding
Bool -> Bool -> Bool
|| StyleState
prevStyle StyleState
-> Getting (Maybe Border) StyleState (Maybe Border) -> Maybe Border
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Border) StyleState (Maybe Border)
forall s a. HasBorder s a => Lens' s a
Lens' StyleState (Maybe Border)
L.border Maybe Border -> Maybe Border -> Bool
forall a. Eq a => a -> a -> Bool
/= StyleState
style StyleState
-> Getting (Maybe Border) StyleState (Maybe Border) -> Maybe Border
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Border) StyleState (Maybe Border)
forall s a. HasBorder s a => Lens' s a
Lens' StyleState (Maybe Border)
L.border
Bool -> Bool -> Bool
|| StyleState
prevStyle 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. HasSizeReqH s a => Lens' s a
Lens' StyleState (Maybe SizeReq)
L.sizeReqH Maybe SizeReq -> Maybe SizeReq -> Bool
forall a. Eq a => a -> a -> Bool
/= 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. HasSizeReqH s a => Lens' s a
Lens' StyleState (Maybe SizeReq)
L.sizeReqH
Bool -> Bool -> Bool
|| StyleState
prevStyle 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
Lens' StyleState (Maybe SizeReq)
L.sizeReqW Maybe SizeReq -> Maybe SizeReq -> Bool
forall a. Eq a => a -> a -> Bool
/= 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
Lens' StyleState (Maybe SizeReq)
L.sizeReqW
changeReq :: Bool
changeReq = Bool
captionChanged Bool -> Bool -> Bool
|| Bool
styleChanged
newRect :: Rect
newRect
| Bool
changeReq = Rect
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 = [ 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
Lens' (WidgetNode s e) (Widget s e)
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 :: WidgetEnv s e -> WidgetNode s e -> (SizeReq, SizeReq)
getSizeReq WidgetEnv s e
wenv WidgetNode s e
node = (SizeReq
sizeW, SizeReq
sizeH) where
ts :: Millisecond
ts = WidgetEnv s e
wenv WidgetEnv s e
-> Getting Millisecond (WidgetEnv s e) Millisecond -> Millisecond
forall s a. s -> Getting a s a -> a
^. Getting Millisecond (WidgetEnv s e) Millisecond
forall s a. HasTimestamp s a => Lens' s a
Lens' (WidgetEnv s e) Millisecond
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 = 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
Lens' Rect Double
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
&& (Millisecond, Bool)
prevResize (Millisecond, Bool) -> (Millisecond, Bool) -> Bool
forall a. Eq a => a -> a -> Bool
== (Millisecond
ts, Bool
True) = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
cw
| Bool
otherwise = (SizeReq -> Double) -> Maybe SizeReq -> Maybe Double
forall a b. (a -> b) -> Maybe a -> Maybe b
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
Lens' StyleState (Maybe SizeReq)
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 :: WidgetEnv s e -> WidgetNode s e -> Rect -> WidgetResult 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
Lens' (WidgetEnv s e) FontManager
L.fontManager
ts :: Millisecond
ts = WidgetEnv s e
wenv WidgetEnv s e
-> Getting Millisecond (WidgetEnv s e) Millisecond -> Millisecond
forall s a. s -> Getting a s a -> a
^. Getting Millisecond (WidgetEnv s e) Millisecond
forall s a. HasTimestamp s a => Lens' s a
Lens' (WidgetEnv s e) Millisecond
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
Lens' (WidgetNode s e) WidgetNodeInfo
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
Lens' WidgetNodeInfo WidgetId
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)
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 Rect -> Rect -> Bool
forall a. Eq a => a -> a -> Bool
== Rect
crect
(Millisecond
tsResized, Bool
alreadyResized) = (Millisecond, Bool)
resizeStep
resizeAgain :: Bool
resizeAgain = TextMode
mode TextMode -> TextMode -> Bool
forall a. Eq a => a -> a -> Bool
== TextMode
MultiLine Bool -> Bool -> Bool
&& (Millisecond
tsResized Millisecond -> Millisecond -> Bool
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 Millisecond -> Millisecond -> Bool
forall a. Eq a => a -> a -> Bool
== Millisecond
ts)
newState :: LabelState
newState = LabelState
state {
_lstStyle = style,
_lstTextRect = crect,
_lstTextLines = newTextLines,
_lstResizeStep = (ts, isResized)
}
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
Lens' (WidgetNode s e) (Widget s e)
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
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 (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
Lens' (WidgetNode s e) WidgetNodeInfo
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
Lens' WidgetNodeInfo Rect
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 Int
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
Lens' TextLine TextMetrics
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
Lens' TextMetrics Double
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
Lens' Rect Double
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
Lens' Rect Double
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
Lens' Rect Double
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
Lens' Rect Double
L.h Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
desc)