diff --git a/test/unit/Monomer/Widgets/Util/FocusSpec.hs b/test/unit/Monomer/Widgets/Util/FocusSpec.hs new file mode 100644 index 00000000..a82b3824 --- /dev/null +++ b/test/unit/Monomer/Widgets/Util/FocusSpec.hs @@ -0,0 +1,90 @@ +module Monomer.Widgets.Util.FocusSpec (spec) where + +import Control.Lens ((^.), ix) +import Data.Default +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Widgets.Label +import Monomer.Widgets.Util.Focus +import Monomer.TestUtil + +import qualified Monomer.Lens as L + +spec :: Spec +spec = describe "Focus" $ do + testParentPath + testNextTargetStep + testIsFocusCandidate + +testParentPath :: Spec +testParentPath = describe "parentPath" $ do + it "should return root path" $ do + parentPath (pathInst []) `shouldBe` rootPath + parentPath (pathInst [0]) `shouldBe` rootPath + + it "should return a single element path" $ do + parentPath (pathInst [0, 1]) `shouldBe` Seq.fromList [0] + parentPath (pathInst [1, 4]) `shouldBe` Seq.fromList [1] + + it "should return a multiple element path" $ do + parentPath (pathInst [0, 1, 2]) `shouldBe` Seq.fromList [0, 1] + parentPath (pathInst [0, 1, 2, 3, 4]) `shouldBe` Seq.fromList [0, 1, 2, 3] + +testNextTargetStep :: Spec +testNextTargetStep = describe "nextTargetStep" $ do + it "should return Nothing if next step is not valid" $ do + nextTargetStep (path []) (pathInst []) `shouldBe` Nothing + nextTargetStep (path []) (pathInst_ [] 5) `shouldBe` Nothing + nextTargetStep (path [0]) (pathInst_ [0] 5) `shouldBe` Nothing + nextTargetStep (path [3]) (pathInst_ [0] 5) `shouldBe` Nothing + + it "should return a valid target step" $ do + nextTargetStep (path [2]) (pathInst_ [] 5) `shouldBe` Just 2 + nextTargetStep (path [0, 3]) (pathInst_ [0] 5) `shouldBe` Just 3 + +testIsFocusCandidate :: Spec +testIsFocusCandidate = describe "isFocusCandidate" $ do + it "should return False if not backward candidate" $ do + isFocusCandidate FocusBwd (path [0]) (pathInst [0]) `shouldBe` False + isFocusCandidate FocusBwd (path [0, 0]) (pathInst [0, 1]) `shouldBe` False + + it "should return True if backward candidate" $ do + isFocusCandidate FocusBwd (path []) (pathInst []) `shouldBe` True + isFocusCandidate FocusBwd (path [0]) (pathInst []) `shouldBe` True + isFocusCandidate FocusBwd (path [1]) (pathInst [0]) `shouldBe` True + isFocusCandidate FocusBwd (path [0, 1]) (pathInst [0, 0]) `shouldBe` True + isFocusCandidate FocusBwd (path [0, 0, 1]) (pathInst [0, 0]) `shouldBe` True + isFocusCandidate FocusBwd (path [0, 2]) (pathInst [0, 1, 1]) `shouldBe` True + + it "should return False if not forward candidate" $ do + isFocusCandidate FocusFwd (path []) (pathInst []) `shouldBe` False + isFocusCandidate FocusFwd (path [0]) (pathInst []) `shouldBe` False + isFocusCandidate FocusFwd (path [1]) (pathInst [0]) `shouldBe` False + isFocusCandidate FocusFwd (path [0, 1]) (pathInst [0, 0]) `shouldBe` False + + it "should return True if forward candidate" $ do + isFocusCandidate FocusFwd (path []) (pathInst [0]) `shouldBe` True + isFocusCandidate FocusFwd (path [0]) (pathInst [1]) `shouldBe` True + isFocusCandidate FocusFwd (path [0, 0]) (pathInst [0, 1]) `shouldBe` True + isFocusCandidate FocusFwd (path [0, 1, 1]) (pathInst [0, 2]) `shouldBe` True + +path :: [PathStep] -> Path +path p = Seq.fromList p + +pathInst :: [PathStep] -> WidgetInstance s e +pathInst path = pathInst_ path 0 + +pathInst_ :: [PathStep] -> Int -> WidgetInstance s e +pathInst_ path childCount = newInst where + mkChild idx = pathInst_ (path ++ [idx]) 0 + newInst = (label "Test") { + _wiPath = Seq.fromList path, + _wiChildren = Seq.fromList $ fmap mkChild [0..childCount - 1], + _wiVisible = True, + _wiEnabled = True, + _wiFocusable = True + } diff --git a/test/unit/Monomer/Widgets/Util/StyleSpec.hs b/test/unit/Monomer/Widgets/Util/StyleSpec.hs new file mode 100644 index 00000000..968a5bc8 --- /dev/null +++ b/test/unit/Monomer/Widgets/Util/StyleSpec.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Monomer.Widgets.Util.StyleSpec (spec) where + +import Control.Lens ((&), (^.), (^?), (^?!), (.~), (?~), _Just, ix, non) +import Data.Default +import Data.Sequence (Seq) +import Data.Text (Text) +import Test.Hspec + +import qualified Data.Sequence as Seq + +import Monomer.Core +import Monomer.Event +import Monomer.Graphics +import Monomer.Widgets.Label +import Monomer.Widgets.Util.Style +import Monomer.TestUtil + +import qualified Monomer.Lens as L + +spec :: Spec +spec = describe "Style" $ do + testActiveStyle + testHandleSizeChange + +testActiveStyle :: Spec +testActiveStyle = describe "activeStyle" $ do + it "should return basic style" $ + activeStyle wenvBasic instNormal ^. L.bgColor `shouldBe` Just white + + it "should return hover style" $ + activeStyle wenvHover instNormal ^. L.bgColor `shouldBe` Just green + + it "should return focus style" $ do + activeStyle wenvFocus instNormal ^. L.bgColor `shouldBe` Just blue + activeStyle wenvHoverFocus instNormal ^. L.bgColor `shouldBe` Just blue + + it "should return disabled style" $ do + activeStyle wenvBasic instDisabled ^. L.bgColor `shouldBe` Just gray + activeStyle wenvHover instDisabled ^. L.bgColor `shouldBe` Just gray + activeStyle wenvFocus instDisabled ^. L.bgColor `shouldBe` Just gray + activeStyle wenvHoverFocus instDisabled ^. L.bgColor `shouldBe` Just gray + + where + wenvBasic = mockWenv () & L.inputStatus . L.mousePos .~ Point 0 0 + wenvFocus = wenvBasic & L.focusedPath .~ Seq.fromList [0] + wenvHover = mockWenv () & L.inputStatus . L.mousePos .~ Point 200 200 + wenvHoverFocus = wenvHover + & L.inputStatus . L.mousePos .~ Point 200 200 + & L.focusedPath .~ Seq.fromList [0] + instNormal = createInst True + instDisabled = createInst False + +testHandleSizeChange :: Spec +testHandleSizeChange = describe "handleSizeChange" $ do + it "should request Resize widgets if sizeReq changed" $ do + resHover ^? _Just . L.requests . ix 0 `shouldSatisfy` isResizeWidgets + resHover ^? _Just . L.requests `shouldSatisfy` (==1) . maybeLength + + it "should not request Resize widgets if sizeReq has not changed" $ + resFocus ^? _Just . L.requests `shouldSatisfy` (==0) . maybeLength + + where + wenv = mockWenv () + style = createStyle + & L.hover ?~ padding 10 + hoverStyle = style ^?! L.hover . _Just + focusStyle = style ^?! L.focus . _Just + baseInst = createInst True & L.style .~ style + inst = instInit wenv baseInst + point = Point 200 200 + path = Seq.fromList [0] + wenvHover = mockWenv () & L.inputStatus . L.mousePos .~ point + wenvFocus = mockWenv () & L.focusedPath .~ path + evtEnter = Enter path point + resHover = handleStyleChange wenvHover path evtEnter hoverStyle Nothing inst + resFocus = handleStyleChange wenvFocus path Focus focusStyle Nothing inst + +isResizeWidgets :: Maybe (WidgetRequest s) -> Bool +isResizeWidgets (Just ResizeWidgets) = True +isResizeWidgets _ = False + +maybeLength :: Maybe (Seq a) -> Int +maybeLength Nothing = 0 +maybeLength (Just s) = Seq.length s + +createStyle :: Style +createStyle = newStyle where + basic = createStyleState 10 white + hover = createStyleState 20 green + focus = createStyleState 30 blue + disabled = createStyleState 40 gray + newStyle = Style basic hover focus disabled + +createStyleState :: Double -> Color -> Maybe StyleState +createStyleState size col = Just newState where + newState = textSize size <> bgColor col + +createInst :: Bool -> WidgetInstance s e +createInst enabled = newInst where + viewport = Rect 100 100 200 200 + newInst = (label "Test") { + _wiPath = Seq.fromList [0], + _wiViewport = viewport, + _wiRenderArea = viewport, + _wiStyle = createStyle, + _wiVisible = True, + _wiEnabled = enabled, + _wiFocusable = True + } diff --git a/test/unit/Spec.hs b/test/unit/Spec.hs index 5faad5f1..ac4afd86 100644 --- a/test/unit/Spec.hs +++ b/test/unit/Spec.hs @@ -18,6 +18,8 @@ import qualified Monomer.Widgets.StackSpec as StackSpec import qualified Monomer.Widgets.TextFieldSpec as TextFieldSpec import qualified Monomer.Widgets.ZStackSpec as ZStackSpec +import qualified Monomer.Widgets.Util.FocusSpec as FocusSpec +import qualified Monomer.Widgets.Util.StyleSpec as StyleSpec import qualified Monomer.Widgets.Util.TextSpec as TextSpec main :: IO () @@ -47,5 +49,7 @@ widgets = describe "Widgets" $ do widgetsUtil widgetsUtil :: Spec -widgetsUtil = describe "Util" +widgetsUtil = describe "Util" $ do + FocusSpec.spec + StyleSpec.spec TextSpec.spec