Add tests for floatingField

src/Monomer/Widgets/FloatingField.hs

@@ -20,7 +20,7 @@ import Data.Default
 import Data.Either
 import Data.Maybe
 import Data.Text (Text)
-import Data.Text.Read (rational)
+import Data.Text.Read (signed, rational)
 import Data.Typeable (Typeable)
 
 import qualified Data.Attoparsec.Text as A
@@ -159,7 +159,7 @@ floatingFieldD_ widgetData configs = newInst where
   newInst = inputField_ "floatingField" inputConfig
 
 floatFromText :: FormattableFloat a => Maybe a -> Maybe a -> Text -> Maybe a
-floatFromText minVal maxVal t = case rational t of
+floatFromText minVal maxVal t = case signed rational t of
   Right (val, _)
     | numberInBounds minVal maxVal val -> Just val
   _ -> Nothing
@@ -169,10 +169,11 @@ floatToText decimals val = F.sformat (F.fixed decimals) val
 
 acceptFloatInput :: Int -> Text -> Bool
 acceptFloatInput decimals text = isRight (A.parseOnly parser text) where
+  sign = A.option "" (single '-')
   number = A.takeWhile isDigit
   digit = T.singleton <$> A.digit
   rest = join [single '.', upto decimals digit]
-  parser = join [number, A.option "" rest] <* A.endOfInput
+  parser = join [sign, number, A.option "" rest] <* A.endOfInput
 
 -- Parsing helpers
 join :: [A.Parser Text] -> A.Parser Text

src/Monomer/Widgets/InputField.hs

@@ -308,7 +308,7 @@ makeInputField config state = widget where
     newVal = fromText newText
     stateVal = fromMaybe currVal newVal
     onChangeEvts
-      | stateVal /= currVal = fmap ($ stateVal) (_ifcOnChange config)
+      | isValid && stateVal /= currVal = fmap ($ stateVal) (_ifcOnChange config)
       | otherwise = []
     events = onChangeEvts
     reqValid

src/Monomer/Widgets/IntegralField.hs

@@ -156,8 +156,9 @@ integralToText val = F.sformat F.int val
 
 acceptIntegralInput :: Text -> Bool
 acceptIntegralInput text = isRight (A.parseOnly parser text) where
+  sign = A.option "" (single '-')
   number = A.takeWhile isDigit
-  parser = join [A.option "" (single '-'), number] <* A.endOfInput
+  parser = join [sign, number] <* A.endOfInput
 
 join :: [A.Parser Text] -> A.Parser Text
 join [] = return T.empty

test/unit/Monomer/Widgets/FloatingFieldSpec.hs

@@ -0,0 +1,144 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Monomer.Widgets.FloatingFieldSpec (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.TestKeyboardUtil
+import Monomer.Widgets.FloatingField
+
+import qualified Monomer.Lens as L
+
+newtype TestEvt
+  = NumberChanged Double
+  deriving (Eq, Show)
+
+data TestModel = TestModel {
+  _tmFloatingValue :: Double,
+  _tmFloatingValid :: Bool
+} deriving (Eq, Show)
+
+makeLensesWith abbreviatedFields ''TestModel
+
+spec :: Spec
+spec = describe "FloatingField" $ do
+  handleEvent
+  handleEventValue
+  updateSizeReq
+
+handleEvent :: Spec
+handleEvent = describe "handleEvent" $ do
+  it "should input '123' without select on focus" $ do
+    modelBasic [evtT "1", evtT "2", evtT "3"] ^. floatingValue `shouldBe` 1230
+    modelBasic [evtT "1", evtT "2", evtT "3"] ^. floatingValid `shouldBe` True
+
+  it "should input '1.23'" $ do
+    model [evtT "1.23"] ^. floatingValue `shouldBe` 1.23
+    model [evtT "1.23"] ^. floatingValid `shouldBe` True
+
+  it "should input '-1'" $ do
+    model [evtT "-1"] ^. floatingValue `shouldBe` -1
+    model [evtT "-1"] ^. floatingValid `shouldBe` True
+
+  it "should input '1501'" $ do
+    model [evtT "1", evtT "5", evtT "0", evtT "1"] ^. floatingValue `shouldBe` 1501
+    model [evtT "1", evtT "5", evtT "0", evtT "1"] ^. floatingValid `shouldBe` True
+
+  it "should input '1502', but fail because of maxValue" $ do
+    model [evtT "1", evtT "5", evtT "0", evtT "2"] ^. floatingValue `shouldBe` 150
+    model [evtT "1", evtT "5", evtT "0", evtT "2"] ^. floatingValid `shouldBe` False
+
+  it "should input '123', remove one character and input '4'" $ do
+    model [evtT "123", delCharL, evtT "4"] ^. floatingValue `shouldBe` 124
+    model [evtT "123", delCharL, evtT "4"] ^. floatingValid `shouldBe` True
+
+  it "should input '123', remove one word and input '456'" $ do
+    model [evtT "123", delWordL, evtT "456"] ^. floatingValue `shouldBe` 456
+    model [evtT "123", delWordL, evtT "456"] ^. floatingValid `shouldBe` True
+
+  it "should input '123.34', remove one word and input '56'" $ do
+    model [evtT "123.34", delWordL, evtT "56"] ^. floatingValue `shouldBe` 123.56
+    model [evtT "123.34", delWordL, evtT "56"] ^. floatingValid `shouldBe` True
+
+  it "should input '123.34', remove two words and input '56'" $ do
+    model [evtT "123.34", delWordL, delWordL, evtT "56"] ^. floatingValue `shouldBe` 56
+    model [evtT "123.34", delWordL, delWordL, evtT "56"] ^. floatingValid `shouldBe` True
+
+  where
+    wenv = mockWenvEvtUnit (TestModel 0 True)
+    basicFloatingInst = floatingField floatingValue
+    floatInst = floatingField_ floatingValue [maxValue 1501, selectOnFocus True, validInput floatingValid]
+    model es = instHandleEventModel wenv (Focus : es) floatInst
+    modelBasic es = instHandleEventModel wenv es basicFloatingInst
+
+handleEventValue :: Spec
+handleEventValue = describe "handleEvent" $ do
+  it "should input an '100'" $
+    evts [evtT "1", evtT "0", evtT "0"] `shouldBe` Seq.fromList [NumberChanged 10, NumberChanged 100]
+
+  it "should input a '1' and be considered invalid" $ do
+    evts [evtT "1"] `shouldBe` Seq.fromList []
+    model [evtT "1"] ^. floatingValid `shouldBe` False
+
+  it "should input '1', move to beginning and input '5'" $ do
+    let steps = [evtT "1", moveLineL, evtT "5"]
+    lastEvt steps `shouldBe` NumberChanged 51
+
+  it "should input '1', input '.' then input '5'" $ do
+    let steps = [evtT "10", evtT ".", evtT "5"]
+    lastEvt steps `shouldBe` NumberChanged 10.5
+    model steps ^. floatingValid `shouldBe` True
+
+  it "should input '20', input '.' twice then input '777'" $ do
+    let steps = [evtT "20", evtT ".", evtT ".", evtT "7", evtT "7", evtT "7"]
+    lastEvt steps `shouldBe` NumberChanged 20.77
+    model steps ^. floatingValid `shouldBe` True
+
+  it "should input '10', '.' then input '2345'" $ do
+    let steps = [evtT "10", evtT ".", evtT "2", evtT "3", evtT "4", evtT "5"]
+    lastEvtDecimals steps `shouldBe` NumberChanged 10.234
+
+  it "should input '3', input 'a' then input '6'" $ do
+    let steps = [evtT "3", evtT "a", evtT "6"]
+    lastEvt steps `shouldBe` NumberChanged 36
+    model steps ^. floatingValid `shouldBe` True
+
+  it "should input '1234', delete line then input '777'" $ do
+    let steps = [evtT "1234", selLineL, evtT "777"]
+    lastEvt steps `shouldBe` NumberChanged 777
+    model steps ^. floatingValid `shouldBe` True
+
+  where
+    wenv = mockWenv (TestModel 0 False)
+    floatInst = floatingFieldV_ 0 NumberChanged [minValue 10, maxValue 2345, selectOnFocus True, validInput floatingValid]
+    floatDecimalsInst = floatingFieldV_ 0 NumberChanged [selectOnFocus True, decimals 3]
+    evts es = instHandleEventEvts wenv (Focus : es) floatInst
+    evtsAlt es = instHandleEventEvts wenv (Focus : es) floatDecimalsInst
+    model es = instHandleEventModel wenv (Focus : es) floatInst
+    lastIdx es = Seq.index es (Seq.length es - 1)
+    lastEvt es = lastIdx (evts es)
+    lastEvtDecimals es = lastIdx (evtsAlt es)
+
+updateSizeReq :: Spec
+updateSizeReq = describe "updateSizeReq" $ do
+  it "should return width = Flex 70 1" $
+    sizeReqW `shouldBe` FlexSize 70 1
+
+  it "should return height = Fixed 20" $
+    sizeReqH `shouldBe` FixedSize 20
+
+  where
+    wenv = mockWenvEvtUnit (TestModel 1000 True)
+    (sizeReqW, sizeReqH) = instUpdateSizeReq wenv (floatingField floatingValue)

test/unit/Monomer/Widgets/IntegralFieldSpec.hs

@@ -33,7 +33,7 @@ data TestModel = TestModel {
 makeLensesWith abbreviatedFields ''TestModel
 
 spec :: Spec
-spec = fdescribe "IntegralField" $ do
+spec = describe "IntegralField" $ do
   handleEvent
   handleEventValue
   updateSizeReq

test/unit/Spec.hs

@@ -7,6 +7,7 @@ import qualified Monomer.Widgets.BoxSpec as BoxSpec
 import qualified Monomer.Widgets.ButtonSpec as ButtonSpec
 import qualified Monomer.Widgets.CheckboxSpec as CheckboxSpec
 import qualified Monomer.Widgets.ConfirmSpec as ConfirmSpec
+import qualified Monomer.Widgets.FloatingFieldSpec as FloatingFieldSpec
 import qualified Monomer.Widgets.GridSpec as GridSpec
 import qualified Monomer.Widgets.LabelSpec as LabelSpec
 import qualified Monomer.Widgets.IntegralFieldSpec as IntegralFieldSpec
@@ -24,6 +25,7 @@ spec = do
   ButtonSpec.spec
   CheckboxSpec.spec
   ConfirmSpec.spec
+  FloatingFieldSpec.spec
   GridSpec.spec
   LabelSpec.spec
   IntegralFieldSpec.spec