mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-08-16 23:40:54 +03:00
Add textField unit tests (missing two, which require changes in textField)
This commit is contained in:
parent
ff49bd6ef3
commit
8b4bfea6f5
@ -15,7 +15,7 @@ class WindowSize t s | t -> s where
|
||||
windowSize :: s -> t
|
||||
|
||||
-- Input
|
||||
class ValidInput t s where
|
||||
class ValidInput t s | t -> s where
|
||||
validInput :: ALens' s Bool -> t
|
||||
|
||||
class SelectOnFocus t where
|
||||
|
@ -141,6 +141,8 @@ makeInputField config state = widget where
|
||||
| isBackspace = Just $ moveCursor removeText (min currSelVal tp) 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
|
||||
| isSelectLeft = Just $ moveCursor txt (tp - 1) (Just tp)
|
||||
@ -154,6 +156,9 @@ makeInputField config state = widget where
|
||||
tp = currPos
|
||||
emptySel = isNothing currSel
|
||||
(part1, part2) = T.splitAt currPos currText
|
||||
currSelVal = fromMaybe 0 currSel
|
||||
activeSel = isJust currSel
|
||||
delim c = c == ' ' || c == '.' || c == ','
|
||||
prevWordStart = T.dropWhileEnd (not . delim) $ T.dropWhileEnd delim part1
|
||||
prevWordStartIdx = T.length prevWordStart
|
||||
nextWordEnd = T.dropWhile (not . delim) $ T.dropWhile delim part2
|
||||
@ -167,16 +172,16 @@ makeInputField config state = widget where
|
||||
isMoveWord = not isShift && isWordMod
|
||||
isSelect = isShift && not isWordMod
|
||||
isSelectWord = isShift && isWordMod
|
||||
isMoveLeft = isMove && isKeyLeft code
|
||||
isMoveRight = isMove && isKeyRight code
|
||||
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
|
||||
isSelectLeft = isSelect && isKeyLeft code
|
||||
isSelectRight = isSelect && isKeyRight code
|
||||
isSelectWordL = isSelectWord && isKeyLeft code
|
||||
isSelectWordR = isSelectWord && isKeyRight code
|
||||
delim c = c == ' ' || c == '.' || c == ','
|
||||
currSelVal = fromMaybe 0 currSel
|
||||
removeText
|
||||
| isJust currSel = replaceText txt ""
|
||||
| otherwise = T.init part1 <> part2
|
||||
|
4
tasks.md
4
tasks.md
@ -258,6 +258,7 @@
|
||||
- Right aligned version has cusor overlaid (add caret size to offset in specific cases)
|
||||
- Check clipboard
|
||||
- Check Container thing in hover adding columns (not targetValid = Nothing should be removed)
|
||||
- Add missing keyboard functions in Event
|
||||
|
||||
- Pending
|
||||
- Add testing
|
||||
@ -276,7 +277,6 @@
|
||||
|
||||
Maybe postponed after release?
|
||||
- Check label with flexHeight
|
||||
- Add missing keyboard functions in Event
|
||||
- Make WidgetState Generic (check if it's worth it)
|
||||
- Add Bold/Italic support (instead of different Font for each case)
|
||||
- Check 1px difference on right side of labels/buttons (probably already fixed)
|
||||
@ -287,7 +287,7 @@ Maybe postponed after release?
|
||||
- Create numeric wrapper that allows increasing/decreasing with mouse
|
||||
- Handle window title, maximize, etc
|
||||
- Also handle as requests?
|
||||
- Provide a way of exiting application
|
||||
- Provide a way of exiting application/close window handler
|
||||
- TextOverflow in TextStyle?
|
||||
- Handle onBlur/onFocus in all focusable widgets
|
||||
- Avoid findNextFocus on unfocusable children (listView items)
|
||||
|
@ -142,37 +142,29 @@ instResize wenv viewport inst = newInst where
|
||||
instHandleEventModel
|
||||
:: (Eq s)
|
||||
=> WidgetEnv s e
|
||||
-> SystemEvent
|
||||
-> [SystemEvent]
|
||||
-> WidgetInstance s e
|
||||
-> s
|
||||
instHandleEventModel wenv evt inst = _weModel wenv2 where
|
||||
(wenv2, _, _) = instHandleEvent wenv evt inst
|
||||
instHandleEventModel wenv evts inst = _weModel wenv2 where
|
||||
(wenv2, _, _) = instHandleEvents wenv evts inst
|
||||
|
||||
instHandleEventEvts
|
||||
:: (Eq s)
|
||||
=> WidgetEnv s e
|
||||
-> SystemEvent
|
||||
-> [SystemEvent]
|
||||
-> WidgetInstance s e
|
||||
-> Seq e
|
||||
instHandleEventEvts wenv evt inst = events where
|
||||
(_, events, _) = instHandleEvent wenv evt inst
|
||||
instHandleEventEvts wenv evts inst = events where
|
||||
(_, events, _) = instHandleEvents wenv evts inst
|
||||
|
||||
instHandleEventRoot
|
||||
:: (Eq s)
|
||||
=> WidgetEnv s e
|
||||
-> SystemEvent
|
||||
-> [SystemEvent]
|
||||
-> WidgetInstance s e
|
||||
-> WidgetInstance s e
|
||||
instHandleEventRoot wenv evt inst = newRoot where
|
||||
(_, _, newRoot) = instHandleEvent wenv evt inst
|
||||
|
||||
instHandleEvent
|
||||
:: (Eq s)
|
||||
=> WidgetEnv s e
|
||||
-> SystemEvent
|
||||
-> WidgetInstance s e
|
||||
-> HandlerStep s e
|
||||
instHandleEvent wenv evt inst = instHandleEvents wenv [evt] inst
|
||||
instHandleEventRoot wenv evts inst = newRoot where
|
||||
(_, _, newRoot) = instHandleEvents wenv evts inst
|
||||
|
||||
instHandleEvents
|
||||
:: (Eq s)
|
||||
|
@ -35,4 +35,4 @@ handleEvent = describe "handleEvent" $ do
|
||||
where
|
||||
wenv = mockWenv () & L.theme .~ darkTheme
|
||||
alertInst = instInit wenv (alert "Alert!" CloseClick)
|
||||
events p = instHandleEventEvts wenv (Click p LeftBtn) alertInst
|
||||
events p = instHandleEventEvts wenv [Click p LeftBtn] alertInst
|
||||
|
@ -34,7 +34,7 @@ handleEvent = describe "handleEvent" $ do
|
||||
wenv = mockWenv ()
|
||||
btn = button "Click" BtnClick
|
||||
boxInst = instInit wenv (box btn)
|
||||
events p = instHandleEventEvts wenv (Click p LeftBtn) boxInst
|
||||
events p = instHandleEventEvts wenv [Click p LeftBtn] boxInst
|
||||
|
||||
updateSizeReq :: Spec
|
||||
updateSizeReq = describe "updateSizeReq" $ do
|
||||
|
@ -34,8 +34,8 @@ handleEvent = describe "handleEvent" $ do
|
||||
where
|
||||
wenv = mockWenv ()
|
||||
btn = instInit wenv (button "Click" BtnClick)
|
||||
clickEvts p = instHandleEventEvts wenv (Click p LeftBtn) btn
|
||||
keyEvts key = instHandleEventEvts wenv (KeyAction def key KeyPressed) btn
|
||||
clickEvts p = instHandleEventEvts wenv [Click p LeftBtn] btn
|
||||
keyEvts key = instHandleEventEvts wenv [KeyAction def key KeyPressed] btn
|
||||
|
||||
updateSizeReq :: Spec
|
||||
updateSizeReq = describe "updateSizeReq" $ do
|
||||
|
@ -49,8 +49,8 @@ handleEvent = describe "handleEvent" $ do
|
||||
where
|
||||
wenv = mockWenvEvtUnit (TestModel False)
|
||||
chkInst = checkbox testBool
|
||||
clickModel p = instHandleEventModel wenv (Click p LeftBtn) chkInst
|
||||
keyModel key = instHandleEventModel wenv (KeyAction def key KeyPressed) chkInst
|
||||
clickModel p = instHandleEventModel wenv [Click p LeftBtn] chkInst
|
||||
keyModel key = instHandleEventModel wenv [KeyAction def key KeyPressed] chkInst
|
||||
|
||||
handleEventValue :: Spec
|
||||
handleEventValue = describe "handleEventValue" $ do
|
||||
@ -69,8 +69,8 @@ handleEventValue = describe "handleEventValue" $ do
|
||||
wenv = mockWenv (TestModel False)
|
||||
chkInst = checkboxV False BoolSel
|
||||
chkInstT = checkboxV True BoolSel
|
||||
clickModel p inst = instHandleEventEvts wenv (Click p LeftBtn) inst
|
||||
keyModel key inst = instHandleEventEvts wenv (KeyAction def key KeyPressed) inst
|
||||
clickModel p inst = instHandleEventEvts wenv [Click p LeftBtn] inst
|
||||
keyModel key inst = instHandleEventEvts wenv [KeyAction def key KeyPressed] inst
|
||||
|
||||
updateSizeReq :: Spec
|
||||
updateSizeReq = describe "updateSizeReq" $ do
|
||||
|
@ -39,4 +39,4 @@ handleEvent = describe "handleEvent" $ do
|
||||
where
|
||||
wenv = mockWenv () & L.theme .~ darkTheme
|
||||
confirmInst = instInit wenv (confirm "Confirm!" AcceptClick CancelClick)
|
||||
events p = instHandleEventEvts wenv (Click p LeftBtn) confirmInst
|
||||
events p = instHandleEventEvts wenv [Click p LeftBtn] confirmInst
|
||||
|
@ -56,8 +56,8 @@ handleEvent = describe "handleEvent" $ do
|
||||
wenv = mockWenvEvtUnit (TestModel Apple)
|
||||
orangeInst = radio fruit Orange
|
||||
bananaInst = radio fruit Banana
|
||||
clickModel p inst = instHandleEventModel wenv (Click p LeftBtn) inst
|
||||
keyModel key inst = instHandleEventModel wenv (KeyAction def key KeyPressed) inst
|
||||
clickModel p inst = instHandleEventModel wenv [Click p LeftBtn] inst
|
||||
keyModel key inst = instHandleEventModel wenv [KeyAction def key KeyPressed] inst
|
||||
|
||||
handleEventValue :: Spec
|
||||
handleEventValue = describe "handleEventValue" $ do
|
||||
@ -73,8 +73,8 @@ handleEventValue = describe "handleEventValue" $ do
|
||||
wenv = mockWenv (TestModel Apple)
|
||||
orangeInst = radioV Apple FruitSel Orange
|
||||
bananaInst = radioV Apple FruitSel Banana
|
||||
clickModel p inst = instHandleEventEvts wenv (Click p LeftBtn) inst
|
||||
keyModel key inst = instHandleEventEvts wenv (KeyAction def key KeyPressed) inst
|
||||
clickModel p inst = instHandleEventEvts wenv [Click p LeftBtn] inst
|
||||
keyModel key inst = instHandleEventEvts wenv [KeyAction def key KeyPressed] inst
|
||||
|
||||
updateSizeReq :: Spec
|
||||
updateSizeReq = describe "updateSizeReq" $ do
|
||||
|
165
test/unit/Monomer/Widgets/TextFieldSpec.hs
Normal file
165
test/unit/Monomer/Widgets/TextFieldSpec.hs
Normal file
@ -0,0 +1,165 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Monomer.Widgets.TextFieldSpec (spec) where
|
||||
|
||||
import Control.Lens ((&), (^.), (.~))
|
||||
import Control.Lens.TH (abbreviatedFields, makeLensesWith)
|
||||
import Data.Default
|
||||
import Data.Text (Text)
|
||||
import Test.Hspec
|
||||
|
||||
import qualified Data.Sequence as Seq
|
||||
|
||||
import Monomer.Core
|
||||
import Monomer.Event
|
||||
import Monomer.TestUtil
|
||||
import Monomer.Widgets.TextField
|
||||
|
||||
import qualified Monomer.Lens as L
|
||||
|
||||
newtype TestEvt
|
||||
= TextChanged Text
|
||||
deriving (Eq, Show)
|
||||
|
||||
newtype TestModel = TestModel {
|
||||
_tmTextValue :: Text
|
||||
} deriving (Eq, Show)
|
||||
|
||||
makeLensesWith abbreviatedFields ''TestModel
|
||||
|
||||
spec :: Spec
|
||||
spec = fdescribe "TextField" $ do
|
||||
handleEvent
|
||||
handleEventValue
|
||||
updateSizeReq
|
||||
|
||||
handleEvent :: Spec
|
||||
handleEvent = describe "handleEvent" $ do
|
||||
it "should input an 'a'" $
|
||||
model [evtT "a"] ^. textValue `shouldBe` "a"
|
||||
|
||||
it "should input 'ababa', remove the middle 'a' and input 'c'" $ do
|
||||
let steps = [evtT "ababa", moveCharL, moveCharL, evtK keyBackspace, evtT "c"]
|
||||
model steps ^. textValue `shouldBe` "abcba"
|
||||
|
||||
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"
|
||||
|
||||
it "should input 'This is a dog', move to beginning, select first word and input 'that'" $ do
|
||||
let str = "This is a dog"
|
||||
let steps = [evtT str, moveWordL, moveWordL, moveWordL, moveWordL, selWordR, evtT "that"]
|
||||
model steps ^. textValue `shouldBe` "that is a dog"
|
||||
|
||||
it "should input 'This is a dog', select one word, deselect and input 'big '" $ do
|
||||
let str = "This is a dog"
|
||||
let steps = [evtT str, selWordL, moveCharL, evtT "big "]
|
||||
model steps ^. textValue `shouldBe` "This is a big dog"
|
||||
|
||||
it "should input 'This string is', and reject ' invalid' since maxLength == 20" $ do
|
||||
let str = "This string is"
|
||||
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
|
||||
let str = "This is text"
|
||||
let steps = [evtT str, Focus, evtT "No"]
|
||||
model steps ^. textValue `shouldBe` "No"
|
||||
where
|
||||
wenv = mockWenvEvtUnit (TestModel "")
|
||||
txtInst = textField_ textValue [maxLength 20, selectOnFocus True]
|
||||
model es = instHandleEventModel wenv es txtInst
|
||||
|
||||
handleEventValue :: Spec
|
||||
handleEventValue = describe "handleEvent" $ do
|
||||
it "should input an 'ab'" $
|
||||
evts [evtT "a", evtT "b"] `shouldBe` Seq.fromList [TextChanged "a", TextChanged "ab"]
|
||||
|
||||
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 "]
|
||||
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
|
||||
let str = "This is a dog"
|
||||
let steps = [evtT str, moveWordL, moveWordL, moveWordL, selWordR, moveCharR, evtT "n't"]
|
||||
lastEvt steps `shouldBe` TextChanged "This isn't a dog"
|
||||
|
||||
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"]
|
||||
lastEvt steps `shouldBe` TextChanged "This is a cat"
|
||||
where
|
||||
wenv = mockWenv (TestModel "")
|
||||
txtInst = textFieldV "" TextChanged
|
||||
evts es = instHandleEventEvts wenv es txtInst
|
||||
lastIdx es = Seq.index es (Seq.length es - 1)
|
||||
lastEvt es = lastIdx (evts es)
|
||||
|
||||
updateSizeReq :: Spec
|
||||
updateSizeReq = describe "updateSizeReq" $ do
|
||||
it "should return width = Flex 100 1" $
|
||||
sizeReqW `shouldBe` FlexSize 100 1
|
||||
|
||||
it "should return height = Fixed 20" $
|
||||
sizeReqH `shouldBe` FixedSize 20
|
||||
|
||||
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
|
@ -11,6 +11,7 @@ import qualified Monomer.Widgets.GridSpec as GridSpec
|
||||
import qualified Monomer.Widgets.LabelSpec as LabelSpec
|
||||
import qualified Monomer.Widgets.RadioSpec as RadioSpec
|
||||
import qualified Monomer.Widgets.StackSpec as StackSpec
|
||||
import qualified Monomer.Widgets.TextFieldSpec as TextFieldSpec
|
||||
|
||||
main :: IO ()
|
||||
main = hspec spec
|
||||
@ -26,3 +27,4 @@ spec = do
|
||||
LabelSpec.spec
|
||||
RadioSpec.spec
|
||||
StackSpec.spec
|
||||
TextFieldSpec.spec
|
||||
|
Loading…
Reference in New Issue
Block a user