From eb4f36638ca8879c939760bb19597edb3783cac5 Mon Sep 17 00:00:00 2001 From: Francisco Vallarino Date: Sun, 15 Nov 2020 23:58:26 -0300 Subject: [PATCH] Improve inputField, add new tests --- app/Main.hs | 2 +- src/Monomer/Widgets/InputField.hs | 44 ++++++++-- test/unit/Monomer/TestKeyboardUtil.hs | 95 ++++++++++++++++++++++ test/unit/Monomer/Widgets/TextFieldSpec.hs | 77 +++++------------- watch-tests.sh | 2 +- 5 files changed, 152 insertions(+), 68 deletions(-) create mode 100644 test/unit/Monomer/TestKeyboardUtil.hs diff --git a/app/Main.hs b/app/Main.hs index 6c2f5b35..343c0f58 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -78,7 +78,7 @@ handleAppEvent model evt = case evt of _ -> [] buildUI :: App -> WidgetInstance App AppEvent -buildUI model = trace "Creating UI" widgetTree where +buildUI model = trace "Creating UI" widgetTree5 where widgetTreeAlt | model ^. clickCount `mod` 2 == 0 = widgetTree10 | otherwise = widgetTree11 diff --git a/src/Monomer/Widgets/InputField.hs b/src/Monomer/Widgets/InputField.hs index 806d7daa..3265c31a 100644 --- a/src/Monomer/Widgets/InputField.hs +++ b/src/Monomer/Widgets/InputField.hs @@ -137,18 +137,25 @@ makeInputField config state = widget where reqs = setModelValid (isJust parsedVal) handleKeyPress wenv mod code + | isDelBackWord && emptySel = Just $ moveCursor removeWord prevWordStartIdx Nothing + | isDelBackWord = Just $ moveCursor removeText minTpSel Nothing | isBackspace && emptySel = Just $ moveCursor removeText (tp - 1) Nothing - | isBackspace = Just $ moveCursor removeText (min currSelVal tp) Nothing + | isBackspace = Just $ moveCursor removeText minTpSel 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 + | isMoveLineL = Just $ moveCursor txt 0 Nothing + | isMoveLineR = Just $ moveCursor txt txtLen Nothing + | isSelectAll = Just $ moveCursor txt 0 (Just txtLen) | isSelectLeft = Just $ moveCursor txt (tp - 1) (Just tp) | isSelectRight = Just $ moveCursor txt (tp + 1) (Just tp) | isSelectWordL = Just $ moveCursor txt prevWordStartIdx (Just tp) | isSelectWordR = Just $ moveCursor txt nextWordEndIdx (Just tp) + | isSelectLineL = Just $ moveCursor txt 0 (Just tp) + | isSelectLineR = Just $ moveCursor txt txtLen (Just tp) + | isDeselectLeft = Just $ moveCursor txt minTpSel Nothing + | isDeselectRight = Just $ moveCursor txt maxTpSel Nothing | otherwise = Nothing where txt = currText @@ -158,6 +165,8 @@ makeInputField config state = widget where (part1, part2) = T.splitAt currPos currText currSelVal = fromMaybe 0 currSel activeSel = isJust currSel + minTpSel = min tp currSelVal + maxTpSel = max tp currSelVal delim c = c == ' ' || c == '.' || c == ',' prevWordStart = T.dropWhileEnd (not . delim) $ T.dropWhileEnd delim part1 prevWordStartIdx = T.length prevWordStart @@ -167,24 +176,41 @@ makeInputField config state = widget where isWordMod | isMacOS wenv = _kmLeftAlt mod | otherwise = _kmLeftCtrl mod + isLineMod + | isMacOS wenv = _kmLeftCtrl mod + | otherwise = _kmLeftAlt mod + isAllMod + | isMacOS wenv = _kmLeftGUI mod + | otherwise = _kmLeftCtrl mod isBackspace = isKeyBackspace code && (tp > 0 || isJust currSel) - isMove = not isShift && not isWordMod - isMoveWord = not isShift && isWordMod - isSelect = isShift && not isWordMod - isSelectWord = isShift && isWordMod + isDelBackWord = isBackspace && isWordMod + isMove = not isShift && not isWordMod && not isLineMod + isMoveWord = not isShift && isWordMod && not isLineMod + isMoveLine = not isShift && isLineMod && not isWordMod + isSelect = isShift && not isWordMod && not isLineMod + isSelectWord = isShift && isWordMod && not isLineMod + isSelectLine = isShift && isLineMod && not isWordMod 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 + isMoveLineL = isMoveLine && isKeyLeft code + isMoveLineR = isMoveLine && isKeyRight code + isSelectAll = isAllMod && isKeyA code isSelectLeft = isSelect && isKeyLeft code isSelectRight = isSelect && isKeyRight code isSelectWordL = isSelectWord && isKeyLeft code isSelectWordR = isSelectWord && isKeyRight code + isSelectLineL = isSelectLine && isKeyLeft code + isSelectLineR = isSelectLine && isKeyRight code + isDeselectLeft = isMove && activeSel && isKeyLeft code + isDeselectRight = isMove && activeSel && isKeyRight code removeText | isJust currSel = replaceText txt "" | otherwise = T.init part1 <> part2 + removeWord + | isJust currSel = replaceText txt "" + | otherwise = prevWordStart <> part2 moveCursor txt newPos newSel | isJust currSel && isNothing newSel = (txt, fixedPos, Nothing) | isJust currSel && Just fixedPos == currSel = (txt, fixedPos, Nothing) diff --git a/test/unit/Monomer/TestKeyboardUtil.hs b/test/unit/Monomer/TestKeyboardUtil.hs new file mode 100644 index 00000000..0a43bf62 --- /dev/null +++ b/test/unit/Monomer/TestKeyboardUtil.hs @@ -0,0 +1,95 @@ +module Monomer.TestKeyboardUtil where + +import Control.Lens ((&), (^.), (.~)) +import Data.Default +import Data.Text (Text) + +import Monomer.Event + +import qualified Monomer.Lens as L + +-- For Mac OS, Meta acts as Windows' Ctrl (and viceversa) on text movement/selection +modA :: KeyMod +modA = def + & L.leftCtrl .~ True + +modC :: KeyMod +modC = def + & L.leftAlt .~ True + +modG :: KeyMod +modG = def + & L.leftGUI .~ True + +modS :: KeyMod +modS = def & L.leftShift .~ True + +modAS :: KeyMod +modAS = def + & L.leftCtrl .~ True + & L.leftShift .~ True + +modCS :: KeyMod +modCS = def + & L.leftAlt .~ True + & L.leftShift .~ True + +evtK :: KeyCode -> SystemEvent +evtK k = KeyAction def k KeyPressed + +evtKA :: KeyCode -> SystemEvent +evtKA k = KeyAction modA k KeyPressed + +evtKC :: KeyCode -> SystemEvent +evtKC k = KeyAction modC k KeyPressed + +evtKG :: KeyCode -> SystemEvent +evtKG k = KeyAction modG k KeyPressed + +evtKS :: KeyCode -> SystemEvent +evtKS k = KeyAction modS k KeyPressed + +evtKAS :: KeyCode -> SystemEvent +evtKAS k = KeyAction modAS 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 + +moveLineL :: SystemEvent +moveLineL = evtKA keyLeft + +moveLineR :: SystemEvent +moveLineR = evtKA keyRight + +selCharL :: SystemEvent +selCharL = evtKS keyLeft + +selCharR :: SystemEvent +selCharR = evtKS keyRight + +selWordL :: SystemEvent +selWordL = evtKCS keyLeft + +selWordR :: SystemEvent +selWordR = evtKCS keyRight + +selLineL :: SystemEvent +selLineL = evtKAS keyLeft + +selLineR :: SystemEvent +selLineR = evtKAS keyRight diff --git a/test/unit/Monomer/Widgets/TextFieldSpec.hs b/test/unit/Monomer/Widgets/TextFieldSpec.hs index e368ef1c..a54da6ac 100644 --- a/test/unit/Monomer/Widgets/TextFieldSpec.hs +++ b/test/unit/Monomer/Widgets/TextFieldSpec.hs @@ -16,6 +16,7 @@ import qualified Data.Sequence as Seq import Monomer.Core import Monomer.Event import Monomer.TestUtil +import Monomer.TestKeyboardUtil import Monomer.Widgets.TextField import qualified Monomer.Lens as L @@ -31,7 +32,7 @@ newtype TestModel = TestModel { makeLensesWith abbreviatedFields ''TestModel spec :: Spec -spec = fdescribe "TextField" $ do +spec = describe "TextField" $ do handleEvent handleEventValue updateSizeReq @@ -64,7 +65,12 @@ handleEvent = describe "handleEvent" $ do 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 + it "should input 'This is text', select all and input 'No'" $ do + let str = "This is text" + let steps = [evtT str, evtKG keyA, evtT "No"] + model steps ^. textValue `shouldBe` "No" + + it "should input 'This is text', receive focus (with select on Focus) and input 'No'" $ do let str = "This is text" let steps = [evtT str, Focus, evtT "No"] model steps ^. textValue `shouldBe` "No" @@ -80,7 +86,7 @@ handleEventValue = describe "handleEvent" $ do 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 "] + let steps = [evtT str, evtT "?", moveLineL, 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 @@ -90,8 +96,18 @@ handleEventValue = describe "handleEvent" $ do 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"] + let steps = [evtT str, evtKC keyBackspace, evtT "cat"] lastEvt steps `shouldBe` TextChanged "This is a cat" + + it "should input 'This is a dog', select to beginning and input 'No'" $ do + let str = "This is a dog" + let steps = [evtT str, selLineL, evtT "No"] + lastEvt steps `shouldBe` TextChanged "No" + + it "should input 'This is a dog', move to beginning, select until end and input 'No'" $ do + let str = "This is a dog" + let steps = [evtT str, moveLineL, selLineR, evtT "No"] + lastEvt steps `shouldBe` TextChanged "No" where wenv = mockWenv (TestModel "") txtInst = textFieldV "" TextChanged @@ -110,56 +126,3 @@ updateSizeReq = describe "updateSizeReq" $ do 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/watch-tests.sh b/watch-tests.sh index 46f9b6b9..90a423e2 100755 --- a/watch-tests.sh +++ b/watch-tests.sh @@ -1 +1 @@ -ghcid --command "stack ghci monomer:lib monomer:test:monomer-test --ghci-options=-fobject-code" +ghcid --command "stack ghci monomer:lib monomer:test:monomer-test"