content: {-|
  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
    handleWheel
    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
  
  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
      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
  