Merge pull request #98 from quickstrom/action-seq-reselect-fix

Action seq reselect fix

cli/src/Quickstrom/CLI/Reporter/HTML.hs

@@ -65,7 +65,7 @@ data Test = Test {transitions :: Transitions}
   deriving (Eq, Show, Generic, JSON.ToJSON)
 
 data Transition screenshot = Transition
-  { actionSequence :: Maybe (Quickstrom.ActionSequence ActionSubject),
+  { actionSequence :: Maybe (NonEmpty (Quickstrom.Action ActionSubject)),
     states :: States screenshot,
     stutter :: Bool
   }
@@ -198,7 +198,8 @@ traceToTransitions (Quickstrom.Trace es) = go (Vector.fromList es) mempty
     actionTransition :: Vector (Quickstrom.TraceElement Quickstrom.TraceElementEffect) -> Maybe (Transition ByteString, Vector (Quickstrom.TraceElement Quickstrom.TraceElementEffect))
     actionTransition t = flip evalStateT t $ do
       (_, s1) <- pop (_Ctor @"TraceState")
-      a <- pop (_Ctor @"TraceAction" . _2 . Control.Lens.to (traverse %~ toActionSubject))
+      actionSeq <- pop (_Ctor @"TraceAction" . _2)
+      let a = map (map toActionSubject) (Quickstrom.actionSequenceToNonEmpty actionSeq)
       (ann2, s2) <- pop (_Ctor @"TraceState")
       let diffs = elementStateDiffs s1 s2
       pure (Transition (Just a) (States (toState diffs s1) (toState diffs s2)) (ann2 == Quickstrom.Stutter), Vector.drop 2 t)

cli/test/Quickstrom/CLI/Reporter/HTMLTest.hs

@@ -58,11 +58,11 @@ toTrace ts =
 
 toTransition :: Transition ByteString -> [Quickstrom.TraceElement Quickstrom.TraceElementEffect]
 toTransition (Transition action' (States _ to') _) =
-  maybe [] (pure . toActionElement) action'
+  maybe [] (\(a :| as) -> pure (toActionElement (Quickstrom.ActionSequence a as))) action'
     <> [toStateElement to']
 
-toActionElement :: Quickstrom.ActionSequence ActionSubject -> Quickstrom.TraceElement Quickstrom.TraceElementEffect
-toActionElement a = Quickstrom.TraceAction Quickstrom.NoStutter (map toActionSubject a) Quickstrom.ActionSuccess
+toActionElement :: Quickstrom.ActionSequence ActionSubject ActionSubject -> Quickstrom.TraceElement Quickstrom.TraceElementEffect
+toActionElement a = Quickstrom.TraceAction Quickstrom.NoStutter (bimap toActionSubject toActionSubject a) Quickstrom.ActionSuccess
 
 toActionSubject :: ActionSubject -> Quickstrom.ActionSubject
 toActionSubject as =
@@ -123,7 +123,7 @@ genTransitions = do
 genTransitionFrom :: State ByteString -> Gen (Transition ByteString)
 genTransitionFrom from' =
   Transition
-    <$> Gen.oneof [Just <$> genActionSequence, pure Nothing]
+    <$> Gen.oneof [Just . Quickstrom.actionSequenceToNonEmpty <$> genActionSequence, pure Nothing]
     <*> (States from' <$> genState)
     <*> pure False
 
@@ -142,8 +142,8 @@ genPosition = Quickstrom.Position <$> genNat <*> genNat <*> genNat <*> genNat
 genNat :: Gen Int
 genNat = getPositive <$> arbitrary
 
-genActionSequence :: Gen (Quickstrom.ActionSequence ActionSubject)
-genActionSequence = pure (Quickstrom.ActionSequence (pure (Quickstrom.KeyPress 'a')))
+genActionSequence :: Gen (Quickstrom.ActionSequence ActionSubject ActionSubject)
+genActionSequence = pure (Quickstrom.ActionSequence (Quickstrom.KeyPress 'a') [])
 
 identifier :: [Char] -> Gen Text
 identifier prefix = Text.pack . (prefix <>) . show <$> arbitrary @Word
@@ -182,7 +182,7 @@ instance ToExpr Quickstrom.ElementState
 
 instance ToExpr ElementStateValue
 
-instance ToExpr s => ToExpr (Quickstrom.ActionSequence s)
+instance (ToExpr s1, ToExpr s2) => ToExpr (Quickstrom.ActionSequence s1 s2)
 
 instance ToExpr s => ToExpr (Quickstrom.Action s)
 

docs/default.nix

@@ -1,7 +1,7 @@
 { pkgs ? import ../nixpkgs.nix { } }:
 let
   src = pkgs.nix-gitignore.gitignoreSource [ ] ./.;
-  sphinx-env = pkgs.python37.withPackages (ps: [ ps.sphinx ps.sphinx_rtd_theme ]);
+  sphinx-env = pkgs.python3.withPackages (ps: [ ps.sphinx ps.sphinx_rtd_theme ]);
   dependencies = [ sphinx-env pkgs.texlive.combined.scheme-basic pkgs.graphviz ];
   site = pkgs.stdenv.mkDerivation {
     inherit src;

integration-tests/default.nix

@@ -85,6 +85,13 @@ in makeTests {
     browser = browsers.firefox;
     expectedExitCode = 0;
   };
+  ActionSequence = {
+    spec = ./passing/ActionSequence.spec.purs;
+    origin = "$src/passing/ActionSequence.html";
+    options = "--max-actions=10";
+    browser = browsers.firefox;
+    expectedExitCode = 0;
+  };
   MultiPage = {
     spec = ./passing/MultiPage.spec.purs;
     origin = "$src/passing/MultiPage.html";

integration-tests/passing/ActionSequence.html

@@ -0,0 +1,28 @@
+<!DOCTYPE html>
+<html lang="en">
+<head>
+    <meta charset="UTF-8">
+    <meta name="viewport" content="width=device-width, initial-scale=1.0">
+    <title>Form</title>
+</head>
+<body>
+    <form action="ActionSequence.html">
+        <input type="text" name="message">
+        <input type="submit" value="Go">
+    </form>
+    <script>
+        const form = document.querySelector("form");
+        const params = new URLSearchParams(window.location.search);
+        const msgParam = params.get('message');
+        if (msgParam) {
+            form.remove();
+            let confirm = document.createElement("button");
+            confirm.textContent = `Confirm "${msgParam}"`;
+            confirm.addEventListener("click", () => {
+                confirm.disabled = true;
+            });
+            document.body.appendChild(confirm);
+        }
+    </script>
+</body>
+</html>

integration-tests/passing/ActionSequence.spec.purs

@@ -0,0 +1,21 @@
+-- This spec only tests that the fixed sequence of actions works, even though
+-- the `button` isn't in the DOM until after the form has been submitted.
+module Spec where
+
+import Quickstrom
+import Data.Maybe (Maybe(..), isJust, isNothing)
+import Data.String (trim)
+
+readyWhen :: String
+readyWhen = "form"
+
+actions :: Actions 
+actions = [ 
+  focus "input[type=text]" 
+    `followedBy` enterText "Hello" 
+    `followedBy` specialKeyPress KeyEnter 
+    `followedBy` await "button" `followedBy` click "button" 
+  ]
+
+proposition :: Boolean
+proposition = true

runner/quickstrom-runner.cabal

@@ -11,6 +11,7 @@ copyright:            Oskar Wickström
 common shared-deps
   build-depends:      base ^>= 4.12
                     , aeson
+                    , bifunctors
                     , bytestring
                     , containers
                     , directory

runner/src/Quickstrom/Action.hs

@@ -1,16 +1,16 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Quickstrom.Action where
 
 
 import Data.Aeson (ToJSON, FromJSON)
-import qualified Data.List.NonEmpty as NonEmpty
-import Data.Vector (Vector)
 import GHC.Generics (Generic)
 import Quickstrom.Element
 import Quickstrom.Prelude
+import Data.Bifunctor.TH (deriveBifunctor)
 
 data Selected = Selected Selector Int
   deriving (Eq, Show, Generic, FromJSON, ToJSON, Hashable)
@@ -28,18 +28,17 @@ data Action sel
   -- `Back` and `Forward` can't be supported, as the history cannot be introspected to validate if these actions are possible.
   deriving (Eq, Show, Functor, Foldable, Traversable, Generic, ToJSON, Hashable)
 
-newtype ActionSequence sel = ActionSequence (NonEmpty (Action sel))
+data ActionSequence restSel firstSel = ActionSequence (Action firstSel) [Action restSel]
   deriving (Eq, Show, Functor, Foldable, Traversable, Generic, ToJSON, Hashable)
 
-type PotentialActionSequence = [Action Selector]
+$(deriveBifunctor ''ActionSequence)
 
-type SelectedActionSequence = [Action Selected]
+actionSequenceToNonEmpty :: ActionSequence s s -> NonEmpty (Action s)
+actionSequenceToNonEmpty (ActionSequence a as) = a :| as
 
-actionSequenceToList :: ActionSequence sel -> [Action sel]
-actionSequenceToList (ActionSequence actions') = NonEmpty.toList actions'
+type PotentialActionSequence = [Action Selector]
 
-actionSequencesToLists :: Vector (Int, ActionSequence sel) -> Vector (Int, [Action sel])
-actionSequencesToLists = map (second actionSequenceToList)
+type SelectedActionSequence = [Action Selected]
 
 data Weighted a = Weighted {weight :: Int, weighted :: a}
   deriving (Show, Eq, Functor, Foldable, Traversable, Generic)

runner/src/Quickstrom/Pretty.hs

@@ -35,9 +35,9 @@ prettyAction = \case
   Navigate uri -> "navigate to" <+> pretty uri
   Refresh -> "refresh"
 
-prettyActionSeq :: ActionSequence ActionSubject -> Doc AnsiStyle
-prettyActionSeq (ActionSequence (action' :| [])) = prettyAction action'
-prettyActionSeq (ActionSequence (action :| actions')) = "Sequence:" <> line <> indent 2 (vsep (zipWith item [1 ..] (action : toList actions')))
+prettyActionSeq :: ActionSequence ActionSubject ActionSubject -> Doc AnsiStyle
+prettyActionSeq (ActionSequence action' []) = prettyAction action'
+prettyActionSeq (ActionSequence action actions') = "Sequence:" <> line <> indent 2 (vsep (zipWith item [1 ..] (action : toList actions')))
   where
     item :: Int -> Action ActionSubject -> Doc AnsiStyle
     item i = \case

runner/src/Quickstrom/PureScript/ForeignFunction.hs

@@ -212,8 +212,10 @@ instance (MonadError EvalError m, ToHaskellValue m a) => ToHaskellValue m (Weigh
       <$> (require ss (Proxy @"VInt") =<< accessField ss "weight" obj)
       <*> (toHaskellValue ss =<< accessField ss "weighted" obj)
 
-instance MonadError EvalError m => ToHaskellValue m (ActionSequence Selector) where
-  toHaskellValue ss v = ActionSequence <$> toHaskellValue ss v
+instance MonadError EvalError m => ToHaskellValue m (ActionSequence Selector Selector) where
+  toHaskellValue ss v = do
+    a :| as <- toHaskellValue ss v
+    pure (ActionSequence a as)
 
 instance MonadError EvalError m => ToHaskellValue m (Action Selector) where
   toHaskellValue ss v = do

runner/src/Quickstrom/PureScript/Program.hs

@@ -90,7 +90,7 @@ loadModuleFromSource modules input =
       pure result
   where
     printErrors :: P.MultipleErrors -> Text
-    printErrors errs = toS (P.prettyPrintMultipleErrors P.defaultPPEOptions (errs))
+    printErrors errs = toS (P.prettyPrintMultipleErrors P.defaultPPEOptions errs)
 
 loadModuleFromCoreFn :: FilePath -> ExceptT Text IO (Module CF.Ann)
 loadModuleFromCoreFn path = do
@@ -195,7 +195,7 @@ loadProgram ms input = runExceptT $ do
 
 data SpecificationProgram = SpecificationProgram
   { specificationReadyWhen :: Quickstrom.Selector,
-    specificationActions :: Vector (Quickstrom.Weighted (Quickstrom.ActionSequence Quickstrom.Selector)),
+    specificationActions :: Vector (Quickstrom.Weighted (Quickstrom.ActionSequence Quickstrom.Selector Quickstrom.Selector)),
     specificationQueries :: Quickstrom.Queries,
     specificationProgram :: Program WithObservedStates
   }

runner/src/Quickstrom/Run.hs

@@ -52,7 +52,7 @@ import qualified Pipes.Prelude as Pipes
 import Quickstrom.Action
 import Quickstrom.Prelude hiding (Prefix, catch, check, trace)
 import Quickstrom.Result
-import Quickstrom.Run.Actions (awaitElement, defaultTimeout, generateValidActions, isCurrentlyValid, reselect, runActionSequence)
+import Quickstrom.Run.Actions (awaitElement, defaultTimeout, generateValidActions, isCurrentlyValid, selectOne, runActionSequence, Selectable)
 import Quickstrom.Run.Runner (CheckEnv (..), CheckOptions (..), Runner, Size (..), run)
 import Quickstrom.Run.Scripts (CheckScripts (..), readScripts, runCheckScript)
 import Quickstrom.Run.Shrinking
@@ -139,7 +139,7 @@ runSingle spec size = do
       if checkMaxShrinks > 0
         then do
           Pipes.yield (Shrinking checkMaxShrinks)
-          let prefixes = shrinkPrefixes (map (map (view #selected)) (trace ^.. traceActions))
+          let prefixes = shrinkPrefixes (map (bimap (view #selected) (view #selected)) (trace ^.. traceActions))
           counterExamples <-
             Pipes.toListM
               ( searchSmallestFailingPrefix runShrink (_Ctor @"ShrinkTestFailure") prefixes
@@ -152,9 +152,9 @@ runSingle spec size = do
         else pure (Left ft)
   where
     runAndVerifyIsolated ::
-      (MonadIO m, MonadCatch m, WebDriver m) =>
+      (MonadIO m, MonadCatch m, WebDriver m, Selectable s) =>
       Int ->
-      Producer (ActionSequence ActionSubject) (Runner m) () ->
+      Producer (ActionSequence s ActionSubject) (Runner m) () ->
       Producer TestEvent (Runner m) (Either FailedTest (Trace TraceElementEffect))
     runAndVerifyIsolated n producer = do
       trace <- lift do
@@ -168,13 +168,12 @@ runSingle spec size = do
         Left err -> pure (Left (FailedTest n trace (Just err)))
     runShrink ::
       (MonadIO m, MonadCatch m, WebDriver m) =>
-      Prefix (ActionSequence Selected) ->
+      Prefix (ActionSequence Selected Selected) ->
       Producer TestEvent (Runner m) ShrinkResult
     runShrink (Prefix actions') = do
       Pipes.yield (RunningShrink (length actions'))
       Pipes.each actions'
-        >-> Pipes.mapM (traverse reselect)
-        >-> Pipes.mapMaybe (traverse identity)
+        >-> Pipes.mapM (traverse selectOne)
         >-> Pipes.filterM isCurrentlyValid
         & runAndVerifyIsolated 0
         & (<&> either ShrinkTestFailure ShrinkTestSuccess)
@@ -222,15 +221,15 @@ takeScreenshot' = do
   CheckEnv {checkOptions = CheckOptions {checkCaptureScreenshots}} <- ask
   if checkCaptureScreenshots then Just <$> takeScreenshot else pure Nothing
 
-observeManyStatesAfter :: (MonadIO m, MonadCatch m, WebDriver m) => Queries -> ActionSequence ActionSubject -> Pipe a (TraceElement ()) (Runner m) ()
+observeManyStatesAfter :: (MonadIO m, MonadCatch m, WebDriver m, Selectable  s) => Queries -> ActionSequence s ActionSubject -> Pipe a (TraceElement ()) (Runner m) ()
 observeManyStatesAfter queries' actionSequence = do
   CheckEnv {checkScripts = scripts, checkOptions = CheckOptions {checkMaxTrailingStateChanges, checkTrailingStateChangeTimeout}} <- lift ask
   lift (runCheckScript (registerNextStateObserver scripts checkTrailingStateChangeTimeout queries'))
-  result <- lift (runActionSequence (actionSequence & traverse %~ view #element))
+  (actionSequence', result) <- lift (runActionSequence actionSequence)
   lift (runCheckScript (awaitNextState scripts) `catch` (\WebDriverResponseError {} -> pass))
   newState <- lift (runCheckScript (observeState scripts queries'))
   screenshot <- lift takeScreenshot'
-  Pipes.yield (TraceAction () actionSequence result)
+  Pipes.yield (TraceAction () actionSequence' result)
   Pipes.yield (TraceState () (ObservedState screenshot newState))
   nonStutters <-
     ( loop checkTrailingStateChangeTimeout
@@ -253,7 +252,7 @@ observeManyStatesAfter queries' actionSequence = do
       loop (mapTimeout (* 2) timeout)
 
 {-# SCC runActions' "runActions'" #-}
-runActions' :: (MonadIO m, MonadCatch m, WebDriver m, Specification spec) => spec -> Pipe (ActionSequence ActionSubject) (TraceElement ()) (Runner m) ()
+runActions' :: (MonadIO m, MonadCatch m, WebDriver m, Selectable s, Specification spec) => spec -> Pipe (ActionSequence s ActionSubject) (TraceElement ()) (Runner m) ()
 runActions' spec = do
   scripts <- lift (asks checkScripts)
   state1 <- lift (runCheckScript (observeState scripts queries'))