From 8b4bfea6f551cee802faf614cdd138e0fad91e4a Mon Sep 17 00:00:00 2001 From: Francisco Vallarino Date: Sun, 15 Nov 2020 16:10:46 -0300 Subject: [PATCH] Add textField unit tests (missing two, which require changes in textField) --- src/Monomer/Core/Combinators.hs | 2 +- src/Monomer/Widgets/InputField.hs | 13 +- tasks.md | 4 +- test/unit/Monomer/TestUtil.hs | 26 ++-- test/unit/Monomer/Widgets/AlertSpec.hs | 2 +- test/unit/Monomer/Widgets/BoxSpec.hs | 2 +- test/unit/Monomer/Widgets/ButtonSpec.hs | 4 +- test/unit/Monomer/Widgets/CheckboxSpec.hs | 8 +- test/unit/Monomer/Widgets/ConfirmSpec.hs | 2 +- test/unit/Monomer/Widgets/RadioSpec.hs | 8 +- test/unit/Monomer/Widgets/TextFieldSpec.hs | 165 +++++++++++++++++++++ test/unit/Spec.hs | 2 + 12 files changed, 201 insertions(+), 37 deletions(-) create mode 100644 test/unit/Monomer/Widgets/TextFieldSpec.hs diff --git a/src/Monomer/Core/Combinators.hs b/src/Monomer/Core/Combinators.hs index 52240727..95fbbaba 100644 --- a/src/Monomer/Core/Combinators.hs +++ b/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 diff --git a/src/Monomer/Widgets/InputField.hs b/src/Monomer/Widgets/InputField.hs index a9b56434..806d7daa 100644 --- a/src/Monomer/Widgets/InputField.hs +++ b/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 diff --git a/tasks.md b/tasks.md index 7abcd743..0a55cf6f 100644 --- a/tasks.md +++ b/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) diff --git a/test/unit/Monomer/TestUtil.hs b/test/unit/Monomer/TestUtil.hs index cfcae75c..311ce03f 100644 --- a/test/unit/Monomer/TestUtil.hs +++ b/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) diff --git a/test/unit/Monomer/Widgets/AlertSpec.hs b/test/unit/Monomer/Widgets/AlertSpec.hs index 2e3f0218..533b5484 100644 --- a/test/unit/Monomer/Widgets/AlertSpec.hs +++ b/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 diff --git a/test/unit/Monomer/Widgets/BoxSpec.hs b/test/unit/Monomer/Widgets/BoxSpec.hs index f27e83d8..85c40af7 100644 --- a/test/unit/Monomer/Widgets/BoxSpec.hs +++ b/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 diff --git a/test/unit/Monomer/Widgets/ButtonSpec.hs b/test/unit/Monomer/Widgets/ButtonSpec.hs index ff97ebaa..1a41c592 100644 --- a/test/unit/Monomer/Widgets/ButtonSpec.hs +++ b/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 diff --git a/test/unit/Monomer/Widgets/CheckboxSpec.hs b/test/unit/Monomer/Widgets/CheckboxSpec.hs index 03956563..30a2eb51 100644 --- a/test/unit/Monomer/Widgets/CheckboxSpec.hs +++ b/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 diff --git a/test/unit/Monomer/Widgets/ConfirmSpec.hs b/test/unit/Monomer/Widgets/ConfirmSpec.hs index a4759c38..a79576de 100644 --- a/test/unit/Monomer/Widgets/ConfirmSpec.hs +++ b/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 diff --git a/test/unit/Monomer/Widgets/RadioSpec.hs b/test/unit/Monomer/Widgets/RadioSpec.hs index a4b7ef71..f6e20351 100644 --- a/test/unit/Monomer/Widgets/RadioSpec.hs +++ b/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 diff --git a/test/unit/Monomer/Widgets/TextFieldSpec.hs b/test/unit/Monomer/Widgets/TextFieldSpec.hs new file mode 100644 index 00000000..e368ef1c --- /dev/null +++ b/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 diff --git a/test/unit/Spec.hs b/test/unit/Spec.hs index 90cd6f82..a460944f 100644 --- a/test/unit/Spec.hs +++ b/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