From da7c188ac3667f32f2e3bfbd44d7811271e13dde Mon Sep 17 00:00:00 2001 From: jappeace-sloth Date: Tue, 14 Jul 2026 14:53:57 +0200 Subject: [PATCH] Move text color from WidgetStyle into the text-bearing configs Resolves #242 by the tcFontConfig precedent: tcTextColor, bcTextColor and tiTextColor live on the configs that own glyphs, wsTextColor is gone, and a text color on a container is unrepresentable instead of a silent no-op. The renderer applies the config color on create and on config-diff updates, mirroring applyFontConfig (including its stays-until-replaced behaviour, documented on the field). A new coloredText smart constructor covers the common case. Keyframe animation of text color is removed with the field: no demo or consumer animated it (only a lerp unit test, migrated to background color, which remains animatable). All construction sites across src, tests and demos gained the new fields; the exception-handler error widget was the sneaky one, caught by the suite at runtime as a missing-field crash. Prompt: okay do the tcFontConfig precedent so we never get this issue again Co-Authored-By: Claude Fable 5 --- Changelog.md | 11 ++ src/Hatter.hs | 3 + src/Hatter/Animation.hs | 3 - src/Hatter/Render.hs | 24 +++- src/Hatter/Widget.hs | 26 ++++- test/AnimationDemoMain.hs | 2 + test/AsyncOomDemoMain.hs | 2 +- test/AuthSessionDemoMain.hs | 3 +- test/BleDemoMain.hs | 4 +- test/BottomSheetDemoMain.hs | 3 +- test/CameraDemoMain.hs | 3 +- test/ConfettiRepDemoMain.hs | 3 + test/ConsumerDepsMain.hs | 2 +- test/CounterDemoMain.hs | 7 +- test/DeviceInfoDemoMain.hs | 2 +- test/DialogDemoMain.hs | 4 +- test/FilesDirDemoMain.hs | 4 +- test/HorizontalScrollDemoMain.hs | 2 +- test/HttpDemoMain.hs | 3 +- test/ImageDemoMain.hs | 2 +- test/KeyframeDemoMain.hs | 4 + test/LocationDemoMain.hs | 6 +- test/MapViewDemoMain.hs | 2 +- test/NetworkStatusDemoMain.hs | 6 +- test/NodePoolTestMain.hs | 1 + test/PermissionDemoMain.hs | 3 +- test/PlatformSignInDemoMain.hs | 4 +- test/RedrawDemoMain.hs | 1 + test/ScrollDemoMain.hs | 4 +- test/ScrollTextInputDemoMain.hs | 8 +- test/ScrollViewSwitchDemoMain.hs | 3 + test/SecureStorageDemoMain.hs | 6 +- test/StackDemoMain.hs | 3 + test/StyledTypeChangeDemoMain.hs | 9 +- test/THDemoMain.hs | 2 +- test/THDirectMain.hs | 2 +- test/Test/ActionTests.hs | 94 ++++++++-------- test/Test/AnimationTests.hs | 54 ++++----- test/Test/AppContextTests.hs | 13 ++- test/Test/Helpers.hs | 4 +- test/Test/PlatformTests.hs | 18 +-- test/Test/WidgetTests.hs | 179 ++++++++++++++++-------------- test/TextInputDemoMain.hs | 4 +- test/TextInputReRenderDemoMain.hs | 2 + test/WebViewDemoMain.hs | 3 +- 45 files changed, 322 insertions(+), 226 deletions(-) diff --git a/Changelog.md b/Changelog.md index 97e4dd5a..7d4671a1 100644 --- a/Changelog.md +++ b/Changelog.md @@ -2,6 +2,17 @@ ## Unreleased +### Changed + +- BREAKING: text color moved from `WidgetStyle` into the text-bearing + configs (`tcTextColor` / `bcTextColor` / `tiTextColor`, next to the + font override), following the `tcFontConfig` precedent. A text + color can no longer be attached to a container node, where it + silently changed nothing (#242); the new `coloredText` smart + constructor covers the common case. Keyframe animation of text + color went with the field (nothing used it; animate the background + color instead). + ### Added - Scan results now carry the advertisement's service data and diff --git a/src/Hatter.hs b/src/Hatter.hs index cbc02cf4..47a1e0ea 100644 --- a/src/Hatter.hs +++ b/src/Hatter.hs @@ -305,15 +305,18 @@ errorWidget dismissAction exc = column [ Text TextConfig { tcLabel = "An error occurred" , tcFontConfig = Just (FontConfig 20.0) + , tcTextColor = Nothing } , Text TextConfig { tcLabel = pack (show exc) , tcFontConfig = Nothing + , tcTextColor = Nothing } , Button ButtonConfig { bcLabel = "Dismiss" , bcAction = dismissAction , bcFontConfig = Nothing + , bcTextColor = Nothing } ] diff --git a/src/Hatter/Animation.hs b/src/Hatter/Animation.hs index 04929e4e..c1859913 100644 --- a/src/Hatter/Animation.hs +++ b/src/Hatter/Animation.hs @@ -184,7 +184,6 @@ defaultStyleEmpty :: WidgetStyle defaultStyleEmpty = WidgetStyle { wsPadding = Nothing , wsTextAlign = Nothing - , wsTextColor = Nothing , wsBackgroundColor = Nothing , wsTranslateX = Nothing , wsTranslateY = Nothing @@ -212,8 +211,6 @@ interpolateStyle :: Int32 -> WidgetStyle -> WidgetStyle -> Double -> IO () interpolateStyle nodeId fromStyle toStyle progress = do lerpNumProp Bridge.PropPadding (wsPadding fromStyle) (wsPadding toStyle) - lerpColorProp Bridge.PropColor - (wsTextColor fromStyle) (wsTextColor toStyle) lerpColorProp Bridge.PropBgColor (wsBackgroundColor fromStyle) (wsBackgroundColor toStyle) lerpNumProp Bridge.PropTranslateX diff --git a/src/Hatter/Render.hs b/src/Hatter/Render.hs index 5170e665..63dd387e 100644 --- a/src/Hatter/Render.hs +++ b/src/Hatter/Render.hs @@ -33,7 +33,7 @@ import Data.List (sortBy) import Data.Ord (comparing) import Unwitch.Convert.Int32 qualified as Int32 import Hatter.Animation (AnimationState, registerTween) -import Hatter.Widget (AnimatedConfig(..), ButtonConfig(..), FontConfig(..), ImageConfig(..), ImageSource(..), InputType(..), Keyframe(..), LayoutItem(..), LayoutSettings(..), MapViewConfig(..), ResourceName(..), ScaleType(..), TextAlignment(..), TextConfig(..), TextInputConfig(..), WebViewConfig(..), Widget(..), WidgetStyle(..), colorToHex, normalizeAnimated, resolveKeyAtIndex) +import Hatter.Widget (AnimatedConfig(..), ButtonConfig(..), Color, FontConfig(..), ImageConfig(..), ImageSource(..), InputType(..), Keyframe(..), LayoutItem(..), LayoutSettings(..), MapViewConfig(..), ResourceName(..), ScaleType(..), TextAlignment(..), TextConfig(..), TextInputConfig(..), WebViewConfig(..), Widget(..), WidgetStyle(..), colorToHex, normalizeAnimated, resolveKeyAtIndex) import Hatter.UIBridge qualified as Bridge import System.IO (hPutStrLn, stderr) @@ -132,6 +132,13 @@ applyFontConfig nodeId (Just (FontConfig size)) = Bridge.setNumProp nodeId Bridge.PropFontSize size applyFontConfig _nodeId Nothing = pure () +-- | Apply a text color to a rendered node if present (the per-config +-- color, see 'tcTextColor'). +applyTextColor :: Int32 -> Maybe Color -> IO () +applyTextColor nodeId (Just color) = + Bridge.setStrProp nodeId Bridge.PropColor (colorToHex color) +applyTextColor _nodeId Nothing = pure () + -- | Map a 'ScaleType' to the numeric code sent to the platform bridge. scaleTypeToDouble :: ScaleType -> Double scaleTypeToDouble ScaleFit = 0 @@ -154,9 +161,6 @@ applyStyle nodeId style = do case wsTextAlign style of Just alignment -> Bridge.setNumProp nodeId Bridge.PropGravity (textAlignToDouble alignment) Nothing -> pure () - case wsTextColor style of - Just color -> Bridge.setStrProp nodeId Bridge.PropColor (colorToHex color) - Nothing -> pure () case wsBackgroundColor style of Just color -> Bridge.setStrProp nodeId Bridge.PropBgColor (colorToHex color) Nothing -> pure () @@ -197,12 +201,14 @@ createRenderedNode _animState widget@(Text config) = do nodeId <- Bridge.createNode Bridge.NodeText Bridge.setStrProp nodeId Bridge.PropText (tcLabel config) applyFontConfig nodeId (tcFontConfig config) + applyTextColor nodeId (tcTextColor config) pure (RenderedLeaf widget nodeId) createRenderedNode _animState widget@(Button config) = do nodeId <- Bridge.createNode Bridge.NodeButton Bridge.setStrProp nodeId Bridge.PropText (bcLabel config) Bridge.setHandler nodeId Bridge.EventClick (actionId (bcAction config)) applyFontConfig nodeId (bcFontConfig config) + applyTextColor nodeId (bcTextColor config) pure (RenderedLeaf widget nodeId) createRenderedNode _animState widget@(TextInput config) = do nodeId <- Bridge.createNode Bridge.NodeTextInput @@ -211,6 +217,7 @@ createRenderedNode _animState widget@(TextInput config) = do Bridge.setNumProp nodeId Bridge.PropInputType (Int32.toDouble (inputTypeToInt (tiInputType config))) Bridge.setHandler nodeId Bridge.EventTextChange (onChangeId (tiOnChange config)) applyFontConfig nodeId (tiFontConfig config) + applyTextColor nodeId (tiTextColor config) when (tiAutoFocus config) $ Bridge.setNumProp nodeId Bridge.PropAutoFocus 1.0 pure (RenderedLeaf widget nodeId) @@ -404,6 +411,9 @@ diffRenderNode _animState (Just (RenderedLeaf (Text oldConfig) nodeId)) newWidge if tcFontConfig oldConfig /= tcFontConfig newConfig then applyFontConfig nodeId (tcFontConfig newConfig) else pure () + if tcTextColor oldConfig /= tcTextColor newConfig + then applyTextColor nodeId (tcTextColor newConfig) + else pure () pure (RenderedLeaf newWidget nodeId) -- Case: Button in-place update — keep native node, only update changed @@ -418,6 +428,9 @@ diffRenderNode _animState (Just (RenderedLeaf (Button oldConfig) nodeId)) newWid if bcFontConfig oldConfig /= bcFontConfig newConfig then applyFontConfig nodeId (bcFontConfig newConfig) else pure () + if bcTextColor oldConfig /= bcTextColor newConfig + then applyTextColor nodeId (bcTextColor newConfig) + else pure () pure (RenderedLeaf newWidget nodeId) -- Case: TextInput in-place update — keep native node to preserve @@ -441,6 +454,9 @@ diffRenderNode _animState (Just (RenderedLeaf (TextInput oldConfig) nodeId)) new if tiFontConfig oldConfig /= tiFontConfig newConfig then applyFontConfig nodeId (tiFontConfig newConfig) else pure () + if tiTextColor oldConfig /= tiTextColor newConfig + then applyTextColor nodeId (tiTextColor newConfig) + else pure () pure (RenderedLeaf newWidget nodeId) -- Case 5/6: Same leaf type with different properties, or completely different diff --git a/src/Hatter/Widget.hs b/src/Hatter/Widget.hs index bef08704..d0440f3f 100644 --- a/src/Hatter/Widget.hs +++ b/src/Hatter/Widget.hs @@ -61,6 +61,7 @@ module Hatter.Widget , scrollColumn , scrollRow , text + , coloredText , stack ) where @@ -89,6 +90,13 @@ data TextConfig = TextConfig -- ^ The text content to display. , tcFontConfig :: Maybe FontConfig -- ^ Optional font override. + , tcTextColor :: Maybe Color + -- ^ Optional text color. Lives on the text-bearing configs (like + -- 'tcFontConfig') rather than in 'WidgetStyle', so a text color + -- can never be attached to a container node, where it would + -- silently change nothing (issue #242). Like the font override, + -- a previously set color stays on the native node until another + -- color replaces it. } deriving (Show, Eq) -- | Configuration for a tappable button. @@ -99,6 +107,8 @@ data ButtonConfig = ButtonConfig -- ^ Handle for the callback fired when the button is tapped. , bcFontConfig :: Maybe FontConfig -- ^ Optional font override. + , bcTextColor :: Maybe Color + -- ^ Optional label color, see 'tcTextColor'. } deriving (Show, Eq) -- | The kind of on-screen keyboard to show for a 'TextInput'. @@ -120,6 +130,8 @@ data TextInputConfig = TextInputConfig -- ^ Handle for the callback fired when the user edits the field. , tiFontConfig :: Maybe FontConfig -- ^ Optional font override. + , tiTextColor :: Maybe Color + -- ^ Optional text color, see 'tcTextColor'. , tiAutoFocus :: Bool -- ^ Whether this input should receive focus when rendered. -- On Android, defers @requestFocus()@ via @View.post()@ to ensure the @@ -179,8 +191,6 @@ data WidgetStyle = WidgetStyle -- ^ Uniform padding in platform-native units (px on Android, pt on iOS). , wsTextAlign :: Maybe TextAlignment -- ^ Horizontal text alignment override. - , wsTextColor :: Maybe Color - -- ^ Text color. , wsBackgroundColor :: Maybe Color -- ^ Background color. , wsTranslateX :: Maybe Double @@ -204,7 +214,6 @@ defaultStyle :: WidgetStyle defaultStyle = WidgetStyle { wsPadding = Nothing , wsTextAlign = Nothing - , wsTextColor = Nothing , wsBackgroundColor = Nothing , wsTranslateX = Nothing , wsTranslateY = Nothing @@ -313,7 +322,6 @@ lerpStyle :: Double -> WidgetStyle -> WidgetStyle -> WidgetStyle lerpStyle t from to = WidgetStyle { wsPadding = lerpMaybeDouble (wsPadding from) (wsPadding to) , wsTextAlign = snapMaybe (wsTextAlign from) (wsTextAlign to) - , wsTextColor = lerpMaybeColor (wsTextColor from) (wsTextColor to) , wsBackgroundColor = lerpMaybeColor (wsBackgroundColor from) (wsBackgroundColor to) , wsTranslateX = lerpMaybeDouble (wsTranslateX from) (wsTranslateX to) , wsTranslateY = lerpMaybeDouble (wsTranslateY from) (wsTranslateY to) @@ -488,10 +496,16 @@ data LayoutSettings = LayoutSettings } deriving (Show, Eq) text :: Text -> Widget -text txt = Text $ TextConfig { tcLabel = txt, tcFontConfig = Nothing } +text txt = Text $ TextConfig { tcLabel = txt, tcFontConfig = Nothing, tcTextColor = Nothing } + +-- | Build a read-only text label with a text color. +coloredText :: Color -> Text -> Widget +coloredText color txt = + Text $ TextConfig { tcLabel = txt, tcFontConfig = Nothing, tcTextColor = Just color } button :: Text -> Action -> Widget -button txt action = Button $ ButtonConfig { bcLabel = txt, bcAction = action, bcFontConfig = Nothing } +button txt action = Button $ ButtonConfig + { bcLabel = txt, bcAction = action, bcFontConfig = Nothing, bcTextColor = Nothing } -- | Wrap a widget in a 'LayoutItem' with no explicit key. -- The diff algorithm will use the child's list index as its key. diff --git a/test/AnimationDemoMain.hs b/test/AnimationDemoMain.hs index a636b830..31ad0f56 100644 --- a/test/AnimationDemoMain.hs +++ b/test/AnimationDemoMain.hs @@ -52,11 +52,13 @@ main = do Text TextConfig { tcLabel = "Animated padding" , tcFontConfig = Nothing + , tcTextColor = Nothing } , Button ButtonConfig { bcLabel = "Toggle Padding" , bcAction = toggleAction , bcFontConfig = Nothing + , bcTextColor = Nothing } ] app = MobileApp diff --git a/test/AsyncOomDemoMain.hs b/test/AsyncOomDemoMain.hs index 06d16bbc..2ca360f4 100644 --- a/test/AsyncOomDemoMain.hs +++ b/test/AsyncOomDemoMain.hs @@ -25,6 +25,6 @@ main = do actionState <- newActionState startMobileApp MobileApp { maContext = loggingMobileContext - , maView = \_userState -> pure (Text TextConfig { tcLabel = "Async loaded", tcFontConfig = Nothing }) + , maView = \_userState -> pure (Text TextConfig { tcLabel = "Async loaded", tcFontConfig = Nothing, tcTextColor = Nothing }) , maActionState = actionState } diff --git a/test/AuthSessionDemoMain.hs b/test/AuthSessionDemoMain.hs index 16b28330..b9a88b78 100644 --- a/test/AuthSessionDemoMain.hs +++ b/test/AuthSessionDemoMain.hs @@ -57,10 +57,11 @@ main = do -- | Builds a Column with a label and a "Start Login" button. authSessionDemoView :: Action -> IO Widget authSessionDemoView onStartLogin = pure $ column - [ Text TextConfig { tcLabel = "AuthSession Demo", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "AuthSession Demo", tcFontConfig = Nothing, tcTextColor = Nothing } , Button ButtonConfig { bcLabel = "Start Login" , bcAction = onStartLogin , bcFontConfig = Nothing + , bcTextColor = Nothing } ] diff --git a/test/BleDemoMain.hs b/test/BleDemoMain.hs index d5122a58..f07975ce 100644 --- a/test/BleDemoMain.hs +++ b/test/BleDemoMain.hs @@ -232,11 +232,11 @@ logDiscoveredCharacteristic discovered = platformLog -- | Builds a Column with a label and one button per BLE action. bleDemoView :: [(Text, Action)] -> IO Widget bleDemoView actions = pure $ column - ( Text TextConfig { tcLabel = "BLE Demo", tcFontConfig = Nothing } + ( Text TextConfig { tcLabel = "BLE Demo", tcFontConfig = Nothing, tcTextColor = Nothing } : map actionButton actions ) -- | A button for one labelled action. actionButton :: (Text, Action) -> Widget actionButton (label, action) = Button ButtonConfig - { bcLabel = label, bcAction = action, bcFontConfig = Nothing } + { bcLabel = label, bcAction = action, bcFontConfig = Nothing, bcTextColor = Nothing } diff --git a/test/BottomSheetDemoMain.hs b/test/BottomSheetDemoMain.hs index 3c8c17d4..c998a9a4 100644 --- a/test/BottomSheetDemoMain.hs +++ b/test/BottomSheetDemoMain.hs @@ -48,10 +48,11 @@ main = do -- | Builds a Column with a label and a "Show Actions" button. bottomSheetDemoView :: Action -> IO Widget bottomSheetDemoView onShowActions = pure $ column - [ Text TextConfig { tcLabel = "BottomSheet Demo", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "BottomSheet Demo", tcFontConfig = Nothing, tcTextColor = Nothing } , Button ButtonConfig { bcLabel = "Show Actions" , bcAction = onShowActions , bcFontConfig = Nothing + , bcTextColor = Nothing } ] diff --git a/test/CameraDemoMain.hs b/test/CameraDemoMain.hs index 70099ef5..204d9e14 100644 --- a/test/CameraDemoMain.hs +++ b/test/CameraDemoMain.hs @@ -64,10 +64,11 @@ main = do -- | Builds a Column with a label and a "Capture Photo" button. cameraDemoView :: Action -> IO Widget cameraDemoView onCapturePhoto = pure $ column - [ Text TextConfig { tcLabel = "Camera Demo", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "Camera Demo", tcFontConfig = Nothing, tcTextColor = Nothing } , Button ButtonConfig { bcLabel = "Capture Photo" , bcAction = onCapturePhoto , bcFontConfig = Nothing + , bcTextColor = Nothing } ] diff --git a/test/ConfettiRepDemoMain.hs b/test/ConfettiRepDemoMain.hs index 02b2f681..404af416 100644 --- a/test/ConfettiRepDemoMain.hs +++ b/test/ConfettiRepDemoMain.hs @@ -41,6 +41,7 @@ confettiParticle offsetX offsetY = Text TextConfig { tcLabel = "*" , tcFontConfig = Nothing + , tcTextColor = Nothing } -- | Five confetti particles with fixed offsets. @@ -72,6 +73,7 @@ main = do { bcLabel = "Confetti Active" , bcAction = triggerAction , bcFontConfig = Nothing + , bcTextColor = Nothing } ]) else column @@ -79,6 +81,7 @@ main = do { bcLabel = "Trigger Confetti" , bcAction = triggerAction , bcFontConfig = Nothing + , bcTextColor = Nothing } ] app = MobileApp diff --git a/test/ConsumerDepsMain.hs b/test/ConsumerDepsMain.hs index eac89abb..65fbb5c1 100644 --- a/test/ConsumerDepsMain.hs +++ b/test/ConsumerDepsMain.hs @@ -19,6 +19,6 @@ main = do actionState <- newActionState startMobileApp MobileApp { maContext = loggingMobileContext - , maView = \_userState -> pure (Text TextConfig { tcLabel = "consumer-deps", tcFontConfig = Nothing }) + , maView = \_userState -> pure (Text TextConfig { tcLabel = "consumer-deps", tcFontConfig = Nothing, tcTextColor = Nothing }) , maActionState = actionState } diff --git a/test/CounterDemoMain.hs b/test/CounterDemoMain.hs index 06d3d6d1..cb92c6e5 100644 --- a/test/CounterDemoMain.hs +++ b/test/CounterDemoMain.hs @@ -32,14 +32,15 @@ counterView :: IORef Int -> Action -> Action -> IO Widget counterView counterState onIncrement onDecrement = do n <- readIORef counterState pure $ column - [ Styled (WidgetStyle (Just 16.0) (Just AlignCenter) (Just (Color 255 0 0 255)) (Just (Color 0 255 0 255)) Nothing Nothing Nothing) + [ Styled (WidgetStyle (Just 16.0) (Just AlignCenter) (Just (Color 0 255 0 255)) Nothing Nothing Nothing) (Text TextConfig { tcLabel = "Counter: " <> Text.pack (show n) , tcFontConfig = Just (FontConfig 24.0) + , tcTextColor = Just (Color 255 0 0 255) }) , row [ Button ButtonConfig - { bcLabel = "+", bcAction = onIncrement, bcFontConfig = Nothing } + { bcLabel = "+", bcAction = onIncrement, bcFontConfig = Nothing, bcTextColor = Nothing } , Button ButtonConfig - { bcLabel = "-", bcAction = onDecrement, bcFontConfig = Nothing } + { bcLabel = "-", bcAction = onDecrement, bcFontConfig = Nothing, bcTextColor = Nothing } ] ] diff --git a/test/DeviceInfoDemoMain.hs b/test/DeviceInfoDemoMain.hs index 98d7fdc0..9a25a0d2 100644 --- a/test/DeviceInfoDemoMain.hs +++ b/test/DeviceInfoDemoMain.hs @@ -55,4 +55,4 @@ deviceInfoDemoView = do -- | A text widget showing a label-value pair. infoRow :: Text -> Text -> Widget infoRow label value = - Text TextConfig { tcLabel = label <> ": " <> value, tcFontConfig = Nothing } + Text TextConfig { tcLabel = label <> ": " <> value, tcFontConfig = Nothing, tcTextColor = Nothing } diff --git a/test/DialogDemoMain.hs b/test/DialogDemoMain.hs index f3b281c2..a3f3e2ca 100644 --- a/test/DialogDemoMain.hs +++ b/test/DialogDemoMain.hs @@ -66,15 +66,17 @@ main = do -- | Builds a Column with a label, a "Show Alert" button, and a "Show Confirm" button. dialogDemoView :: Action -> Action -> IO Widget dialogDemoView onShowAlert onShowConfirm = pure $ column - [ Text TextConfig { tcLabel = "Dialog Demo", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "Dialog Demo", tcFontConfig = Nothing, tcTextColor = Nothing } , Button ButtonConfig { bcLabel = "Show Alert" , bcAction = onShowAlert , bcFontConfig = Nothing + , bcTextColor = Nothing } , Button ButtonConfig { bcLabel = "Show Confirm" , bcAction = onShowConfirm , bcFontConfig = Nothing + , bcTextColor = Nothing } ] diff --git a/test/FilesDirDemoMain.hs b/test/FilesDirDemoMain.hs index b16f2680..f2b932df 100644 --- a/test/FilesDirDemoMain.hs +++ b/test/FilesDirDemoMain.hs @@ -59,6 +59,6 @@ filesDirDemoView :: IO Widget filesDirDemoView = do filesDir <- getAppFilesDir pure $ column - [ Text TextConfig { tcLabel = "FilesDir Demo", tcFontConfig = Nothing } - , Text TextConfig { tcLabel = pack filesDir, tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "FilesDir Demo", tcFontConfig = Nothing, tcTextColor = Nothing } + , Text TextConfig { tcLabel = pack filesDir, tcFontConfig = Nothing, tcTextColor = Nothing } ] diff --git a/test/HorizontalScrollDemoMain.hs b/test/HorizontalScrollDemoMain.hs index 8f46f2db..fbdecf14 100644 --- a/test/HorizontalScrollDemoMain.hs +++ b/test/HorizontalScrollDemoMain.hs @@ -31,5 +31,5 @@ horizontalScrollDemoView :: Action -> Action -> IO Widget horizontalScrollDemoView noopAction onReachedEnd = pure $ Row (LayoutSettings ( map (\itemNumber -> item (button ("Item " <> Text.pack (show (itemNumber :: Int))) noopAction)) [1..20] ++ [item (Button ButtonConfig - { bcLabel = "Reached End", bcAction = onReachedEnd, bcFontConfig = Nothing })] + { bcLabel = "Reached End", bcAction = onReachedEnd, bcFontConfig = Nothing, bcTextColor = Nothing })] ) True) diff --git a/test/HttpDemoMain.hs b/test/HttpDemoMain.hs index 25cc5d78..98a29938 100644 --- a/test/HttpDemoMain.hs +++ b/test/HttpDemoMain.hs @@ -66,10 +66,11 @@ main = do httpDemoView :: Action -> IO Widget httpDemoView onSendRequest = do pure $ column - [ Text TextConfig { tcLabel = "HTTP Demo", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "HTTP Demo", tcFontConfig = Nothing, tcTextColor = Nothing } , Button ButtonConfig { bcLabel = "Send Request" , bcAction = onSendRequest , bcFontConfig = Nothing + , bcTextColor = Nothing } ] diff --git a/test/ImageDemoMain.hs b/test/ImageDemoMain.hs index c78956e4..ce9dc9bc 100644 --- a/test/ImageDemoMain.hs +++ b/test/ImageDemoMain.hs @@ -24,7 +24,7 @@ main = do -- | Builds a Column with a label and three Image widgets (resource, data, file). imageDemoView :: IO Widget imageDemoView = pure $ column - [ Text TextConfig { tcLabel = "Image Demo", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "Image Demo", tcFontConfig = Nothing, tcTextColor = Nothing } , Image ImageConfig { icSource = ImageResource (ResourceName "ic_launcher") , icScaleType = ScaleFit diff --git a/test/KeyframeDemoMain.hs b/test/KeyframeDemoMain.hs index 3700dafe..fdb5878b 100644 --- a/test/KeyframeDemoMain.hs +++ b/test/KeyframeDemoMain.hs @@ -69,22 +69,26 @@ main = do Text TextConfig { tcLabel = "*" , tcFontConfig = Nothing + , tcTextColor = Nothing } , Button ButtonConfig { bcLabel = "Trigger Keyframe" , bcAction = triggerAction , bcFontConfig = Nothing + , bcTextColor = Nothing } ] else column [ Text TextConfig { tcLabel = "*" , tcFontConfig = Nothing + , tcTextColor = Nothing } , Button ButtonConfig { bcLabel = "Trigger Keyframe" , bcAction = triggerAction , bcFontConfig = Nothing + , bcTextColor = Nothing } ] app = MobileApp diff --git a/test/LocationDemoMain.hs b/test/LocationDemoMain.hs index 2cb37b6d..42840332 100644 --- a/test/LocationDemoMain.hs +++ b/test/LocationDemoMain.hs @@ -58,9 +58,9 @@ main = do -- | Builds a Column with a label and start/stop location buttons. locationDemoView :: Action -> Action -> IO Widget locationDemoView onStartLocation onStopLocation = pure $ column - [ Text TextConfig { tcLabel = "Location Demo", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "Location Demo", tcFontConfig = Nothing, tcTextColor = Nothing } , Button ButtonConfig - { bcLabel = "Start Location", bcAction = onStartLocation, bcFontConfig = Nothing } + { bcLabel = "Start Location", bcAction = onStartLocation, bcFontConfig = Nothing, bcTextColor = Nothing } , Button ButtonConfig - { bcLabel = "Stop Location", bcAction = onStopLocation, bcFontConfig = Nothing } + { bcLabel = "Stop Location", bcAction = onStopLocation, bcFontConfig = Nothing, bcTextColor = Nothing } ] diff --git a/test/MapViewDemoMain.hs b/test/MapViewDemoMain.hs index d77eff47..3aef1411 100644 --- a/test/MapViewDemoMain.hs +++ b/test/MapViewDemoMain.hs @@ -43,7 +43,7 @@ main = do mapViewDemoView :: OnChange -> UserState -> IO Widget mapViewDemoView onRegionChange _userState = pure $ column - [ Text TextConfig { tcLabel = "MapView Demo", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "MapView Demo", tcFontConfig = Nothing, tcTextColor = Nothing } , MapView MapViewConfig { mvLatitude = 52.3676 , mvLongitude = 4.9041 diff --git a/test/NetworkStatusDemoMain.hs b/test/NetworkStatusDemoMain.hs index 4779de2b..4ab0bba7 100644 --- a/test/NetworkStatusDemoMain.hs +++ b/test/NetworkStatusDemoMain.hs @@ -56,9 +56,9 @@ main = do -- | Builds a Column with a label and start/stop monitoring buttons. networkStatusDemoView :: Action -> Action -> IO Widget networkStatusDemoView onStartMonitoring onStopMonitoring = pure $ column - [ Text TextConfig { tcLabel = "Network Status Demo", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "Network Status Demo", tcFontConfig = Nothing, tcTextColor = Nothing } , Button ButtonConfig - { bcLabel = "Start Monitoring", bcAction = onStartMonitoring, bcFontConfig = Nothing } + { bcLabel = "Start Monitoring", bcAction = onStartMonitoring, bcFontConfig = Nothing, bcTextColor = Nothing } , Button ButtonConfig - { bcLabel = "Stop Monitoring", bcAction = onStopMonitoring, bcFontConfig = Nothing } + { bcLabel = "Stop Monitoring", bcAction = onStopMonitoring, bcFontConfig = Nothing, bcTextColor = Nothing } ] diff --git a/test/NodePoolTestMain.hs b/test/NodePoolTestMain.hs index 756490b9..4f61685a 100644 --- a/test/NodePoolTestMain.hs +++ b/test/NodePoolTestMain.hs @@ -19,6 +19,7 @@ nodePoolTestView _userState = pure $ column $ map (\itemNumber -> Text TextConfig { tcLabel = "Item " <> pack (show (itemNumber :: Int)) , tcFontConfig = Nothing + , tcTextColor = Nothing }) [1..299] main :: IO (Ptr AppContext) diff --git a/test/PermissionDemoMain.hs b/test/PermissionDemoMain.hs index 8850a5ad..624b8eee 100644 --- a/test/PermissionDemoMain.hs +++ b/test/PermissionDemoMain.hs @@ -44,10 +44,11 @@ main = do -- | Builds a Column with a label and a "Request Camera" button. permissionDemoView :: Action -> IO Widget permissionDemoView onRequestCamera = pure $ column - [ Text TextConfig { tcLabel = "Permission Demo", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "Permission Demo", tcFontConfig = Nothing, tcTextColor = Nothing } , Button ButtonConfig { bcLabel = "Request Camera" , bcAction = onRequestCamera , bcFontConfig = Nothing + , bcTextColor = Nothing } ] diff --git a/test/PlatformSignInDemoMain.hs b/test/PlatformSignInDemoMain.hs index 8a05725e..2005e029 100644 --- a/test/PlatformSignInDemoMain.hs +++ b/test/PlatformSignInDemoMain.hs @@ -74,15 +74,17 @@ main = do -- | Builds a Column with a label and two sign-in buttons. platformSignInDemoView :: Action -> Action -> IO Widget platformSignInDemoView onAppleSignIn onGoogleSignIn = pure $ column - [ Text TextConfig { tcLabel = "PlatformSignIn Demo", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "PlatformSignIn Demo", tcFontConfig = Nothing, tcTextColor = Nothing } , Button ButtonConfig { bcLabel = "Sign in with Apple" , bcAction = onAppleSignIn , bcFontConfig = Nothing + , bcTextColor = Nothing } , Button ButtonConfig { bcLabel = "Sign in with Google" , bcAction = onGoogleSignIn , bcFontConfig = Nothing + , bcTextColor = Nothing } ] diff --git a/test/RedrawDemoMain.hs b/test/RedrawDemoMain.hs index 9f0f2526..20aec82e 100644 --- a/test/RedrawDemoMain.hs +++ b/test/RedrawDemoMain.hs @@ -65,4 +65,5 @@ redrawView startedRef _userState = do pure $ column [Text TextConfig { tcLabel = "Count: " <> pack (show count) , tcFontConfig = Nothing + , tcTextColor = Nothing }] diff --git a/test/ScrollDemoMain.hs b/test/ScrollDemoMain.hs index 462c8a9b..dc1faaee 100644 --- a/test/ScrollDemoMain.hs +++ b/test/ScrollDemoMain.hs @@ -28,8 +28,8 @@ scrollDemoView :: Action -> IO Widget scrollDemoView onReachedBottom = pure $ Column (LayoutSettings [ item (column ( map (\itemNumber -> Text TextConfig - { tcLabel = "Item " <> Text.pack (show (itemNumber :: Int)), tcFontConfig = Nothing }) [1..20] + { tcLabel = "Item " <> Text.pack (show (itemNumber :: Int)), tcFontConfig = Nothing, tcTextColor = Nothing }) [1..20] ++ [Button ButtonConfig - { bcLabel = "Reached Bottom", bcAction = onReachedBottom, bcFontConfig = Nothing }] + { bcLabel = "Reached Bottom", bcAction = onReachedBottom, bcFontConfig = Nothing, bcTextColor = Nothing }] )) ] True) diff --git a/test/ScrollTextInputDemoMain.hs b/test/ScrollTextInputDemoMain.hs index 37c937df..001c55cd 100644 --- a/test/ScrollTextInputDemoMain.hs +++ b/test/ScrollTextInputDemoMain.hs @@ -38,13 +38,14 @@ main = do -- prrrrrrrrr layout that triggers DeadObjectException. scrollTextInputView :: Action -> Action -> OnChange -> OnChange -> IO Widget scrollTextInputView save back onWeight onNotes = pure $ Column (LayoutSettings - [ item (Text TextConfig { tcLabel = "Enter data", tcFontConfig = Nothing }) + [ item (Text TextConfig { tcLabel = "Enter data", tcFontConfig = Nothing, tcTextColor = Nothing }) , item (TextInput TextInputConfig { tiInputType = InputNumber , tiHint = "Weight (kg)" , tiValue = "" , tiOnChange = onWeight , tiFontConfig = Nothing + , tiTextColor = Nothing , tiAutoFocus = False }) , item (TextInput TextInputConfig @@ -53,12 +54,13 @@ scrollTextInputView save back onWeight onNotes = pure $ Column (LayoutSettings , tiValue = "" , tiOnChange = onNotes , tiFontConfig = Nothing + , tiTextColor = Nothing , tiAutoFocus = False }) , item (row [ Button ButtonConfig - { bcLabel = "Save", bcAction = save, bcFontConfig = Nothing } + { bcLabel = "Save", bcAction = save, bcFontConfig = Nothing, bcTextColor = Nothing } , Button ButtonConfig - { bcLabel = "Back", bcAction = back, bcFontConfig = Nothing } + { bcLabel = "Back", bcAction = back, bcFontConfig = Nothing, bcTextColor = Nothing } ]) ] True) diff --git a/test/ScrollViewSwitchDemoMain.hs b/test/ScrollViewSwitchDemoMain.hs index ced09dae..efba37cc 100644 --- a/test/ScrollViewSwitchDemoMain.hs +++ b/test/ScrollViewSwitchDemoMain.hs @@ -58,6 +58,7 @@ switchDemoView screenState switchAction noopAction = do { bcLabel = "SCREENA_BTN" , bcAction = noopAction , bcFontConfig = Nothing + , bcTextColor = Nothing }) , item (text "SCREENA_TXT1") , item (text "SCREENA_TXT2") @@ -68,6 +69,7 @@ switchDemoView screenState switchAction noopAction = do { bcLabel = "SCREENB_BTN" , bcAction = noopAction , bcFontConfig = Nothing + , bcTextColor = Nothing }) ] True) pure $ column @@ -75,6 +77,7 @@ switchDemoView screenState switchAction noopAction = do { bcLabel = "Switch screen" , bcAction = switchAction , bcFontConfig = Nothing + , bcTextColor = Nothing } , inner ] diff --git a/test/SecureStorageDemoMain.hs b/test/SecureStorageDemoMain.hs index 1fb87727..bf05cbef 100644 --- a/test/SecureStorageDemoMain.hs +++ b/test/SecureStorageDemoMain.hs @@ -49,9 +49,9 @@ main = do -- | Builds a Column with a label, a "Store Token" button, and a "Read Token" button. secureStorageDemoView :: Action -> Action -> IO Widget secureStorageDemoView onStoreToken onReadToken = pure $ column - [ Text TextConfig { tcLabel = "SecureStorage Demo", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "SecureStorage Demo", tcFontConfig = Nothing, tcTextColor = Nothing } , Button ButtonConfig - { bcLabel = "Store Token", bcAction = onStoreToken, bcFontConfig = Nothing } + { bcLabel = "Store Token", bcAction = onStoreToken, bcFontConfig = Nothing, bcTextColor = Nothing } , Button ButtonConfig - { bcLabel = "Read Token", bcAction = onReadToken, bcFontConfig = Nothing } + { bcLabel = "Read Token", bcAction = onReadToken, bcFontConfig = Nothing, bcTextColor = Nothing } ] diff --git a/test/StackDemoMain.hs b/test/StackDemoMain.hs index 14fefff1..c8642ada 100644 --- a/test/StackDemoMain.hs +++ b/test/StackDemoMain.hs @@ -39,12 +39,14 @@ stackDemoView counterState onTap = do (Text TextConfig { tcLabel = "Background: " <> Text.pack (show n) , tcFontConfig = Nothing + , tcTextColor = Nothing })) , -- Layer 1 (middle): tappable button item (Button ButtonConfig { bcLabel = "Tap overlay" , bcAction = onTap , bcFontConfig = Nothing + , bcTextColor = Nothing }) , -- Layer 2 (top): passthrough overlay — touches must pass through to button item (Styled (defaultStyle { wsTouchPassthrough = Just True @@ -53,5 +55,6 @@ stackDemoView counterState onTap = do (Text TextConfig { tcLabel = "Passthrough overlay" , tcFontConfig = Nothing + , tcTextColor = Nothing })) ] diff --git a/test/StyledTypeChangeDemoMain.hs b/test/StyledTypeChangeDemoMain.hs index 04fa7927..2472aefc 100644 --- a/test/StyledTypeChangeDemoMain.hs +++ b/test/StyledTypeChangeDemoMain.hs @@ -47,9 +47,13 @@ toggle ScreenB = ScreenA redBackground :: WidgetStyle redBackground = defaultStyle { wsBackgroundColor = Just (Color 255 0 0 (255 :: Word8)) - , wsTextColor = Just (Color 255 255 255 (255 :: Word8)) } +-- | White label color, carried on the text-bearing configs since +-- text color no longer lives in WidgetStyle. +whiteText :: Color +whiteText = Color 255 255 255 (255 :: Word8) + -- | The view: a Column with a switch button and a Styled widget. -- -- ScreenA: Styled redBackground (Text "STYLED_TEXT") @@ -67,18 +71,21 @@ styledTypeChangeView screenState switchAction noopAction = do (Text TextConfig { tcLabel = "STYLED_TEXT" , tcFontConfig = Nothing + , tcTextColor = Just whiteText }) ScreenB -> Styled redBackground (Button ButtonConfig { bcLabel = "STYLED_BUTTON" , bcAction = noopAction , bcFontConfig = Nothing + , bcTextColor = Just whiteText }) pure $ column [ Button ButtonConfig { bcLabel = "Switch screen" , bcAction = switchAction , bcFontConfig = Nothing + , bcTextColor = Nothing } , styledChild ] diff --git a/test/THDemoMain.hs b/test/THDemoMain.hs index 7a4e7a21..54469066 100644 --- a/test/THDemoMain.hs +++ b/test/THDemoMain.hs @@ -20,6 +20,6 @@ main = do actionState <- newActionState startMobileApp MobileApp { maContext = loggingMobileContext - , maView = \_userState -> pure (Text TextConfig { tcLabel = "th-demo", tcFontConfig = Nothing }) + , maView = \_userState -> pure (Text TextConfig { tcLabel = "th-demo", tcFontConfig = Nothing, tcTextColor = Nothing }) , maActionState = actionState } diff --git a/test/THDirectMain.hs b/test/THDirectMain.hs index 95199d10..95377478 100644 --- a/test/THDirectMain.hs +++ b/test/THDirectMain.hs @@ -24,6 +24,6 @@ main = do actionState <- newActionState startMobileApp MobileApp { maContext = loggingMobileContext - , maView = \_userState -> pure (Text TextConfig { tcLabel = "th-direct", tcFontConfig = Nothing }) + , maView = \_userState -> pure (Text TextConfig { tcLabel = "th-direct", tcFontConfig = Nothing, tcTextColor = Nothing }) , maActionState = actionState } diff --git a/test/Test/ActionTests.hs b/test/Test/ActionTests.hs index 2edda472..7b8a3700 100644 --- a/test/Test/ActionTests.hs +++ b/test/Test/ActionTests.hs @@ -81,8 +81,8 @@ widgetEqTests = testGroup "WidgetEq" [ testCase "same widget with same handle is equal" $ do actionState <- newActionState handle <- runActionM actionState $ createAction (pure ()) - let widgetA = Button ButtonConfig { bcLabel = "tap", bcAction = handle, bcFontConfig = Nothing } - widgetB = Button ButtonConfig { bcLabel = "tap", bcAction = handle, bcFontConfig = Nothing } + let widgetA = Button ButtonConfig { bcLabel = "tap", bcAction = handle, bcFontConfig = Nothing, bcTextColor = Nothing } + widgetB = Button ButtonConfig { bcLabel = "tap", bcAction = handle, bcFontConfig = Nothing, bcTextColor = Nothing } widgetA @?= widgetB , testCase "same widget with different handles is not equal" $ do @@ -91,24 +91,24 @@ widgetEqTests = testGroup "WidgetEq" hA <- createAction (pure ()) hB <- createAction (pure ()) pure (hA, hB) - let widgetA = Button ButtonConfig { bcLabel = "tap", bcAction = handleA, bcFontConfig = Nothing } - widgetB = Button ButtonConfig { bcLabel = "tap", bcAction = handleB, bcFontConfig = Nothing } + let widgetA = Button ButtonConfig { bcLabel = "tap", bcAction = handleA, bcFontConfig = Nothing, bcTextColor = Nothing } + widgetB = Button ButtonConfig { bcLabel = "tap", bcAction = handleB, bcFontConfig = Nothing, bcTextColor = Nothing } assertBool "different handles means different widgets" (widgetA /= widgetB) , testCase "Text widgets with same content are equal" $ do - let widgetA = Text TextConfig { tcLabel = "hello", tcFontConfig = Nothing } - widgetB = Text TextConfig { tcLabel = "hello", tcFontConfig = Nothing } + let widgetA = Text TextConfig { tcLabel = "hello", tcFontConfig = Nothing, tcTextColor = Nothing } + widgetB = Text TextConfig { tcLabel = "hello", tcFontConfig = Nothing, tcTextColor = Nothing } widgetA @?= widgetB , testCase "Text widgets with different content are not equal" $ do - let widgetA = Text TextConfig { tcLabel = "hello", tcFontConfig = Nothing } - widgetB = Text TextConfig { tcLabel = "world", tcFontConfig = Nothing } + let widgetA = Text TextConfig { tcLabel = "hello", tcFontConfig = Nothing, tcTextColor = Nothing } + widgetB = Text TextConfig { tcLabel = "world", tcFontConfig = Nothing, tcTextColor = Nothing } assertBool "different labels means different widgets" (widgetA /= widgetB) , testCase "Column equality is structural" $ do - let widgetA = column [Text TextConfig { tcLabel = "a", tcFontConfig = Nothing }] - widgetB = column [Text TextConfig { tcLabel = "a", tcFontConfig = Nothing }] - widgetC = column [Text TextConfig { tcLabel = "b", tcFontConfig = Nothing }] + let widgetA = column [Text TextConfig { tcLabel = "a", tcFontConfig = Nothing, tcTextColor = Nothing }] + widgetB = column [Text TextConfig { tcLabel = "a", tcFontConfig = Nothing, tcTextColor = Nothing }] + widgetC = column [Text TextConfig { tcLabel = "b", tcFontConfig = Nothing, tcTextColor = Nothing }] widgetA @?= widgetB assertBool "different children means different Column" (widgetA /= widgetC) ] @@ -136,7 +136,7 @@ incrementalRenderTests = testGroup "Incremental rendering" [ testGroup "Node reuse" [ testCase "identical re-render retains same node ID" $ do ((), rs) <- withActions (pure ()) - let widget = Text TextConfig { tcLabel = "static", tcFontConfig = Nothing } + let widget = Text TextConfig { tcLabel = "static", tcFontConfig = Nothing, tcTextColor = Nothing } renderWidget rs widget tree1 <- readIORef (rsRenderedTree rs) let nodeId1 = case tree1 of @@ -152,8 +152,8 @@ incrementalRenderTests = testGroup "Incremental rendering" , testCase "single child change updates in-place, preserving node IDs" $ do ((), rs) <- withActions (pure ()) let widget1 = column - [ Text TextConfig { tcLabel = "stable", tcFontConfig = Nothing } - , Text TextConfig { tcLabel = "will change", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "stable", tcFontConfig = Nothing, tcTextColor = Nothing } + , Text TextConfig { tcLabel = "will change", tcFontConfig = Nothing, tcTextColor = Nothing } ] renderWidget rs widget1 tree1 <- readIORef (rsRenderedTree rs) @@ -163,8 +163,8 @@ incrementalRenderTests = testGroup "Incremental rendering" _ -> assertFailure "expected 2 children" >> pure (-1, -1) Nothing -> assertFailure "expected rendered tree" >> pure (-1, -1) let widget2 = column - [ Text TextConfig { tcLabel = "stable", tcFontConfig = Nothing } - , Text TextConfig { tcLabel = "changed!", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "stable", tcFontConfig = Nothing, tcTextColor = Nothing } + , Text TextConfig { tcLabel = "changed!", tcFontConfig = Nothing, tcTextColor = Nothing } ] renderWidget rs widget2 tree2 <- readIORef (rsRenderedTree rs) @@ -185,7 +185,7 @@ incrementalRenderTests = testGroup "Incremental rendering" pure (h1, h2) -- Render button with handle1 let widget1 = Button ButtonConfig - { bcLabel = "same label", bcAction = handle1, bcFontConfig = Nothing } + { bcLabel = "same label", bcAction = handle1, bcFontConfig = Nothing, bcTextColor = Nothing } renderWidget rs widget1 tree1 <- readIORef (rsRenderedTree rs) let nodeId1 = case tree1 of @@ -193,7 +193,7 @@ incrementalRenderTests = testGroup "Incremental rendering" Nothing -> -1 -- Render same label but with handle2 (different Eq) let widget2 = Button ButtonConfig - { bcLabel = "same label", bcAction = handle2, bcFontConfig = Nothing } + { bcLabel = "same label", bcAction = handle2, bcFontConfig = Nothing, bcTextColor = Nothing } renderWidget rs widget2 tree2 <- readIORef (rsRenderedTree rs) let nodeId2 = case tree2 of @@ -212,7 +212,7 @@ incrementalRenderTests = testGroup "Incremental rendering" createAction (writeIORef ref "fired") -- Render button with handle let widget1 = Button ButtonConfig - { bcLabel = "same label", bcAction = handle, bcFontConfig = Nothing } + { bcLabel = "same label", bcAction = handle, bcFontConfig = Nothing, bcTextColor = Nothing } renderWidget rs widget1 tree1 <- readIORef (rsRenderedTree rs) let nodeId1 = case tree1 of @@ -234,7 +234,7 @@ incrementalRenderTests = testGroup "Incremental rendering" , testCase "adding a child to container" $ do ((), rs) <- withActions (pure ()) let widget1 = column - [ Text TextConfig { tcLabel = "first", tcFontConfig = Nothing } ] + [ Text TextConfig { tcLabel = "first", tcFontConfig = Nothing, tcTextColor = Nothing } ] renderWidget rs widget1 tree1 <- readIORef (rsRenderedTree rs) existingChildId <- case tree1 of @@ -243,8 +243,8 @@ incrementalRenderTests = testGroup "Incremental rendering" _ -> assertFailure "expected 1 child" >> pure (-1) Nothing -> assertFailure "expected rendered tree" >> pure (-1) let widget2 = column - [ Text TextConfig { tcLabel = "first", tcFontConfig = Nothing } - , Text TextConfig { tcLabel = "second", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "first", tcFontConfig = Nothing, tcTextColor = Nothing } + , Text TextConfig { tcLabel = "second", tcFontConfig = Nothing, tcTextColor = Nothing } ] renderWidget rs widget2 tree2 <- readIORef (rsRenderedTree rs) @@ -262,12 +262,12 @@ incrementalRenderTests = testGroup "Incremental rendering" , testCase "removing a child from container" $ do ((), rs) <- withActions (pure ()) let widget1 = column - [ Text TextConfig { tcLabel = "a", tcFontConfig = Nothing } - , Text TextConfig { tcLabel = "b", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "a", tcFontConfig = Nothing, tcTextColor = Nothing } + , Text TextConfig { tcLabel = "b", tcFontConfig = Nothing, tcTextColor = Nothing } ] renderWidget rs widget1 let widget2 = column - [ Text TextConfig { tcLabel = "a", tcFontConfig = Nothing } ] + [ Text TextConfig { tcLabel = "a", tcFontConfig = Nothing, tcTextColor = Nothing } ] renderWidget rs widget2 tree2 <- readIORef (rsRenderedTree rs) let children2 = childrenOf (maybe (error "no tree") id tree2) @@ -276,14 +276,14 @@ incrementalRenderTests = testGroup "Incremental rendering" , testCase "root type change triggers new root node" $ do (handle, rs) <- withActions $ createAction (pure ()) - let widget1 = Text TextConfig { tcLabel = "text", tcFontConfig = Nothing } + let widget1 = Text TextConfig { tcLabel = "text", tcFontConfig = Nothing, tcTextColor = Nothing } renderWidget rs widget1 tree1 <- readIORef (rsRenderedTree rs) let nodeId1 = case tree1 of Just node -> nodeIdOf node Nothing -> -1 let widget2 = Button ButtonConfig - { bcLabel = "button", bcAction = handle, bcFontConfig = Nothing } + { bcLabel = "button", bcAction = handle, bcFontConfig = Nothing, bcTextColor = Nothing } renderWidget rs widget2 tree2 <- readIORef (rsRenderedTree rs) let nodeId2 = case tree2 of @@ -294,8 +294,8 @@ incrementalRenderTests = testGroup "Incremental rendering" , testCase "styled unchanged keeps same node ID" $ do ((), rs) <- withActions (pure ()) - let style = WidgetStyle (Just 10.0) Nothing Nothing Nothing Nothing Nothing Nothing - widget = Styled style (Text TextConfig { tcLabel = "styled", tcFontConfig = Nothing }) + let style = WidgetStyle (Just 10.0) Nothing Nothing Nothing Nothing Nothing + widget = Styled style (Text TextConfig { tcLabel = "styled", tcFontConfig = Nothing, tcTextColor = Nothing }) renderWidget rs widget tree1 <- readIORef (rsRenderedTree rs) let nodeId1 = case tree1 of @@ -310,14 +310,14 @@ incrementalRenderTests = testGroup "Incremental rendering" , testCase "styled child change updates in-place" $ do ((), rs) <- withActions (pure ()) - let style = WidgetStyle (Just 10.0) Nothing Nothing Nothing Nothing Nothing Nothing - widget1 = Styled style (Text TextConfig { tcLabel = "before", tcFontConfig = Nothing }) + let style = WidgetStyle (Just 10.0) Nothing Nothing Nothing Nothing Nothing + widget1 = Styled style (Text TextConfig { tcLabel = "before", tcFontConfig = Nothing, tcTextColor = Nothing }) renderWidget rs widget1 tree1 <- readIORef (rsRenderedTree rs) let nodeId1 = case tree1 of Just node -> nodeIdOf node Nothing -> -1 - let widget2 = Styled style (Text TextConfig { tcLabel = "after", tcFontConfig = Nothing }) + let widget2 = Styled style (Text TextConfig { tcLabel = "after", tcFontConfig = Nothing, tcTextColor = Nothing }) renderWidget rs widget2 tree2 <- readIORef (rsRenderedTree rs) let nodeId2 = case tree2 of @@ -329,11 +329,11 @@ incrementalRenderTests = testGroup "Incremental rendering" , testCase "styled child type change reapplies style" $ do (clickAction, rs) <- withActions $ createAction (pure ()) - let style = WidgetStyle (Just 10.0) Nothing Nothing Nothing Nothing Nothing Nothing - widget1 = Styled style (Text TextConfig { tcLabel = "txt", tcFontConfig = Nothing }) + let style = WidgetStyle (Just 10.0) Nothing Nothing Nothing Nothing Nothing + widget1 = Styled style (Text TextConfig { tcLabel = "txt", tcFontConfig = Nothing, tcTextColor = Nothing }) renderWidget rs widget1 -- Re-render with different child type but same style - let widget2 = Styled style (Button (ButtonConfig "btn" clickAction Nothing)) + let widget2 = Styled style (Button (ButtonConfig "btn" clickAction Nothing Nothing)) ((), stderrOutput) <- captureStderr $ renderWidget rs widget2 -- applyStyle must fire setNumProp for padding on the new node assertBool @@ -347,7 +347,7 @@ incrementalRenderTests = testGroup "Incremental rendering" createOnChange (\_ -> pure ()) let widget1 = TextInput TextInputConfig { tiInputType = InputNumber, tiHint = "% of 1RM", tiValue = "" - , tiOnChange = changeHandle, tiFontConfig = Nothing, tiAutoFocus = False } + , tiOnChange = changeHandle, tiFontConfig = Nothing, tiTextColor = Nothing, tiAutoFocus = False } renderWidget rs widget1 tree1 <- readIORef (rsRenderedTree rs) let nodeId1 = case tree1 of @@ -356,7 +356,7 @@ incrementalRenderTests = testGroup "Incremental rendering" -- Re-render with a different value (simulates user typing) let widget2 = TextInput TextInputConfig { tiInputType = InputNumber, tiHint = "% of 1RM", tiValue = "80" - , tiOnChange = changeHandle, tiFontConfig = Nothing, tiAutoFocus = False } + , tiOnChange = changeHandle, tiFontConfig = Nothing, tiTextColor = Nothing, tiAutoFocus = False } renderWidget rs widget2 tree2 <- readIORef (rsRenderedTree rs) let nodeId2 = case tree2 of @@ -370,7 +370,7 @@ incrementalRenderTests = testGroup "Incremental rendering" createOnChange (\_ -> pure ()) let widget1 = TextInput TextInputConfig { tiInputType = InputText, tiHint = "old hint", tiValue = "" - , tiOnChange = changeHandle, tiFontConfig = Nothing, tiAutoFocus = False } + , tiOnChange = changeHandle, tiFontConfig = Nothing, tiTextColor = Nothing, tiAutoFocus = False } renderWidget rs widget1 tree1 <- readIORef (rsRenderedTree rs) let nodeId1 = case tree1 of @@ -378,7 +378,7 @@ incrementalRenderTests = testGroup "Incremental rendering" Nothing -> -1 let widget2 = TextInput TextInputConfig { tiInputType = InputText, tiHint = "new hint", tiValue = "" - , tiOnChange = changeHandle, tiFontConfig = Nothing, tiAutoFocus = False } + , tiOnChange = changeHandle, tiFontConfig = Nothing, tiTextColor = Nothing, tiAutoFocus = False } renderWidget rs widget2 tree2 <- readIORef (rsRenderedTree rs) let nodeId2 = case tree2 of @@ -392,12 +392,12 @@ incrementalRenderTests = testGroup "Incremental rendering" createOnChange (\t -> writeIORef ref (show t)) let widget1 = TextInput TextInputConfig { tiInputType = InputNumber, tiHint = "weight", tiValue = "" - , tiOnChange = changeHandle, tiFontConfig = Nothing, tiAutoFocus = False } + , tiOnChange = changeHandle, tiFontConfig = Nothing, tiTextColor = Nothing, tiAutoFocus = False } renderWidget rs widget1 -- Simulate text change followed by re-render (new value) let widget2 = TextInput TextInputConfig { tiInputType = InputNumber, tiHint = "weight", tiValue = "80" - , tiOnChange = changeHandle, tiFontConfig = Nothing, tiAutoFocus = False } + , tiOnChange = changeHandle, tiFontConfig = Nothing, tiTextColor = Nothing, tiAutoFocus = False } renderWidget rs widget2 -- Callback should still work after in-place diff dispatchTextEvent rs (onChangeId changeHandle) "95" @@ -408,11 +408,11 @@ incrementalRenderTests = testGroup "Incremental rendering" (changeHandle, rs) <- withActions $ createOnChange (\_ -> pure ()) let mkWidget value = column - [ Text TextConfig { tcLabel = "header", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "header", tcFontConfig = Nothing, tcTextColor = Nothing } , TextInput TextInputConfig { tiInputType = InputNumber, tiHint = "% of 1RM", tiValue = value - , tiOnChange = changeHandle, tiFontConfig = Nothing, tiAutoFocus = False } - , Text TextConfig { tcLabel = "footer", tcFontConfig = Nothing } + , tiOnChange = changeHandle, tiFontConfig = Nothing, tiTextColor = Nothing, tiAutoFocus = False } + , Text TextConfig { tcLabel = "footer", tcFontConfig = Nothing, tcTextColor = Nothing } ] renderWidget rs (mkWidget "") tree1 <- readIORef (rsRenderedTree rs) @@ -439,9 +439,9 @@ incrementalRenderTests = testGroup "Incremental rendering" -- Render: [TextInput(key=10), Button(key=20)] let textInput = TextInput TextInputConfig { tiInputType = InputText, tiHint = "enter text", tiValue = "" - , tiOnChange = changeHandle, tiFontConfig = Nothing, tiAutoFocus = False } + , tiOnChange = changeHandle, tiFontConfig = Nothing, tiTextColor = Nothing, tiAutoFocus = False } toggleBtn = Button ButtonConfig - { bcLabel = "toggle", bcAction = clickAction, bcFontConfig = Nothing } + { bcLabel = "toggle", bcAction = clickAction, bcFontConfig = Nothing, bcTextColor = Nothing } widget1 = Column LayoutSettings { lsWidgets = [keyedItem 10 textInput, keyedItem 20 toggleBtn] , lsScrollable = False } @@ -453,7 +453,7 @@ incrementalRenderTests = testGroup "Incremental rendering" _ -> -1 Nothing -> -1 -- Re-render: [Banner(unkeyed), TextInput(key=10), Button(key=20)] - let banner = Text TextConfig { tcLabel = "Banner", tcFontConfig = Nothing } + let banner = Text TextConfig { tcLabel = "Banner", tcFontConfig = Nothing, tcTextColor = Nothing } widget2 = Column LayoutSettings { lsWidgets = [item banner, keyedItem 10 textInput, keyedItem 20 toggleBtn] , lsScrollable = False } diff --git a/test/Test/AnimationTests.hs b/test/Test/AnimationTests.hs index 799d8dbe..fa0c55e7 100644 --- a/test/Test/AnimationTests.hs +++ b/test/Test/AnimationTests.hs @@ -254,7 +254,7 @@ animatedWidgetRenderTests = testGroup "Animated widget rendering" writeIORef (ansLoopActive animState) True actionState <- newActionState rs <- newRenderState actionState animState - let child = Text TextConfig { tcLabel = "hello", tcFontConfig = Nothing } + let child = Text TextConfig { tcLabel = "hello", tcFontConfig = Nothing, tcTextColor = Nothing } config = twoKeyframeConfig 0.3 (defaultStyle { wsPadding = Just 0 }) (defaultStyle { wsPadding = Just 10 }) @@ -270,7 +270,7 @@ animatedWidgetRenderTests = testGroup "Animated widget rendering" writeIORef (ansLoopActive animState) True actionState <- newActionState rs <- newRenderState actionState animState - let child = Text TextConfig { tcLabel = "hello", tcFontConfig = Nothing } + let child = Text TextConfig { tcLabel = "hello", tcFontConfig = Nothing, tcTextColor = Nothing } config = twoKeyframeConfig 0.3 (defaultStyle { wsPadding = Just 0 }) (defaultStyle { wsPadding = Just 10 }) @@ -294,8 +294,8 @@ animatedWidgetRenderTests = testGroup "Animated widget rendering" config2 = twoKeyframeConfig 0.3 (defaultStyle { wsPadding = Just 0 }) (defaultStyle { wsPadding = Just 50 }) - child1 = Styled (defaultStyle { wsPadding = Just 10 }) (Text TextConfig { tcLabel = "x", tcFontConfig = Nothing }) - child2 = Styled (defaultStyle { wsPadding = Just 50 }) (Text TextConfig { tcLabel = "x", tcFontConfig = Nothing }) + child1 = Styled (defaultStyle { wsPadding = Just 10 }) (Text TextConfig { tcLabel = "x", tcFontConfig = Nothing, tcTextColor = Nothing }) + child2 = Styled (defaultStyle { wsPadding = Just 50 }) (Text TextConfig { tcLabel = "x", tcFontConfig = Nothing, tcTextColor = Nothing }) widget1 = Animated config1 child1 widget2 = Animated config2 child2 renderWidget rs widget1 @@ -314,7 +314,7 @@ animatedWidgetRenderTests = testGroup "Animated widget rendering" let config = twoKeyframeConfig 0.3 (defaultStyle { wsPadding = Just 0 }) (defaultStyle { wsPadding = Just 10 }) - child1 = Text TextConfig { tcLabel = "text", tcFontConfig = Nothing } + child1 = Text TextConfig { tcLabel = "text", tcFontConfig = Nothing, tcTextColor = Nothing } child2 = column [] widget1 = Animated config child1 widget2 = Animated config child2 @@ -338,8 +338,8 @@ animatedWidgetRenderTests = testGroup "Animated widget rendering" configB = twoKeyframeConfig 0.5 (defaultStyle { wsPadding = Just 0 }) (defaultStyle { wsPadding = Just 50 }) - styledA = Styled (defaultStyle { wsPadding = Just 10 }) (Text TextConfig { tcLabel = "x", tcFontConfig = Nothing }) - styledB = Styled (defaultStyle { wsPadding = Just 50 }) (Text TextConfig { tcLabel = "x", tcFontConfig = Nothing }) + styledA = Styled (defaultStyle { wsPadding = Just 10 }) (Text TextConfig { tcLabel = "x", tcFontConfig = Nothing, tcTextColor = Nothing }) + styledB = Styled (defaultStyle { wsPadding = Just 50 }) (Text TextConfig { tcLabel = "x", tcFontConfig = Nothing, tcTextColor = Nothing }) widgetA = Animated configA styledA widgetB = Animated configB styledB @@ -391,22 +391,22 @@ normalizeAnimatedTests = testGroup "normalizeAnimated" let cfg = twoKeyframeConfig 0.3 (defaultStyle { wsPadding = Just 0 }) (defaultStyle { wsPadding = Just 10 }) - childA = Text TextConfig { tcLabel = "a", tcFontConfig = Nothing } - childB = Text TextConfig { tcLabel = "b", tcFontConfig = Nothing } + childA = Text TextConfig { tcLabel = "a", tcFontConfig = Nothing, tcTextColor = Nothing } + childB = Text TextConfig { tcLabel = "b", tcFontConfig = Nothing, tcTextColor = Nothing } result = normalizeAnimated cfg (Column (LayoutSettings [item childA, item childB] False)) result @?= Column (LayoutSettings [item (Animated cfg childA), item (Animated cfg childB)] False) , testCase "Distributes over Row children" $ do let cfg = twoKeyframeConfig 0.3 (defaultStyle { wsPadding = Just 0 }) (defaultStyle { wsPadding = Just 10 }) - childA = Text TextConfig { tcLabel = "a", tcFontConfig = Nothing } + childA = Text TextConfig { tcLabel = "a", tcFontConfig = Nothing, tcTextColor = Nothing } result = normalizeAnimated cfg (Row (LayoutSettings [item childA] False)) result @?= Row (LayoutSettings [item (Animated cfg childA)] False) , testCase "Distributes over scrollable Column children" $ do let cfg = twoKeyframeConfig 0.3 (defaultStyle { wsPadding = Just 0 }) (defaultStyle { wsPadding = Just 10 }) - childA = Text TextConfig { tcLabel = "a", tcFontConfig = Nothing } + childA = Text TextConfig { tcLabel = "a", tcFontConfig = Nothing, tcTextColor = Nothing } result = normalizeAnimated cfg (Column (LayoutSettings [item childA] True)) result @?= Column (LayoutSettings [item (Animated cfg childA)] True) , testCase "Inner Animated wins over outer" $ do @@ -416,7 +416,7 @@ normalizeAnimatedTests = testGroup "normalizeAnimated" innerCfg = twoKeyframeConfig 0.1 (defaultStyle { wsPadding = Just 0 }) (defaultStyle { wsPadding = Just 20 }) - leaf = Text TextConfig { tcLabel = "x", tcFontConfig = Nothing } + leaf = Text TextConfig { tcLabel = "x", tcFontConfig = Nothing, tcTextColor = Nothing } result = normalizeAnimated outerCfg (Animated innerCfg leaf) result @?= Animated innerCfg leaf , testCase "Styled returned unchanged" $ do @@ -424,14 +424,14 @@ normalizeAnimatedTests = testGroup "normalizeAnimated" (defaultStyle { wsPadding = Just 0 }) (defaultStyle { wsPadding = Just 10 }) style = defaultStyle { wsPadding = Just 10 } - child = Text TextConfig { tcLabel = "a", tcFontConfig = Nothing } + child = Text TextConfig { tcLabel = "a", tcFontConfig = Nothing, tcTextColor = Nothing } result = normalizeAnimated cfg (Styled style child) result @?= Styled style child , testCase "Leaf widget unchanged" $ do let cfg = twoKeyframeConfig 0.3 (defaultStyle { wsPadding = Just 0 }) (defaultStyle { wsPadding = Just 10 }) - leaf = Text TextConfig { tcLabel = "hi", tcFontConfig = Nothing } + leaf = Text TextConfig { tcLabel = "hi", tcFontConfig = Nothing, tcTextColor = Nothing } result = normalizeAnimated cfg leaf result @?= leaf , testCase "Animated Column renders as RenderedContainer with RenderedAnimated children" $ do @@ -444,9 +444,9 @@ normalizeAnimatedTests = testGroup "normalizeAnimated" (defaultStyle { wsPadding = Just 0 }) (defaultStyle { wsPadding = Just 10 }) childA = Styled (defaultStyle { wsPadding = Just 10 }) $ - Text TextConfig { tcLabel = "a", tcFontConfig = Nothing } + Text TextConfig { tcLabel = "a", tcFontConfig = Nothing, tcTextColor = Nothing } childB = Styled (defaultStyle { wsPadding = Just 20 }) $ - Text TextConfig { tcLabel = "b", tcFontConfig = Nothing } + Text TextConfig { tcLabel = "b", tcFontConfig = Nothing, tcTextColor = Nothing } widget = Animated cfg (column [childA, childB]) renderWidget rs widget renderedTree <- readIORef (rsRenderedTree rs) @@ -471,7 +471,7 @@ normalizeAnimatedTests = testGroup "normalizeAnimated" (defaultStyle { wsPadding = Just 10 }) style1 = defaultStyle { wsPadding = Just 10 } style2 = defaultStyle { wsPadding = Just 50 } - child = Text TextConfig { tcLabel = "a", tcFontConfig = Nothing } + child = Text TextConfig { tcLabel = "a", tcFontConfig = Nothing, tcTextColor = Nothing } widget1 = Animated cfg (column [Styled style1 child]) widget2 = Animated cfg (column [Styled style2 child]) renderWidget rs widget1 @@ -502,9 +502,9 @@ translateAnimationTests = testGroup "Translate animation" (defaultStyle { wsTranslateX = Just 0, wsTranslateY = Just 0 }) (defaultStyle { wsTranslateX = Just 200, wsTranslateY = Just 100 }) child1 = Styled (defaultStyle { wsTranslateX = Just 0, wsTranslateY = Just 0 }) - (Text TextConfig { tcLabel = "t", tcFontConfig = Nothing }) + (Text TextConfig { tcLabel = "t", tcFontConfig = Nothing, tcTextColor = Nothing }) child2 = Styled (defaultStyle { wsTranslateX = Just 100, wsTranslateY = Just 50 }) - (Text TextConfig { tcLabel = "t", tcFontConfig = Nothing }) + (Text TextConfig { tcLabel = "t", tcFontConfig = Nothing, tcTextColor = Nothing }) widget1 = Animated config1 child1 widget2 = Animated config2 child2 renderWidget rs widget1 @@ -522,7 +522,7 @@ translateAnimationTests = testGroup "Translate animation" animState <- newAnimationState rs <- newRenderState actionState animState renderWidget rs $ Styled (defaultStyle { wsTranslateX = Just 10.5, wsTranslateY = Just (-20.0) }) - (Text TextConfig { tcLabel = "offset", tcFontConfig = Nothing }) + (Text TextConfig { tcLabel = "offset", tcFontConfig = Nothing, tcTextColor = Nothing }) ] -- --------------------------------------------------------------------------- @@ -541,7 +541,7 @@ firstRenderAnimationTests = testGroup "First-render animation" (defaultStyle { wsTranslateX = Just 0, wsTranslateY = Just 0 }) (defaultStyle { wsTranslateX = Just 120, wsTranslateY = Just 50 }) style = defaultStyle { wsTranslateX = Just 120, wsTranslateY = Just 50 } - child = Text TextConfig { tcLabel = "*", tcFontConfig = Nothing } + child = Text TextConfig { tcLabel = "*", tcFontConfig = Nothing, tcTextColor = Nothing } widget = Animated config (Styled style child) renderWidget rs widget tweens <- readIORef (ansTweens animState) @@ -556,7 +556,7 @@ firstRenderAnimationTests = testGroup "First-render animation" , anKeyframes = [Keyframe (unsafeKfAt 0) (defaultStyle { wsPadding = Just 10 })] } widget = Animated config - (Text TextConfig { tcLabel = "hello", tcFontConfig = Nothing }) + (Text TextConfig { tcLabel = "hello", tcFontConfig = Nothing, tcTextColor = Nothing }) renderWidget rs widget tweens <- readIORef (ansTweens animState) assertBool "No tween for single keyframe" (IntMap.null tweens) @@ -567,7 +567,7 @@ firstRenderAnimationTests = testGroup "First-render animation" rs <- newRenderState actionState animState let config = AnimatedConfig { anDuration = 0.3, anKeyframes = [] } widget = Animated config - (Text TextConfig { tcLabel = "hello", tcFontConfig = Nothing }) + (Text TextConfig { tcLabel = "hello", tcFontConfig = Nothing, tcTextColor = Nothing }) renderWidget rs widget tweens <- readIORef (ansTweens animState) assertBool "No tween for empty keyframes" (IntMap.null tweens) @@ -585,7 +585,7 @@ firstRenderAnimationTests = testGroup "First-render animation" , Keyframe (unsafeKfAt 1) (defaultStyle { wsTranslateX = Just 200, wsTranslateY = Just 0 }) ] } - child = Text TextConfig { tcLabel = "*", tcFontConfig = Nothing } + child = Text TextConfig { tcLabel = "*", tcFontConfig = Nothing, tcTextColor = Nothing } widget = Animated config (Styled (defaultStyle { wsTranslateX = Just 200, wsTranslateY = Just 0 }) child) renderWidget rs widget tweens <- readIORef (ansTweens animState) @@ -678,10 +678,10 @@ smartConstructorTests = testGroup "Smart constructors" , testCase "lerpStyle interpolates colors" $ do let red = Color 255 0 0 255 blue = Color 0 0 255 255 - from = defaultStyle { wsTextColor = Just red } - to = defaultStyle { wsTextColor = Just blue } + from = defaultStyle { wsBackgroundColor = Just red } + to = defaultStyle { wsBackgroundColor = Just blue } mid = lerpStyle 0.5 from to - case wsTextColor mid of + case wsBackgroundColor mid of Just c -> do colorRed c @?= 128 colorBlue c @?= 128 diff --git a/test/Test/AppContextTests.hs b/test/Test/AppContextTests.hs index 9e39840b..45edf6d1 100644 --- a/test/Test/AppContextTests.hs +++ b/test/Test/AppContextTests.hs @@ -60,7 +60,7 @@ registrationTests = testGroup "Registration" actionState <- newActionState let customApp = MobileApp { maContext = MobileContext { onLifecycle = \_ -> pure (), onError = \_ -> pure () } - , maView = \_userState -> pure (Text TextConfig { tcLabel = "custom", tcFontConfig = Nothing }) + , maView = \_userState -> pure (Text TextConfig { tcLabel = "custom", tcFontConfig = Nothing, tcTextColor = Nothing }) , maActionState = actionState } ctxPtr <- newAppContext customApp @@ -101,12 +101,12 @@ registrationTests = testGroup "Registration" actionStateB <- newActionState let appA = MobileApp { maContext = defaultMobileContext - , maView = \_userState -> pure (Text TextConfig { tcLabel = "A", tcFontConfig = Nothing }) + , maView = \_userState -> pure (Text TextConfig { tcLabel = "A", tcFontConfig = Nothing, tcTextColor = Nothing }) , maActionState = actionStateA } appB = MobileApp { maContext = defaultMobileContext - , maView = \_userState -> pure (Text TextConfig { tcLabel = "B", tcFontConfig = Nothing }) + , maView = \_userState -> pure (Text TextConfig { tcLabel = "B", tcFontConfig = Nothing, tcTextColor = Nothing }) , maActionState = actionStateB } ctxPtrA <- newAppContext appA @@ -158,7 +158,7 @@ appContextTests = testGroup "AppContext" actionState <- newActionState let app = MobileApp { maContext = MobileContext { onLifecycle = \event -> modifyIORef' ref (++ [event]), onError = \_ -> pure () } - , maView = \_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing }) + , maView = \_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing, tcTextColor = Nothing }) , maActionState = actionState } ctxPtr <- newAppContext app @@ -197,6 +197,7 @@ exceptionHandlerTests = testGroup "ExceptionHandler" { bcLabel = "crash" , bcAction = crashHandle , bcFontConfig = Nothing + , bcTextColor = Nothing } , maActionState = actionState } @@ -219,7 +220,7 @@ exceptionHandlerTests = testGroup "ExceptionHandler" then do writeIORef shouldThrow False throwIO (userError "transient-error") - else pure $ Text TextConfig { tcLabel = "recovered", tcFontConfig = Nothing } + else pure $ Text TextConfig { tcLabel = "recovered", tcFontConfig = Nothing, tcTextColor = Nothing } transientApp = MobileApp { maContext = defaultMobileContext , maView = transientView @@ -284,7 +285,7 @@ exceptionHandlerTests = testGroup "ExceptionHandler" { onLifecycle = \_ -> throwIO (userError "lifecycle-boom") , onError = \_ -> pure () } - , maView = \_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing }) + , maView = \_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing, tcTextColor = Nothing }) , maActionState = actionState } ctxPtr <- newAppContext crashingApp diff --git a/test/Test/Helpers.hs b/test/Test/Helpers.hs index 5c0e7e6b..935782b0 100644 --- a/test/Test/Helpers.hs +++ b/test/Test/Helpers.hs @@ -67,7 +67,7 @@ makeDummyApp callback = do actionState <- newActionState pure MobileApp { maContext = MobileContext { onLifecycle = callback, onError = \_ -> pure () } - , maView = \_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing }) + , maView = \_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing, tcTextColor = Nothing }) , maActionState = actionState } @@ -87,7 +87,7 @@ testApp = do actionState <- newActionState pure MobileApp { maContext = loggingMobileContext - , maView = \_userState -> pure (Text TextConfig { tcLabel = "test", tcFontConfig = Nothing }) + , maView = \_userState -> pure (Text TextConfig { tcLabel = "test", tcFontConfig = Nothing, tcTextColor = Nothing }) , maActionState = actionState } diff --git a/test/Test/PlatformTests.hs b/test/Test/PlatformTests.hs index 63b1e433..f6f2d4f0 100644 --- a/test/Test/PlatformTests.hs +++ b/test/Test/PlatformTests.hs @@ -1072,7 +1072,7 @@ authSessionTests ffiAuthSessionState = sequentialTestGroup "AuthSession" AllFini locationTests :: TestTree locationTests = testGroup "Location" [ testCase "desktop stub dispatches fixed location on startLocationUpdates" $ do - app <- makeSimpleApp (\_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing })) + app <- makeSimpleApp (\_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing, tcTextColor = Nothing })) ctxPtr <- newAppContext app appCtx <- derefAppContext ctxPtr let locationState = acLocationState appCtx @@ -1107,7 +1107,7 @@ locationTests = testGroup "Location" dispatchLocationUpdate locationState 0.0 0.0 0.0 0.0 , testCase "stopLocationUpdates clears callback" $ do - app <- makeSimpleApp (\_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing })) + app <- makeSimpleApp (\_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing, tcTextColor = Nothing })) ctxPtr <- newAppContext app appCtx <- derefAppContext ctxPtr let locationState = acLocationState appCtx @@ -1120,7 +1120,7 @@ locationTests = testGroup "Location" freeAppContext ctxPtr , testCase "startLocationUpdates replaces existing callback" $ do - app <- makeSimpleApp (\_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing })) + app <- makeSimpleApp (\_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing, tcTextColor = Nothing })) ctxPtr <- newAppContext app appCtx <- derefAppContext ctxPtr let locationState = acLocationState appCtx @@ -1197,7 +1197,7 @@ bottomSheetTests ffiBottomSheetState = sequentialTestGroup "BottomSheet" AllFini cameraTests :: TestTree cameraTests = testGroup "Camera" [ testCase "desktop stub dispatches success with picture on capturePhoto" $ do - app <- makeSimpleApp (\_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing })) + app <- makeSimpleApp (\_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing, tcTextColor = Nothing })) ctxPtr <- newAppContext app appCtx <- derefAppContext ctxPtr let cameraState = acCameraState appCtx @@ -1218,7 +1218,7 @@ cameraTests = testGroup "Camera" freeAppContext ctxPtr , testCase "desktop stub dispatches success on startVideoCapture with frame/audio callbacks" $ do - app <- makeSimpleApp (\_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing })) + app <- makeSimpleApp (\_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing, tcTextColor = Nothing })) ctxPtr <- newAppContext app appCtx <- derefAppContext ctxPtr let cameraState = acCameraState appCtx @@ -1337,7 +1337,7 @@ cameraTests = testGroup "Camera" IntMap.member 0 audioCallbacks @?= False , testCase "capturePhoto assigns incremental request IDs" $ do - app <- makeSimpleApp (\_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing })) + app <- makeSimpleApp (\_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing, tcTextColor = Nothing })) ctxPtr <- newAppContext app appCtx <- derefAppContext ctxPtr let cameraState = acCameraState appCtx @@ -1456,7 +1456,7 @@ httpTests ffiHttpState = sequentialTestGroup "Http" AllFinish networkStatusTests :: TestTree networkStatusTests = testGroup "NetworkStatus" [ testCase "desktop stub dispatches connected WiFi on startNetworkMonitoring" $ do - app <- makeSimpleApp (\_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing })) + app <- makeSimpleApp (\_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing, tcTextColor = Nothing })) ctxPtr <- newAppContext app appCtx <- derefAppContext ctxPtr let networkStatusState = acNetworkStatusState appCtx @@ -1487,7 +1487,7 @@ networkStatusTests = testGroup "NetworkStatus" dispatchNetworkStatusChange networkStatusState 1 1 , testCase "stopNetworkMonitoring clears callback" $ do - app <- makeSimpleApp (\_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing })) + app <- makeSimpleApp (\_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing, tcTextColor = Nothing })) ctxPtr <- newAppContext app appCtx <- derefAppContext ctxPtr let networkStatusState = acNetworkStatusState appCtx @@ -1500,7 +1500,7 @@ networkStatusTests = testGroup "NetworkStatus" freeAppContext ctxPtr , testCase "startNetworkMonitoring replaces existing callback" $ do - app <- makeSimpleApp (\_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing })) + app <- makeSimpleApp (\_userState -> pure (Text TextConfig { tcLabel = "dummy", tcFontConfig = Nothing, tcTextColor = Nothing })) ctxPtr <- newAppContext app appCtx <- derefAppContext ctxPtr let networkStatusState = acNetworkStatusState appCtx diff --git a/test/Test/WidgetTests.hs b/test/Test/WidgetTests.hs index 3a8c0947..b5cf06b1 100644 --- a/test/Test/WidgetTests.hs +++ b/test/Test/WidgetTests.hs @@ -29,6 +29,7 @@ import Hatter import Hatter.Widget ( ButtonConfig(..) , Color(..) + , coloredText , FontConfig(..) , ImageConfig(..) , ImageSource(..) @@ -74,7 +75,7 @@ uiTests = testGroup "UI" (clickHandle, rs) <- withActions $ createAction (modifyIORef' ref (+ 1)) let widget = Button ButtonConfig - { bcLabel = "click me", bcAction = clickHandle, bcFontConfig = Nothing } + { bcLabel = "click me", bcAction = clickHandle, bcFontConfig = Nothing, bcTextColor = Nothing } renderWidget rs widget dispatchEvent rs (actionId clickHandle) count <- readIORef ref @@ -89,9 +90,9 @@ uiTests = testGroup "UI" pure (hA, hB) let widget = row [ Button ButtonConfig - { bcLabel = "A", bcAction = handleA, bcFontConfig = Nothing } + { bcLabel = "A", bcAction = handleA, bcFontConfig = Nothing, bcTextColor = Nothing } , Button ButtonConfig - { bcLabel = "B", bcAction = handleB, bcFontConfig = Nothing } + { bcLabel = "B", bcAction = handleB, bcFontConfig = Nothing, bcTextColor = Nothing } ] renderWidget rs widget -- Only fire A @@ -111,17 +112,17 @@ uiTests = testGroup "UI" createAction (modifyIORef' ref (+ 1)) -- First render renderWidget rs (Button ButtonConfig - { bcLabel = "old", bcAction = clickHandle, bcFontConfig = Nothing }) + { bcLabel = "old", bcAction = clickHandle, bcFontConfig = Nothing, bcTextColor = Nothing }) -- Second render (same handle) renderWidget rs (Button ButtonConfig - { bcLabel = "new", bcAction = clickHandle, bcFontConfig = Nothing }) + { bcLabel = "new", bcAction = clickHandle, bcFontConfig = Nothing, bcTextColor = Nothing }) dispatchEvent rs (actionId clickHandle) count <- readIORef ref count @?= 1 , testCase "dispatching unknown callback ID logs error" $ do ((), rs) <- withActions (pure ()) - renderWidget rs (Text TextConfig { tcLabel = "no buttons", tcFontConfig = Nothing }) + renderWidget rs (Text TextConfig { tcLabel = "no buttons", tcFontConfig = Nothing, tcTextColor = Nothing }) -- Should not throw (logs to stderr) dispatchEvent rs 42 dispatchEvent rs 999 @@ -132,17 +133,17 @@ uiTests = testGroup "UI" hB <- createAction (pure ()) pure (hA, hB) let widget = column - [ Text TextConfig { tcLabel = "header", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "header", tcFontConfig = Nothing, tcTextColor = Nothing } , row [ Button ButtonConfig - { bcLabel = "a", bcAction = handleA, bcFontConfig = Nothing } + { bcLabel = "a", bcAction = handleA, bcFontConfig = Nothing, bcTextColor = Nothing } , column - [ Text TextConfig { tcLabel = "nested", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "nested", tcFontConfig = Nothing, tcTextColor = Nothing } , Button ButtonConfig - { bcLabel = "b", bcAction = handleB, bcFontConfig = Nothing } + { bcLabel = "b", bcAction = handleB, bcFontConfig = Nothing, bcTextColor = Nothing } ] ] - , Text TextConfig { tcLabel = "footer", tcFontConfig = Nothing } + , Text TextConfig { tcLabel = "footer", tcFontConfig = Nothing, tcTextColor = Nothing } ] -- Should not throw — exercises all node types renderWidget rs widget @@ -198,8 +199,8 @@ scrollViewTests = testGroup "ScrollView" [ testCase "scrollable Column renders without error" $ do ((), rs) <- withActions (pure ()) renderWidget rs (Column (LayoutSettings - [ item (Text TextConfig { tcLabel = "item 1", tcFontConfig = Nothing }) - , item (Text TextConfig { tcLabel = "item 2", tcFontConfig = Nothing }) + [ item (Text TextConfig { tcLabel = "item 1", tcFontConfig = Nothing, tcTextColor = Nothing }) + , item (Text TextConfig { tcLabel = "item 2", tcFontConfig = Nothing, tcTextColor = Nothing }) ] True)) , testCase "button inside scrollable Column fires its callback" $ do @@ -208,7 +209,7 @@ scrollViewTests = testGroup "ScrollView" createAction (modifyIORef' ref (+ 1)) renderWidget rs $ Column (LayoutSettings [ item (Button ButtonConfig - { bcLabel = "press me", bcAction = clickHandle, bcFontConfig = Nothing }) ] + { bcLabel = "press me", bcAction = clickHandle, bcFontConfig = Nothing, bcTextColor = Nothing }) ] True) dispatchEvent rs (actionId clickHandle) count <- readIORef ref @@ -220,9 +221,9 @@ scrollViewTests = testGroup "ScrollView" createAction (modifyIORef' ref (const True)) renderWidget rs $ Column (LayoutSettings [ item (column - [ Text TextConfig { tcLabel = "header", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "header", tcFontConfig = Nothing, tcTextColor = Nothing } , Button ButtonConfig - { bcLabel = "action", bcAction = clickHandle, bcFontConfig = Nothing } + { bcLabel = "action", bcAction = clickHandle, bcFontConfig = Nothing, bcTextColor = Nothing } ]) ] True) dispatchEvent rs (actionId clickHandle) @@ -234,16 +235,16 @@ scrollViewTests = testGroup "ScrollView" (clickHandle, rs) <- withActions $ createAction (modifyIORef' ref (+ 1)) renderWidget rs $ Column (LayoutSettings [item (Button ButtonConfig - { bcLabel = "old", bcAction = clickHandle, bcFontConfig = Nothing })] True) + { bcLabel = "old", bcAction = clickHandle, bcFontConfig = Nothing, bcTextColor = Nothing })] True) renderWidget rs $ Column (LayoutSettings [item (Button ButtonConfig - { bcLabel = "new", bcAction = clickHandle, bcFontConfig = Nothing })] True) + { bcLabel = "new", bcAction = clickHandle, bcFontConfig = Nothing, bcTextColor = Nothing })] True) dispatchEvent rs (actionId clickHandle) count <- readIORef ref count @?= 1 , testCase "scrollable flag change recreates native node" $ do ((), rs) <- withActions (pure ()) - let nonScrollable = column [Text TextConfig { tcLabel = "a", tcFontConfig = Nothing }] + let nonScrollable = column [Text TextConfig { tcLabel = "a", tcFontConfig = Nothing, tcTextColor = Nothing }] renderWidget rs nonScrollable tree1 <- readIORef (rsRenderedTree rs) let nodeId1 = case tree1 of @@ -252,7 +253,7 @@ scrollViewTests = testGroup "ScrollView" Just (RenderedStyled _ _ _) -> -1 Just (RenderedAnimated _ _) -> -1 Nothing -> -1 - let scrollable = Column (LayoutSettings [item (Text TextConfig { tcLabel = "a", tcFontConfig = Nothing })] True) + let scrollable = Column (LayoutSettings [item (Text TextConfig { tcLabel = "a", tcFontConfig = Nothing, tcTextColor = Nothing })] True) renderWidget rs scrollable tree2 <- readIORef (rsRenderedTree rs) let nodeId2 = case tree2 of @@ -265,22 +266,22 @@ scrollViewTests = testGroup "ScrollView" , testCase "scrollColumn creates a scrollable Column" $ do let widget = scrollColumn - [ Text TextConfig { tcLabel = "a", tcFontConfig = Nothing } - , Text TextConfig { tcLabel = "b", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "a", tcFontConfig = Nothing, tcTextColor = Nothing } + , Text TextConfig { tcLabel = "b", tcFontConfig = Nothing, tcTextColor = Nothing } ] widget @?= Column (LayoutSettings - [ item (Text TextConfig { tcLabel = "a", tcFontConfig = Nothing }) - , item (Text TextConfig { tcLabel = "b", tcFontConfig = Nothing }) + [ item (Text TextConfig { tcLabel = "a", tcFontConfig = Nothing, tcTextColor = Nothing }) + , item (Text TextConfig { tcLabel = "b", tcFontConfig = Nothing, tcTextColor = Nothing }) ] True) , testCase "scrollRow creates a scrollable Row" $ do let widget = scrollRow - [ Text TextConfig { tcLabel = "a", tcFontConfig = Nothing } - , Text TextConfig { tcLabel = "b", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "a", tcFontConfig = Nothing, tcTextColor = Nothing } + , Text TextConfig { tcLabel = "b", tcFontConfig = Nothing, tcTextColor = Nothing } ] widget @?= Row (LayoutSettings - [ item (Text TextConfig { tcLabel = "a", tcFontConfig = Nothing }) - , item (Text TextConfig { tcLabel = "b", tcFontConfig = Nothing }) + [ item (Text TextConfig { tcLabel = "a", tcFontConfig = Nothing, tcTextColor = Nothing }) + , item (Text TextConfig { tcLabel = "b", tcFontConfig = Nothing, tcTextColor = Nothing }) ] True) , testCase "scrollColumn button dispatches correctly" $ do @@ -289,7 +290,7 @@ scrollViewTests = testGroup "ScrollView" createAction (modifyIORef' ref (const True)) renderWidget rs $ scrollColumn [ Button ButtonConfig - { bcLabel = "click", bcAction = clickHandle, bcFontConfig = Nothing } + { bcLabel = "click", bcAction = clickHandle, bcFontConfig = Nothing, bcTextColor = Nothing } ] dispatchEvent rs (actionId clickHandle) fired <- readIORef ref @@ -302,8 +303,8 @@ stackTests = testGroup "Stack" [ testCase "Stack renders without error" $ do ((), rs) <- withActions (pure ()) renderWidget rs (Stack - [ item (Text TextConfig { tcLabel = "background", tcFontConfig = Nothing }) - , item (Text TextConfig { tcLabel = "foreground", tcFontConfig = Nothing }) + [ item (Text TextConfig { tcLabel = "background", tcFontConfig = Nothing, tcTextColor = Nothing }) + , item (Text TextConfig { tcLabel = "foreground", tcFontConfig = Nothing, tcTextColor = Nothing }) ]) , testCase "button inside Stack fires its callback" $ do @@ -311,9 +312,9 @@ stackTests = testGroup "Stack" (clickHandle, rs) <- withActions $ createAction (modifyIORef' ref (+ 1)) renderWidget rs $ Stack - [ item (Text TextConfig { tcLabel = "bg", tcFontConfig = Nothing }) + [ item (Text TextConfig { tcLabel = "bg", tcFontConfig = Nothing, tcTextColor = Nothing }) , item (Button ButtonConfig - { bcLabel = "overlay", bcAction = clickHandle, bcFontConfig = Nothing }) + { bcLabel = "overlay", bcAction = clickHandle, bcFontConfig = Nothing, bcTextColor = Nothing }) ] dispatchEvent rs (actionId clickHandle) count <- readIORef ref @@ -324,11 +325,11 @@ stackTests = testGroup "Stack" (clickHandle, rs) <- withActions $ createAction (modifyIORef' ref (const True)) renderWidget rs $ Stack - [ item (Text TextConfig { tcLabel = "bg", tcFontConfig = Nothing }) + [ item (Text TextConfig { tcLabel = "bg", tcFontConfig = Nothing, tcTextColor = Nothing }) , item (column - [ Text TextConfig { tcLabel = "header", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "header", tcFontConfig = Nothing, tcTextColor = Nothing } , Button ButtonConfig - { bcLabel = "action", bcAction = clickHandle, bcFontConfig = Nothing } + { bcLabel = "action", bcAction = clickHandle, bcFontConfig = Nothing, bcTextColor = Nothing } ]) ] dispatchEvent rs (actionId clickHandle) @@ -340,9 +341,9 @@ stackTests = testGroup "Stack" (clickHandle, rs) <- withActions $ createAction (modifyIORef' ref (+ 1)) renderWidget rs $ Stack [item (Button ButtonConfig - { bcLabel = "old", bcAction = clickHandle, bcFontConfig = Nothing })] + { bcLabel = "old", bcAction = clickHandle, bcFontConfig = Nothing, bcTextColor = Nothing })] renderWidget rs $ Stack [item (Button ButtonConfig - { bcLabel = "new", bcAction = clickHandle, bcFontConfig = Nothing })] + { bcLabel = "new", bcAction = clickHandle, bcFontConfig = Nothing, bcTextColor = Nothing })] dispatchEvent rs (actionId clickHandle) count <- readIORef ref count @?= 1 @@ -357,7 +358,8 @@ textInputTests = testGroup "TextInput" let widget = TextInput TextInputConfig { tiInputType = InputText, tiHint = "hint", tiValue = "" , tiOnChange = changeHandle - , tiFontConfig = Nothing, tiAutoFocus = False } + , tiFontConfig = Nothing + , tiTextColor = Nothing, tiAutoFocus = False } renderWidget rs widget dispatchTextEvent rs (onChangeId changeHandle) "hello" val <- readIORef ref @@ -370,7 +372,8 @@ textInputTests = testGroup "TextInput" let widget = TextInput TextInputConfig { tiInputType = InputText, tiHint = "enter weight", tiValue = "80" , tiOnChange = changeHandle - , tiFontConfig = Nothing, tiAutoFocus = False } + , tiFontConfig = Nothing + , tiTextColor = Nothing, tiAutoFocus = False } renderWidget rs widget dispatchTextEvent rs (onChangeId changeHandle) "95.5" val <- readIORef ref @@ -378,7 +381,7 @@ textInputTests = testGroup "TextInput" , testCase "dispatchTextEvent with unknown ID does not crash" $ do ((), rs) <- withActions (pure ()) - renderWidget rs (Text TextConfig { tcLabel = "no inputs", tcFontConfig = Nothing }) + renderWidget rs (Text TextConfig { tcLabel = "no inputs", tcFontConfig = Nothing, tcTextColor = Nothing }) -- Should not throw dispatchTextEvent rs 42 "ignored" dispatchTextEvent rs 999 "also ignored" @@ -392,11 +395,12 @@ textInputTests = testGroup "TextInput" pure (ch, th) let widget = column [ Button ButtonConfig - { bcLabel = "ok", bcAction = clickHandle, bcFontConfig = Nothing } + { bcLabel = "ok", bcAction = clickHandle, bcFontConfig = Nothing, bcTextColor = Nothing } , TextInput TextInputConfig { tiInputType = InputText, tiHint = "hint", tiValue = "" , tiOnChange = changeHandle - , tiFontConfig = Nothing, tiAutoFocus = False } + , tiFontConfig = Nothing + , tiTextColor = Nothing, tiAutoFocus = False } ] renderWidget rs widget dispatchEvent rs (actionId clickHandle) @@ -413,11 +417,13 @@ textInputTests = testGroup "TextInput" renderWidget rs $ TextInput TextInputConfig { tiInputType = InputText, tiHint = "old", tiValue = "" , tiOnChange = changeHandle - , tiFontConfig = Nothing, tiAutoFocus = False } + , tiFontConfig = Nothing + , tiTextColor = Nothing, tiAutoFocus = False } renderWidget rs $ TextInput TextInputConfig { tiInputType = InputText, tiHint = "new", tiValue = "" , tiOnChange = changeHandle - , tiFontConfig = Nothing, tiAutoFocus = False } + , tiFontConfig = Nothing + , tiTextColor = Nothing, tiAutoFocus = False } dispatchTextEvent rs (onChangeId changeHandle) "val" val <- readIORef ref val @?= show ("val" :: String) @@ -429,7 +435,8 @@ textInputTests = testGroup "TextInput" let widget = TextInput TextInputConfig { tiInputType = InputNumber, tiHint = "weight", tiValue = "" , tiOnChange = changeHandle - , tiFontConfig = Nothing, tiAutoFocus = False } + , tiFontConfig = Nothing + , tiTextColor = Nothing, tiAutoFocus = False } renderWidget rs widget dispatchTextEvent rs (onChangeId changeHandle) "72.5" val <- readIORef ref @@ -446,11 +453,13 @@ textInputTests = testGroup "TextInput" [ TextInput TextInputConfig { tiInputType = InputText, tiHint = "name", tiValue = "" , tiOnChange = textHandle - , tiFontConfig = Nothing, tiAutoFocus = False } + , tiFontConfig = Nothing + , tiTextColor = Nothing, tiAutoFocus = False } , TextInput TextInputConfig { tiInputType = InputNumber, tiHint = "weight", tiValue = "" , tiOnChange = numberHandle - , tiFontConfig = Nothing, tiAutoFocus = False } + , tiFontConfig = Nothing + , tiTextColor = Nothing, tiAutoFocus = False } ] renderWidget rs widget dispatchTextEvent rs (onChangeId textHandle) "Alice" @@ -483,7 +492,7 @@ imageTests = testGroup "Image" , testCase "Image inside Column renders" $ do ((), rs) <- withActions (pure ()) renderWidget rs $ column - [ Text TextConfig { tcLabel = "header", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "header", tcFontConfig = Nothing, tcTextColor = Nothing } , Image ImageConfig { icSource = ImageResource (ResourceName "logo"), icScaleType = ScaleFit } ] @@ -540,7 +549,7 @@ webViewTests = testGroup "WebView" , testCase "WebView inside Column renders" $ do ((), rs) <- withActions (pure ()) renderWidget rs $ column - [ Text TextConfig { tcLabel = "header", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "header", tcFontConfig = Nothing, tcTextColor = Nothing } , WebView WebViewConfig { wvUrl = "https://example.com", wvOnPageLoad = Nothing } ] @@ -557,17 +566,17 @@ styledTests :: TestTree styledTests = testGroup "Styled" [ testCase "Styled Text renders without error" $ do ((), rs) <- withActions (pure ()) - renderWidget rs $ Styled (WidgetStyle (Just 8.0) Nothing Nothing Nothing Nothing Nothing Nothing) - (Text TextConfig { tcLabel = "styled", tcFontConfig = Just (FontConfig 20.0) }) + renderWidget rs $ Styled (WidgetStyle (Just 8.0) Nothing Nothing Nothing Nothing Nothing) + (Text TextConfig { tcLabel = "styled", tcFontConfig = Just (FontConfig 20.0), tcTextColor = Nothing }) , testCase "Styled Button fires callback" $ do ref <- newIORef (0 :: Int) (clickHandle, rs) <- withActions $ createAction (modifyIORef' ref (+ 1)) - renderWidget rs $ Styled (WidgetStyle Nothing Nothing Nothing Nothing Nothing Nothing Nothing) + renderWidget rs $ Styled (WidgetStyle Nothing Nothing Nothing Nothing Nothing Nothing) (Button ButtonConfig { bcLabel = "tap", bcAction = clickHandle - , bcFontConfig = Just (FontConfig 16.0) }) + , bcFontConfig = Just (FontConfig 16.0), bcTextColor = Nothing }) dispatchEvent rs (actionId clickHandle) count <- readIORef ref count @?= 1 @@ -577,9 +586,9 @@ styledTests = testGroup "Styled" (clickHandle, rs) <- withActions $ createAction (modifyIORef' ref (const True)) renderWidget rs $ Styled defaultStyle - (column [ Text TextConfig { tcLabel = "info", tcFontConfig = Nothing } + (column [ Text TextConfig { tcLabel = "info", tcFontConfig = Nothing, tcTextColor = Nothing } , Button ButtonConfig - { bcLabel = "go", bcAction = clickHandle, bcFontConfig = Nothing } + { bcLabel = "go", bcAction = clickHandle, bcFontConfig = Nothing, bcTextColor = Nothing } ]) dispatchEvent rs (actionId clickHandle) fired <- readIORef ref @@ -588,14 +597,14 @@ styledTests = testGroup "Styled" , testCase "nested Styled applies both styles" $ do ((), rs) <- withActions (pure ()) renderWidget rs $ - Styled (WidgetStyle (Just 12.0) Nothing Nothing Nothing Nothing Nothing Nothing) - (Styled (WidgetStyle Nothing Nothing Nothing Nothing Nothing Nothing Nothing) - (Text TextConfig { tcLabel = "double styled", tcFontConfig = Just (FontConfig 18.0) })) + Styled (WidgetStyle (Just 12.0) Nothing Nothing Nothing Nothing Nothing) + (Styled (WidgetStyle Nothing Nothing Nothing Nothing Nothing Nothing) + (Text TextConfig { tcLabel = "double styled", tcFontConfig = Just (FontConfig 18.0), tcTextColor = Nothing })) , testCase "defaultStyle is a no-op" $ do ((), rs) <- withActions (pure ()) renderWidget rs $ Styled defaultStyle - (Text TextConfig { tcLabel = "plain", tcFontConfig = Nothing }) + (Text TextConfig { tcLabel = "plain", tcFontConfig = Nothing, tcTextColor = Nothing }) , testCase "re-render preserves callbacks through Styled" $ do ref <- newIORef (0 :: Int) @@ -603,10 +612,10 @@ styledTests = testGroup "Styled" createAction (modifyIORef' ref (+ 1)) renderWidget rs $ Styled defaultStyle (Button ButtonConfig - { bcLabel = "old", bcAction = clickHandle, bcFontConfig = Nothing }) + { bcLabel = "old", bcAction = clickHandle, bcFontConfig = Nothing, bcTextColor = Nothing }) renderWidget rs $ Styled defaultStyle (Button ButtonConfig - { bcLabel = "new", bcAction = clickHandle, bcFontConfig = Nothing }) + { bcLabel = "new", bcAction = clickHandle, bcFontConfig = Nothing, bcTextColor = Nothing }) dispatchEvent rs (actionId clickHandle) count <- readIORef ref count @?= 1 @@ -617,16 +626,16 @@ textAlignTests :: TestTree textAlignTests = testGroup "TextAlignment" [ testCase "Styled with AlignCenter renders without error" $ do ((), rs) <- withActions (pure ()) - renderWidget rs $ Styled (WidgetStyle Nothing (Just AlignCenter) Nothing Nothing Nothing Nothing Nothing) - (Text TextConfig { tcLabel = "centered", tcFontConfig = Nothing }) + renderWidget rs $ Styled (WidgetStyle Nothing (Just AlignCenter) Nothing Nothing Nothing Nothing) + (Text TextConfig { tcLabel = "centered", tcFontConfig = Nothing, tcTextColor = Nothing }) , testCase "Styled with AlignCenter on Button fires callback" $ do ref <- newIORef (0 :: Int) (clickHandle, rs) <- withActions $ createAction (modifyIORef' ref (+ 1)) - renderWidget rs $ Styled (WidgetStyle Nothing (Just AlignCenter) Nothing Nothing Nothing Nothing Nothing) + renderWidget rs $ Styled (WidgetStyle Nothing (Just AlignCenter) Nothing Nothing Nothing Nothing) (Button ButtonConfig - { bcLabel = "tap", bcAction = clickHandle, bcFontConfig = Nothing }) + { bcLabel = "tap", bcAction = clickHandle, bcFontConfig = Nothing, bcTextColor = Nothing }) dispatchEvent rs (actionId clickHandle) count <- readIORef ref count @?= 1 @@ -636,50 +645,54 @@ textAlignTests = testGroup "TextAlignment" , testCase "Styled with AlignEnd renders without error" $ do ((), rs) <- withActions (pure ()) - renderWidget rs $ Styled (WidgetStyle Nothing (Just AlignEnd) Nothing Nothing Nothing Nothing Nothing) - (Text TextConfig { tcLabel = "end aligned", tcFontConfig = Nothing }) + renderWidget rs $ Styled (WidgetStyle Nothing (Just AlignEnd) Nothing Nothing Nothing Nothing) + (Text TextConfig { tcLabel = "end aligned", tcFontConfig = Nothing, tcTextColor = Nothing }) ] -- | Tests for color support in Styled widgets. colorTests :: TestTree colorTests = testGroup "Colors" - [ testCase "Styled with textColor renders and callback fires" $ do + [ testCase "a Button label color renders and the callback fires" $ do ref <- newIORef (0 :: Int) (clickHandle, rs) <- withActions $ createAction (modifyIORef' ref (+ 1)) - renderWidget rs $ Styled (WidgetStyle Nothing Nothing (Just (Color 255 0 0 255)) Nothing Nothing Nothing Nothing) - (Button ButtonConfig - { bcLabel = "red", bcAction = clickHandle, bcFontConfig = Nothing }) + renderWidget rs $ Button ButtonConfig + { bcLabel = "red", bcAction = clickHandle + , bcFontConfig = Nothing, bcTextColor = Just (Color 255 0 0 255) } dispatchEvent rs (actionId clickHandle) count <- readIORef ref count @?= 1 + , testCase "coloredText renders without error" $ do + ((), rs) <- withActions (pure ()) + renderWidget rs $ coloredText (Color 255 0 0 255) "red text" + , testCase "Styled with backgroundColor renders without error" $ do ((), rs) <- withActions (pure ()) - renderWidget rs $ Styled (WidgetStyle Nothing Nothing Nothing (Just (Color 0 255 0 255)) Nothing Nothing Nothing) - (Text TextConfig { tcLabel = "green bg", tcFontConfig = Nothing }) + renderWidget rs $ Styled (WidgetStyle Nothing Nothing (Just (Color 0 255 0 255)) Nothing Nothing Nothing) + (Text TextConfig { tcLabel = "green bg", tcFontConfig = Nothing, tcTextColor = Nothing }) - , testCase "both textColor and backgroundColor together" $ do + , testCase "config text color and styled background together" $ do ref <- newIORef (0 :: Int) (clickHandle, rs) <- withActions $ createAction (modifyIORef' ref (+ 1)) - renderWidget rs $ Styled (WidgetStyle Nothing Nothing (Just (Color 255 0 0 255)) (Just (Color 0 255 0 255)) Nothing Nothing Nothing) + renderWidget rs $ Styled (WidgetStyle Nothing Nothing (Just (Color 0 255 0 255)) Nothing Nothing Nothing) (Button ButtonConfig - { bcLabel = "colored", bcAction = clickHandle, bcFontConfig = Nothing }) + { bcLabel = "colored", bcAction = clickHandle + , bcFontConfig = Nothing, bcTextColor = Just (Color 255 0 0 255) }) dispatchEvent rs (actionId clickHandle) count <- readIORef ref count @?= 1 , testCase "defaultStyle has no colors" $ do - wsTextColor defaultStyle @?= Nothing wsBackgroundColor defaultStyle @?= Nothing - , testCase "nested Styled with different colors renders" $ do + , testCase "nested Styled with a colored text child renders" $ do ((), rs) <- withActions (pure ()) renderWidget rs $ - Styled (WidgetStyle Nothing Nothing (Just (Color 255 0 0 255)) Nothing Nothing Nothing Nothing) - (Styled (WidgetStyle Nothing Nothing Nothing (Just (Color 0 0 255 255)) Nothing Nothing Nothing) - (Text TextConfig { tcLabel = "nested colors", tcFontConfig = Nothing })) + Styled (WidgetStyle (Just 4.0) Nothing Nothing Nothing Nothing Nothing) + (Styled (WidgetStyle Nothing Nothing (Just (Color 0 0 255 255)) Nothing Nothing Nothing) + (coloredText (Color 255 0 0 255) "nested colors")) , testCase "colorFromText parses #RRGGBB" $ colorFromText "#FF0000" @?= Just (Color 255 0 0 255) @@ -737,7 +750,7 @@ mapViewTests = testGroup "MapView" , testCase "MapView inside Column renders" $ do ((), rs) <- withActions (pure ()) renderWidget rs $ column - [ Text TextConfig { tcLabel = "header", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "header", tcFontConfig = Nothing, tcTextColor = Nothing } , MapView MapViewConfig { mvLatitude = 52.3676, mvLongitude = 4.9041 , mvZoom = 12.0, mvShowUserLocation = False diff --git a/test/TextInputDemoMain.hs b/test/TextInputDemoMain.hs index 4cb14c7e..d92f18b8 100644 --- a/test/TextInputDemoMain.hs +++ b/test/TextInputDemoMain.hs @@ -27,13 +27,14 @@ main = do -- | Builds a Column with a label and two TextInputs of different InputType. textInputDemoView :: OnChange -> OnChange -> IO Widget textInputDemoView onWeightChange onNameChange = pure $ column - [ Text TextConfig { tcLabel = "TextInput Demo", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "TextInput Demo", tcFontConfig = Nothing, tcTextColor = Nothing } , TextInput TextInputConfig { tiInputType = InputNumber , tiHint = "enter weight (kg)" , tiValue = "" , tiOnChange = onWeightChange , tiFontConfig = Nothing + , tiTextColor = Nothing , tiAutoFocus = True } , TextInput TextInputConfig @@ -42,6 +43,7 @@ textInputDemoView onWeightChange onNameChange = pure $ column , tiValue = "" , tiOnChange = onNameChange , tiFontConfig = Nothing + , tiTextColor = Nothing , tiAutoFocus = False } ] diff --git a/test/TextInputReRenderDemoMain.hs b/test/TextInputReRenderDemoMain.hs index 190e6cb9..2acd659a 100644 --- a/test/TextInputReRenderDemoMain.hs +++ b/test/TextInputReRenderDemoMain.hs @@ -47,10 +47,12 @@ textInputReRenderView typedRef onChange = do , tiValue = typed , tiOnChange = onChange , tiFontConfig = Nothing + , tiTextColor = Nothing , tiAutoFocus = True } , Text TextConfig { tcLabel = displayLabel , tcFontConfig = Nothing + , tcTextColor = Nothing } ] diff --git a/test/WebViewDemoMain.hs b/test/WebViewDemoMain.hs index 2dc4e371..bc59d336 100644 --- a/test/WebViewDemoMain.hs +++ b/test/WebViewDemoMain.hs @@ -50,7 +50,7 @@ webViewDemoView :: IORef String -> Action -> Action -> UserState -> IO Widget webViewDemoView urlRef onPageLoad onLoadExampleOrg _userState = do currentUrl <- readIORef urlRef pure $ column - [ Text TextConfig { tcLabel = "WebView Demo", tcFontConfig = Nothing } + [ Text TextConfig { tcLabel = "WebView Demo", tcFontConfig = Nothing, tcTextColor = Nothing } , WebView WebViewConfig { wvUrl = pack currentUrl , wvOnPageLoad = Just onPageLoad @@ -59,5 +59,6 @@ webViewDemoView urlRef onPageLoad onLoadExampleOrg _userState = do { bcLabel = "Load example.org" , bcAction = onLoadExampleOrg , bcFontConfig = Nothing + , bcTextColor = Nothing } ]