mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-08-17 07:50:31 +03:00
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
This commit is contained in:
parent
a16e8599df
commit
465f33c460
@ -321,9 +321,11 @@ makeInputField !config !state = widget where
|
|||||||
|
|
||||||
handleKeyPress wenv mod code
|
handleKeyPress wenv mod code
|
||||||
| isDelBackWordNoSel && editable = Just $ moveCursor removeWord prevWordStartIdx Nothing
|
| 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 && 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
|
| isMoveLeft = Just $ moveCursor txt (tp - 1) Nothing
|
||||||
| isMoveRight = Just $ moveCursor txt (tp + 1) Nothing
|
| isMoveRight = Just $ moveCursor txt (tp + 1) Nothing
|
||||||
| isMoveWordL = Just $ moveCursor txt prevWordStartIdx Nothing
|
| isMoveWordL = Just $ moveCursor txt prevWordStartIdx Nothing
|
||||||
@ -369,8 +371,12 @@ makeInputField !config !state = widget where
|
|||||||
| isMacOS wenv = _kmLeftGUI mod
|
| isMacOS wenv = _kmLeftGUI mod
|
||||||
| otherwise = _kmLeftCtrl mod
|
| otherwise = _kmLeftCtrl mod
|
||||||
isBackspace = isKeyBackspace code && (tp > 0 || isJust currSel)
|
isBackspace = isKeyBackspace code && (tp > 0 || isJust currSel)
|
||||||
|
isDelete = isKeyDelete code && (tp < T.length currText || isJust currSel)
|
||||||
isDelBackWord = isBackspace && isWordMod
|
isDelBackWord = isBackspace && isWordMod
|
||||||
|
isDelForwardWord = isDelete && isWordMod
|
||||||
isDelBackWordNoSel = isDelBackWord && emptySel
|
isDelBackWordNoSel = isDelBackWord && emptySel
|
||||||
|
isDelForwardWordNoSel = isDelForwardWord && emptySel
|
||||||
|
isDelWord = isDelBackWord || isDelForwardWord
|
||||||
isMove = not isShift && not isWordMod && not isLineMod
|
isMove = not isShift && not isWordMod && not isLineMod
|
||||||
isMoveWord = not isShift && isWordMod && not isLineMod
|
isMoveWord = not isShift && isWordMod && not isLineMod
|
||||||
isMoveLine = not isShift && isLineMod && not isWordMod
|
isMoveLine = not isShift && isLineMod && not isWordMod
|
||||||
@ -395,9 +401,15 @@ makeInputField !config !state = widget where
|
|||||||
removeText
|
removeText
|
||||||
| isJust currSel = replaceText txt ""
|
| isJust currSel = replaceText txt ""
|
||||||
| otherwise = T.init part1 <> part2
|
| otherwise = T.init part1 <> part2
|
||||||
|
removeTextF
|
||||||
|
| isJust currSel = replaceText txt ""
|
||||||
|
| otherwise = part1 <> T.tail part2
|
||||||
removeWord
|
removeWord
|
||||||
| isJust currSel = replaceText txt ""
|
| isJust currSel = replaceText txt ""
|
||||||
| otherwise = prevWordStart <> part2
|
| otherwise = prevWordStart <> part2
|
||||||
|
removeWordF
|
||||||
|
| isJust currSel = replaceText txt ""
|
||||||
|
| otherwise = part1 <> nextWordEnd
|
||||||
moveCursor txt newPos newSel
|
moveCursor txt newPos newSel
|
||||||
| isJust currSel && isNothing newSel = (txt, fixedPos, Nothing)
|
| isJust currSel && isNothing newSel = (txt, fixedPos, Nothing)
|
||||||
| isJust currSel && Just fixedPos == currSel = (txt, fixedPos, Nothing)
|
| isJust currSel && Just fixedPos == currSel = (txt, fixedPos, Nothing)
|
||||||
@ -626,8 +638,8 @@ makeInputField !config !state = widget where
|
|||||||
_ifsHistIdx = histIdx + 1
|
_ifsHistIdx = histIdx + 1
|
||||||
}
|
}
|
||||||
| otherwise = tempState {
|
| otherwise = tempState {
|
||||||
_ifsHistory = Seq.take (histIdx - 1) history |> newStep,
|
_ifsHistory = Seq.take histIdx history |> newStep,
|
||||||
_ifsHistIdx = histIdx
|
_ifsHistIdx = histIdx + 1
|
||||||
}
|
}
|
||||||
!newNode = node
|
!newNode = node
|
||||||
& L.widget .~ makeInputField config newState
|
& L.widget .~ makeInputField config newState
|
||||||
@ -822,11 +834,11 @@ moveHistory wenv node state config steps = result where
|
|||||||
currHistIdx = _ifsHistIdx state
|
currHistIdx = _ifsHistIdx state
|
||||||
lenHistory = length currHistory
|
lenHistory = length currHistory
|
||||||
reqHistIdx
|
reqHistIdx
|
||||||
| steps == -1 && currHistIdx == lenHistory = currHistIdx - 2
|
| steps == -1 && currHistIdx == lenHistory = currHistIdx - 1
|
||||||
| otherwise = currHistIdx + steps
|
| otherwise = currHistIdx + steps
|
||||||
histStep = Seq.lookup reqHistIdx currHistory
|
histStep = Seq.lookup (reqHistIdx - 1) currHistory
|
||||||
result
|
result
|
||||||
| null currHistory || reqHistIdx < 0 = Just (createResult historyStep)
|
| null currHistory || reqHistIdx <= 0 = Just (createResult historyStep)
|
||||||
| otherwise = fmap createResult histStep
|
| otherwise = fmap createResult histStep
|
||||||
createResult histStep = resultReqsEvts newNode reqs evts where
|
createResult histStep = resultReqsEvts newNode reqs evts where
|
||||||
(reqs, evts) = genReqsEvents node config state (_ihsText histStep) []
|
(reqs, evts) = genReqsEvents node config state (_ihsText histStep) []
|
||||||
|
@ -330,9 +330,11 @@ makeTextArea !wdata !config !state = widget where
|
|||||||
|
|
||||||
handleKeyPress wenv mod code
|
handleKeyPress wenv mod code
|
||||||
| isDelBackWordNoSel && editable = Just removeWordL
|
| 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 && 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
|
| isMoveLeft = Just $ moveCursor txt (tpX - 1, tpY) Nothing
|
||||||
| isMoveRight = Just $ moveCursor txt (tpX + 1, tpY) Nothing
|
| isMoveRight = Just $ moveCursor txt (tpX + 1, tpY) Nothing
|
||||||
| isMoveUp = Just $ moveCursor txt (tpX, tpY - 1) Nothing
|
| isMoveUp = Just $ moveCursor txt (tpX, tpY - 1) Nothing
|
||||||
@ -416,8 +418,12 @@ makeTextArea !wdata !config !state = widget where
|
|||||||
| otherwise = _kmLeftCtrl mod
|
| otherwise = _kmLeftCtrl mod
|
||||||
|
|
||||||
isBackspace = isKeyBackspace code
|
isBackspace = isKeyBackspace code
|
||||||
|
isDelete = isKeyDelete code
|
||||||
isDelBackWord = isBackspace && isWordMod
|
isDelBackWord = isBackspace && isWordMod
|
||||||
|
isDelForwardWord = isDelete && isWordMod
|
||||||
isDelBackWordNoSel = isDelBackWord && emptySel
|
isDelBackWordNoSel = isDelBackWord && emptySel
|
||||||
|
isDelForwardWordNoSel = isDelForwardWord && emptySel
|
||||||
|
isDelWord = isDelBackWord || isDelForwardWord
|
||||||
|
|
||||||
isMove = not isShift && not isWordMod && not isLineMod
|
isMove = not isShift && not isWordMod && not isLineMod
|
||||||
isMoveWord = not isShift && isWordMod && not isLineMod
|
isMoveWord = not isShift && isWordMod && not isLineMod
|
||||||
@ -463,7 +469,12 @@ makeTextArea !wdata !config !state = widget where
|
|||||||
removeCharL
|
removeCharL
|
||||||
| tpX > 0 = replaceFix (tpX - 1, tpY) ""
|
| tpX > 0 = replaceFix (tpX - 1, tpY) ""
|
||||||
| otherwise = replaceFix (lineLen (tpY - 1), tpY - 1) ""
|
| 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 ""
|
removeWordL = replaceFix prevWordPos ""
|
||||||
|
removeWordR = replaceFix nextWordPos ""
|
||||||
moveCursor txt newPos newSel
|
moveCursor txt newPos newSel
|
||||||
| isJust selStart && isNothing newSel = (txt, fixedPos, Nothing)
|
| isJust selStart && isNothing newSel = (txt, fixedPos, Nothing)
|
||||||
| isJust selStart && Just fixedPos == selStart = (txt, fixedPos, Nothing)
|
| isJust selStart && Just fixedPos == selStart = (txt, fixedPos, Nothing)
|
||||||
|
@ -18,7 +18,7 @@ module Monomer.Widgets.Singles.TextAreaSpec (spec) where
|
|||||||
import Control.Lens ((&), (^.), (.~))
|
import Control.Lens ((&), (^.), (.~))
|
||||||
import Control.Lens.TH (abbreviatedFields, makeLensesWith)
|
import Control.Lens.TH (abbreviatedFields, makeLensesWith)
|
||||||
import Data.Default
|
import Data.Default
|
||||||
import Data.Text (Text)
|
import Data.Text (Text, pack)
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
|
|
||||||
import qualified Data.Sequence as Seq
|
import qualified Data.Sequence as Seq
|
||||||
@ -64,6 +64,10 @@ handleEvent = describe "handleEvent" $ do
|
|||||||
let steps = [evtT "ababa", moveCharL, moveCharL, evtK keyBackspace, evtT "c"]
|
let steps = [evtT "ababa", moveCharL, moveCharL, evtK keyBackspace, evtT "c"]
|
||||||
model steps ^. textValue `shouldBe` "abcba"
|
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
|
it "should input 'ababa', select last two and input 'c'" $ do
|
||||||
let steps = [evtT "ababa", selCharL, selCharL, selCharL, evtT "c"]
|
let steps = [evtT "ababa", selCharL, selCharL, selCharL, evtT "c"]
|
||||||
model steps ^. textValue `shouldBe` "abc"
|
model steps ^. textValue `shouldBe` "abc"
|
||||||
@ -291,6 +295,14 @@ handleEventHistory = describe "handleEventHistory" $ do
|
|||||||
model steps2 ^. textValue `shouldBe` "This is text"
|
model steps2 ^. textValue `shouldBe` "This is text"
|
||||||
lastEvt steps2 `shouldBe` TextChanged "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
|
it "should input 'This is text', have the last two words removed, undo and redo" $ do
|
||||||
let str = "This is text"
|
let str = "This is text"
|
||||||
let steps1 = [evtT str, evtKA keyBackspace, evtKA keyBackspace]
|
let steps1 = [evtT str, evtKA keyBackspace, evtKA keyBackspace]
|
||||||
@ -299,7 +311,7 @@ handleEventHistory = describe "handleEventHistory" $ do
|
|||||||
model steps2 ^. textValue `shouldBe` "This is "
|
model steps2 ^. textValue `shouldBe` "This is "
|
||||||
lastEvt steps2 `shouldBe` TextChanged "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 str = "This is just a string"
|
||||||
let steps1 = [evtT str, evtKA keyBackspace, evtKA keyBackspace, evtKA keyBackspace, evtKA keyBackspace, evtKA keyBackspace]
|
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"]
|
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"
|
model steps2 ^. textValue `shouldBe` "This is not"
|
||||||
lastEvt steps2 `shouldBe` TextChanged "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
|
where
|
||||||
wenv = mockWenv (TestModel "")
|
wenv = mockWenv (TestModel "")
|
||||||
txtCfg = [onChange TextChanged, selectOnFocus, onFocus GotFocus, onBlur LostFocus]
|
txtCfg = [onChange TextChanged, selectOnFocus, onFocus GotFocus, onBlur LostFocus]
|
||||||
|
@ -18,7 +18,7 @@ module Monomer.Widgets.Singles.TextFieldSpec (spec) where
|
|||||||
import Control.Lens ((&), (^.), (.~))
|
import Control.Lens ((&), (^.), (.~))
|
||||||
import Control.Lens.TH (abbreviatedFields, makeLensesWith)
|
import Control.Lens.TH (abbreviatedFields, makeLensesWith)
|
||||||
import Data.Default
|
import Data.Default
|
||||||
import Data.Text (Text)
|
import Data.Text (Text, pack)
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
|
|
||||||
import qualified Data.Sequence as Seq
|
import qualified Data.Sequence as Seq
|
||||||
@ -66,6 +66,10 @@ handleEvent = describe "handleEvent" $ do
|
|||||||
let steps = [evtT "ababa", moveCharL, moveCharL, evtK keyBackspace, evtT "c"]
|
let steps = [evtT "ababa", moveCharL, moveCharL, evtK keyBackspace, evtT "c"]
|
||||||
model steps ^. textValue `shouldBe` "abcba"
|
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
|
it "should input 'ababa', select last two and input 'c'" $ do
|
||||||
let steps = [evtT "ababa", selCharL, selCharL, selCharL, evtT "c"]
|
let steps = [evtT "ababa", selCharL, selCharL, selCharL, evtT "c"]
|
||||||
model steps ^. textValue `shouldBe` "abc"
|
model steps ^. textValue `shouldBe` "abc"
|
||||||
@ -238,6 +242,14 @@ handleEventHistory = describe "handleEventHistory" $ do
|
|||||||
model steps2 ^. textValue `shouldBe` "This is text"
|
model steps2 ^. textValue `shouldBe` "This is text"
|
||||||
lastEvt steps2 `shouldBe` TextChanged "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
|
it "should input 'This is text', have the last two words removed, undo and redo" $ do
|
||||||
let str = "This is text"
|
let str = "This is text"
|
||||||
let steps1 = [evtT str, evtKA keyBackspace, evtKA keyBackspace]
|
let steps1 = [evtT str, evtKA keyBackspace, evtKA keyBackspace]
|
||||||
@ -246,7 +258,7 @@ handleEventHistory = describe "handleEventHistory" $ do
|
|||||||
model steps2 ^. textValue `shouldBe` "This is "
|
model steps2 ^. textValue `shouldBe` "This is "
|
||||||
lastEvt steps2 `shouldBe` TextChanged "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 str = "This is just a string"
|
||||||
let steps1 = [evtT str, evtKA keyBackspace, evtKA keyBackspace, evtKA keyBackspace, evtKA keyBackspace, evtKA keyBackspace]
|
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"]
|
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"
|
model steps2 ^. textValue `shouldBe` "This is not"
|
||||||
lastEvt steps2 `shouldBe` TextChanged "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
|
where
|
||||||
wenv = mockWenv (TestModel "")
|
wenv = mockWenv (TestModel "")
|
||||||
txtCfg = [onChange TextChanged, selectOnFocus, onFocus GotFocus, onBlur LostFocus]
|
txtCfg = [onChange TextChanged, selectOnFocus, onFocus GotFocus, onBlur LostFocus]
|
||||||
|
Loading…
Reference in New Issue
Block a user