Add test cases for focus and style functions

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
+  }

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
+  }

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