Add support for delete key in inputField and textArea (and fix undo bug) (#294)

* add support for delete key in inputField

* add support for delete key in textArea

* add unit tests for delete key

* fix inputField undo behavior

* add more unit tests for textField and textArea

src/Monomer/Widgets/Singles/Base/InputField.hs

@@ -321,9 +321,11 @@ makeInputField !config !state = widget where
 
   handleKeyPress wenv mod code
     | isDelBackWordNoSel && editable = Just $ moveCursor removeWord prevWordStartIdx Nothing
-    | isDelBackWord && editable = Just $ moveCursor removeText minTpSel Nothing
+    | isDelForwardWordNoSel && editable = Just $ moveCursor removeWordF tp Nothing
+    | isDelWord && editable = Just $ moveCursor removeText minTpSel Nothing
     | isBackspace && emptySel && editable = Just $ moveCursor removeText (tp - 1) Nothing
-    | isBackspace && editable = Just $ moveCursor removeText minTpSel Nothing
+    | isDelete && emptySel && editable = Just $ moveCursor removeTextF tp Nothing
+    | (isBackspace || isDelete) && editable = Just $ moveCursor removeText minTpSel Nothing
     | isMoveLeft = Just $ moveCursor txt (tp - 1) Nothing
     | isMoveRight = Just $ moveCursor txt (tp + 1) Nothing
     | isMoveWordL = Just $ moveCursor txt prevWordStartIdx Nothing
@@ -369,8 +371,12 @@ makeInputField !config !state = widget where
         | isMacOS wenv = _kmLeftGUI mod
         | otherwise = _kmLeftCtrl mod
       isBackspace = isKeyBackspace code && (tp > 0 || isJust currSel)
+      isDelete = isKeyDelete code && (tp < T.length currText || isJust currSel)
       isDelBackWord = isBackspace && isWordMod
+      isDelForwardWord = isDelete && isWordMod
       isDelBackWordNoSel = isDelBackWord && emptySel
+      isDelForwardWordNoSel = isDelForwardWord && emptySel
+      isDelWord = isDelBackWord || isDelForwardWord
       isMove = not isShift && not isWordMod && not isLineMod
       isMoveWord = not isShift && isWordMod && not isLineMod
       isMoveLine = not isShift && isLineMod && not isWordMod
@@ -395,9 +401,15 @@ makeInputField !config !state = widget where
       removeText
         | isJust currSel = replaceText txt ""
         | otherwise = T.init part1 <> part2
+      removeTextF
+        | isJust currSel = replaceText txt ""
+        | otherwise = part1 <> T.tail part2
       removeWord
         | isJust currSel = replaceText txt ""
         | otherwise = prevWordStart <> part2
+      removeWordF
+        | isJust currSel = replaceText txt ""
+        | otherwise = part1 <> nextWordEnd
       moveCursor txt newPos newSel
         | isJust currSel && isNothing newSel = (txt, fixedPos, Nothing)
         | isJust currSel && Just fixedPos == currSel = (txt, fixedPos, Nothing)
@@ -626,8 +638,8 @@ makeInputField !config !state = widget where
           _ifsHistIdx = histIdx + 1
         }
       | otherwise = tempState {
-          _ifsHistory = Seq.take (histIdx - 1) history |> newStep,
+          _ifsHistory = Seq.take histIdx history |> newStep,
-          _ifsHistIdx = histIdx
+          _ifsHistIdx = histIdx + 1
         }
     !newNode = node
       & L.widget .~ makeInputField config newState
@@ -822,11 +834,11 @@ moveHistory wenv node state config steps = result where
   currHistIdx = _ifsHistIdx state
   lenHistory = length currHistory
   reqHistIdx
-    | steps == -1 && currHistIdx == lenHistory = currHistIdx - 2
+    | steps == -1 && currHistIdx == lenHistory = currHistIdx - 1
     | otherwise = currHistIdx + steps
-  histStep = Seq.lookup reqHistIdx currHistory
+  histStep = Seq.lookup (reqHistIdx - 1) currHistory
   result
-    | null currHistory || reqHistIdx < 0 = Just (createResult historyStep)
+    | null currHistory || reqHistIdx <= 0 = Just (createResult historyStep)
     | otherwise = fmap createResult histStep
   createResult histStep = resultReqsEvts newNode reqs evts where
     (reqs, evts) = genReqsEvents node config state (_ihsText histStep) []

src/Monomer/Widgets/Singles/TextArea.hs

@@ -330,9 +330,11 @@ makeTextArea !wdata !config !state = widget where
 
   handleKeyPress wenv mod code
     | isDelBackWordNoSel && editable = Just removeWordL
-    | isDelBackWord && editable = Just (replaceText state selStart "")
+    | isDelForwardWordNoSel && editable = Just removeWordR
+    | isDelWord && editable = Just (replaceText state selStart "")
     | isBackspace && emptySel && editable = Just removeCharL
-    | isBackspace && editable = Just (replaceText state selStart "")
+    | isDelete && emptySel && editable = Just removeCharR
+    | (isBackspace || isDelete) && editable = Just (replaceText state selStart "")
     | isMoveLeft = Just $ moveCursor txt (tpX - 1, tpY) Nothing
     | isMoveRight = Just $ moveCursor txt (tpX + 1, tpY) Nothing
     | isMoveUp = Just $ moveCursor txt (tpX, tpY - 1) Nothing
@@ -416,8 +418,12 @@ makeTextArea !wdata !config !state = widget where
         | otherwise = _kmLeftCtrl mod
 
       isBackspace = isKeyBackspace code
+      isDelete = isKeyDelete code
       isDelBackWord = isBackspace && isWordMod
+      isDelForwardWord = isDelete && isWordMod
       isDelBackWordNoSel = isDelBackWord && emptySel
+      isDelForwardWordNoSel = isDelForwardWord && emptySel
+      isDelWord = isDelBackWord || isDelForwardWord
 
       isMove = not isShift && not isWordMod && not isLineMod
       isMoveWord = not isShift && isWordMod && not isLineMod
@@ -463,7 +469,12 @@ makeTextArea !wdata !config !state = widget where
       removeCharL
         | tpX > 0 = replaceFix (tpX - 1, tpY) ""
         | otherwise = replaceFix (lineLen (tpY - 1), tpY - 1) ""
+      removeCharR
+        | tpX < lineLen tpY = replaceFix (tpX + 1, tpY) ""
+        | tpY >= length textLines - 1 = replaceFix (tpX, tpY) ""
+        | otherwise = replaceFix (0, tpY + 1) ""
       removeWordL = replaceFix prevWordPos ""
+      removeWordR = replaceFix nextWordPos ""
       moveCursor txt newPos newSel
         | isJust selStart && isNothing newSel = (txt, fixedPos, Nothing)
         | isJust selStart && Just fixedPos == selStart = (txt, fixedPos, Nothing)

test/unit/Monomer/Widgets/Singles/TextAreaSpec.hs

@@ -18,7 +18,7 @@ module Monomer.Widgets.Singles.TextAreaSpec (spec) where
 import Control.Lens ((&), (^.), (.~))
 import Control.Lens.TH (abbreviatedFields, makeLensesWith)
 import Data.Default
-import Data.Text (Text)
+import Data.Text (Text, pack)
 import Test.Hspec
 
 import qualified Data.Sequence as Seq
@@ -64,6 +64,10 @@ handleEvent = describe "handleEvent" $ do
     let steps = [evtT "ababa", moveCharL, moveCharL, evtK keyBackspace, evtT "c"]
     model steps ^. textValue `shouldBe` "abcba"
 
+  it "should input 'ababa' and remove the middle 'a'" $ do
+    let steps = [evtT "ababa", moveCharL, moveCharL, moveCharL, evtK keyDelete]
+    model steps ^. textValue `shouldBe` "abba"
+
   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"
@@ -291,6 +295,14 @@ handleEventHistory = describe "handleEventHistory" $ do
     model steps2 ^. textValue `shouldBe` "This is text"
     lastEvt steps2 `shouldBe` TextChanged "This is text"
 
+  it "should input 'This is text', have the middle word removed and then undo" $ do
+    let str = "This is text"
+    let steps1 = [evtT str] ++ (replicate 8 moveCharL) ++ [evtKA keyDelete]
+    let steps2 = steps1 ++ [evtKG keyZ]
+    model steps1 ^. textValue `shouldBe` "This text"
+    model steps2 ^. textValue `shouldBe` "This is text"
+    lastEvt steps2 `shouldBe` TextChanged "This is text"
+
   it "should input 'This is text', have the last two words removed, undo and redo" $ do
     let str = "This is text"
     let steps1 = [evtT str, evtKA keyBackspace, evtKA keyBackspace]
@@ -299,7 +311,7 @@ handleEventHistory = describe "handleEventHistory" $ do
     model steps2 ^. textValue `shouldBe` "This is "
     lastEvt steps2 `shouldBe` TextChanged "This is "
 
-  it "should input 'This is just a string', play around with history and come end up with 'This is just text" $ do
+  it "should input 'This is just a string', play around with history and end up with 'This is just text'" $ do
     let str = "This is just a string"
     let steps1 = [evtT str, evtKA keyBackspace, evtKA keyBackspace, evtKA keyBackspace, evtKA keyBackspace, evtKA keyBackspace]
     let steps2 = steps1 ++ [evtKG keyZ, evtKG keyZ, evtKG keyZ, evtKG keyZ, evtKG keyZ, evtKGS keyZ, evtKGS keyZ, evtT "text"]
@@ -315,6 +327,21 @@ handleEventHistory = describe "handleEventHistory" $ do
     model steps2 ^. textValue `shouldBe` "This is not"
     lastEvt steps2 `shouldBe` TextChanged "This is not"
 
+  it "should input 'This is text', undo to the beginning, input 'text', do one undo and end up with 'tex'" $ do
+    let str = "This is text"
+    let steps1 = (evtT . pack . pure <$> str) ++ (replicate 12 $ evtKG keyZ)
+    let steps2 = steps1 ++ [evtT "t", evtT "e", evtT "x", evtT "t", evtKG keyZ]
+    model steps1 ^. textValue `shouldBe` ""
+    model steps2 ^. textValue `shouldBe` "tex"
+    lastEvt steps2 `shouldBe` TextChanged "tex"
+
+  it "should input 'qwe', undo, input 'e', undo and end up with 'qw'" $ do
+    let steps1 = [evtT "q", evtT "w", evtT "e", evtKG keyZ]
+    let steps2 = steps1 ++ [evtT "e", evtKG keyZ]
+    model steps1 ^. textValue `shouldBe` "qw"
+    model steps2 ^. textValue `shouldBe` "qw"
+    lastEvt steps2 `shouldBe` TextChanged "qw"
+
   where
     wenv = mockWenv (TestModel "")
     txtCfg = [onChange TextChanged, selectOnFocus, onFocus GotFocus, onBlur LostFocus]

test/unit/Monomer/Widgets/Singles/TextFieldSpec.hs

@@ -18,7 +18,7 @@ module Monomer.Widgets.Singles.TextFieldSpec (spec) where
 import Control.Lens ((&), (^.), (.~))
 import Control.Lens.TH (abbreviatedFields, makeLensesWith)
 import Data.Default
-import Data.Text (Text)
+import Data.Text (Text, pack)
 import Test.Hspec
 
 import qualified Data.Sequence as Seq
@@ -66,6 +66,10 @@ handleEvent = describe "handleEvent" $ do
     let steps = [evtT "ababa", moveCharL, moveCharL, evtK keyBackspace, evtT "c"]
     model steps ^. textValue `shouldBe` "abcba"
 
+  it "should input 'ababa' and remove the middle 'a'" $ do
+    let steps = [evtT "ababa", moveCharL, moveCharL, moveCharL, evtK keyDelete]
+    model steps ^. textValue `shouldBe` "abba"
+
   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"
@@ -238,6 +242,14 @@ handleEventHistory = describe "handleEventHistory" $ do
     model steps2 ^. textValue `shouldBe` "This is text"
     lastEvt steps2 `shouldBe` TextChanged "This is text"
 
+  it "should input 'This is text', have the middle word removed and then undo" $ do
+    let str = "This is text"
+    let steps1 = [evtT str] ++ (replicate 8 moveCharL) ++ [evtKA keyDelete]
+    let steps2 = steps1 ++ [evtKG keyZ]
+    model steps1 ^. textValue `shouldBe` "This text"
+    model steps2 ^. textValue `shouldBe` "This is text"
+    lastEvt steps2 `shouldBe` TextChanged "This is text"
+
   it "should input 'This is text', have the last two words removed, undo and redo" $ do
     let str = "This is text"
     let steps1 = [evtT str, evtKA keyBackspace, evtKA keyBackspace]
@@ -246,7 +258,7 @@ handleEventHistory = describe "handleEventHistory" $ do
     model steps2 ^. textValue `shouldBe` "This is "
     lastEvt steps2 `shouldBe` TextChanged "This is "
 
-  it "should input 'This is just a string', play around with history and come end up with 'This is just text" $ do
+  it "should input 'This is just a string', play around with history and end up with 'This is just text'" $ do
     let str = "This is just a string"
     let steps1 = [evtT str, evtKA keyBackspace, evtKA keyBackspace, evtKA keyBackspace, evtKA keyBackspace, evtKA keyBackspace]
     let steps2 = steps1 ++ [evtKG keyZ, evtKG keyZ, evtKG keyZ, evtKG keyZ, evtKG keyZ, evtKGS keyZ, evtKGS keyZ, evtT "text"]
@@ -262,6 +274,21 @@ handleEventHistory = describe "handleEventHistory" $ do
     model steps2 ^. textValue `shouldBe` "This is not"
     lastEvt steps2 `shouldBe` TextChanged "This is not"
 
+  it "should input 'This is text', undo to the beginning, input 'text', do one undo and end up with 'tex'" $ do
+    let str = "This is text"
+    let steps1 = (evtT . pack . pure <$> str) ++ (replicate 12 $ evtKG keyZ)
+    let steps2 = steps1 ++ [evtT "t", evtT "e", evtT "x", evtT "t", evtKG keyZ]
+    model steps1 ^. textValue `shouldBe` ""
+    model steps2 ^. textValue `shouldBe` "tex"
+    lastEvt steps2 `shouldBe` TextChanged "tex"
+
+  it "should input 'qwe', undo, input 'e', undo and end up with 'qw'" $ do
+    let steps1 = [evtT "q", evtT "w", evtT "e", evtKG keyZ]
+    let steps2 = steps1 ++ [evtT "e", evtKG keyZ]
+    model steps1 ^. textValue `shouldBe` "qw"
+    model steps2 ^. textValue `shouldBe` "qw"
+    lastEvt steps2 `shouldBe` TextChanged "qw"
+
   where
     wenv = mockWenv (TestModel "")
     txtCfg = [onChange TextChanged, selectOnFocus, onFocus GotFocus, onBlur LostFocus]