Add support for switching vertical wheel scrolling to horizontal in scroll widget by pressing the shift key (#137)

* Add support for switching vertical wheel scrolling to horizontal scrolling by pressing the shift key

* Update Changelog

* Update Changelog

ChangeLog.md

@@ -1,3 +1,10 @@
+## 1.5.0.0 (in development)
+
+### Added
+
+- Support for switching vertical wheel scrolling to horizontal in scroll widget by pressing the shift key ([PR #137](https://github.com/fjvallarino/monomer/pull/137)).
+- Drawing and theme utility functions ([PR #138](https://github.com/fjvallarino/monomer/pull/138)).
+
 ## 1.4.0.0
 
 ### Breaking changes

src/Monomer/Widgets/Containers/Scroll.hs

@@ -588,8 +588,12 @@ makeScroll config state = widget where
       result
         | needsUpdate = Just $ makeResult newState
         | otherwise = Nothing
-      stepX = wheelRate * wx
-      stepY = wheelRate * wy
+      stepX
+        | shiftPressed && changedY = wheelRate * wy
+        | otherwise = wheelRate * wx
+      stepY
+        | shiftPressed = 0
+        | otherwise = wheelRate * wy
       newState = state {
         _sstDeltaX = scrollAxisH (stepX + dx),
         _sstDeltaY = scrollAxisV (stepY + dy)
@@ -601,6 +605,7 @@ makeScroll config state = widget where
       style = scrollCurrentStyle wenv node
       contentArea = getContentArea node style
       mousePos = wenv ^. L.inputStatus . L.mousePos
+      shiftPressed = isShiftPressed (wenv ^. L.inputStatus . L.keyMod)
 
       Rect cx cy cw ch = contentArea
       sctx = scrollStatus config wenv node state mousePos

test/unit/Monomer/Widgets/Containers/ScrollSpec.hs

@@ -53,6 +53,7 @@ handleEvent = describe "handleEvent" $ do
   handleBarClick
   handleThumbDrag
   handleChildrenFocus
+  handleWheel
   handleNestedWheel
   handleMessageReset
   raiseOnChange
@@ -168,6 +169,47 @@ handleChildrenFocus = describe "handleChildrenFocus" $ do
     evtsIgnore es = nodeHandleEventEvts wenv es ignoreNode
     evtsFollow es = nodeHandleEventEvts wenv es followNode
 
+handleWheel :: Spec
+handleWheel = describe "handleWheel" $ do
+  it "should scroll horizontally with the horizontal wheel and click the second button" $ do
+    eventsH False `shouldBe` Seq.fromList [Button2]
+
+  it "should scroll horizontally with the horizontal wheel, ignoring shift, and click the second button" $ do
+    eventsH True `shouldBe` Seq.fromList [Button2]
+
+  it "should scroll vertically with the vertical wheel and click the third button" $ do
+    eventsV False `shouldBe` Seq.fromList [Button3]
+
+  it "should scroll horizontally with the vertical wheel, since shift is pressed, and click the second button" $ do
+    eventsV True `shouldBe` Seq.fromList [Button2]
+
+  where
+    wenv shiftPressed = mockWenv ()
+      & L.windowSize .~ Size 640 480
+      & L.inputStatus . L.keyMod . L.leftShift .~ shiftPressed
+
+    point = Point 160 240
+    st = [width 640, height 480]
+    stackNode = vstack [
+        hstack [
+          button "Button 1" Button1 `styleBasic` st,
+          button "Button 2" Button2 `styleBasic` st
+        ],
+        hstack [
+          button "Button 3" Button3 `styleBasic` st,
+          button "Button 4" Button4 `styleBasic` st
+        ]
+      ]
+    scrollNode = scroll stackNode
+
+    eventsH shift = nodeHandleEventEvts (wenv shift) es scrollNode where
+      evtWheel = WheelScroll point (Point (-2000) 0) WheelNormal
+      es = [evtWheel, evtClick point]
+
+    eventsV shift = nodeHandleEventEvts (wenv shift) es scrollNode where
+      evtWheel = WheelScroll point (Point 0 (-2000)) WheelNormal
+      es = [evtWheel, evtClick point]
+
 handleNestedWheel :: Spec
 handleNestedWheel = describe "handleNestedWheel" $ do
   it "should scroll main widget" $ do