DateFieldSpec.hs

{-|
Module      : Monomer.Widgets.Singles.DateFieldSpec
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 DateField widget.
-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

module Monomer.Widgets.Singles.DateFieldSpec (spec) where

import Control.Lens ((&), (^.), (.~))
import Control.Lens.TH (abbreviatedFields, makeLensesWith)
import Data.Default
import Data.Text (Text)
import Data.Time
import Test.Hspec

import qualified Data.Sequence as Seq

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

import qualified Monomer.Lens as L

data TestEvt
  = DateChanged Day
  | DateValid Bool
  | GotFocus Path
  | LostFocus Path
  deriving (Eq, Show)

data DateModel = DateModel {
  _imDateValue :: Day,
  _imDateValid :: Bool
} deriving (Eq, Show)

instance Default DateModel where
  def = DateModel {
    _imDateValue = fromGregorian 2000 01 01,
    _imDateValid = True
  }

data MDateModel = MDateModel {
  _imMDateValue :: Maybe Day,
  _imMDateValid :: Bool
} deriving (Eq, Show)

instance Default MDateModel where
  def = MDateModel {
    _imMDateValue = Nothing,
    _imMDateValid = True
  }

makeLensesWith abbreviatedFields ''DateModel
makeLensesWith abbreviatedFields ''MDateModel

spec :: Spec
spec = describe "DateField" $ do
  handleEventDate
  handleEventValueDate
  handleEventMouseDragDate
  handleEventReadOnly
  handleShiftFocus
  getSizeReqDate
  testWidgetType

handleEventDate :: Spec
handleEventDate = describe "handleEventDate" $ do
  it "should remove the contents and get Nothing as model value" $ do
    modelBasic [evtKG keyA, evtK keyBackspace] ^. mDateValue `shouldBe` Nothing
    modelBasic [evtKG keyA, evtK keyBackspace] ^. mDateValid `shouldBe` True

  it "should input '2000-02-14'" $ do
    modelBasic [evtKG keyA, evtT "2000", evtT "-02-14"] ^. mDateValue `shouldBe` Just (fromGregorian 2000 02 14)
    modelBasic [evtKG keyA, evtT "2000", evtT "-02-14"] ^. mDateValid `shouldBe` True

  it "should input '1' (invalid date)" $ do
    model [evtKG keyA, evtT "1"] ^. mDateValue `shouldBe` Just midDate
    model [evtKG keyA, evtT "1"] ^. mDateValid `shouldBe` False
    events [evtKG keyA, evtT "1"] `shouldBe` Seq.fromList [DateValid False]

  it "should input '30/12/1999' but fail because of minValue" $ do
    model [evtT "30/12/1999"] ^. mDateValue `shouldBe` Just midDate
    model [evtT "30/12/1999"] ^. mDateValid `shouldBe` False
    events [evtT "30/12/1999"] `shouldBe` Seq.fromList [DateValid False]

  it "should input '01/03/2005' but fail because of maxValue" $ do
    model [evtT "01/04/2005"] ^. mDateValue `shouldBe` Just midDate
    model [evtT "01/04/2005"] ^. mDateValid `shouldBe` False
    events [evtT "01/04/2005"] `shouldBe` Seq.fromList [DateValid False]

  it "should remove one character and input '4'" $ do
    model [moveCharR, delCharL, evtT "4"] ^. mDateValue `shouldBe` Just (fromGregorian 2004 03 02)
    model [moveCharR, delCharL, evtT "4"] ^. mDateValid `shouldBe` True
    events [moveCharR, delCharL, evtT "4"] `shouldBe` Seq.fromList [DateValid False, DateValid True]

  it "should input '14/02/2001', remove one word and input '2000'" $ do
    model [evtT "14/02/2001", delWordL, evtT "2000"] ^. mDateValue `shouldBe` Just (fromGregorian 2000 02 14)
    model [evtT "14/02/2001", delWordL, evtT "2000"] ^. mDateValid `shouldBe` True
    events [evtT "14/02/2001", delWordL, evtT "2000"] `shouldBe` Seq.fromList [DateValid True, DateValid False, DateValid True]

  it "should update the model when using the wheel" $ do
    let p = Point 100 10
    let steps1 = [WheelScroll p (Point 0 (-2000)) WheelNormal]
    let steps2 = [WheelScroll p (Point 0 (-64)) WheelNormal]
    let steps3 = [WheelScroll p (Point 0 64) WheelNormal]
    let steps4 = [WheelScroll p (Point 0 (-2000)) WheelFlipped]
    model steps1 ^. mDateValue `shouldBe` Just minDate
    model steps2 ^. mDateValue `shouldBe` Just (fromGregorian 2001 12 28)
    model steps3 ^. mDateValue `shouldBe` Just (fromGregorian 2002 05 05)
    model steps4 ^. mDateValue `shouldBe` Just maxDate

  it "should generate an event when focus is received" $
    events [evtFocus] `shouldBe` Seq.singleton (GotFocus emptyPath)

  it "should generate an event when focus is lost" $
    events [evtBlur] `shouldBe` Seq.singleton (LostFocus emptyPath)

  where
    minDate = fromGregorian 2000 01 01
    midDate = fromGregorian 2002 03 02
    maxDate = fromGregorian 2005 03 05
    wenv = mockWenv (MDateModel (Just midDate) True)
    basicDateNode :: WidgetNode MDateModel TestEvt
    basicDateNode = dateField_ mDateValue [validInput mDateValid, selectOnFocus_ False, dateFormatYYYYMMDD, dateFormatDelimiter '-']
    dateCfg = [minValue (Just minDate), maxValue (Just maxDate), validInput mDateValid, validInputV DateValid, onFocus GotFocus, onBlur LostFocus]
    dateNode = dateField_ mDateValue dateCfg
    model es = nodeHandleEventModel wenv (evtFocus : es) dateNode
    modelBasic es = nodeHandleEventModel wenv es basicDateNode
    events es = nodeHandleEventEvts wenv es dateNode

handleEventValueDate :: Spec
handleEventValueDate = describe "handleEventDate" $ do
  it "should input an '11/23/1983'" $
    evts [evtT "11/23/1983"] `shouldBe` Seq.fromList [DateChanged lowDate]

  it "should move right, delete one character and input '5'" $ do
    let steps = [moveCharR, delCharL, evtT "5"]
    lastEvt steps `shouldBe` DateChanged (fromGregorian 1985 03 02)
    model steps ^. dateValid `shouldBe` True

  it "should move right and delete one character" $ do
    let steps = [moveCharR, delCharL]
    evts steps `shouldBe` Seq.empty
    model steps ^. dateValid `shouldBe` False

  it "should input '11/23/198', input '.', 'a', then input '3'" $ do
    let steps = [evtT "11/23/198", evtT ".", evtT "a", evtT "3"]
    lastEvt steps `shouldBe` DateChanged lowDate
    model steps ^. dateValid `shouldBe` True

  it "should input '03/0544/199555'" $ do
    let steps = [evtT "03", evtT "/05", evtT "44", evtT "/1995", evtT "55"]
    lastEvt steps `shouldBe` DateChanged maxDate

  where
    minDate = fromGregorian 1980 01 01
    lowDate = fromGregorian 1983 11 23
    midDate = fromGregorian 1989 03 02
    maxDate = fromGregorian 1995 03 05
    wenv = mockWenv (DateModel minDate False)
    dateNode = dateFieldV_ midDate DateChanged [minValue minDate, maxValue maxDate, selectOnFocus, validInput dateValid, dateFormatMMDDYYYY]
    evts es = nodeHandleEventEvts wenv (evtFocus : es) dateNode
    model es = nodeHandleEventModel wenv (evtFocus : es) dateNode
    lastIdx es = Seq.index es (Seq.length es - 1)
    lastEvt es = lastIdx (evts es)

handleEventMouseDragDate :: Spec
handleEventMouseDragDate = describe "handleEventMouseDragDate" $ do
  it "should drag upwards 100 pixels, setting the value to 10/06/1989" $ do
    let selStart = Point 50 30
    let selEnd = Point 50 (-70)
    let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd]
    model steps ^. dateValue `shouldBe` fromGregorian 1989 06 10

  it "should drag downwards 100 pixels, setting the value to 14/08/1988 (dragRate = 2)" $ do
    let selStart = Point 50 50
    let selEnd = Point 50 150
    let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd]
    model steps ^. dateValue `shouldBe` fromGregorian 1988 08 14

  it "should drag downwards 10000 pixels, staying at minDate (the minimum)" $ do
    let selStart = Point 50 50
    let selEnd = Point 50 10050
    let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd]
    model steps ^. dateValue `shouldBe` minDate

  it "should drag upwards 2000 pixels, staying at maxDate (the maximum)" $ do
    let selStart = Point 50 50
    let selEnd = Point 50 (-1950)
    let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd]
    model steps ^. dateValue `shouldBe` maxDate

  it "should drag downwards 30 and 20 pixels, setting the value to 11/01/1989" $ do
    let selStart = Point 50 30
    let selMid = Point 50 60
    let selEnd = Point 50 50
    let steps = [
          evtPress selStart, evtMove selMid, evtRelease selMid,
          evtPress selStart, evtMove selEnd, evtRelease selEnd
          ]
    model steps ^. dateValue `shouldBe` fromGregorian 1989 01 11

  it "should set focus and drag upwards 100 pixels, but value stay at midDate since shift is not pressed" $ do
    let selStart = Point 50 30
    let selEnd = Point 50 (-70)
    let steps = [evtK keyTab, evtPress selStart, evtMove selEnd, evtRelease selEnd]
    model steps ^. dateValue `shouldBe` midDate

  it "should set focus and drag upwards 100 pixels, setting the value to 10/06/1989 since shift is pressed" $ do
    let selStart = Point 50 30
    let selEnd = Point 50 (-70)
    let steps = [evtKS keyTab, evtPress selStart, evtMove selEnd, evtRelease selEnd]
    model steps ^. dateValue `shouldBe` fromGregorian 1989 06 10

  it "should drag upwards 100 pixels, setting the value to 10/06/1989 even if it was double clicked on" $ do
    let selStart = Point 50 30
    let selEnd = Point 50 (-70)
    let steps = [evtDblClick selStart, evtPress selStart, evtMove selEnd, evtRelease selEnd]
    model steps ^. dateValue `shouldBe` fromGregorian 1989 06 10

  where
    minDate = fromGregorian 1980 01 01
    midDate = fromGregorian 1989 03 02
    maxDate = fromGregorian 1995 03 05
    wenv = mockWenv (DateModel midDate True)
      & L.inputStatus . L.keyMod . L.leftShift .~ True
    dateNode = vstack [
        button "Test" (DateChanged midDate), -- Used only to have focus
        dateField dateValue,
        dateField_ dateValue [dragRate 2, minValue minDate, maxValue maxDate]
      ]
    evts es = nodeHandleEventEvts wenv es dateNode
    model es = nodeHandleEventModel wenv es dateNode
    lastIdx es = Seq.index es (Seq.length es - 1)
    lastEvt es = lastIdx (evts es)

handleEventReadOnly :: Spec
handleEventReadOnly = describe "handleEventReadOnly" $ do
  it "should ignore text input" $ do
    let steps = [moveCharR, delCharL, evtT "5"]
    model steps ^. dateValue `shouldBe` initDate
  
  it "should ignore drag" $ do
    let selStart = Point 5 5
    let selEnd = Point 100 2000
    let steps = [evtPress selStart, evtMove selEnd, evtRelease selEnd]
    model steps ^. dateValue `shouldBe` initDate

  it "should ignore wheel" $ do
    let steps = [WheelScroll (Point 100 10) (Point 0 (-2000)) WheelNormal]
    model steps ^. dateValue `shouldBe` initDate

  where
    initDate = fromGregorian 1999 11 21
    wenv = mockWenv (DateModel initDate True)
      & L.inputStatus . L.keyMod . L.leftShift .~ True
    dateCfg = [readOnly :: DateFieldCfg DateModel TestEvt Day]
    dateNode = dateField_ dateValue dateCfg
    model es = nodeHandleEventModel wenv es dateNode

handleShiftFocus :: Spec
handleShiftFocus = describe "handleShiftFocus" $ do
  it "should set focus when clicked" $ do
    evts [evtPress p] `shouldBe` Seq.fromList [GotFocus $ Seq.fromList [0, 0]]

  it "should not set focus when clicked with shift pressed" $ do
    evts [evtKS keyA, evtPress p] `shouldBe` Seq.empty

  where
    wenv = mockWenv (DateModel (fromGregorian 1989 03 02) True)
    p = Point 100 30
    floatNode = vstack [
        dateField_ dateValue [wheelRate 1],
        dateField_ dateValue [wheelRate 1, onFocus GotFocus]
      ]
    evts es = nodeHandleEventEvts wenv es floatNode

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

  it "should return height = Fixed 20" $
    sizeReqH `shouldBe` fixedSize 20

  it "should return width = Flex 100 1 when resizeOnChange = True" $
    sizeReqW2 `shouldBe` expandSize 100 1

  it "should return height = Fixed 20 when resizeOnChange = True" $
    sizeReqH2 `shouldBe` fixedSize 20

  where
    wenv = mockWenvEvtUnit (def :: DateModel)
    (sizeReqW, sizeReqH) = nodeGetSizeReq wenv (dateField dateValue)
    dateResize = dateField_ dateValue [resizeOnChange]
    (sizeReqW2, sizeReqH2) = nodeGetSizeReq wenv dateResize

testWidgetType :: Spec
testWidgetType = describe "testWidgetType" $ do
  it "should set the correct widgetType" $
    node ^. L.info . L.widgetType `shouldBe` "dateField-Day"

  where
    node :: WidgetNode DateModel TestEvt
    node = dateField dateValue