mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-09-20 00:09:02 +03:00
Add test cases for focus and style functions
This commit is contained in:
parent
196fcd4fe7
commit
94d1278b7a
90
test/unit/Monomer/Widgets/Util/FocusSpec.hs
Normal file
90
test/unit/Monomer/Widgets/Util/FocusSpec.hs
Normal file
@ -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
|
||||
}
|
113
test/unit/Monomer/Widgets/Util/StyleSpec.hs
Normal file
113
test/unit/Monomer/Widgets/Util/StyleSpec.hs
Normal file
@ -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
|
||||
}
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user