monomer-1.4.0.0: test/unit/Monomer/Widgets/Containers/ScrollSpec.hs
{-|
Module : Monomer.Widgets.Containers.ScrollSpec
Copyright : (c) 2018 Francisco Vallarino
License : BSD-3-Clause (see the LICENSE file)
Maintainer : fjvallarino@gmail.com
Stability : experimental
Portability : non-portable
Unit tests for Scroll widget.
-}
module Monomer.Widgets.Containers.ScrollSpec (spec) where
import Control.Lens ((&), (^.), (^?), (^?!), (.~), _Just, ix)
import Data.Default
import Data.Text (Text)
import Data.Sequence (Seq(..))
import Test.Hspec
import qualified Data.Sequence as Seq
import Monomer.Core
import Monomer.Core.Combinators
import Monomer.Core.Themes.SampleThemes
import Monomer.Event
import Monomer.Graphics.ColorTable
import Monomer.TestEventUtil
import Monomer.TestUtil
import Monomer.Widgets.Composite
import Monomer.Widgets.Containers.Scroll
import Monomer.Widgets.Containers.Stack
import Monomer.Widgets.Singles.Button
import Monomer.Widgets.Singles.Label
import Monomer.Widgets.Singles.Spacer
import qualified Monomer.Lens as L
data ButtonEvt
= Button1
| Button2
| Button3
| Button4
| OnScrollChange ScrollStatus
deriving (Eq, Show)
spec :: Spec
spec = describe "Scroll" $ do
handleEvent
forwardStyle
resize
handleEvent :: Spec
handleEvent = describe "handleEvent" $ do
handleBarClick
handleThumbDrag
handleChildrenFocus
handleNestedWheel
handleMessageReset
raiseOnChange
handleBarClick :: Spec
handleBarClick = describe "handleBarClick" $ do
it "should click the first button" $ do
evts [evtClick point] `shouldBe` Seq.fromList [Button1]
it "should scroll right and click the second button" $ do
evts [evtPress midHBar, evtClick point] `shouldBe` Seq.fromList [Button2]
it "should scroll down and click the third button" $ do
evts [evtPress midVBar, evtClick point] `shouldBe` Seq.fromList [Button3]
it "should scroll down and right and click the fourth button" $ do
evts [evtPress midHBar, evtPress midVBar, evtClick point] `shouldBe` Seq.fromList [Button4]
where
wenv = mockWenv ()
& L.theme .~ darkTheme
& L.windowSize .~ Size 640 480
point = Point 320 200
midHBar = Point 630 476
midVBar = Point 636 470
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
evts es = nodeHandleEventEvts wenv es scrollNode
handleThumbDrag :: Spec
handleThumbDrag = describe "handleThumbDrag" $ do
it "should click the first button" $ do
evts [evtClick pClick] `shouldBe` Seq.fromList [Button1]
it "should drag the thumb right and click the second button" $ do
evts [evtPress pStartH, evtMove pEndH, evtClick pClick] `shouldBe` Seq.fromList [Button2]
it "should drag the thumb down and click the third button" $ do
evts [evtPress pStartV, evtMove pEndV, evtClick pClick] `shouldBe` Seq.fromList [Button3]
it "should drag the thumb down and right and click the fourth button" $ do
let steps = [ evtPress pStartH, evtMove pEndH, evtRelease pEndH,
evtPress pStartV, evtMove pEndV, evtRelease pEndV,
evtClick pClick ]
evts steps `shouldBe` Seq.fromList [Button4]
it "should fail to drag the thumb right because of thumb size, causing it to click the first button" $ do
evtsSmall [evtPress pStartH, evtMove pEndH, evtClick pClick] `shouldBe` Seq.fromList [Button1]
it "should fail to drag the thumb down because of thumb size, causing it to click the first button" $ do
evtsSmall [evtPress pStartV, evtMove pEndV, evtClick pClick] `shouldBe` Seq.fromList [Button1]
where
wenv = mockWenv ()
& L.theme .~ darkTheme
& L.windowSize .~ Size 640 480
pClick = Point 320 200
pStartH = Point 50 476
pEndH = Point 400 476
pStartV = Point 636 50
pEndV = Point 636 300
st = [width 6400, height 4800]
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_ [thumbMinSize 100] stackNode
evts es = nodeHandleEventEvts wenv es scrollNode
evtsSmall es = nodeHandleEventEvts wenv es (scroll stackNode)
handleChildrenFocus :: Spec
handleChildrenFocus = describe "handleChildrenFocus" $ do
it "should not follow focus events" $ do
evtsIgnore evts1 `shouldBe` Seq.fromList [Button1]
evtsIgnore evts2 `shouldBe` Seq.fromList [Button1]
evtsIgnore evts3 `shouldBe` Seq.fromList [Button1]
it "should follow focus events" $ do
evtsFollow evts1 `shouldBe` Seq.fromList [Button2]
evtsFollow evts3 `shouldBe` Seq.fromList [Button4]
where
wenv = mockWenv () & L.windowSize .~ Size 640 480
point = Point 320 200
evts1 = [evtK keyTab, evtClick point]
evts2 = [evtK keyTab, evtK keyTab, evtClick point]
evts3 = [evtK keyTab, evtK keyTab, evtK keyTab, evtClick point]
st = [width 640, height 480]
stackNode = vstack [
button "Button 1" Button1 `styleBasic` st,
button "Button 2" Button2 `styleBasic` st,
button "Button 3" Button3 `styleBasic` st,
button "Button 4" Button4 `styleBasic` st
]
ignoreNode = scroll_ [scrollFollowFocus_ False] stackNode
followNode = scroll stackNode
evtsIgnore es = nodeHandleEventEvts wenv es ignoreNode
evtsFollow es = nodeHandleEventEvts wenv es followNode
handleNestedWheel :: Spec
handleNestedWheel = describe "handleNestedWheel" $ do
it "should scroll main widget" $ do
events evts1 `shouldBe` Seq.fromList [Button4]
it "should scroll child widget" $ do
events evts2 `shouldBe` Seq.fromList [Button3]
where
wenv = mockWenv () & L.windowSize .~ Size 640 480
pointClick = Point 160 240
pointWheel1 = Point 480 240
pointWheel2 = Point 160 240
evtWheel p = WheelScroll p (Point 0 (-2000)) WheelNormal
evts1 = [evtWheel pointWheel1, evtClick pointClick]
evts2 = [evtWheel pointWheel2, evtClick pointClick]
st = [width 320, height 480]
childNode = vscroll (vstack [
button "Button 1" Button1 `styleBasic` st,
button "Button 2" Button2 `styleBasic` st,
button "Button 3" Button3 `styleBasic` st
]) `styleBasic` [height 480]
mainNode = vstack [
childNode,
button "Button 4" Button4 `styleBasic` st
] `styleBasic` [width 320]
scrollNode = vscroll $ hstack [
mainNode,
filler
]
events es = nodeHandleEventEvts wenv es scrollNode
handleMessageReset :: Spec
handleMessageReset = describe "handleMessageReset" $ do
it "should not generate an event if scroll does not show Button1" $
events es `shouldBe` Seq.empty
it "should generate an event if scroll shows Button1" $
events (evtK keyTab : es) `shouldBe` Seq.singleton Button1
where
wenv = mockWenv ()
es = [evtK keyTab, evtClick (Point 10 10), evtClick (Point 10 10)]
handleEvent
:: WidgetEnv () ButtonEvt
-> WidgetNode () ButtonEvt
-> ()
-> ButtonEvt
-> [EventResponse () ButtonEvt () ButtonEvt]
handleEvent wenv node model evt = case evt of
Button1 -> [Report Button1]
Button3 -> [Message "mainScroll" ScrollReset]
_ -> []
buildUI wenv model = scroll (vstack [
button "Button 1" Button1 `styleBasic` [height 480],
button "Button 2" Button2 `styleBasic` [height 480],
button "Button 3" Button3 `styleBasic` [height 480]
]) `nodeKey` "mainScroll"
cmpNode = composite "main" id buildUI handleEvent
events es = nodeHandleEventEvts wenv es cmpNode
raiseOnChange :: Spec
raiseOnChange = describe "raiseOnChange" $ do
it "should raise the event on init" $ do
let evts es = nodeHandleEventEvts_ wenv WInitKeepFirst es scrollNode
let (OnScrollChange status) :<| Empty = evts []
scrollDeltaX status `shouldBe` 0
scrollDeltaY status `shouldBe` 0
validateStatus status
it "should raise the event when horizontal bar is clicked" $ do
let (OnScrollChange status) :<| Empty = evts [evtPress midHBar]
scrollDeltaX status `shouldBe` -648
scrollDeltaY status `shouldBe` 0
validateStatus status
it "should raise the event when vertical bar is clicked" $ do
let (OnScrollChange status) :<| Empty = evts [evtPress midVBar]
scrollDeltaX status `shouldBe` 0
scrollDeltaY status `shouldBe` -488
validateStatus status
it "should raise the event when wheel is scrolled" $ do
let evtWheel = WheelScroll (Point 320 240) (Point 0 (-20)) WheelNormal
let (OnScrollChange status) :<| Empty = evts [evtWheel]
scrollDeltaX status `shouldBe` 0
scrollDeltaY status `shouldBe` -200
validateStatus status
where
validateStatus status = do
scrollRect status `shouldBe` Rect 0 0 640 480
scrollVpSize status `shouldBe` Size 632 472
scrollChildSize status `shouldBe` Size 1280 960
wenv = mockWenv ()
& L.theme .~ darkTheme
& L.windowSize .~ Size 640 480
midHBar = Point 630 476
midVBar = Point 636 470
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_ [onChange OnScrollChange] stackNode
evts es = nodeHandleEventEvts wenv es scrollNode
forwardStyle :: Spec
forwardStyle = describe "forwardStyle" $ do
it "should assign scroll the top style, while the child be set to default" $ do
pnode1 ^? L.info . L.style . L.basic . _Just `shouldBe` Just (border 1 black <> padding 10)
cnode1 ^? L.info . L.style . L.basic . _Just `shouldBe` Just def
it "should split the style according to the rules of scrollFwdDefault" $ do
pnode2 ^? L.info . L.style . L.basic . _Just `shouldBe` Just (border 1 black)
cnode2 ^? L.info . L.style . L.basic . _Just `shouldBe` Just (padding 10)
where
wenv = mockWenv () & L.windowSize .~ Size 640 480
snode1 = scroll (label "Test") `styleBasic` [border 1 black, padding 10]
snode2 = scroll_ [scrollFwdStyle scrollFwdDefault] (label "Test") `styleBasic` [border 1 black, padding 10]
pnode1 = nodeInit wenv snode1
cnode1 = pnode1 ^?! L.children . ix 0
pnode2 = nodeInit wenv snode2
cnode2 = pnode2 ^?! L.children . ix 0
resize :: Spec
resize = describe "resize" $ do
resizeLarge
resizeSmall
resizeOverlaySmall
resizeH
resizeV
resizeOverlayH
resizeOverlayV
resizeLarge :: Spec
resizeLarge = describe "resizeLarge" $ do
it "should have the provided viewport size" $
viewport `shouldBe` vp
it "should assign all the requested space" $
childrenVp `shouldBe` Seq.fromList [cvp1]
where
wenv = mockWenv () & L.windowSize .~ Size 640 480
vp = Rect 0 0 640 480
cvp1 = Rect 0 0 3000 2000
scrollNode = scroll (label "" `styleBasic` [width 3000, height 2000])
newNode = nodeInit wenv scrollNode
viewport = newNode ^. L.info . L.viewport
childrenVp = roundRectUnits . _wniViewport . _wnInfo <$> newNode ^. L.children
resizeSmall :: Spec
resizeSmall = describe "resizeSmall" $ do
it "should have the provided viewport size" $
viewport `shouldBe` vp
it "should assign all the requested space" $
childrenVp `shouldBe` Seq.fromList [cvp1]
where
wenv = mockWenv () & L.windowSize .~ Size 640 480
vp = Rect 0 0 640 480
cvp1 = Rect 0 0 640 480
scrollNode = scroll (label "" `styleBasic` [width 300, height 200])
newNode = nodeInit wenv scrollNode
viewport = newNode ^. L.info . L.viewport
childrenVp = roundRectUnits . _wniViewport . _wnInfo <$> newNode ^. L.children
resizeOverlaySmall :: Spec
resizeOverlaySmall = describe "resizeOverlaySmall" $ do
it "should have the provided viewport size" $
viewport `shouldBe` vp
it "should assign all the requested space" $
childrenVp `shouldBe` Seq.fromList [cvp1]
where
wenv = mockWenv () & L.windowSize .~ Size 640 480
vp = Rect 0 0 640 480
cvp1 = Rect 0 0 640 480
scrollNode = scroll_ [scrollOverlay] (label "" `styleBasic` [width 300, height 200])
newNode = nodeInit wenv scrollNode
viewport = newNode ^. L.info . L.viewport
childrenVp = roundRectUnits . _wniViewport . _wnInfo <$> newNode ^. L.children
resizeH :: Spec
resizeH = describe "resizeH" $ do
it "should have the provided viewport size" $
viewport `shouldBe` vp
it "should assign all the requested horizontal space" $
childrenVp `shouldBe` Seq.fromList [cvp1]
where
wenv = mockWenv () & L.windowSize .~ Size 640 480
vp = Rect 0 0 640 480
cvp1 = Rect 0 0 3000 470
scrollNode = hscroll (label "" `styleBasic` [width 3000, height 2000])
newNode = nodeInit wenv scrollNode
viewport = newNode ^. L.info . L.viewport
childrenVp = roundRectUnits . _wniViewport . _wnInfo <$> newNode ^. L.children
resizeV :: Spec
resizeV = describe "resizeV" $ do
it "should have the provided viewport size" $
viewport `shouldBe` vp
it "should assign all the requested vertical space" $
childrenVp `shouldBe` Seq.fromList [cvp1]
where
wenv = mockWenv () & L.windowSize .~ Size 640 480
vp = Rect 0 0 640 480
cvp1 = Rect 0 0 630 2000
scrollNode = vscroll (label "" `styleBasic` [width 3000, height 2000])
newNode = nodeInit wenv scrollNode
viewport = newNode ^. L.info . L.viewport
childrenVp = roundRectUnits . _wniViewport . _wnInfo <$> newNode ^. L.children
resizeOverlayH :: Spec
resizeOverlayH = describe "resizeOverlayH" $ do
it "should have the provided viewport size" $
viewport `shouldBe` vp
it "should assign all the requested horizontal space" $
childrenVp `shouldBe` Seq.fromList [cvp1]
where
wenv = mockWenv () & L.windowSize .~ Size 640 480
vp = Rect 0 0 640 480
cvp1 = Rect 0 0 3000 480
scrollNode = hscroll_ [scrollOverlay] (label "" `styleBasic` [width 3000, height 2000])
newNode = nodeInit wenv scrollNode
viewport = newNode ^. L.info . L.viewport
childrenVp = roundRectUnits . _wniViewport . _wnInfo <$> newNode ^. L.children
resizeOverlayV :: Spec
resizeOverlayV = describe "resizeOverlayV" $ do
it "should have the provided viewport size" $
viewport `shouldBe` vp
it "should assign all the requested vertical space" $
childrenVp `shouldBe` Seq.fromList [cvp1]
where
wenv = mockWenv () & L.windowSize .~ Size 640 480
vp = Rect 0 0 640 480
cvp1 = Rect 0 0 640 2000
scrollNode = vscroll_ [scrollOverlay] (label "" `styleBasic` [width 3000, height 2000])
newNode = nodeInit wenv scrollNode
viewport = newNode ^. L.info . L.viewport
childrenVp = roundRectUnits . _wniViewport . _wnInfo <$> newNode ^. L.children