mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-07-14 23:30:30 +03:00
Improve inputField, add new tests
This commit is contained in:
Francisco Vallarino
parent
8b4bfea6f5
commit
eb4f36638c
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
95
test/unit/Monomer/TestKeyboardUtil.hs
Normal file
95
test/unit/Monomer/TestKeyboardUtil.hs
Normal file
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user