DragDropSpec.hs

{-|
Module      : Monomer.Widgets.Containers.DragDropSpec
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 Drag and Drop related widgets.
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

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

import Control.Lens ((&), (^.), (.~))
import Control.Lens.TH (abbreviatedFields, makeLensesWith)
import Data.Default
import Data.List (delete)
import Data.Sequence (Seq(..))
import Data.Text (Text)
import Test.Hspec

import qualified Data.Sequence as Seq
import qualified Data.Text as T

import Monomer.Core
import Monomer.Core.Combinators
import Monomer.Event
import Monomer.TestUtil
import Monomer.TestEventUtil
import Monomer.Widgets.Composite
import Monomer.Widgets.Containers.Draggable
import Monomer.Widgets.Containers.DropTarget
import Monomer.Widgets.Containers.Grid
import Monomer.Widgets.Containers.Stack
import Monomer.Widgets.Singles.Label

import qualified Monomer.Lens as L

data TestEvt
  = DropTo1 Int
  | DropTo2 Int
  deriving (Eq, Show)

data TestItem = TestItem {
  _tiIdx :: Int,
  _tiMsg :: Text
} deriving (Eq, Show)

data TestModel = TestModel {
  _tmItems1 :: [Int],
  _tmItems2 :: [Int]
} deriving (Eq, Show)

makeLensesWith abbreviatedFields ''TestItem
makeLensesWith abbreviatedFields ''TestModel

spec :: Spec
spec = describe "Drag & Drop" $ do
  handleEvent
  getSizeReq

handleEvent :: Spec
handleEvent = describe "handleEvent" $ do
  it "should leave items intact if drag is not completed" $ do
    let selStart = Point 20 10
    let selEnd = Point 20 100
    let steps = evtDrag selStart selEnd
    model steps ^. items1 `shouldBe` [1, 2, 3, 4, 5]
    model steps ^. items2 `shouldBe` []

  it "should update items list if drag was successful" $ do
    let selStart = Point 20 10
    let selEnd = Point 400 10
    let steps = evtDrag selStart selEnd
    model steps ^. items1 `shouldBe` [2, 3, 4, 5]
    model steps ^. items2 `shouldBe` [1]

  it "should both update items list if successive drags were successful" $ do
    let selStart = Point 20 10
    let selEnd = Point 400 10
    let steps = evtDrag selStart selEnd
                ++ evtDrag selStart selEnd 
                ++ evtDrag selStart selEnd 
                ++ evtDrag selEnd selStart
    model steps ^. items1 `shouldBe` [4, 5, 1]
    model steps ^. items2 `shouldBe` [2, 3]

  where
    wenv = mockWenvEvtUnit (TestModel [1..5] [])
    handleEvent wenv node model evt = case evt of
      DropTo1 idx -> [Model $ model
        & items2 .~ delete idx (model ^. items2)
        & items1 .~ model ^. items1 ++ [idx]]
      DropTo2 idx -> [Model $ model
        & items1 .~ delete idx (model ^. items1)
        & items2 .~ model ^. items2 ++ [idx]]
    buildUI wenv model = hgrid [
        dropTarget DropTo1 $ vstack (fmap dragLbl (model ^. items1)),
        dropTarget DropTo2 $ vstack (fmap dragLbl (model ^. items2))
      ]
    dragLbl idx = draggable idx (label "Label")
    mainNode = composite "main" id buildUI handleEvent
    model es = nodeHandleEventModel wenv es mainNode

getSizeReq :: Spec
getSizeReq = describe "getSizeReq" $ do
  it "should return same reqW as child node" $ do
    dgSizeReqW `shouldBe` lSizeReqW
    dtSizeReqW `shouldBe` lSizeReqW

  it "should return same reqH as child node" $ do
    dgSizeReqH `shouldBe` lSizeReqH
    dtSizeReqH `shouldBe` lSizeReqH

  where
    wenv = mockWenv (TestModel [] [])
    item = TestItem 0 ""
    lblNode = label "Test label"
    (lSizeReqW, lSizeReqH) = nodeGetSizeReq wenv lblNode
    (dgSizeReqW, dgSizeReqH) = nodeGetSizeReq wenv (draggable item lblNode)
    (dtSizeReqW, dtSizeReqH) = nodeGetSizeReq wenv (dropTarget DropTo2 lblNode)