packages feed

skeletest 0.3.3 → 0.3.4

raw patch · 25 files changed

+697/−380 lines, 25 files

Files

CHANGELOG.md view
@@ -1,3 +1,11 @@+## v0.3.4++API changes:+* Replace `hookModifyFileSpecs` with `hookModifySpecRegistry`+* Remove field prefixes from many constructors (e.g. `Hooks`, `TestInfo`, etc.)+* Turn on `NoFieldSelectors` everywhere+* Add `focus` for focusing a specific test ([#58](https://github.com/brandonchinn178/skeletest/issues/58))+ ## v0.3.3  Configuration:
README.md view
@@ -45,7 +45,7 @@   -- either myFunc nor otherFunc   prop "myFunc x . otherFunc === id" $ do     x <- forAll $ Gen.int (Range.linear 0 100)-    let input = +    let input =           Gen.list (Range.linear 0 10) $             Gen.string (Range.linear 0 100) Gen.unicode     (myFunc x . otherFunc) P.=== id `shouldSatisfy` P.isoWith input@@ -181,7 +181,7 @@ Some more examples: * `test/MySpec.hs and ([myFooFunc] or [myBarFunc]) and @fast` * `[myFooFunc] or test/MySpec.hs[myBarFunc]`- + When multiple targets are specified, they are joined with `or`.  ### Assertions and Predicates@@ -441,8 +441,8 @@  Skeletest lets you hook into specific parts of test execution. Skeletest currently supports the following hooks: -* `hookModifyFileSpecs` - Modify the specs in each file. Runs once per file, taking in the `[SpecTree]` containing all the specs in the file. This can be used to do your own test selection, test transformations, etc.-* `hookRunTest` - Modify how/if a test is run. Takes the `TestInfo` of the currently running test. `TestInfo` contains `testInfoMarkers`, which you can query with `findMarker` or `hasMarkerNamed`.+* `modifySpecRegistry` - Modify all the specs in the test suite. This can be used to do your own test selection, test transformations, etc.+* `runTest` - Modify how/if a test is run. Takes the `TestInfo` of the currently running test. `TestInfo` contains `testInfoMarkers`, which you can query with `findMarker` or `hasMarkerNamed`.  ### Plugins @@ -458,9 +458,9 @@   defaultPlugin     { hooks =         defaultHooks-          { hookRunTest = \testInfo runTest -> do+          { runTest = \testInfo run -> do               putStrLn "before test"-              result <- runTest+              result <- run               putStrLn "after test"               pure result           }
skeletest.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0  name: skeletest-version: 0.3.3+version: 0.3.4 synopsis: Batteries-included, opinionated test framework description: Batteries-included, opinionated test framework. See README.md for more details. homepage: https://github.com/brandonchinn178/skeletest#readme@@ -19,6 +19,7 @@   test/Skeletest/__snapshots__/AssertionsSpec.snap.md   test/Skeletest/__snapshots__/PropSpec.snap.md   test/Skeletest/__snapshots__/MainSpec.snap.md+  test/Skeletest/__snapshots__/PluginSpec.snap.md   test/Skeletest/__snapshots__/PredicateSpec.snap.md   test/Skeletest/Internal/__snapshots__/SnapshotSpec.snap.md   test/Skeletest/Internal/__snapshots__/CLISpec.snap.md@@ -128,6 +129,7 @@     Skeletest.Internal.SpecSpec     Skeletest.Internal.TestTargetsSpec     Skeletest.MainSpec+    Skeletest.PluginSpec     Skeletest.PredicateSpec     Skeletest.PropSpec     Skeletest.TestUtils.Integration
src/Skeletest.hs view
@@ -8,6 +8,7 @@   -- ** Modifiers   xfail,   skip,+  focus,   markManual,    -- ** Markers
src/Skeletest/Internal/Capture.hs view
@@ -86,7 +86,7 @@     result       { testResultMessage =           TestResultMessageBox . concat $-            [ toBoxContents (testResultMessage result)+            [ toBoxContents result.testResultMessage             , renderOutput output             ]       }
src/Skeletest/Internal/Fixtures.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE NoFieldSelectors #-}  module Skeletest.Internal.Fixtures (   Fixture (..),@@ -32,10 +34,8 @@ import Data.Text qualified as Text import Data.Typeable (TypeRep, Typeable, eqT, typeOf, typeRep, (:~:) (Refl)) import Skeletest.Internal.Error (SkeletestError (..), invariantViolation)-import Skeletest.Internal.TestInfo (-  TestInfo (testFile),-  getTestInfo,- )+import Skeletest.Internal.TestInfo (getTestInfo)+import Skeletest.Internal.TestInfo qualified as TestInfo import Skeletest.Internal.Utils.Map qualified as Map.Utils import System.Directory (   createDirectory,@@ -86,7 +86,7 @@     fmap getScopedAccessors $       case fixtureScope @a of         PerTestFixture -> PerTestFixtureKey <$> myThreadId-        PerFileFixture -> PerFileFixtureKey . testFile <$> getTestInfo+        PerFileFixture -> PerFileFixtureKey . (.file) <$> getTestInfo         PerSessionFixture -> pure PerSessionFixtureKey    let insertFixture state = updateScopedFixtures (OMap.>| (rep, state))@@ -193,16 +193,16 @@ getScopedAccessors scopeKey =   case scopeKey of     PerTestFixtureKey tid ->-      ( Map.Utils.findOrEmpty tid . testFixtures-      , \f registry -> registry{testFixtures = Map.Utils.adjustNested f tid (testFixtures registry)}+      ( Map.Utils.findOrEmpty tid . (.testFixtures)+      , \f registry -> registry{testFixtures = Map.Utils.adjustNested f tid registry.testFixtures}       )     PerFileFixtureKey fp ->-      ( Map.Utils.findOrEmpty fp . fileFixtures-      , \f registry -> registry{fileFixtures = Map.Utils.adjustNested f fp (fileFixtures registry)}+      ( Map.Utils.findOrEmpty fp . (.fileFixtures)+      , \f registry -> registry{fileFixtures = Map.Utils.adjustNested f fp registry.fileFixtures}       )     PerSessionFixtureKey ->-      ( sessionFixtures-      , \f registry -> registry{sessionFixtures = f (sessionFixtures registry)}+      ( (.sessionFixtures)+      , \f registry -> registry{sessionFixtures = f registry.sessionFixtures}       )  {----- Built-in fixtures -----}
src/Skeletest/Internal/GHC.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoFieldSelectors #-}  {-| Provide a pure API for GHC internals. @@ -49,6 +50,7 @@   HsName,   hsName,   hsVarName,+  hsFieldName,   getHsName, ) where @@ -332,6 +334,15 @@  hsVarName :: Text -> HsName p hsVarName = HsVarName++hsFieldName :: TH.Name -> String -> HsName p+hsFieldName conName fieldName =+  HsName $+    TH.mkNameG_fld+      (fromMaybe "" $ TH.namePackage conName)+      (fromMaybe "" $ TH.nameModule conName)+      (TH.nameBase conName)+      fieldName  hsGhcName :: forall p. (IsPass p) => GHC.IdP (GhcPass p) -> HsName (GhcPass p) hsGhcName = HsGhcName . onPsOrRn @p GhcIdPs GhcIdRn
src/Skeletest/Internal/Markers.hs view
@@ -1,12 +1,15 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+ module Skeletest.Internal.Markers (   IsMarker (..),   AnonMarker (..),   SomeMarker (..),   findMarker,+  hasMarker,   hasMarkerNamed, ) where -import Data.Maybe (listToMaybe, mapMaybe)+import Data.Maybe (isJust, listToMaybe, mapMaybe) import Data.Typeable (Typeable, cast)  class (Show a, Typeable a) => IsMarker a where@@ -30,6 +33,10 @@ -- | Find the first marker in the given list with the given type. findMarker :: forall a. (IsMarker a) => [SomeMarker] -> Maybe a findMarker = listToMaybe . mapMaybe (\(SomeMarker m) -> cast m)++-- | Helper for @isJust . findMarker @MyMarker@.+hasMarker :: forall a. (IsMarker a) => [SomeMarker] -> Bool+hasMarker = isJust . findMarker @a  -- | Return true if the given marker name is present. hasMarkerNamed :: String -> [SomeMarker] -> Bool
src/Skeletest/Internal/Plugin.hs view
@@ -52,13 +52,13 @@ transformMainModule :: Preprocessor.Options -> ParsedModule -> ParsedModule transformMainModule options modl =   modl-    { moduleFuncs = (hsVarName options.mainFuncName, Just mainFun) : moduleFuncs modl+    { moduleFuncs = (hsVarName options.mainFuncName, Just mainFun) : modl.moduleFuncs     }  where   findVar name =     fmap hsExprVar . listToMaybe $       [ funName-      | (funName, _) <- moduleFuncs modl+      | (funName, _) <- modl.moduleFuncs       , getHsName funName == name       ] @@ -77,9 +77,9 @@             [ hsExprApps (hsExprVar (hsName '(:))) $                 [ hsExprRecordCon                     (hsName 'Plugin.Plugin)-                    [ (hsName 'Plugin.cliFlags, cliFlagsExpr)-                    , (hsName 'Plugin.snapshotRenderers, snapshotRenderersExpr)-                    , (hsName 'Plugin.hooks, hooksExpr)+                    [ (hsFieldName 'Plugin.Plugin "cliFlags", cliFlagsExpr)+                    , (hsFieldName 'Plugin.Plugin "snapshotRenderers", snapshotRenderersExpr)+                    , (hsFieldName 'Plugin.Plugin "hooks", hooksExpr)                     ]                 , pluginsExpr                 ]@@ -129,7 +129,7 @@     -- Matches:     --   P.con $ User "..."     HsExprOp (getExpr -> HsExprVar name) (getExpr -> HsExprVar dollar) arg-      | matchesName ctx (hsName '($)) dollar+      | ctx.matchesName (hsName '($)) dollar       , isCon name ->           convertCon arg     -- Check if P.con is by itself@@ -142,7 +142,7 @@           skeletestPluginError (getLoc e) "P.con must be applied to exactly one argument"     _ -> e  where-  isCon = matchesName ctx (hsName 'P.con)+  isCon = ctx.matchesName (hsName 'P.con)    convertCon con =     case getExpr con of@@ -220,7 +220,7 @@ replaceIsoChecker ctx e =   case getExpr e of     HsExprOp l (getExpr -> HsExprVar eqeqeq) r-      | matchesName ctx (hsName '(P.===)) eqeqeq ->+      | ctx.matchesName (hsName '(P.===)) eqeqeq ->           inlineIsoChecker l r     _ -> e  where
src/Skeletest/Internal/Predicate.hs view
@@ -1,10 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeData #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoFieldSelectors #-}  module Skeletest.Internal.Predicate (   Predicate,@@ -137,7 +139,7 @@          in PredicateFail . withFailCtx failCtx predicateShowFailCtx $ predicateExplain  renderPredicate :: Predicate m a -> Text-renderPredicate = predicateDisp+renderPredicate = (.predicateDisp)  data PredicateFuncResult = PredicateFuncResult   { predicateSuccess :: Bool@@ -196,10 +198,10 @@ noCtx = NoFailCtx  showMergedCtxs :: [PredicateFuncResult] -> ShowFailCtx-showMergedCtxs = max ShowFailCtx . maybe NoFailCtx Foldable1.maximum . NonEmpty.nonEmpty . map predicateShowFailCtx+showMergedCtxs = max ShowFailCtx . maybe NoFailCtx Foldable1.maximum . NonEmpty.nonEmpty . map (.predicateShowFailCtx)  showCtx :: PredicateFuncResult -> PredicateFuncResult-showCtx result = result{predicateShowFailCtx = max ShowFailCtx $ predicateShowFailCtx result}+showCtx result = result{predicateShowFailCtx = max ShowFailCtx result.predicateShowFailCtx}  {----- General -----} @@ -312,7 +314,7 @@   Predicate     { predicateFunc = \actual ->         if length actual == length predList-          then verifyAll listify <$> sequence (zipWith predicateFunc predList actual)+          then verifyAll listify <$> sequence (zipWith (.predicateFunc) predList actual)           else             pure               PredicateFuncResult@@ -325,7 +327,7 @@     }  where   listify vals = "[" <> Text.intercalate ", " vals <> "]"-  disp = listify $ map predicateDisp predList+  disp = listify $ map (.predicateDisp) predList   dispNeg = "not " <> disp  class IsTuple a where@@ -381,7 +383,7 @@  where   preds = toHListPred (Proxy @a) predTup   tupify vals = "(" <> Text.intercalate ", " vals <> ")"-  disp = tupify $ HList.toListWith predicateDisp preds+  disp = tupify $ HList.toListWith (.predicateDisp) preds   dispNeg = "not " <> disp  -- | A predicate checking if the input matches the given constructor.@@ -433,7 +435,7 @@   conName = Text.pack conNameS   disp = "matches " <> predsDisp   dispNeg = "does not match " <> predsDisp-  predsDisp = consify $ HList.toListWith predicateDisp preds+  predsDisp = consify $ HList.toListWith (.predicateDisp) preds    -- consify ["= 1", "anything"] => User{id = (= 1), name = anything}   -- consify ["= 1", "anything"] => Foo (= 1) anything@@ -517,7 +519,7 @@   Predicate     { predicateFunc = \actual -> do         result <- showCtx <$> predicateFunc actual-        pure result{predicateSuccess = Prelude.not $ predicateSuccess result}+        pure result{predicateSuccess = Prelude.not result.predicateSuccess}     , predicateDisp = predicateDispNeg     , predicateDispNeg = predicateDisp     }@@ -541,13 +543,13 @@ and preds =   Predicate     { predicateFunc = \actual ->-        verifyAll (const "All predicates passed") <$> mapM (\p -> predicateFunc p actual) preds+        verifyAll (const "All predicates passed") <$> mapM (\p -> p.predicateFunc actual) preds     , predicateDisp = andify predList     , predicateDispNeg = "At least one failure:\n" <> andify predList     }  where   andify = Text.intercalate "\nand "-  predList = map (parens . predicateDisp) preds+  predList = map (parens . (.predicateDisp)) preds  -- | A predicate checking if the input matches any of the given predicates --@@ -556,13 +558,13 @@ or preds =   Predicate     { predicateFunc = \actual ->-        verifyAny (const "No predicates passed") <$> mapM (\p -> predicateFunc p actual) preds+        verifyAny (const "No predicates passed") <$> mapM (\p -> p.predicateFunc actual) preds     , predicateDisp = orify predList     , predicateDispNeg = "All failures:\n" <> orify predList     }  where   orify = Text.intercalate "\nor "-  predList = map (parens . predicateDisp) preds+  predList = map (parens . (.predicateDisp)) preds  {----- Containers -----} @@ -892,7 +894,7 @@ runPredicates preds = HList.toListWithM run . HList.hzip preds  where   run :: (Predicate m :*: Identity) a -> m PredicateFuncResult-  run (p :*: Identity x) = predicateFunc p x+  run (p :*: Identity x) = p.predicateFunc x  verifyAll :: ([Text] -> Text) -> [PredicateFuncResult] -> PredicateFuncResult verifyAll mergeMessages results =@@ -900,12 +902,12 @@     { predicateSuccess = isNothing firstFailure     , predicateExplain =         case firstFailure of-          Just p -> predicateExplain p-          Nothing -> mergeMessages $ map predicateExplain results+          Just p -> p.predicateExplain+          Nothing -> mergeMessages $ map (.predicateExplain) results     , predicateShowFailCtx = showMergedCtxs results     }  where-  firstFailure = listToMaybe $ filter (Prelude.not . predicateSuccess) results+  firstFailure = listToMaybe $ filter (Prelude.not . (.predicateSuccess)) results  verifyAny :: ([Text] -> Text) -> [PredicateFuncResult] -> PredicateFuncResult verifyAny mergeMessages results =@@ -913,12 +915,12 @@     { predicateSuccess = isJust firstSuccess     , predicateExplain =         case firstSuccess of-          Just p -> predicateExplain p-          Nothing -> mergeMessages $ map predicateExplain results+          Just p -> p.predicateExplain+          Nothing -> mergeMessages $ map (.predicateExplain) results     , predicateShowFailCtx = showMergedCtxs results     }  where-  firstSuccess = listToMaybe $ filter predicateSuccess results+  firstSuccess = listToMaybe $ filter (.predicateSuccess) results  render :: a -> Text render = Text.pack . anythingToString
src/Skeletest/Internal/Snapshot.hs view
@@ -97,8 +97,8 @@ instance Fixture SnapshotFileFixture where   fixtureScope = PerFileFixture   fixtureAction = do-    TestInfo{testFile} <- getTestInfo-    let snapshotPath = getSnapshotPath testFile+    TestInfo{file} <- getTestInfo+    let snapshotPath = getSnapshotPath file      mSnapshotFile <-       try (Text.readFile snapshotPath) >>= \case@@ -143,13 +143,13 @@  where   SnapshotContext     { snapshotRenderers = renderers-    , snapshotTestInfo = testInfo@TestInfo{testFile}+    , snapshotTestInfo = testInfo@TestInfo{file}     , snapshotIndex     } = snapshotContext    emptySnapshotFile =     SnapshotFile-      { testFile = Text.pack testFile+      { testFile = Text.pack file       , snapshots = Map.empty       } @@ -244,7 +244,7 @@   snapshotFileName = replaceExtension testFileName ".snap.md"  toTestIdentifier :: TestInfo -> TestIdentifier-toTestIdentifier TestInfo{testContexts, testName} = testContexts <> [testName]+toTestIdentifier TestInfo{contexts, name} = contexts <> [name]  decodeSnapshotFile :: Text -> Maybe SnapshotFile decodeSnapshotFile = parseFile . Text.lines
src/Skeletest/Internal/Spec.hs view
@@ -1,53 +1,53 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}  module Skeletest.Internal.Spec (   -- * Spec interface-  Spec,-  SpecTree (..),+  X.Spec,+  X.SpecTree (..),++  -- ** Execution   runSpecs,    -- ** Entrypoint-  SpecRegistry,-  SpecInfo (..),-  pruneSpec,-  applyTestSelections,+  X.SpecRegistry,+  X.SpecInfo (..),    -- ** Defining a Spec-  describe,-  Testable (..),-  test,-  it,-  prop,+  X.describe,+  X.Testable (..),+  X.test,+  X.it,+  X.prop,    -- ** Modifiers-  xfail,-  skip,-  markManual,+  X.xfail,+  X.skip,+  X.focus,+  X.markManual,    -- ** Markers-  IsMarker (..),-  withMarkers,-  withMarker,+  X.IsMarker (..),+  X.withMarkers,+  X.withMarker,++  -- ** Built-in hooks+  applyTestSelectionsHook,+  manualTestsHook,+  xfailHook,+  skipHook,+  focusHook, ) where  import Control.Concurrent (myThreadId)-import Control.Monad (forM, guard)-import Control.Monad.Trans.Reader qualified as Trans-import Control.Monad.Trans.Writer (Writer, execWriter, tell)-import Data.Functor.Identity (runIdentity)-import Data.Maybe (catMaybes, isJust, mapMaybe)-import Data.Text (Text)+import Control.Monad (forM) import Data.Text qualified as Text import Data.Text.IO qualified as Text-import Skeletest.Assertions (Testable, runTestable) import Skeletest.Internal.Capture (addCapturedOutput, withCaptureOutput) import Skeletest.Internal.Fixtures (FixtureScopeKey (..), cleanupFixtures) import Skeletest.Internal.Markers (-  AnonMarker (..),-  IsMarker (..),-  SomeMarker (..),   findMarker,  ) import Skeletest.Internal.Spec.Output (@@ -57,7 +57,21 @@   reportTestResultWithInlineMessage,   reportTestResultWithoutMessage,  )-import Skeletest.Internal.Spec.Tree (SpecTree (..))+import Skeletest.Internal.Spec.Tree (+  MarkerFocus (..),+  MarkerManual (..),+  MarkerSkip (..),+  MarkerXFail (..),+  SpecInfo (..),+  SpecRegistry,+  SpecTest (..),+  SpecTree (..),+  applyTestSelections,+  getSpecTrees,+  mapSpecs,+  pruneSpec,+ )+import Skeletest.Internal.Spec.Tree qualified as X import Skeletest.Internal.TestInfo (TestInfo (TestInfo), withTestInfo) import Skeletest.Internal.TestInfo qualified as TestInfo import Skeletest.Internal.TestRunner (@@ -66,11 +80,8 @@   testResultFromAssertionFail,   testResultFromError,  )-import Skeletest.Internal.TestTargets (TestTarget, TestTargets, matchesTest)-import Skeletest.Internal.TestTargets qualified as TestTargets import Skeletest.Internal.Utils.Color qualified as Color-import Skeletest.Plugin (Hooks (..), defaultHooks)-import Skeletest.Prop.Internal (Property)+import Skeletest.Plugin (Hooks (..), defaultHooks, filterSpecTests, hasMarker) import System.Console.Terminal.Size qualified as Term import UnliftIO.Exception (   finally,@@ -78,97 +89,44 @@   try,  ) -type Spec = Spec' ()--newtype Spec' a = Spec (Writer [SpecTree] a)-  deriving (Functor, Applicative, Monad)--getSpecTrees :: Spec -> [SpecTree]-getSpecTrees (Spec spec) = execWriter spec--withSpecTrees :: (Monad m) => ([SpecTree] -> m [SpecTree]) -> Spec -> m Spec-withSpecTrees f = fmap (Spec . tell) . f . getSpecTrees---- | Traverse the tree with the given processing function.------ To preprocess trees with @pre@ and postprocess with @post@:------ >>> traverseSpecTrees (\go -> post <=< mapM go <=< pre) spec-traverseSpecTrees ::-  forall m.-  (Monad m) =>-  ( (SpecTree -> m SpecTree) ->-    [SpecTree] ->-    m [SpecTree]-  ) ->-  Spec ->-  m Spec-traverseSpecTrees f = withSpecTrees go- where-  go :: [SpecTree] -> m [SpecTree]-  go = f recurseGroups--  recurseGroups = \case-    group@SpecGroup{} -> do-      trees' <- go $ groupTrees group-      pure group{groupTrees = trees'}-    stest@SpecTest{} -> pure stest---- | Map the tree with the given processing function.------ To preprocess trees with @pre@ and postprocess with @post@:------ >>> mapSpecTrees (\go -> post . map go . pre) spec-mapSpecTrees ::-  ( (SpecTree -> SpecTree) ->-    [SpecTree] ->-    [SpecTree]-  ) ->-  Spec ->-  Spec-mapSpecTrees f = runIdentity . traverseSpecTrees (\go -> pure . f (runIdentity . go))- {----- Execute spec -----}  -- | Run the given Specs and return whether all of the tests passed. runSpecs :: Hooks -> SpecRegistry -> IO Bool-runSpecs hooks0 specs =+runSpecs hooks specs =   (`finally` cleanupFixtures PerSessionFixtureKey) $-    fmap and . forM specs $ \SpecInfo{..} ->+    fmap and . forM (pruneSpec specs) $ \SpecInfo{..} ->       (`finally` cleanupFixtures (PerFileFixtureKey specPath)) $ do         let emptyTestInfo =               TestInfo-                { testContexts = []-                , testName = ""-                , testMarkers = []-                , testFile = specPath+                { contexts = []+                , name = ""+                , markers = []+                , file = specPath                 }         Text.putStrLn $ Text.pack specPath-        specTrees <- hookModifyFileSpecs $ getSpecTrees specSpec+        let specTrees = getSpecTrees specSpec         runTrees emptyTestInfo specTrees  where-  Hooks{..} = builtinHooks <> hooks0-  builtinHooks = xfailHook <> skipHook-   runTrees baseTestInfo = fmap and . mapM (runTree baseTestInfo)   runTree baseTestInfo = \case-    SpecGroup{..} -> do+    SpecTree_Group{..} -> do       let lvl = getIndentLevel baseTestInfo-      reportGroup lvl groupLabel-      runTrees baseTestInfo{TestInfo.testContexts = TestInfo.testContexts baseTestInfo <> [groupLabel]} groupTrees-    SpecTest{..} -> do+      reportGroup lvl label+      runTrees baseTestInfo{TestInfo.contexts = baseTestInfo.contexts <> [label]} trees+    SpecTree_Test test -> do       let lvl = getIndentLevel baseTestInfo-      reportTestInProgress lvl testName+      reportTestInProgress lvl test.name        let testInfo =             baseTestInfo-              { TestInfo.testName = testName-              , TestInfo.testMarkers = testMarkers+              { TestInfo.name = test.name+              , TestInfo.markers = test.markers               }       TestResult{..} <-         withTestInfo testInfo $ do           tid <- myThreadId-          runTest testInfo testAction `finally` cleanupFixtures (PerTestFixtureKey tid)+          runTest testInfo test.action `finally` cleanupFixtures (PerTestFixtureKey tid)        case testResultMessage of         TestResultMessageNone -> do@@ -177,11 +135,11 @@           reportTestResultWithInlineMessage lvl testResultLabel msg         TestResultMessageBox box -> do           termSize <- Term.size-          reportTestResultWithBoxMessage termSize lvl testName testResultLabel box+          reportTestResultWithBoxMessage termSize lvl test.name testResultLabel box       pure testResultSuccess    runTest info action =-    hookRunTest info $ do+    hooks.runTest info $ do       (mCapture, resultOrError) <- withCaptureOutput (try action)       case resultOrError of         Right result -> pure result@@ -191,121 +149,34 @@               Just e' -> testResultFromAssertionFail e'               Nothing -> testResultFromError e -  getIndentLevel testInfo = length (TestInfo.testContexts testInfo) + 1 -- +1 to include the module name--{----- Entrypoint -----}--type SpecRegistry = [SpecInfo]--data SpecInfo = SpecInfo-  { specPath :: FilePath-  , specSpec :: Spec-  }--pruneSpec :: SpecRegistry -> SpecRegistry-pruneSpec = mapMaybe $ \info -> do-  let spec = mapSpecTrees (\go -> filter (not . isEmptySpec) . map go) (specSpec info)-  guard $ (not . null . getSpecTrees) spec-  pure info{specSpec = spec}- where-  isEmptySpec = \case-    SpecGroup _ [] -> True-    _ -> False---- TODO: make hookable? implement manual tests with hook?-applyTestSelections :: TestTargets -> SpecRegistry -> SpecRegistry-applyTestSelections = \case-  Just selections -> map (applyTestSelections' selections)-  -- if no selections are specified, hide manual tests-  Nothing -> map (\info -> info{specSpec = hideManualTests $ specSpec info})- where-  hideManualTests = mapSpecTrees (\go -> filter (not . isManualTest) . map go)-  isManualTest = \case-    SpecGroup{} -> False-    SpecTest{testMarkers} -> isJust $ findMarker @MarkerManual testMarkers--applyTestSelections' :: TestTarget -> SpecInfo -> SpecInfo-applyTestSelections' selections info = info{specSpec = applySelections $ specSpec info}- where-  applySelections = (`Trans.runReader` []) . traverseSpecTrees apply--  apply go = mapMaybeM $ \case-    group@SpecGroup{groupLabel} -> Just <$> Trans.local (<> [groupLabel]) (go group)-    stest@SpecTest{testName, testMarkers} -> do-      groups <- Trans.ask-      let attrs =-            TestTargets.TestAttrs-              { testPath = specPath info-              , testIdentifier = groups <> [testName]-              , testMarkers = [Text.pack $ getMarkerName m | SomeMarker m <- testMarkers]-              }-      pure $-        if matchesTest selections attrs-          then Just stest-          else Nothing--  mapMaybeM f = fmap catMaybes . mapM f+  getIndentLevel testInfo = length testInfo.contexts + 1 -- +1 to include the module name -{----- Defining a Spec -----}+{----- Built-in hooks -----} --- | The entity or concept being tested.-describe :: String -> Spec -> Spec-describe name = runIdentity . withSpecTrees (pure . (: []) . mkGroup)- where-  mkGroup trees =-    SpecGroup-      { groupLabel = Text.pack name-      , groupTrees = trees-      }+applyTestSelectionsHook :: Hooks+applyTestSelectionsHook =+  defaultHooks+    { modifySpecRegistry = \case+        Just selections -> \modify -> fmap (map (applyTestSelections selections)) . modify+        Nothing -> id+    } -test :: (Testable m) => String -> m () -> Spec-test name t = Spec $ tell [mkTest]+manualTestsHook :: Hooks+manualTestsHook =+  defaultHooks+    { modifySpecRegistry = \case+        -- only hide manual tests when no selections are specified+        Just _ -> id+        Nothing -> \modify -> fmap (mapSpecs hideManual) . modify+    }  where-  mkTest =-    SpecTest-      { testName = Text.pack name-      , testMarkers = []-      , testAction = runTestable t-      }---- | Define an IO-based test.------ Should typically be written to be read as full sentences in traditional BDD style:--- https://en.wikipedia.org/wiki/Behavior-driven_development.------ @--- describe \"User\" $ do---   it "can be checked for equality" $ do---     user1 `shouldBe` user1--- @-it :: String -> IO () -> Spec-it = test---- | Define a property test.------ @--- describe \"User\" $ do---   prop "decode . encode === Just" $ do---     let genUser = ...---     (decode . encode) P.=== Just \`shouldSatisfy\` P.isoWith genUser--- @-prop :: String -> Property -> Spec-prop = test--{----- Modifiers -----}---- | Mark the given spec as expected to fail.--- Fails tests if they unexpectedly pass.------ Can be selected with the marker @@xfail@-xfail :: String -> Spec -> Spec-xfail = withMarker . MarkerXFail . Text.pack+  hideManual = filterSpecTests (not . hasMarker @MarkerManual . (.markers))  xfailHook :: Hooks xfailHook =   defaultHooks-    { hookRunTest = \testInfo runTest ->-        case findMarker (TestInfo.testMarkers testInfo) of+    { runTest = \testInfo runTest ->+        case findMarker testInfo.markers of           Just (MarkerXFail reason) -> modify reason <$> runTest           Nothing -> runTest     }@@ -325,17 +196,11 @@           , testResultMessage = TestResultMessageInline reason           } --- | Skip all tests in the given spec.------ Can be selected with the marker @@skip@-skip :: String -> Spec -> Spec-skip = withMarker . MarkerSkip . Text.pack- skipHook :: Hooks skipHook =   defaultHooks-    { hookRunTest = \testInfo runTest ->-        case findMarker (TestInfo.testMarkers testInfo) of+    { runTest = \testInfo runTest ->+        case findMarker (testInfo.markers) of           Just (MarkerSkip reason) ->             pure               TestResult@@ -346,43 +211,18 @@           Nothing -> runTest     } --- | Mark tests as tests that should only be run when explicitly specified on the command line.-markManual :: Spec -> Spec-markManual = withMarker MarkerManual--{----- Markers -----}--newtype MarkerXFail = MarkerXFail Text-  deriving (Show)--instance IsMarker MarkerXFail where-  getMarkerName _ = "xfail"--newtype MarkerSkip = MarkerSkip Text-  deriving (Show)--instance IsMarker MarkerSkip where-  getMarkerName _ = "skip"--data MarkerManual = MarkerManual-  deriving (Show)--instance IsMarker MarkerManual where-  getMarkerName _ = "manual"---- | Adds the given marker to all the tests in the given spec.------ Useful for selecting tests from the command line or identifying tests in hooks-withMarker :: (IsMarker a) => a -> Spec -> Spec-withMarker m = mapSpecTrees (\go -> map (addMarker . go))+focusHook :: Hooks+focusHook =+  defaultHooks+    { modifySpecRegistry = \_ modify -> fmap applyFocus . modify+    }  where-  marker = SomeMarker m-  addMarker = \case-    group@SpecGroup{} -> group-    tree@SpecTest{} -> tree{testMarkers = marker : testMarkers tree}---- | Adds the given names as plain markers to all tests in the given spec.------ See 'getMarkerName'.-withMarkers :: [String] -> Spec -> Spec-withMarkers = foldr (\name acc -> withMarker (AnonMarker name) . acc) id+  applyFocus specs = if hasFocus specs then mapSpecs hideNotFocused specs else specs+  hasFocus = any (anySpecTests isFocused . (.specSpec))+  anySpecTests f spec =+    let go = \case+          SpecTree_Group{trees} -> concatMap go trees+          SpecTree_Test test -> [test]+     in any f $ concatMap go (getSpecTrees spec)+  isFocused test = hasMarker @MarkerFocus test.markers+  hideNotFocused = filterSpecTests isFocused
src/Skeletest/Internal/Spec/Tree.hs view
@@ -1,25 +1,316 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE NoFieldSelectors #-}+ module Skeletest.Internal.Spec.Tree (+  -- * Spec interface+  Spec,   SpecTree (..),+  SpecTest (..),++  -- ** Entrypoint+  SpecRegistry,+  SpecInfo (..),+  pruneSpec,+  applyTestSelections,++  -- ** Defining a Spec+  describe,+  Testable (..),+  test,+  it,+  prop,++  -- ** Modifiers+  MarkerXFail (..),+  xfail,+  MarkerSkip (..),+  skip,+  MarkerFocus (..),+  focus,+  MarkerManual (..),+  markManual,++  -- ** Markers+  IsMarker (..),+  withMarkers,+  withMarker,++  -- ** Internal API+  getSpecTrees,+  withSpecTrees,+  mapSpecTrees,+  traverseSpecTrees,+  mapSpecTests,+  filterSpecTests,+  traverseSpecTests,+  mapSpecs,+  traverseSpecs, ) where +import Control.Monad (guard, (>=>))+import Control.Monad.Trans.Reader qualified as Trans+import Control.Monad.Trans.Writer (Writer, execWriter, tell)+import Data.Functor.Identity (runIdentity)+import Data.Maybe (catMaybes, mapMaybe) import Data.Text (Text)-import Skeletest.Internal.Markers (SomeMarker)+import Data.Text qualified as Text+import Skeletest.Assertions (Testable, runTestable)+import Skeletest.Internal.Markers (+  AnonMarker (..),+  IsMarker (..),+  SomeMarker (..),+ ) import Skeletest.Internal.TestRunner (TestResult)+import Skeletest.Internal.TestTargets (TestTarget, matchesTest)+import Skeletest.Internal.TestTargets qualified as TestTargets+import Skeletest.Prop.Internal (Property) +type Spec = Spec' ()++newtype Spec' a = Spec (Writer [SpecTree] a)+  deriving (Functor, Applicative, Monad)+ data SpecTree-  = SpecGroup-      { groupLabel :: Text-      , groupTrees :: [SpecTree]+  = SpecTree_Group+      { label :: Text+      , trees :: [SpecTree]       }-  | SpecTest-      { testName :: Text-      , testMarkers :: [SomeMarker]-      -- ^ Markers, in order from least to most recently applied.-      ---      -- >>> withMarker MarkerA . withMarker MarkerB $ test ...-      ---      -- will contain-      ---      -- >>> SpecTest { testMarkers = [MarkerA, MarkerB] }-      , testAction :: IO TestResult+  | SpecTree_Test SpecTest++data SpecTest = SpecTest+  { name :: Text+  , markers :: [SomeMarker]+  -- ^ Markers, in order from least to most recently applied.+  --+  -- >>> withMarker MarkerA . withMarker MarkerB $ test ...+  --+  -- will contain+  --+  -- >>> SpecTree_Test { testMarkers = [MarkerA, MarkerB] }+  , action :: IO TestResult+  }++getSpecTrees :: Spec -> [SpecTree]+getSpecTrees (Spec spec) = execWriter spec++withSpecTrees :: (Monad m) => ([SpecTree] -> m [SpecTree]) -> Spec -> m Spec+withSpecTrees f = fmap (Spec . tell) . f . getSpecTrees++-- | Traverse the tree with the given processing function.+--+-- To preprocess trees with @pre@ and postprocess with @post@:+--+-- >>> traverseSpecTrees (\go -> post <=< mapM go <=< pre) spec+traverseSpecTrees ::+  forall m.+  (Monad m) =>+  ((SpecTree -> m SpecTree) -> [SpecTree] -> m [SpecTree]) ->+  Spec ->+  m Spec+traverseSpecTrees f = withSpecTrees go+ where+  go :: [SpecTree] -> m [SpecTree]+  go = f recurseGroups++  recurseGroups = \case+    group@SpecTree_Group{} -> do+      trees' <- go group.trees+      pure group{trees = trees'}+    stest@SpecTree_Test{} -> pure stest++-- | Map the tree with the given processing function.+--+-- To preprocess trees with @pre@ and postprocess with @post@:+--+-- >>> mapSpecTrees (\go -> post . map go . pre) spec+mapSpecTrees ::+  ((SpecTree -> SpecTree) -> [SpecTree] -> [SpecTree]) ->+  Spec ->+  Spec+mapSpecTrees f = runIdentity . traverseSpecTrees (\go -> pure . f (runIdentity . go))++traverseSpecTests :: (Monad m) => (SpecTest -> m SpecTest) -> Spec -> m Spec+traverseSpecTests f = traverseSpecTrees $ \go ->+  traverse $+    go >=> \case+      group@SpecTree_Group{} -> pure group+      SpecTree_Test test_ -> SpecTree_Test <$> f test_++mapSpecTests :: (SpecTest -> SpecTest) -> Spec -> Spec+mapSpecTests f = runIdentity . traverseSpecTests (pure . f)++filterSpecTests :: (SpecTest -> Bool) -> Spec -> Spec+filterSpecTests f = mapSpecTrees $ \go -> filter f' . map go+ where+  f' = \case+    SpecTree_Group{} -> True+    SpecTree_Test test_ -> f test_++{----- Entrypoint -----}++type SpecRegistry = [SpecInfo]++data SpecInfo = SpecInfo+  { specPath :: FilePath+  , specSpec :: Spec+  }++traverseSpecs :: (Applicative f) => (Spec -> f Spec) -> SpecRegistry -> f SpecRegistry+traverseSpecs f = traverse $ \info -> (\spec -> info{specSpec = spec}) <$> f info.specSpec++mapSpecs :: (Spec -> Spec) -> SpecRegistry -> SpecRegistry+mapSpecs f = runIdentity . traverseSpecs (pure . f)++-- | Remove specs with no tests.+pruneSpec :: SpecRegistry -> SpecRegistry+pruneSpec = mapMaybe $ \info -> do+  let spec = mapSpecTrees (\go -> filter (not . isEmptySpec) . map go) info.specSpec+  guard $ (not . null . getSpecTrees) spec+  pure info{specSpec = spec}+ where+  isEmptySpec = \case+    SpecTree_Group _ [] -> True+    _ -> False++applyTestSelections :: TestTarget -> SpecInfo -> SpecInfo+applyTestSelections selections info = info{specSpec = applySelections info.specSpec}+ where+  applySelections = (`Trans.runReader` []) . traverseSpecTrees apply++  apply go = mapMaybeM $ \case+    group@SpecTree_Group{label} -> Just <$> Trans.local (<> [label]) (go group)+    stest@(SpecTree_Test test_) -> do+      groups <- Trans.ask+      let attrs =+            TestTargets.TestAttrs+              { path = info.specPath+              , identifier = groups <> [test_.name]+              , markers = [Text.pack $ getMarkerName m | SomeMarker m <- test_.markers]+              }+      pure $+        if matchesTest selections attrs+          then Just stest+          else Nothing++  mapMaybeM f = fmap catMaybes . mapM f++{----- Defining a Spec -----}++-- | The entity or concept being tested.+describe :: String -> Spec -> Spec+describe name = runIdentity . withSpecTrees (pure . (: []) . mkGroup)+ where+  mkGroup trees =+    SpecTree_Group+      { label = Text.pack name+      , trees       }++test :: (Testable m) => String -> m () -> Spec+test name t = Spec $ tell [mkTest]+ where+  mkTest =+    SpecTree_Test $+      SpecTest+        { name = Text.pack name+        , markers = []+        , action = runTestable t+        }++-- | Define an IO-based test.+--+-- Should typically be written to be read as full sentences in traditional BDD style:+-- https://en.wikipedia.org/wiki/Behavior-driven_development.+--+-- @+-- describe \"User\" $ do+--   it "can be checked for equality" $ do+--     user1 `shouldBe` user1+-- @+it :: String -> IO () -> Spec+it = test++-- | Define a property test.+--+-- @+-- describe \"User\" $ do+--   prop "decode . encode === Just" $ do+--     let genUser = ...+--     (decode . encode) P.=== Just \`shouldSatisfy\` P.isoWith genUser+-- @+prop :: String -> Property -> Spec+prop = test++{----- Modifiers -----}++-- | Mark the given spec as expected to fail with the given description.+-- Fails tests if they unexpectedly pass.+--+-- Can be selected with the marker @@xfail@+xfail :: String -> Spec -> Spec+xfail = withMarker . MarkerXFail . Text.pack++-- | Skip all tests in the given spec with the given description.+--+-- Can be selected with the marker @@skip@+skip :: String -> Spec -> Spec+skip = withMarker . MarkerSkip . Text.pack++-- | If at least one test is focused, skip all unfocused tests.+--+-- This definition includes a WARNING so that CI errors if it's accidentally+-- committed (assuming CI runs with @-Wall -Werror@).+--+-- @since 0.3.4+focus :: Spec -> Spec+focus = withMarker MarkerFocus+{-# WARNING in "x-focused-tests" focus "focus should only be used in development" #-}++-- | Mark tests as tests that should only be run when explicitly specified on the command line.+markManual :: Spec -> Spec+markManual = withMarker MarkerManual++{----- Markers -----}++newtype MarkerXFail = MarkerXFail Text+  deriving (Show)++instance IsMarker MarkerXFail where+  getMarkerName _ = "xfail"++newtype MarkerSkip = MarkerSkip Text+  deriving (Show)++instance IsMarker MarkerSkip where+  getMarkerName _ = "skip"++data MarkerFocus = MarkerFocus+  deriving (Show)++instance IsMarker MarkerFocus where+  getMarkerName _ = "focus"++data MarkerManual = MarkerManual+  deriving (Show)++instance IsMarker MarkerManual where+  getMarkerName _ = "manual"++-- | Adds the given marker to all the tests in the given spec.+--+-- Useful for selecting tests from the command line or identifying tests in hooks+withMarker :: (IsMarker a) => a -> Spec -> Spec+withMarker m = mapSpecTrees (\go -> map (addMarker . go))+ where+  marker = SomeMarker m+  addMarker = \case+    group@SpecTree_Group{} -> group+    SpecTree_Test test_ -> SpecTree_Test test_{markers = marker : test_.markers}++-- | Adds the given names as plain markers to all tests in the given spec.+--+-- See 'getMarkerName'.+withMarkers :: [String] -> Spec -> Spec+withMarkers = foldr (\name acc -> withMarker (AnonMarker name) . acc) id
src/Skeletest/Internal/TestInfo.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoFieldSelectors #-}  module Skeletest.Internal.TestInfo (   TestInfo (..),@@ -20,10 +21,10 @@ import UnliftIO.IORef (IORef, modifyIORef, newIORef, readIORef)  data TestInfo = TestInfo-  { testContexts :: [Text]-  , testName :: Text-  , testMarkers :: [SomeMarker]-  , testFile :: FilePath+  { contexts :: [Text]+  , name :: Text+  , markers :: [SomeMarker]+  , file :: FilePath   -- ^ Relative to CWD   }   deriving (Show)
src/Skeletest/Internal/TestRunner.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoFieldSelectors #-}  module Skeletest.Internal.TestRunner (   -- * Testable
src/Skeletest/Internal/TestTargets.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoFieldSelectors #-}  module Skeletest.Internal.TestTargets (   TestTargets,@@ -23,6 +24,7 @@ import Text.Megaparsec.Char qualified as Parser import Text.Megaparsec.Char.Lexer qualified as Parser.L +-- | 'Nothing' means no test targets were provided to the CLI type TestTargets = Maybe TestTarget  data TestTarget@@ -37,9 +39,9 @@   deriving (Eq)  data TestAttrs = TestAttrs-  { testPath :: FilePath-  , testIdentifier :: [Text]-  , testMarkers :: [Text]+  { path :: FilePath+  , identifier :: [Text]+  , markers :: [Text]   }  matchesTest :: TestTarget -> TestAttrs -> Bool@@ -47,9 +49,9 @@  where   go = \case     TestTargetEverything -> True-    TestTargetFile path -> testPath == path-    TestTargetName s -> s `Text.isInfixOf` Text.unwords testIdentifier-    TestTargetMarker marker -> marker `elem` testMarkers+    TestTargetFile path' -> path == path'+    TestTargetName s -> s `Text.isInfixOf` Text.unwords identifier+    TestTargetMarker marker -> marker `elem` markers     TestTargetNot e -> not $ go e     TestTargetAnd l r -> go l && go r     TestTargetOr l r -> go l || go r
src/Skeletest/Main.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -20,7 +21,7 @@   Spec, ) where -import Control.Monad (unless)+import Control.Monad (unless, (<=<)) import Skeletest.Internal.CLI (Flag, flag, loadCliArgs) import Skeletest.Internal.Capture (CaptureOutputFlag) import Skeletest.Internal.Snapshot (@@ -33,11 +34,14 @@ import Skeletest.Internal.Spec (   Spec,   SpecInfo (..),-  applyTestSelections,-  pruneSpec,+  applyTestSelectionsHook,+  focusHook,+  manualTestsHook,   runSpecs,+  skipHook,+  xfailHook,  )-import Skeletest.Plugin (Plugin (..))+import Skeletest.Plugin (Hooks (..), Plugin (..)) import Skeletest.Prop.Internal (PropLimitFlag, PropSeedFlag) import System.Exit (exitFailure) @@ -45,14 +49,24 @@ runSkeletest = runSkeletest' . mconcat  runSkeletest' :: Plugin -> [(FilePath, Spec)] -> IO ()-runSkeletest' Plugin{..} testModules = do+runSkeletest' Plugin{hooks = hooks0, ..} testModules = do   selections <- loadCliArgs builtinFlags cliFlags   setSnapshotRenderers (snapshotRenderers <> defaultSnapshotRenderers)    let initialSpecs = map mkSpec testModules-  success <- runSpecs hooks . pruneSpec . applyTestSelections selections $ initialSpecs+  success <- runSpecs hooks <=< hooks.modifySpecRegistry selections pure $ initialSpecs   unless success exitFailure  where+  hooks = mconcat builtinHooks <> hooks0++  builtinHooks =+    [ xfailHook+    , skipHook+    , focusHook+    , applyTestSelectionsHook+    , manualTestsHook+    ]+   builtinFlags =     [ flag @SnapshotUpdateFlag     , flag @PropSeedFlag
src/Skeletest/Plugin.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE NoFieldSelectors #-}+ module Skeletest.Plugin (   -- * Plugin   Plugin (..),@@ -10,27 +14,47 @@   -- * Re-exports    -- ** TestResult-  TestResult (..),-  TestResultMessage (..),-  BoxSpec,-  BoxSpecContent (..),+  X.TestResult (..),+  X.TestResultMessage (..),+  X.BoxSpec,+  X.BoxSpecContent (..),    -- ** TestInfo-  TestInfo (..),+  X.TestInfo (..),    -- ** Markers-  findMarker,-  hasMarkerNamed,+  X.findMarker,+  X.hasMarker,+  X.hasMarkerNamed,++  -- ** SpecRegistry+  X.SpecRegistry,+  X.Spec,+  X.SpecInfo (..),+  X.SpecTree (..),+  X.SpecTest (..),+  X.getSpecTrees,+  X.withSpecTrees,+  X.mapSpecTrees,+  X.traverseSpecTrees,+  X.mapSpecTests,+  X.traverseSpecTests,+  X.filterSpecTests,+  X.mapSpecs,+  X.traverseSpecs, ) where -import Control.Monad ((>=>)) import Skeletest.Internal.CLI (Flag)-import Skeletest.Internal.Markers (findMarker, hasMarkerNamed)+import Skeletest.Internal.Markers qualified as X import Skeletest.Internal.Snapshot (SnapshotRenderer)-import Skeletest.Internal.Spec.Output (BoxSpec, BoxSpecContent (..))-import Skeletest.Internal.Spec.Tree (SpecTree)+import Skeletest.Internal.Spec.Output qualified as X+import Skeletest.Internal.Spec.Tree (SpecRegistry)+import Skeletest.Internal.Spec.Tree qualified as X import Skeletest.Internal.TestInfo (TestInfo (..))-import Skeletest.Internal.TestRunner (TestResult (..), TestResultMessage (..))+import Skeletest.Internal.TestInfo qualified as X+import Skeletest.Internal.TestRunner (TestResult (..))+import Skeletest.Internal.TestRunner qualified as X+import Skeletest.Internal.TestTargets (TestTargets)  -- | A plugin for extending Skeletest. --@@ -45,9 +69,9 @@ instance Semigroup Plugin where   plugin1 <> plugin2 =     Plugin-      { cliFlags = cliFlags plugin1 <> cliFlags plugin2-      , snapshotRenderers = snapshotRenderers plugin1 <> snapshotRenderers plugin2-      , hooks = hooks plugin1 <> hooks plugin2+      { cliFlags = plugin1.cliFlags <> plugin2.cliFlags+      , snapshotRenderers = plugin1.snapshotRenderers <> plugin2.snapshotRenderers+      , hooks = plugin1.hooks <> plugin2.hooks       }  instance Monoid Plugin where@@ -66,18 +90,25 @@ -- Use 'defaultHooks' instead of using v'Hooks' directly, to minimize -- breaking changes. data Hooks = Hooks-  { hookModifyFileSpecs :: [SpecTree] -> IO [SpecTree]-  -- ^ Modify the specs in a file-  -- @since 0.3.2-  , hookRunTest :: TestInfo -> IO TestResult -> IO TestResult+  { modifySpecRegistry :: TestTargets -> (SpecRegistry -> IO SpecRegistry) -> (SpecRegistry -> IO SpecRegistry)+  -- ^ Modify all the specs in the test suite, being able to modify before/after+  -- previously registered hooks.+  --+  -- For example:+  -- @+  -- \_ modify -> pre >=> modify >=> post+  -- @+  --+  -- @since 0.3.4+  , runTest :: TestInfo -> IO TestResult -> IO TestResult   -- ^ Modify how a test is executed   }  instance Semigroup Hooks where   hooks1 <> hooks2 =     Hooks-      { hookModifyFileSpecs = hookModifyFileSpecs hooks1 >=> hookModifyFileSpecs hooks2-      , hookRunTest = \testInfo -> hookRunTest hooks2 testInfo . hookRunTest hooks1 testInfo+      { modifySpecRegistry = \targets -> hooks2.modifySpecRegistry targets . hooks1.modifySpecRegistry targets+      , runTest = \testInfo -> hooks2.runTest testInfo . hooks1.runTest testInfo       }  instance Monoid Hooks where@@ -86,6 +117,6 @@ defaultHooks :: Hooks defaultHooks =   Hooks-    { hookModifyFileSpecs = pure-    , hookRunTest = \_ -> id+    { modifySpecRegistry = \_ -> id+    , runTest = \_ -> id     }
src/Skeletest/Prop/Internal.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE RecordWildCards #-}  module Skeletest.Prop.Internal (@@ -239,7 +240,7 @@               failure                 { testFailContext =                     -- N.B. testFailContext is reversed!-                    testFailContext failure <> reverse info+                    failure.testFailContext <> reverse info                 }  where   reportProgress _ = pure ()
test/Skeletest/Internal/SpecSpec.hs view
@@ -56,6 +56,23 @@       stderr `shouldBe` ""       stdout `shouldSatisfy` P.matchesSnapshot +  describe "focus" $ do+    -- TODO: test that using focus with -Werror fails+    integration . it "only runs focused test" $ do+      runner <- getFixture+      addTestFile runner "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , ""+        , "spec = do"+        , "  focus . it \"in progress\" $ pure ()"+        , "  it \"not working yet\" $ failTest \"broken\""+        ]++      (stdout, _) <- expectSuccess $ runTests runner []+      stdout `shouldSatisfy` P.matchesSnapshot+   describe "markManual" $ do     integration . it "skips manual tests by default" $ do       runner <- getFixture
test/Skeletest/Internal/TestTargetsSpec.hs view
@@ -11,9 +11,9 @@   describe "matchesTest" $ do     let someAttrs =           TestAttrs-            { testPath = "MyTestSpec.hs"-            , testIdentifier = ["a", "b", "test name"]-            , testMarkers = ["mark1", "mark2"]+            { path = "MyTestSpec.hs"+            , identifier = ["a", "b", "test name"]+            , markers = ["mark1", "mark2"]             }      sequence_@@ -28,37 +28,37 @@           ,             ( "matches tests in file"             , TestTargetFile "FooSpec.hs"-            , someAttrs{testPath = "FooSpec.hs"}+            , someAttrs{path = "FooSpec.hs"}             )           ,             ( "matches test name substring"             , TestTargetName "foo"-            , someAttrs{testIdentifier = ["group1", "group2", "my foo test"]}+            , someAttrs{identifier = ["group1", "group2", "my foo test"]}             )           ,             ( "matches group name substring"             , TestTargetName "fooFunc"-            , someAttrs{testIdentifier = ["fooFunction", "does a thing"]}+            , someAttrs{identifier = ["fooFunction", "does a thing"]}             )           ,             ( "matches a marker exactly"             , TestTargetMarker "fast"-            , someAttrs{testMarkers = ["fast", "slow"]}+            , someAttrs{markers = ["fast", "slow"]}             )           ,             ( "matches a NOT target when target does not match"             , TestTargetNot (TestTargetFile "FooSpec.hs")-            , someAttrs{testPath = "BarSpec.hs"}+            , someAttrs{path = "BarSpec.hs"}             )           ,             ( "matches an AND target when target matches both"             , TestTargetAnd (TestTargetFile "FooSpec.hs") (TestTargetMarker "fast")-            , someAttrs{testPath = "FooSpec.hs", testMarkers = ["fast"]}+            , someAttrs{path = "FooSpec.hs", markers = ["fast"]}             )           ,             ( "matches an OR target when target matches one"             , TestTargetOr (TestTargetFile "FooSpec.hs") (TestTargetMarker "fast")-            , someAttrs{testPath = "FooSpec.hs", testMarkers = []}+            , someAttrs{path = "FooSpec.hs", markers = []}             )           ]       ]@@ -70,32 +70,32 @@           [             ( "does not match test in another file"             , TestTargetFile "FooSpec.hs"-            , someAttrs{testPath = "BarSpec.hs"}+            , someAttrs{path = "BarSpec.hs"}             )           ,             ( "does not match test not containing name"             , TestTargetName "foo"-            , someAttrs{testIdentifier = ["group1", "group2", "other test"]}+            , someAttrs{identifier = ["group1", "group2", "other test"]}             )           ,             ( "does not match marker substring"             , TestTargetMarker "fastish"-            , someAttrs{testMarkers = ["fast"]}+            , someAttrs{markers = ["fast"]}             )           ,             ( "does not match a NOT target when target matches"             , TestTargetNot (TestTargetFile "FooSpec.hs")-            , someAttrs{testPath = "FooSpec.hs"}+            , someAttrs{path = "FooSpec.hs"}             )           ,             ( "does not match an AND target when target does not match one"             , TestTargetAnd (TestTargetFile "FooSpec.hs") (TestTargetMarker "fast")-            , someAttrs{testPath = "BarSpec.hs", testMarkers = ["fast"]}+            , someAttrs{path = "BarSpec.hs", markers = ["fast"]}             )           ,             ( "does not match an OR target when target does not match either"             , TestTargetOr (TestTargetFile "FooSpec.hs") (TestTargetMarker "fast")-            , someAttrs{testPath = "BarSpec.hs", testMarkers = []}+            , someAttrs{path = "BarSpec.hs", markers = []}             )           ]       ]
test/Skeletest/Internal/__snapshots__/SpecSpec.snap.md view
@@ -1,5 +1,12 @@ # test/Skeletest/Internal/SpecSpec.hs +## focus / only runs focused test++```+./ExampleSpec.hs+    in progress: OK+```+ ## skip / skips tests completely  ```
+ test/Skeletest/PluginSpec.hs view
@@ -0,0 +1,62 @@+module Skeletest.PluginSpec (spec) where++import Skeletest+import Skeletest.Predicate qualified as P+import Skeletest.TestUtils.Integration++spec :: Spec+spec = do+  describe "runTest" $ do+    integration . it "allows hooking into test execution" $ do+      runner <- getFixture+      setMainFile runner $+        [ "import Skeletest.Main"+        , "import Skeletest.Plugin"+        , ""+        , "plugins = [defaultPlugin{hooks = myHooks}]"+        , "myHooks = defaultHooks"+        , "  { runTest = \\_ run -> do"+        , "      putStrLn \"before test\""+        , "      result <- run"+        , "      putStrLn \"after test\""+        , "      pure result"+        , "  }"+        ]+      addTestFile runner "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , "import Skeletest"+        , "spec = it \"should run\" $ pure ()"+        ]+      (stdout, _) <- expectSuccess $ runTests runner []+      stdout `shouldSatisfy` P.matchesSnapshot++  describe "modifySpecRegistry" $ do+    integration . it "allows modifying specs" $ do+      runner <- getFixture+      setMainFile runner $+        [ "{-# LANGUAGE DisambiguateRecordFields #-}"+        , "{-# LANGUAGE LambdaCase #-}"+        , "{-# LANGUAGE NamedFieldPuns #-}"+        , "{-# LANGUAGE OverloadedRecordDot #-}"+        , "{-# LANGUAGE OverloadedStrings #-}"+        , ""+        , "import qualified Data.Text as T"+        , "import Skeletest.Main"+        , "import Skeletest.Plugin"+        , ""+        , "plugins = [defaultPlugin{hooks = myHooks}]"+        , "myHooks = defaultHooks"+        , "  { modifySpecRegistry = \\_ modify -> (fmap . mapSpecs . filterSpecTests) isValid . modify"+        , "  }"+        , " where"+        , "  isValid = not . (\"SKIP\" `T.isPrefixOf`) . (.name)"+        ]+      addTestFile runner "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , "import Skeletest"+        , "spec = do"+        , "  it \"should run\" $ pure ()"+        , "  it \"SKIP should not run\" $ failTest \"bad\""+        ]+      (stdout, _) <- expectSuccess $ runTests runner []+      stdout `shouldSatisfy` P.matchesSnapshot
test/Skeletest/TestUtils/Integration.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoFieldSelectors #-}  module Skeletest.TestUtils.Integration (   integration,@@ -76,7 +78,7 @@ addTestFile :: FixtureTestRunner -> FilePath -> FileContents -> IO () addTestFile FixtureTestRunner{testRunnerSettingsRef} fp contents =   modifyIORef testRunnerSettingsRef $ \settings ->-    settings{testFiles = (fp, contents) : testFiles settings}+    settings{testFiles = (fp, contents) : settings.testFiles}  readTestFile :: FixtureTestRunner -> FilePath -> IO String readTestFile FixtureTestRunner{testRunnerDir} fp = readFile $ testRunnerDir </> fp
+ test/Skeletest/__snapshots__/PluginSpec.snap.md view
@@ -0,0 +1,17 @@+# test/Skeletest/PluginSpec.hs++## modifySpecRegistry / allows modifying specs++```+./ExampleSpec.hs+    should run: OK+```++## runTest / allows hooking into test execution++```+./ExampleSpec.hs+    should run: before test+after test+OK+```