mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-08-16 23:40:54 +03:00
Improve inputField, add new tests
This commit is contained in:
parent
8b4bfea6f5
commit
eb4f36638c
@ -78,7 +78,7 @@ handleAppEvent model evt = case evt of
|
|||||||
_ -> []
|
_ -> []
|
||||||
|
|
||||||
buildUI :: App -> WidgetInstance App AppEvent
|
buildUI :: App -> WidgetInstance App AppEvent
|
||||||
buildUI model = trace "Creating UI" widgetTree where
|
buildUI model = trace "Creating UI" widgetTree5 where
|
||||||
widgetTreeAlt
|
widgetTreeAlt
|
||||||
| model ^. clickCount `mod` 2 == 0 = widgetTree10
|
| model ^. clickCount `mod` 2 == 0 = widgetTree10
|
||||||
| otherwise = widgetTree11
|
| otherwise = widgetTree11
|
||||||
|
@ -137,18 +137,25 @@ makeInputField config state = widget where
|
|||||||
reqs = setModelValid (isJust parsedVal)
|
reqs = setModelValid (isJust parsedVal)
|
||||||
|
|
||||||
handleKeyPress wenv mod code
|
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 && 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
|
| isMoveLeft = Just $ moveCursor txt (tp - 1) Nothing
|
||||||
| isMoveRight = 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
|
| isMoveWordL = Just $ moveCursor txt prevWordStartIdx Nothing
|
||||||
| isMoveWordR = Just $ moveCursor txt nextWordEndIdx 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)
|
| isSelectLeft = Just $ moveCursor txt (tp - 1) (Just tp)
|
||||||
| isSelectRight = Just $ moveCursor txt (tp + 1) (Just tp)
|
| isSelectRight = Just $ moveCursor txt (tp + 1) (Just tp)
|
||||||
| isSelectWordL = Just $ moveCursor txt prevWordStartIdx (Just tp)
|
| isSelectWordL = Just $ moveCursor txt prevWordStartIdx (Just tp)
|
||||||
| isSelectWordR = Just $ moveCursor txt nextWordEndIdx (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
|
| otherwise = Nothing
|
||||||
where
|
where
|
||||||
txt = currText
|
txt = currText
|
||||||
@ -158,6 +165,8 @@ makeInputField config state = widget where
|
|||||||
(part1, part2) = T.splitAt currPos currText
|
(part1, part2) = T.splitAt currPos currText
|
||||||
currSelVal = fromMaybe 0 currSel
|
currSelVal = fromMaybe 0 currSel
|
||||||
activeSel = isJust currSel
|
activeSel = isJust currSel
|
||||||
|
minTpSel = min tp currSelVal
|
||||||
|
maxTpSel = max tp currSelVal
|
||||||
delim c = c == ' ' || c == '.' || c == ','
|
delim c = c == ' ' || c == '.' || c == ','
|
||||||
prevWordStart = T.dropWhileEnd (not . delim) $ T.dropWhileEnd delim part1
|
prevWordStart = T.dropWhileEnd (not . delim) $ T.dropWhileEnd delim part1
|
||||||
prevWordStartIdx = T.length prevWordStart
|
prevWordStartIdx = T.length prevWordStart
|
||||||
@ -167,24 +176,41 @@ makeInputField config state = widget where
|
|||||||
isWordMod
|
isWordMod
|
||||||
| isMacOS wenv = _kmLeftAlt mod
|
| isMacOS wenv = _kmLeftAlt mod
|
||||||
| otherwise = _kmLeftCtrl 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)
|
isBackspace = isKeyBackspace code && (tp > 0 || isJust currSel)
|
||||||
isMove = not isShift && not isWordMod
|
isDelBackWord = isBackspace && isWordMod
|
||||||
isMoveWord = not isShift && isWordMod
|
isMove = not isShift && not isWordMod && not isLineMod
|
||||||
isSelect = isShift && not isWordMod
|
isMoveWord = not isShift && isWordMod && not isLineMod
|
||||||
isSelectWord = isShift && isWordMod
|
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
|
isMoveLeft = isMove && not activeSel && isKeyLeft code
|
||||||
isMoveRight = isMove && not activeSel && isKeyRight code
|
isMoveRight = isMove && not activeSel && isKeyRight code
|
||||||
isDeselectLeft = isMove && activeSel && isKeyLeft code
|
|
||||||
isDeselectRight = isMove && activeSel && isKeyRight code
|
|
||||||
isMoveWordL = isMoveWord && isKeyLeft code
|
isMoveWordL = isMoveWord && isKeyLeft code
|
||||||
isMoveWordR = isMoveWord && isKeyRight code
|
isMoveWordR = isMoveWord && isKeyRight code
|
||||||
|
isMoveLineL = isMoveLine && isKeyLeft code
|
||||||
|
isMoveLineR = isMoveLine && isKeyRight code
|
||||||
|
isSelectAll = isAllMod && isKeyA code
|
||||||
isSelectLeft = isSelect && isKeyLeft code
|
isSelectLeft = isSelect && isKeyLeft code
|
||||||
isSelectRight = isSelect && isKeyRight code
|
isSelectRight = isSelect && isKeyRight code
|
||||||
isSelectWordL = isSelectWord && isKeyLeft code
|
isSelectWordL = isSelectWord && isKeyLeft code
|
||||||
isSelectWordR = isSelectWord && isKeyRight code
|
isSelectWordR = isSelectWord && isKeyRight code
|
||||||
|
isSelectLineL = isSelectLine && isKeyLeft code
|
||||||
|
isSelectLineR = isSelectLine && isKeyRight code
|
||||||
|
isDeselectLeft = isMove && activeSel && isKeyLeft code
|
||||||
|
isDeselectRight = isMove && activeSel && isKeyRight code
|
||||||
removeText
|
removeText
|
||||||
| isJust currSel = replaceText txt ""
|
| isJust currSel = replaceText txt ""
|
||||||
| otherwise = T.init part1 <> part2
|
| otherwise = T.init part1 <> part2
|
||||||
|
removeWord
|
||||||
|
| isJust currSel = replaceText txt ""
|
||||||
|
| otherwise = prevWordStart <> part2
|
||||||
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)
|
||||||
|
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.Core
|
||||||
import Monomer.Event
|
import Monomer.Event
|
||||||
import Monomer.TestUtil
|
import Monomer.TestUtil
|
||||||
|
import Monomer.TestKeyboardUtil
|
||||||
import Monomer.Widgets.TextField
|
import Monomer.Widgets.TextField
|
||||||
|
|
||||||
import qualified Monomer.Lens as L
|
import qualified Monomer.Lens as L
|
||||||
@ -31,7 +32,7 @@ newtype TestModel = TestModel {
|
|||||||
makeLensesWith abbreviatedFields ''TestModel
|
makeLensesWith abbreviatedFields ''TestModel
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = fdescribe "TextField" $ do
|
spec = describe "TextField" $ do
|
||||||
handleEvent
|
handleEvent
|
||||||
handleEventValue
|
handleEventValue
|
||||||
updateSizeReq
|
updateSizeReq
|
||||||
@ -64,7 +65,12 @@ handleEvent = describe "handleEvent" $ do
|
|||||||
let steps = [evtT str, evtT " invalid"]
|
let steps = [evtT str, evtT " invalid"]
|
||||||
model steps ^. textValue `shouldBe` "This string is"
|
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 str = "This is text"
|
||||||
let steps = [evtT str, Focus, evtT "No"]
|
let steps = [evtT str, Focus, evtT "No"]
|
||||||
model steps ^. textValue `shouldBe` "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
|
it "should input 'this is a dog', input '?', move to beginning and input 'Is '" $ do
|
||||||
let str = "this is a dog"
|
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?"
|
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
|
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
|
it "should input 'This is a dog', remove one word and input 'bird'" $ do
|
||||||
let str = "This is a dog"
|
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"
|
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
|
where
|
||||||
wenv = mockWenv (TestModel "")
|
wenv = mockWenv (TestModel "")
|
||||||
txtInst = textFieldV "" TextChanged
|
txtInst = textFieldV "" TextChanged
|
||||||
@ -110,56 +126,3 @@ updateSizeReq = describe "updateSizeReq" $ do
|
|||||||
where
|
where
|
||||||
wenv = mockWenvEvtUnit (TestModel "Test value")
|
wenv = mockWenvEvtUnit (TestModel "Test value")
|
||||||
(sizeReqW, sizeReqH) = instUpdateSizeReq wenv (textField textValue)
|
(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