Merge pull request #93 from quickstrom/shrink-tree-improve

Shrink tree improvements

cli/app/Main.hs

@@ -476,15 +476,5 @@ renderSize (Quickstrom.Size s) = pretty s
 renderList :: [Doc ann] -> Doc ann
 renderList = vsep . map (\x -> bullet <+> align x)
 
-ordinal :: (Pretty n, Integral n) => n -> Doc ann
-ordinal 11 = "11th"
-ordinal 12 = "12th"
-ordinal n =
-  pretty n <> case n `rem` 10 of
-    1 -> "st"
-    2 -> "nd"
-    3 -> "rd"
-    _ -> "th"
-
 version :: String
 version = $(Quickstrom.version)

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

@@ -55,7 +55,7 @@ data Report = Report
 data Result
   = Passed {passedTests :: Vector Test}
   | Failed
-      { shrinkLevels :: Int,
+      { numShrinks :: Int,
         reason :: Maybe Text,
         passedTests :: Vector Test,
         failedTest :: Test
@@ -154,7 +154,7 @@ htmlReporter reportDir = Quickstrom.Reporter {preCheck, report}
           failedTest' <- traceToTest reportDir (failedTest ^. #trace)
           pure
             Failed
-              { shrinkLevels = Quickstrom.numShrinks failedTest,
+              { numShrinks = Quickstrom.numShrinks failedTest,
                 reason = Quickstrom.reason failedTest,
                 passedTests = passedTests',
                 failedTest = failedTest'

html-report/src/App.tsx

@@ -16,7 +16,7 @@ export type Passed = {
 
 export type Failed = {
     tag: "Failed";
-    shrinkLevels: number;
+    numShrinks: number;
     reason?: string;
     passedTests: Test[];
     failedTest: Test;
@@ -176,7 +176,7 @@ function ordinal(n: number): string {
             switch (n % 10) {
                 case 1: return `${n}st`;
                 case 2: return `2nd`;
-                default: return `1st`;
+                default: return `${n}th`;
             }
     }
 }
@@ -187,9 +187,8 @@ function Header({ report, onTestSelect }: { report: Report<Result>, onTestSelect
             case "Failed":
                 return <div class="summary failure">
                     <p>
-                        Failed on {ordinal(report.result.passedTests.length + 1)} test and after {pluralize(report.result.shrinkLevels, "level")} of
-              shrinking
-              {report.result.reason || "."}
+                        Failed on {ordinal(report.result.passedTests.length + 1)} test and after {pluralize(report.result.numShrinks, "shrink")}.
+              {report.result.reason}
                     </p>
                 </div>;
             case "Errored":

runner/quickstrom-runner.cabal

@@ -71,6 +71,7 @@ library
                     , Quickstrom.Run.Actions
                     , Quickstrom.Run.Runner
                     , Quickstrom.Run.Scripts
+                    , Quickstrom.Run.Shrinking
                     , Quickstrom.Specification
                     , Quickstrom.Timeout
                     , Quickstrom.Trace
@@ -89,6 +90,7 @@ test-suite quickstrom-runner-test
   other-modules:      Quickstrom.Gen
                     , Quickstrom.PureScript.AnalyzeTest
                     , Quickstrom.PureScriptTest
+                    , Quickstrom.Run.ShrinkingTest
                     , Quickstrom.TraceTest
   build-depends:      base
                     , quickstrom-runner

runner/src/Quickstrom/Action.hs

@@ -12,7 +12,7 @@ import Quickstrom.Element
 import Quickstrom.Prelude
 
 data Selected = Selected Selector Int
-  deriving (Eq, Show, Generic, ToJSON)
+  deriving (Eq, Show, Generic, ToJSON, Hashable)
 
 data Action sel
   = Focus sel
@@ -25,10 +25,10 @@ data Action sel
   | Navigate Text
   | Refresh
   -- `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)
+  deriving (Eq, Show, Functor, Foldable, Traversable, Generic, ToJSON, Hashable)
 
 newtype ActionSequence sel = ActionSequence (NonEmpty (Action sel))
-  deriving (Eq, Show, Functor, Foldable, Traversable, Generic, ToJSON)
+  deriving (Eq, Show, Functor, Foldable, Traversable, Generic, ToJSON, Hashable)
 
 type PotentialActionSequence = [Action Selector]
 

runner/src/Quickstrom/Run.hs

@@ -32,8 +32,7 @@ module Quickstrom.Run
 where
 
 import Control.Lens hiding (each)
-import Control.Lens.Extras (is)
-import Control.Monad (fail, forever, when)
+import Control.Monad (fail)
 import Control.Monad.Catch (MonadCatch, catch)
 import Control.Monad.Trans.Class (MonadTrans (lift))
 import Data.Function ((&))
@@ -43,26 +42,26 @@ import Data.List hiding (map, sortOn)
 import Data.Text (Text)
 import qualified Data.Text as Text
 import Data.Text.Prettyprint.Doc
-import Data.Tree
 import Data.Vector (Vector)
 import GHC.Generics (Generic)
 import Pipes (Pipe, Producer, (>->))
 import qualified Pipes
 import qualified Pipes.Prelude as Pipes
 import Quickstrom.Action
 import Quickstrom.Element (Element)
-import Quickstrom.Prelude hiding (catch, check, trace)
+import Quickstrom.Prelude hiding (catch, check, trace, Prefix)
 import Quickstrom.Result
 import Quickstrom.Run.Actions (awaitElement, defaultTimeout, generateValidActions, isCurrentlyValid, reselect, runActionSequence)
 import Quickstrom.Run.Runner (CheckEnv (..), CheckOptions (..), Runner, Size (..), run)
 import Quickstrom.Run.Scripts (CheckScripts (..), readScripts, runCheckScript)
+import Quickstrom.Run.Shrinking
 import Quickstrom.Specification
 import Quickstrom.Timeout (Timeout, mapTimeout)
 import Quickstrom.Trace
 import Quickstrom.WebDriver.Class
 import qualified Text.URI as URI
 
-data PassedTest = PassedTest
+newtype PassedTest = PassedTest
   { trace :: Trace TraceElementEffect
   }
   deriving (Show, Generic)
@@ -118,22 +117,6 @@ check opts@CheckOptions {checkTests} spec = do
 elementsToTrace :: Monad m => Producer (TraceElement ()) (Runner m) () -> Runner m (Trace ())
 elementsToTrace = fmap Trace . Pipes.toListM
 
-minBy :: (Monad m, Ord b) => (a -> b) -> Producer a m () -> m (Maybe a)
-minBy f = Pipes.fold step Nothing identity
-  where
-    step x a = Just $ case x of
-      Nothing -> a
-      Just a' ->
-        case f a `compare` f a' of
-          EQ -> a
-          LT -> a
-          GT -> a'
-
-select :: Monad m => (a -> Maybe b) -> Pipe a b m ()
-select f = forever do
-  x <- Pipes.await
-  maybe (pure ()) Pipes.yield (f x)
-
 runSingle ::
   (MonadIO m, MonadCatch m, WebDriver m, Specification spec) =>
   spec ->
@@ -155,13 +138,15 @@ runSingle spec size = do
       if checkMaxShrinks > 0
         then do
           Pipes.yield (Shrinking checkMaxShrinks)
-          let shrinks = shrinkForest shrinkActions (trace ^.. traceActions)
-          counterExamples <- Pipes.toListM
-              ( traverseShrinks runShrink (_Ctor @"ShrinkTestFailure") shrinks
+          let prefixes = shrinkPrefixes (trace ^.. traceActions)
+          counterExamples <-
+            Pipes.toListM
+              ( searchSmallestFailingPrefix runShrink (_Ctor @"ShrinkTestFailure") prefixes
                   >-> Pipes.take checkMaxShrinks
-                  >-> select (preview (_Ctor @"ShrinkTestFailure"))
               )
-          let counterExample = headMay (sortOn (lengthOf (field @"trace" . traceElements)) counterExamples)
+          let counterExample =
+                  counterExamples
+                    & minimumByOf (folded. _Ctor @"ShrinkTestFailure") (compare `on` lengthOf (field @"trace" . traceElements))
           pure (maybe (Left ft) (Left . (field @"numShrinks" .~ length counterExamples)) counterExample)
         else pure (Left ft)
   where
@@ -182,9 +167,9 @@ runSingle spec size = do
         Left err -> pure (Left (FailedTest n trace (Just err)))
     runShrink ::
       (MonadIO m, MonadCatch m, WebDriver m) =>
-      Shrink [ActionSequence Selected] ->
+      Prefix (ActionSequence Selected) ->
       Producer TestEvent (Runner m) ShrinkResult
-    runShrink (Shrink actions') = do
+    runShrink (Prefix actions') = do
       Pipes.yield (RunningShrink (length actions'))
       Pipes.each actions'
         >-> Pipes.mapM (traverse reselect)
@@ -209,13 +194,6 @@ sizes :: CheckOptions -> [Size]
 sizes CheckOptions {checkMaxActions = Size maxActions, checkTests} =
   map (\n -> Size (n * maxActions `div` fromIntegral checkTests)) [1 .. fromIntegral checkTests]
 
-shrinkActions :: [a] -> [[a]]
-shrinkActions [] = []
-shrinkActions as = filter (not . null) [first75, init as]
-  where
-    first75 = take (floor @Double (fromIntegral (length as) * 0.75)) as
--- shrinkActions = QuickCheck.shrinkList shrinkAction
-
 navigateToOrigin :: WebDriver m => Runner m ()
 navigateToOrigin = do
   CheckOptions {checkOrigin} <- asks checkOptions
@@ -286,24 +264,4 @@ runActions' spec = do
     loop = do
       actionSequence <- Pipes.await
       observeManyStatesAfter queries' actionSequence
-      loop
-
-newtype Shrink a = Shrink a
-  deriving (Eq, Show)
-
-shrinkForest :: (a -> [a]) -> a -> Forest (Shrink a)
-shrinkForest shrink = go
-  where
-    go = map (\x -> Node (Shrink x) (go x)) . shrink
-
-traverseShrinks :: Monad m => (Shrink a -> m b) -> Prism' b x -> Forest (Shrink a) -> Producer b m ()
-traverseShrinks test failure = go
-  where
-    go = \case
-      [] -> pure ()
-      Node x xs : rest -> do
-        r <- lift (test x)
-        Pipes.yield r
-        when (is failure r) do
-          go xs
-        go rest
+      loop

runner/src/Quickstrom/Run/Shrinking.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Quickstrom.Run.Shrinking (Prefix (..), shrinkPrefixes, searchSmallestFailingPrefix, drawShrinkForest) where
+
+import Control.Lens
+import Control.Lens.Extras (is)
+import Data.String (String)
+import Data.Tree
+import qualified Pipes
+import Quickstrom.Prelude hiding (Prefix)
+
+newtype Prefix a = Prefix { unPrefix :: [a] }
+  deriving (Eq, Show, Hashable, Functor, Foldable, Traversable)
+
+shrinkPrefixes :: [a] -> Forest (Prefix a)
+shrinkPrefixes as = go 0 (length as `div` 2) as
+  where
+    go minLength n xs
+      | n < 1 = []
+      | otherwise =
+        let len = length xs - n
+        in if len <= minLength
+          then go minLength (n `div` 2) xs
+          else
+            let xs' = take len xs
+            in Node (Prefix xs') (go minLength (len `div` 2) xs') :
+                go len (n `div` 2) xs
+
+searchSmallestFailingPrefix :: Monad m => (Prefix a -> m b) -> Prism' b x -> Forest (Prefix a) -> Pipes.Producer b m ()
+searchSmallestFailingPrefix test failure = go
+  where
+    go = \case
+      [] -> pure ()
+      Node x xs : rest -> do
+        r <- lift (test x)
+        Pipes.yield r
+        if is failure r
+          then go xs
+          else go rest
+
+drawShrinkForest :: Show a => Forest (Prefix a) -> String
+drawShrinkForest = drawForest . map (map show)

runner/test/Quickstrom/Run/ShrinkingTest.hs

@@ -0,0 +1,20 @@
+module Quickstrom.Run.ShrinkingTest where
+
+import Quickstrom.Prelude
+import Quickstrom.Run.Shrinking (shrinkPrefixes, Prefix (unPrefix))
+import Data.Tree
+import Test.QuickCheck
+
+prop_shrinkPrefixes_includes_all_prefixes :: NonEmptyList Int -> Property
+prop_shrinkPrefixes_includes_all_prefixes (NonEmpty xs) = 
+    let allPrefixes = sort (map unPrefix (foldMap flatten (shrinkPrefixes xs)))
+    in allPrefixes === tailSafe (initSafe (inits xs))
+
+prop_shrinkPrefixes_is_ordered :: NonEmptyList Int -> Property
+prop_shrinkPrefixes_is_ordered (NonEmpty xs) = property $
+    let treeMaxLen = foldTree (\p subLengths -> maximum (length (unPrefix p) : subLengths))
+        isOrdered forest =
+          let lengths = map treeMaxLen forest
+          in lengths == sort lengths && all (isOrdered . subForest) forest
+    in isOrdered (shrinkPrefixes xs)
+