Add textField unit tests (missing two, which require changes in textField)

src/Monomer/Core/Combinators.hs

@@ -15,7 +15,7 @@ class WindowSize t s | t -> s where
   windowSize :: s -> t
 
 -- Input
-class ValidInput t s where
+class ValidInput t s | t -> s where
   validInput :: ALens' s Bool -> t
 
 class SelectOnFocus t where

src/Monomer/Widgets/InputField.hs

@@ -141,6 +141,8 @@ makeInputField config state = widget where
     | isBackspace = Just $ moveCursor removeText (min currSelVal tp) Nothing
     | isMoveLeft = Just $ moveCursor txt (tp - 1) Nothing
     | isMoveRight = Just $ moveCursor txt (tp + 1) Nothing
+    | isDeselectLeft = Just $ moveCursor txt (min tp currSelVal) Nothing
+    | isDeselectRight = Just $ moveCursor txt (max tp currSelVal) Nothing
     | isMoveWordL = Just $ moveCursor txt prevWordStartIdx Nothing
     | isMoveWordR = Just $ moveCursor txt nextWordEndIdx Nothing
     | isSelectLeft = Just $ moveCursor txt (tp - 1) (Just tp)
@@ -154,6 +156,9 @@ makeInputField config state = widget where
       tp = currPos
       emptySel = isNothing currSel
       (part1, part2) = T.splitAt currPos currText
+      currSelVal = fromMaybe 0 currSel
+      activeSel = isJust currSel
+      delim c = c == ' ' || c == '.' || c == ','
       prevWordStart = T.dropWhileEnd (not . delim) $ T.dropWhileEnd delim part1
       prevWordStartIdx = T.length prevWordStart
       nextWordEnd = T.dropWhile (not . delim) $ T.dropWhile delim part2
@@ -167,16 +172,16 @@ makeInputField config state = widget where
       isMoveWord = not isShift && isWordMod
       isSelect = isShift && not isWordMod
       isSelectWord = isShift && isWordMod
-      isMoveLeft = isMove && isKeyLeft code
-      isMoveRight = isMove && isKeyRight code
+      isMoveLeft = isMove && not activeSel && isKeyLeft code
+      isMoveRight = isMove && not activeSel && isKeyRight code
+      isDeselectLeft = isMove && activeSel && isKeyLeft code
+      isDeselectRight = isMove && activeSel && isKeyRight code
       isMoveWordL = isMoveWord && isKeyLeft code
       isMoveWordR = isMoveWord && isKeyRight code
       isSelectLeft = isSelect && isKeyLeft code
       isSelectRight = isSelect && isKeyRight code
       isSelectWordL = isSelectWord && isKeyLeft code
       isSelectWordR = isSelectWord && isKeyRight code
-      delim c = c == ' ' || c == '.' || c == ','
-      currSelVal = fromMaybe 0 currSel
       removeText
         | isJust currSel = replaceText txt ""
         | otherwise = T.init part1 <> part2

tasks.md

@@ -258,6 +258,7 @@
     - Right aligned version has cusor overlaid (add caret size to offset in specific cases)
     - Check clipboard
   - Check Container thing in hover adding columns (not targetValid = Nothing should be removed)
+  - Add missing keyboard functions in Event
 
 - Pending
   - Add testing
@@ -276,7 +277,6 @@
 
 Maybe postponed after release?
   - Check label with flexHeight
-  - Add missing keyboard functions in Event
   - Make WidgetState Generic (check if it's worth it)
   - Add Bold/Italic support (instead of different Font for each case)
   - Check 1px difference on right side of labels/buttons (probably already fixed)
@@ -287,7 +287,7 @@ Maybe postponed after release?
     - Create numeric wrapper that allows increasing/decreasing with mouse
   - Handle window title, maximize, etc
     - Also handle as requests?
-    - Provide a way of exiting application
+    - Provide a way of exiting application/close window handler
   - TextOverflow in TextStyle?
   - Handle onBlur/onFocus in all focusable widgets
   - Avoid findNextFocus on unfocusable children (listView items)

test/unit/Monomer/TestUtil.hs

@@ -142,37 +142,29 @@ instResize wenv viewport inst = newInst where
 instHandleEventModel
   :: (Eq s)
   => WidgetEnv s e
-  -> SystemEvent
+  -> [SystemEvent]
   -> WidgetInstance s e
   -> s
-instHandleEventModel wenv evt inst = _weModel wenv2 where
-  (wenv2, _, _) = instHandleEvent wenv evt inst
+instHandleEventModel wenv evts inst = _weModel wenv2 where
+  (wenv2, _, _) = instHandleEvents wenv evts inst
 
 instHandleEventEvts
   :: (Eq s)
   => WidgetEnv s e
-  -> SystemEvent
+  -> [SystemEvent]
   -> WidgetInstance s e
   -> Seq e
-instHandleEventEvts wenv evt inst = events where
-  (_, events, _) = instHandleEvent wenv evt inst
+instHandleEventEvts wenv evts inst = events where
+  (_, events, _) = instHandleEvents wenv evts inst
 
 instHandleEventRoot
   :: (Eq s)
   => WidgetEnv s e
-  -> SystemEvent
+  -> [SystemEvent]
   -> WidgetInstance s e
   -> WidgetInstance s e
-instHandleEventRoot wenv evt inst = newRoot where
-  (_, _, newRoot) = instHandleEvent wenv evt inst
-
-instHandleEvent
-  :: (Eq s)
-  => WidgetEnv s e
-  -> SystemEvent
-  -> WidgetInstance s e
-  -> HandlerStep s e
-instHandleEvent wenv evt inst = instHandleEvents wenv [evt] inst
+instHandleEventRoot wenv evts inst = newRoot where
+  (_, _, newRoot) = instHandleEvents wenv evts inst
 
 instHandleEvents
   :: (Eq s)

test/unit/Monomer/Widgets/AlertSpec.hs

@@ -35,4 +35,4 @@ handleEvent = describe "handleEvent" $ do
   where
     wenv = mockWenv () & L.theme .~ darkTheme
     alertInst = instInit wenv (alert "Alert!" CloseClick)
-    events p = instHandleEventEvts wenv (Click p LeftBtn) alertInst
+    events p = instHandleEventEvts wenv [Click p LeftBtn] alertInst

test/unit/Monomer/Widgets/BoxSpec.hs

@@ -34,7 +34,7 @@ handleEvent = describe "handleEvent" $ do
     wenv = mockWenv ()
     btn = button "Click" BtnClick
     boxInst = instInit wenv (box btn)
-    events p = instHandleEventEvts wenv (Click p LeftBtn) boxInst
+    events p = instHandleEventEvts wenv [Click p LeftBtn] boxInst
 
 updateSizeReq :: Spec
 updateSizeReq = describe "updateSizeReq" $ do

test/unit/Monomer/Widgets/ButtonSpec.hs

@@ -34,8 +34,8 @@ handleEvent = describe "handleEvent" $ do
   where
     wenv = mockWenv ()
     btn = instInit wenv (button "Click" BtnClick)
-    clickEvts p = instHandleEventEvts wenv (Click p LeftBtn) btn
-    keyEvts key = instHandleEventEvts wenv (KeyAction def key KeyPressed) btn
+    clickEvts p = instHandleEventEvts wenv [Click p LeftBtn] btn
+    keyEvts key = instHandleEventEvts wenv [KeyAction def key KeyPressed] btn
 
 updateSizeReq :: Spec
 updateSizeReq = describe "updateSizeReq" $ do

test/unit/Monomer/Widgets/CheckboxSpec.hs

@@ -49,8 +49,8 @@ handleEvent = describe "handleEvent" $ do
   where
     wenv = mockWenvEvtUnit (TestModel False)
     chkInst = checkbox testBool
-    clickModel p = instHandleEventModel wenv (Click p LeftBtn) chkInst
-    keyModel key = instHandleEventModel wenv (KeyAction def key KeyPressed) chkInst
+    clickModel p = instHandleEventModel wenv [Click p LeftBtn] chkInst
+    keyModel key = instHandleEventModel wenv [KeyAction def key KeyPressed] chkInst
 
 handleEventValue :: Spec
 handleEventValue = describe "handleEventValue" $ do
@@ -69,8 +69,8 @@ handleEventValue = describe "handleEventValue" $ do
     wenv = mockWenv (TestModel False)
     chkInst = checkboxV False BoolSel
     chkInstT = checkboxV True BoolSel
-    clickModel p inst = instHandleEventEvts wenv (Click p LeftBtn) inst
-    keyModel key inst = instHandleEventEvts wenv (KeyAction def key KeyPressed) inst
+    clickModel p inst = instHandleEventEvts wenv [Click p LeftBtn] inst
+    keyModel key inst = instHandleEventEvts wenv [KeyAction def key KeyPressed] inst
 
 updateSizeReq :: Spec
 updateSizeReq = describe "updateSizeReq" $ do

test/unit/Monomer/Widgets/ConfirmSpec.hs

@@ -39,4 +39,4 @@ handleEvent = describe "handleEvent" $ do
   where
     wenv = mockWenv () & L.theme .~ darkTheme
     confirmInst = instInit wenv (confirm "Confirm!" AcceptClick CancelClick)
-    events p = instHandleEventEvts wenv (Click p LeftBtn) confirmInst
+    events p = instHandleEventEvts wenv [Click p LeftBtn] confirmInst

test/unit/Monomer/Widgets/RadioSpec.hs

@@ -56,8 +56,8 @@ handleEvent = describe "handleEvent" $ do
     wenv = mockWenvEvtUnit (TestModel Apple)
     orangeInst = radio fruit Orange
     bananaInst = radio fruit Banana
-    clickModel p inst = instHandleEventModel wenv (Click p LeftBtn) inst
-    keyModel key inst = instHandleEventModel wenv (KeyAction def key KeyPressed) inst
+    clickModel p inst = instHandleEventModel wenv [Click p LeftBtn] inst
+    keyModel key inst = instHandleEventModel wenv [KeyAction def key KeyPressed] inst
 
 handleEventValue :: Spec
 handleEventValue = describe "handleEventValue" $ do
@@ -73,8 +73,8 @@ handleEventValue = describe "handleEventValue" $ do
     wenv = mockWenv (TestModel Apple)
     orangeInst = radioV Apple FruitSel Orange
     bananaInst = radioV Apple FruitSel Banana
-    clickModel p inst = instHandleEventEvts wenv (Click p LeftBtn) inst
-    keyModel key inst = instHandleEventEvts wenv (KeyAction def key KeyPressed) inst
+    clickModel p inst = instHandleEventEvts wenv [Click p LeftBtn] inst
+    keyModel key inst = instHandleEventEvts wenv [KeyAction def key KeyPressed] inst
 
 updateSizeReq :: Spec
 updateSizeReq = describe "updateSizeReq" $ do

test/unit/Monomer/Widgets/TextFieldSpec.hs

@@ -0,0 +1,165 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Monomer.Widgets.TextFieldSpec (spec) where
+
+import Control.Lens ((&), (^.), (.~))
+import Control.Lens.TH (abbreviatedFields, makeLensesWith)
+import Data.Default
+import Data.Text (Text)
+import Test.Hspec
+
+import qualified Data.Sequence as Seq
+
+import Monomer.Core
+import Monomer.Event
+import Monomer.TestUtil
+import Monomer.Widgets.TextField
+
+import qualified Monomer.Lens as L
+
+newtype TestEvt
+  = TextChanged Text
+  deriving (Eq, Show)
+
+newtype TestModel = TestModel {
+  _tmTextValue :: Text
+} deriving (Eq, Show)
+
+makeLensesWith abbreviatedFields ''TestModel
+
+spec :: Spec
+spec = fdescribe "TextField" $ do
+  handleEvent
+  handleEventValue
+  updateSizeReq
+
+handleEvent :: Spec
+handleEvent = describe "handleEvent" $ do
+  it "should input an 'a'" $
+    model [evtT "a"] ^. textValue `shouldBe` "a"
+
+  it "should input 'ababa', remove the middle 'a' and input 'c'" $ do
+    let steps = [evtT "ababa", moveCharL, moveCharL, evtK keyBackspace, evtT "c"]
+    model steps ^. textValue `shouldBe` "abcba"
+
+  it "should input 'ababa', select last two and input 'c'" $ do
+    let steps = [evtT "ababa", selCharL, selCharL, selCharL, evtT "c"]
+    model steps ^. textValue `shouldBe` "abc"
+
+  it "should input 'This is a dog', move to beginning, select first word and input 'that'" $ do
+    let str = "This is a dog"
+    let steps = [evtT str, moveWordL, moveWordL, moveWordL, moveWordL, selWordR, evtT "that"]
+    model steps ^. textValue `shouldBe` "that is a dog"
+
+  it "should input 'This is a dog', select one word, deselect and input 'big '" $ do
+    let str = "This is a dog"
+    let steps = [evtT str, selWordL, moveCharL, evtT "big "]
+    model steps ^. textValue `shouldBe` "This is a big dog"
+
+  it "should input 'This string is', and reject ' invalid' since maxLength == 20" $ do
+    let str = "This string is"
+    let steps = [evtT str, evtT " invalid"]
+    model steps ^. textValue `shouldBe` "This string is"
+
+  it "should input 'This is text', receive focus and input 'No'" $ do
+    let str = "This is text"
+    let steps = [evtT str, Focus, evtT "No"]
+    model steps ^. textValue `shouldBe` "No"
+  where
+    wenv = mockWenvEvtUnit (TestModel "")
+    txtInst = textField_ textValue [maxLength 20, selectOnFocus True]
+    model es = instHandleEventModel wenv es txtInst
+
+handleEventValue :: Spec
+handleEventValue = describe "handleEvent" $ do
+  it "should input an 'ab'" $
+    evts [evtT "a", evtT "b"] `shouldBe` Seq.fromList [TextChanged "a", TextChanged "ab"]
+
+  it "should input 'this is a dog', input '?', move to beginning and input 'Is '" $ do
+    let str = "this is a dog"
+    let steps = [evtT str, evtT "?", evtT "is "]
+    lastEvt steps `shouldBe` TextChanged "Is this is a dog?"
+
+  it "should input 'This is a dog', move before 'is', select 'is', deselect it and input 'nt'" $ do
+    let str = "This is a dog"
+    let steps = [evtT str, moveWordL, moveWordL, moveWordL, selWordR, moveCharR, evtT "n't"]
+    lastEvt steps `shouldBe` TextChanged "This isn't a dog"
+
+  it "should input 'This is a dog', remove one word and input 'bird'" $ do
+    let str = "This is a dog"
+    let steps = [evtT str, evtT "cat"]
+    lastEvt steps `shouldBe` TextChanged "This is a cat"
+  where
+    wenv = mockWenv (TestModel "")
+    txtInst = textFieldV "" TextChanged
+    evts es = instHandleEventEvts wenv es txtInst
+    lastIdx es = Seq.index es (Seq.length es - 1)
+    lastEvt es = lastIdx (evts es)
+
+updateSizeReq :: Spec
+updateSizeReq = describe "updateSizeReq" $ do
+  it "should return width = Flex 100 1" $
+    sizeReqW `shouldBe` FlexSize 100 1
+
+  it "should return height = Fixed 20" $
+    sizeReqH `shouldBe` FixedSize 20
+
+  where
+    wenv = mockWenvEvtUnit (TestModel "Test value")
+    (sizeReqW, sizeReqH) = instUpdateSizeReq wenv (textField textValue)
+
+modC :: KeyMod
+modC = def
+  & L.leftCtrl .~ True
+  & L.leftAlt .~ True
+
+modS :: KeyMod
+modS = def & L.leftShift .~ True
+
+modCS :: KeyMod
+modCS = def
+  & L.leftCtrl .~ True
+  & L.leftAlt .~ True
+  & L.leftShift .~ True
+
+evtK :: KeyCode -> SystemEvent
+evtK k = KeyAction def k KeyPressed
+
+evtKC :: KeyCode -> SystemEvent
+evtKC k = KeyAction modC k KeyPressed
+
+evtKS :: KeyCode -> SystemEvent
+evtKS k = KeyAction modS k KeyPressed
+
+evtKCS :: KeyCode -> SystemEvent
+evtKCS k = KeyAction modCS k KeyPressed
+
+evtT :: Text -> SystemEvent
+evtT t = TextInput t
+
+moveCharL :: SystemEvent
+moveCharL = evtK keyLeft
+
+moveCharR :: SystemEvent
+moveCharR = evtK keyRight
+
+moveWordL :: SystemEvent
+moveWordL = evtKC keyLeft
+
+moveWordR :: SystemEvent
+moveWordR = evtKC keyRight
+
+selCharL :: SystemEvent
+selCharL = evtKS keyLeft
+
+selCharR :: SystemEvent
+selCharR = evtKS keyRight
+
+selWordL :: SystemEvent
+selWordL = evtKCS keyLeft
+
+selWordR :: SystemEvent
+selWordR = evtKCS keyRight

test/unit/Spec.hs

@@ -11,6 +11,7 @@ import qualified Monomer.Widgets.GridSpec as GridSpec
 import qualified Monomer.Widgets.LabelSpec as LabelSpec
 import qualified Monomer.Widgets.RadioSpec as RadioSpec
 import qualified Monomer.Widgets.StackSpec as StackSpec
+import qualified Monomer.Widgets.TextFieldSpec as TextFieldSpec
 
 main :: IO ()
 main = hspec spec
@@ -26,3 +27,4 @@ spec = do
   LabelSpec.spec
   RadioSpec.spec
   StackSpec.spec
+  TextFieldSpec.spec