diff --git a/TODO.txt b/TODO.txt index bb59ed6d..1ae33e4e 100644 --- a/TODO.txt +++ b/TODO.txt @@ -286,7 +286,7 @@ DONE-handlers should return preview action ::HIGH PRIORITY:: -BUG `invalid = error "toggling of LHS_XXX_InheritTrue elements disallowed"` -repro is make a chain of folders, select one in the middle and lock --BUG textarea handler crashes +DONE-BUG textarea handler crashes -line labels still cropping on right side -allow new lines in line labels :O -LHRESS_ChildSelected graphic broken during drag and just in general diff --git a/src/Potato/Flow/Controller/Manipulator/Box.hs b/src/Potato/Flow/Controller/Manipulator/Box.hs index 62b1e0d2..09b026e6 100644 --- a/src/Potato/Flow/Controller/Manipulator/Box.hs +++ b/src/Potato/Flow/Controller/Manipulator/Box.hs @@ -414,7 +414,11 @@ instance PotatoHandler BoxHandler where else if isTextArea && (wasNotActuallyDragging || isCreation) && wasNotDragSelecting - then textAreaHandler_pHandleMouse_onCreation (makeTextAreaHandler (SomePotatoHandler (def :: BoxHandler)) _potatoHandlerInput_canvasSelection rmd isCreation) phi rmd + then let + tah = makeTextAreaHandler (SomePotatoHandler (def :: BoxHandler)) _potatoHandlerInput_canvasSelection rmd isCreation in + if isCreation + then textAreaHandler_pHandleMouse_onCreation tah phi rmd + else pHandleMouse tah phi rmd -- This clears the handler and causes selection to regenerate a new handler. -- Why do we do it this way instead of returning a handler? Not sure, doesn't matter. diff --git a/src/Potato/Flow/Controller/Manipulator/TextArea.hs b/src/Potato/Flow/Controller/Manipulator/TextArea.hs index d775f29e..49ed2667 100644 --- a/src/Potato/Flow/Controller/Manipulator/TextArea.hs +++ b/src/Potato/Flow/Controller/Manipulator/TextArea.hs @@ -140,5 +140,4 @@ instance PotatoHandler TextAreaHandler where } r = pRenderHandler (_textAreaHandler_prevHandler tah) phi <> HandlerRenderOutput [cursor] - -- TODO track mouse activity - pIsHandlerActive _ = HAS_Inactive + pIsHandlerActive _ = HAS_Active_Waiting diff --git a/test/Potato/Flow/Controller/Manipulator/TestHelpers.hs b/test/Potato/Flow/Controller/Manipulator/TestHelpers.hs index 3eb852a7..71c8feef 100644 --- a/test/Potato/Flow/Controller/Manipulator/TestHelpers.hs +++ b/test/Potato/Flow/Controller/Manipulator/TestHelpers.hs @@ -57,3 +57,8 @@ composeObjectFetcherKeep f g pfs = case f pfs of Right o1 -> case g o1 of Left e -> Left e Right o2 -> Right (o1, o2) + + + +emptyOwlStateWithSize :: (Int, Int) -> OwlPFState +emptyOwlStateWithSize (x, y) = OwlPFState emptyOwlTree (SCanvas (LBox 0 (V2 x y))) diff --git a/test/Potato/Flow/Controller/Manipulator/TextAreaSpec.hs b/test/Potato/Flow/Controller/Manipulator/TextAreaSpec.hs new file mode 100644 index 00000000..0aa78eaa --- /dev/null +++ b/test/Potato/Flow/Controller/Manipulator/TextAreaSpec.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} + +module Potato.Flow.Controller.Manipulator.TextAreaSpec ( + spec +) where + +import Relude hiding (empty, + fromList) + +import Test.Hspec + +import Potato.Flow +import Potato.Flow.GoatTester +import Potato.Flow.Controller.Manipulator.TestHelpers + + +import qualified Data.Sequence as Seq + + + + + +basic_test :: Spec +basic_test = hSpecGoatTesterWithOwlPFState (emptyOwlStateWithSize (100,100)) $ do + + setMarker "create a TextArea" + setTool Tool_TextArea + canvasMouseDown (0, 0) + canvasMouseDownUp (50, 50) + verifyOwlCount 1 + + setMarker "add some text" + pressKeys "poop" + verifyRenderNonEmptyCount 4 + verifyCharRenderedAt (V2 0 0) (Just 'p') + + + setMarker "deselect then reselect" + verifyCanvasHandler handlerName_textArea + pressEscape + verifyCanvasHandler handlerName_box + pressEscape + canvasMouseDownUp (25, 25) + + setMarker "move cursor" + canvasMouseDownUp (0, 1) + pressKeys "meow" + verifyRenderNonEmptyCount 8 + verifyCharRenderedAt (V2 3 1) (Just 'w') + + + + +spec :: Spec +spec = do + describe "TextArea" $ do + describe "basic_test" $ basic_test + diff --git a/test/Potato/Flow/Deprecated/Controller/Manipulator/TextAreaSpec.hs b/test/Potato/Flow/Deprecated/Controller/Manipulator/TextAreaSpec.hs index 8f87dfa4..7e499cea 100644 --- a/test/Potato/Flow/Deprecated/Controller/Manipulator/TextAreaSpec.hs +++ b/test/Potato/Flow/Deprecated/Controller/Manipulator/TextAreaSpec.hs @@ -25,6 +25,7 @@ checkSTextAreaTextAt label k c = firstSuperOwlPredicate (Just label) $ \sowl -> SEltTextArea (STextArea _ tm _) -> Map.lookup k tm == Just c _ -> False +-- TODO DELTEE This isn't even testingh TextArea test_basic :: Test test_basic = constructTest "basic" emptyOwlPFState bs expected where bs = [ diff --git a/test/Potato/Flow/GoatTester.hs b/test/Potato/Flow/GoatTester.hs index 5107acf1..e03de7ed 100644 --- a/test/Potato/Flow/GoatTester.hs +++ b/test/Potato/Flow/GoatTester.hs @@ -360,6 +360,15 @@ verifyMostRecentlyCreatedLine f = verifyMostRecentlyCreatedOwl' "verifyMostRecen OwlSubItemLine sline -> f sline x -> Just $ "expected SAutoLine got: " <> show x + +verifyCanvasHandler :: (Monad m) => Text -> GoatTesterT m () +verifyCanvasHandler hname = verifyState "verifyCanvasHandler" f where + f gs = r where + h = _goatState_handler gs + r = if hname == pHandlerName h + then Nothing + else Just $ "expected " <> hname <> "got handler " <> pHandlerName h + verifySelectionIsAndOnlyIs :: (Monad m) => Text -> (SuperOwl -> Maybe Text) -> GoatTesterT m () verifySelectionIsAndOnlyIs desc f = verifyState desc f' where f' gs = r where @@ -370,8 +379,6 @@ verifySelectionIsAndOnlyIs desc f = verifyState desc f' where then Just $ "failed, expected 1 selected 🦉, got " <> show nselection else (\m -> "failed with message: " <> m <> "\ngot:\n" <> potatoShow (_superOwl_elt sowl)) <$> f sowl - - verifyRenderNonEmptyCount :: (Monad m) => Int -> GoatTesterT m () verifyRenderNonEmptyCount expected = verifyState "verifyRenderNonEmptyCount" f where f gs = if n == expected diff --git a/test/Potato/Flow/RenderSpec.hs b/test/Potato/Flow/RenderSpec.hs index 2a3b7392..a4d80e03 100644 --- a/test/Potato/Flow/RenderSpec.hs +++ b/test/Potato/Flow/RenderSpec.hs @@ -170,10 +170,6 @@ spec1 = do -- TODO test something canvas1 `shouldBe` canvas1 - -emptyOwlStateWithSize :: (Int, Int) -> OwlPFState -emptyOwlStateWithSize (x, y) = OwlPFState emptyOwlTree (SCanvas (LBox 0 (V2 x y))) - render_basic :: Spec render_basic = hSpecGoatTesterWithOwlPFState (emptyOwlStateWithSize (20,20)) $ do