From 9ae305496b9eb6ea3ac02099d69d3d88b839a38c Mon Sep 17 00:00:00 2001 From: Francisco Vallarino Date: Wed, 20 Jan 2021 00:11:04 -0300 Subject: [PATCH] Add dial unit tests --- app/Main.hs | 3 +- src/Monomer/Widgets/Dial.hs | 34 +++-- src/Monomer/Widgets/Util/Hover.hs | 8 +- test/unit/Monomer/Widgets/CheckboxSpec.hs | 3 +- test/unit/Monomer/Widgets/DialSpec.hs | 170 ++++++++++++++++++++++ test/unit/Monomer/Widgets/RadioSpec.hs | 9 +- test/unit/Spec.hs | 2 + 7 files changed, 212 insertions(+), 17 deletions(-) create mode 100644 test/unit/Monomer/Widgets/DialSpec.hs diff --git a/app/Main.hs b/app/Main.hs index 18dc2fdf..e23209cf 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -120,7 +120,8 @@ handleAppEvent wenv model evt = case evt of _ -> [] buildUI :: WidgetEnv App AppEvent -> App -> WidgetNode App AppEvent -buildUI wenv model = traceShow "Creating UI" widgetSplitH where +buildUI wenv model = traceShow "Creating UI" widgetDialSingle where + widgetDialSingle = dial double1 (-100) 100 widgetDial = vstack [ hstack [ radioV (model ^. fruit) RadioSt Apple, diff --git a/src/Monomer/Widgets/Dial.hs b/src/Monomer/Widgets/Dial.hs index 35b0ee82..16b745b2 100644 --- a/src/Monomer/Widgets/Dial.hs +++ b/src/Monomer/Widgets/Dial.hs @@ -163,6 +163,7 @@ makeDial field minVal maxVal config state = widget where singleGetActiveStyle = getActiveStyle, singleInit = init, singleRestore = restore, + singleFindByPoint = findByPoint, singleHandleEvent = handleEvent, singleGetSizeReq = getSizeReq, singleRender = render @@ -191,14 +192,13 @@ makeDial field minVal maxVal config state = widget where resNode = newNode & L.widget .~ makeDial field minVal maxVal config newState - newStateFromModel wenv node oldState = newState where - currVal = widgetDataGet (wenv ^. L.model) field - newMaxPos = round (fractionalToReal (maxVal - minVal) / dragRate) - newPos = round (fractionalToReal (currVal - minVal) / dragRate) - newState = oldState { - _dlsMaxPos = newMaxPos, - _dlsPos = newPos - } + findByPoint wenv path point node + | isVisible && pointInEllipse point dialArea = Just path + | otherwise = Nothing + where + isVisible = node ^. L.info . L.visible + path = node ^. L.info . L.path + (_, dialArea) = getDialInfo wenv node config handleEvent wenv target evt node = case evt of Focus -> handleFocusChange _dlcOnFocus _dlcOnFocusReq config node @@ -243,11 +243,14 @@ makeDial field minVal maxVal config state = widget where path = node ^. L.info . L.path isSelectKey code = isKeyReturn code || isKeySpace code addReqsEvts result newVal = newResult where + currVal = widgetDataGet (wenv ^. L.model) field evts = fmap ($ newVal) (_dlcOnChange config) reqs = widgetDataSet field newVal ++ _dlcOnChangeReq config - newResult = result - & L.events .~ Seq.fromList evts - & L.requests <>~ Seq.fromList reqs + newResult + | currVal /= newVal = result + & L.events .~ Seq.fromList evts + & L.requests <>~ Seq.fromList reqs + | otherwise = result getSizeReq wenv currState node = req where theme = activeTheme wenv node @@ -271,6 +274,15 @@ makeDial field minVal maxVal config state = widget where endFg = 45 endHl = start + 270 * posPct + newStateFromModel wenv node oldState = newState where + currVal = widgetDataGet (wenv ^. L.model) field + newMaxPos = round (fractionalToReal (maxVal - minVal) / dragRate) + newPos = round (fractionalToReal (currVal - minVal) / dragRate) + newState = oldState { + _dlsMaxPos = newMaxPos, + _dlsPos = newPos + } + posFromPoint :: DialValue a => a diff --git a/src/Monomer/Widgets/Util/Hover.hs b/src/Monomer/Widgets/Util/Hover.hs index af4fcfd1..8801ad63 100644 --- a/src/Monomer/Widgets/Util/Hover.hs +++ b/src/Monomer/Widgets/Util/Hover.hs @@ -1,5 +1,6 @@ module Monomer.Widgets.Util.Hover ( isPointInNodeVp, + isPointInNodeEllipse, isNodeActive, isNodePressed, isNodeHovered, @@ -24,6 +25,9 @@ import qualified Monomer.Lens as L isPointInNodeVp :: Point -> WidgetNode s e -> Bool isPointInNodeVp p node = pointInRect p (node ^. L.info . L.viewport) +isPointInNodeEllipse :: Point -> WidgetNode s e -> Bool +isPointInNodeEllipse p node = pointInEllipse p (node ^. L.info . L.viewport) + isNodeActive :: WidgetEnv s e -> WidgetNode s e -> Bool isNodeActive wenv node = validPos && pressed where viewport = node ^. L.info . L.viewport @@ -46,9 +50,11 @@ isNodeHovered wenv node = validPos && validPress && topLevel where topLevel = isNodeTopLevel wenv node isNodeHoveredEllipse_ :: Rect -> WidgetEnv s e -> WidgetNode s e -> Bool -isNodeHoveredEllipse_ area wenv node = validPos && topLevel where +isNodeHoveredEllipse_ area wenv node = validPos && validPress && topLevel where mousePos = wenv ^. L.inputStatus . L.mousePos validPos = pointInEllipse mousePos area + pressed = wenv ^. L.mainBtnPress ^? _Just . _1 + validPress = isNothing pressed || isNodePressed wenv node topLevel = isNodeTopLevel wenv node isNodeTopLevel :: WidgetEnv s e -> WidgetNode s e -> Bool diff --git a/test/unit/Monomer/Widgets/CheckboxSpec.hs b/test/unit/Monomer/Widgets/CheckboxSpec.hs index ec3881f5..953bb97b 100644 --- a/test/unit/Monomer/Widgets/CheckboxSpec.hs +++ b/test/unit/Monomer/Widgets/CheckboxSpec.hs @@ -93,5 +93,6 @@ updateSizeReq = describe "updateSizeReq" $ do sizeReqH `shouldBe` FixedSize 20 where - wenv = mockWenvEvtUnit (TestModel False) & L.theme .~ darkTheme + wenv = mockWenvEvtUnit (TestModel False) + & L.theme .~ darkTheme (sizeReqW, sizeReqH) = nodeUpdateSizeReq wenv (checkbox testBool) diff --git a/test/unit/Monomer/Widgets/DialSpec.hs b/test/unit/Monomer/Widgets/DialSpec.hs new file mode 100644 index 00000000..931db3d0 --- /dev/null +++ b/test/unit/Monomer/Widgets/DialSpec.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Monomer.Widgets.DialSpec (spec) where + +import Control.Lens ((&), (^.), (.~)) +import Control.Lens.TH (abbreviatedFields, makeLensesWith) +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.Core.Combinators +import Monomer.Event +import Monomer.TestUtil +import Monomer.TestEventUtil +import Monomer.Widgets.Dial + +import qualified Monomer.Lens as L + +data TestEvt + = DialChanged Double + | GotFocus + | LostFocus + deriving (Eq, Show) + +newtype TestModel = TestModel { + _tmDialVal :: Double +} deriving (Eq, Show) + +makeLensesWith abbreviatedFields ''TestModel + +spec :: Spec +spec = describe "Dial" $ do + handleEventKeyboard + handleEventMouseDrag + handleEventMouseDragVal + updateSizeReq + +handleEventKeyboard :: Spec +handleEventKeyboard = describe "handleEventKeyboard" $ do + it "should press arrow up ten times and set the dial value to 20" $ do + let steps = replicate 10 (evtK keyUp) + model steps ^. dialVal `shouldBe` 20 + + it "should press arrow up + shift ten times and set the dial value to 2" $ do + let steps = replicate 10 (evtKS keyUp) + model steps ^. dialVal `shouldBe` 2 + + it "should press arrow up + ctrl four times and set the dial value to 80" $ do + let steps = replicate 4 (evtKG keyUp) + model steps ^. dialVal `shouldBe` 80 + + it "should press arrow down ten times and set the dial value to -20" $ do + let steps = replicate 10 (evtK keyDown) + model steps ^. dialVal `shouldBe` (-20) + + it "should press arrow down + shift five times and set the dial value to 1" $ do + let steps = replicate 5 (evtKS keyDown) + model steps ^. dialVal `shouldBe` -1 + + it "should press arrow up + ctrl one time and set the dial value to -20" $ do + let steps = [evtKG keyDown] + model steps ^. dialVal `shouldBe` (-20) + + where + wenv = mockWenv (TestModel 0) + & L.theme .~ darkTheme + dialNode = dial dialVal (-100) 100 + model es = nodeHandleEventModel wenv es dialNode + +handleEventMouseDrag :: Spec +handleEventMouseDrag = describe "handleEventMouseDrag" $ do + it "should not change the value when dragging off bounds" $ do + let selStart = Point 0 0 + let selEnd = Point 0 100 + let steps = evtDrag selStart selEnd + model steps ^. dialVal `shouldBe` 0 + + it "should not change the value when dragging horizontally" $ do + let selStart = Point 320 240 + let selEnd = Point 500 240 + let steps = evtDrag selStart selEnd + model steps ^. dialVal `shouldBe` 0 + + it "should drag 100 pixels up and set the dial value to 20" $ do + let selStart = Point 320 240 + let selEnd = Point 320 140 + let steps = evtDrag selStart selEnd + model steps ^. dialVal `shouldBe` 20 + + it "should drag 500 pixels up and set the dial value 100" $ do + let selStart = Point 320 240 + let selEnd = Point 320 (-260) + let steps = evtDrag selStart selEnd + model steps ^. dialVal `shouldBe` 100 + + it "should drag 1000 pixels up, but stay on 100" $ do + let selStart = Point 320 240 + let selEnd = Point 320 (-760) + let steps = evtDrag selStart selEnd + model steps ^. dialVal `shouldBe` 100 + + where + wenv = mockWenv (TestModel 0) + & L.theme .~ darkTheme + dialNode = dial dialVal (-100) 100 + model es = nodeHandleEventModel wenv es dialNode + +handleEventMouseDragVal :: Spec +handleEventMouseDragVal = describe "handleEventMouseDragVal" $ do + it "should not change the value when dragging off bounds" $ do + let selStart = Point 0 0 + let selEnd = Point 0 100 + let steps = evtDrag selStart selEnd + evts steps `shouldBe` Seq.fromList [] + + it "should not change the value when dragging horizontally" $ do + let selStart = Point 320 240 + let selEnd = Point 500 240 + let steps = evtDrag selStart selEnd + evts steps `shouldBe` Seq.fromList [] + + it "should drag 100 pixels up and set the dial value to 110" $ do + let selStart = Point 320 240 + let selEnd = Point 320 140 + let steps = evtDrag selStart selEnd + evts steps `shouldBe` Seq.fromList [DialChanged 110] + + it "should drag 490 pixels up and set the dial value 500" $ do + let selStart = Point 320 240 + let selEnd = Point 320 (-250) + let steps = evtDrag selStart selEnd + evts steps `shouldBe` Seq.fromList [DialChanged 500] + + it "should drag 1000 pixels up, but stay on 500" $ do + let selStart = Point 320 240 + let selEnd = Point 320 (-760) + let steps = evtDrag selStart selEnd + evts steps `shouldBe` Seq.fromList [DialChanged 500] + + it "should generate an event when focus is received" $ + evts [Focus] `shouldBe` Seq.singleton GotFocus + + it "should generate an event when focus is lost" $ + evts [Blur] `shouldBe` Seq.singleton LostFocus + + where + wenv = mockWenv (TestModel 0) + & L.theme .~ darkTheme + dialNode = dialV_ 10 DialChanged (-500) 500 [dragRate 1, onFocus GotFocus, onBlur LostFocus] + evts es = nodeHandleEventEvts wenv es dialNode + +updateSizeReq :: Spec +updateSizeReq = describe "updateSizeReq" $ do + it "should return width = Fixed 50" $ + sizeReqW `shouldBe` FixedSize 50 + + it "should return height = Fixed 50" $ + sizeReqH `shouldBe` FixedSize 50 + + where + wenv = mockWenv (TestModel 0) + & L.theme .~ darkTheme + (sizeReqW, sizeReqH) = nodeUpdateSizeReq wenv (dial dialVal 0 100) diff --git a/test/unit/Monomer/Widgets/RadioSpec.hs b/test/unit/Monomer/Widgets/RadioSpec.hs index a5c0d8a6..edc11f1a 100644 --- a/test/unit/Monomer/Widgets/RadioSpec.hs +++ b/test/unit/Monomer/Widgets/RadioSpec.hs @@ -63,7 +63,8 @@ handleEvent = describe "handleEvent" $ do events Blur orangeNode `shouldBe` Seq.singleton LostFocus where - wenv = mockWenv (TestModel Apple) & L.theme .~ darkTheme + wenv = mockWenv (TestModel Apple) + & L.theme .~ darkTheme orangeNode = radio_ fruit Orange [onFocus GotFocus, onBlur LostFocus] bananaNode = radio fruit Banana clickModel p node = nodeHandleEventModel wenv [Click p LeftBtn] node @@ -82,7 +83,8 @@ handleEventValue = describe "handleEventValue" $ do keyModel keyReturn bananaNode `shouldBe` Seq.singleton (FruitSel Banana) where - wenv = mockWenv (TestModel Apple) & L.theme .~ darkTheme + wenv = mockWenv (TestModel Apple) + & L.theme .~ darkTheme orangeNode = radioV Apple FruitSel Orange bananaNode = radioV Apple FruitSel Banana clickModel p node = nodeHandleEventEvts wenv [Click p LeftBtn] node @@ -97,5 +99,6 @@ updateSizeReq = describe "updateSizeReq" $ do sizeReqH `shouldBe` FixedSize 20 where - wenv = mockWenvEvtUnit (TestModel Apple) & L.theme .~ darkTheme + wenv = mockWenvEvtUnit (TestModel Apple) + & L.theme .~ darkTheme (sizeReqW, sizeReqH) = nodeUpdateSizeReq wenv (radio fruit Apple) diff --git a/test/unit/Spec.hs b/test/unit/Spec.hs index 47795ff2..bd772426 100644 --- a/test/unit/Spec.hs +++ b/test/unit/Spec.hs @@ -12,6 +12,7 @@ import qualified Monomer.Widgets.CheckboxSpec as CheckboxSpec import qualified Monomer.Widgets.CompositeSpec as CompositeSpec import qualified Monomer.Widgets.ContainerSpec as ContainerSpec import qualified Monomer.Widgets.ConfirmSpec as ConfirmSpec +import qualified Monomer.Widgets.DialSpec as DialSpec import qualified Monomer.Widgets.DropdownSpec as DropdownSpec import qualified Monomer.Widgets.FloatingFieldSpec as FloatingFieldSpec import qualified Monomer.Widgets.GridSpec as GridSpec @@ -55,6 +56,7 @@ widgets = describe "Widgets" $ do CompositeSpec.spec ContainerSpec.spec ConfirmSpec.spec + DialSpec.spec DropdownSpec.spec FloatingFieldSpec.spec GridSpec.spec