SelectListSpec.hs

{-|
Module      : Monomer.Widgets.Containers.SelectListSpec
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 SelectList widget.
-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TemplateHaskell #-}

module Monomer.Widgets.Containers.SelectListSpec (spec) where

import Control.Lens ((&), (^.), (^?!), (.~), _1, ix)
import Control.Lens.TH (abbreviatedFields, makeLensesWith)
import Data.Default
import Data.Functor ((<&>))
import Data.Text (Text)
import Test.Hspec
import TextShow

import qualified Data.Sequence as Seq

import Monomer.Core
import Monomer.Core.Combinators
import Monomer.Event
import Monomer.TestEventUtil
import Monomer.TestUtil
import Monomer.Widgets.Containers.SelectList
import Monomer.Widgets.Containers.Stack
import Monomer.Widgets.Singles.Button
import Monomer.Widgets.Singles.Label

import qualified Monomer.Lens as L

data TestEvt
  = ItemSel Int TestItem
  | BtnClick
  | GotFocus Path
  | LostFocus Path
  deriving (Eq, Show)

newtype TestItem = TestItem {
  _tiCode :: Int
} deriving (Eq, Show)

instance TextShow TestItem where
  showb (TestItem c) = "TestItem: " <> showb c

newtype TestModel = TestModel {
  _tmSelectedItem :: TestItem
} deriving (Eq, Show)

makeLensesWith abbreviatedFields ''TestItem
makeLensesWith abbreviatedFields ''TestModel

testItems = [0..99] <&> TestItem
testItem0 = head testItems
testItem3 = testItems!!3
testItem7 = testItems!!7
testItem10 = testItems!!10
testItem70 = testItems!!70

spec :: Spec
spec = describe "SelectList" $ do
  handleEvent
  handleEventValue
  getSizeReq
  testWidgetType

handleEvent :: Spec
handleEvent = describe "handleEvent" $ do
  it "should not update the model if clicked outside the list" $
    clickModel (Point 300 500) ^. selectedItem `shouldBe` testItem0

  it "should update the model when clicked" $
    clickModel (Point 100 70) ^. selectedItem `shouldBe` testItem3

  it "should update the model when clicked, after wheel scrolled" $ do
    let p = Point 100 10
    let steps = [evtK keyTab, WheelScroll p (Point 0 (-140)) WheelNormal, evtClick p]
    model steps ^. selectedItem `shouldBe` testItem70

  it "should update the model when clicked, after list is displaced because of arrow press" $ do
    let p = Point 100 10
    let steps = [evtK keyTab] ++ replicate 26 (evtK keyDown) ++ [evtClick p]
    model steps ^. selectedItem `shouldBe` testItem3

  it "should update the model when Enter/Space is pressed, after navigating to an element" $ do
    let steps = [evtK keyTab] ++ replicate 71 (evtK keyDown) ++ [evtK keyUp, evtK keySpace]
    model steps ^. selectedItem `shouldBe` testItem70

  it "should generate an event when focus is received" $ do
    let p = Point 100 30
    eventsCnt [evtClick p] `shouldBe` Seq.singleton (GotFocus $ Seq.fromList [0, 0])

  it "should generate an event when focus is lost" $ do
    let p = Point 100 30
    let path = Seq.fromList [0, 0]
    eventsCnt [evtClick p, evtBlur] `shouldBe` Seq.fromList [GotFocus path, LostFocus emptyPath]

  where
    wenv = mockWenv (TestModel testItem0)
    slNode = selectList_ selectedItem testItems (label . showt) [onFocus GotFocus, onBlur LostFocus]
    cntNode = vstack [
        button "Test" BtnClick,
        selectList_ selectedItem testItems (label . showt) [onFocus GotFocus, onBlur LostFocus]
      ]
    clickModel p = nodeHandleEventModel wenv [evtClick p] slNode
    model keys = nodeHandleEventModel wenv keys slNode
    events evts = nodeHandleEventEvts wenv evts slNode
    eventsCnt evts = nodeHandleEventEvts wenv evts cntNode

handleEventValue :: Spec
handleEventValue = describe "handleEventValue" $ do
  it "should not generate an event if clicked outside" $
    clickEvts (Point 3000 3000) `shouldBe` Seq.empty

  it "should generate an event when clicked" $
    events [evtK keyTab, evtClick (Point 100 70)] `shouldBe` Seq.singleton (ItemSel 3 testItem3)

  it "should generate an event when Enter/Space is pressed, after navigating to an element" $ do
    let steps = [evtK keyTab] ++ replicate 7 (evtK keyDown) ++ [evtK keySpace]
    events steps `shouldBe` Seq.singleton (ItemSel 7 testItem7)

  where
    wenv = mockWenv (TestModel testItem0)
    slNode = selectListV_ testItem0 ItemSel testItems (label . showt) [onFocus GotFocus, onBlur LostFocus]
    clickEvts p = nodeHandleEventEvts wenv [evtClick p] slNode
    events evts = Seq.drop (Seq.length res - 1) res where
      res = nodeHandleEventEvts wenv evts slNode

getSizeReq :: Spec
getSizeReq = describe "getSizeReq" $ do
  it "should return width = Flex 120" $
    sizeReqW `shouldBe` expandSize 120 1

  it "should return height = Flex 2000 1" $
    sizeReqH `shouldBe` expandSize 2000 1

  where
    wenv = mockWenvEvtUnit (TestModel testItem0)
    slNode = selectList selectedItem testItems (label . showt)
    (sizeReqW, sizeReqH) = nodeGetSizeReq wenv slNode

testWidgetType :: Spec
testWidgetType = describe "testWidgetType" $ do
  it "should set the correct widgetType" $
    node ^?! L.children . ix 0 . L.info . L.widgetType `shouldBe` "selectList-TestItem"

  where
    node :: WidgetNode TestModel TestEvt
    node = selectList selectedItem testItems (label . showt)