Add dial unit tests

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,

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

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

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)

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)

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)

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