packages feed

skeletest (empty) → 0.1.0

raw patch · 57 files changed

+7578/−0 lines, 57 filesdep +Diffdep +aesondep +aeson-pretty

Dependencies added: Diff, aeson, aeson-pretty, ansi-terminal, base, containers, directory, filepath, ghc, hedgehog, megaparsec, ordered-containers, parser-combinators, pretty, process, recover-rtti, skeletest, template-haskell, text, transformers, unliftio

Files

+ CHANGELOG.md view
@@ -0,0 +1,3 @@+## v0.1.0++Initial release
+ LICENSE.md view
@@ -0,0 +1,11 @@+Copyright © 2024-present Brandon Chinn++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,458 @@+# Skeletest++Skeletest is a batteries-included, opinionated test framework heavily inspired by [pytest](https://pytest.org) and [jest](https://jestjs.io). It's the built-in test framework for [Skelly](https://github.com/brandonchinn178/skelly), but it can be used as a standalone library as well.++Features:+* Seamless experience writing unit tests, property tests, and snapshot tests+* Descriptive failure messages+* Easy test selection from CLI+* Automatic fixtures management+* Rich plugin + hooks functionality++## Example++```haskell+import Skeletest+import qualified Skeletest.Predicate as P+import qualified Skeletest.Prop.Gen as Gen+import qualified Skeletest.Prop.Range as Range++spec :: Spec+spec = do+  describe "myFunc" $ do+    it "returns the correct list" $+      myFunc 1 2 `shouldBe` ["a", "b", "c"]++    it "returns a list containing an element" $+      myFunc 1 2 `shouldSatisfy` P.any (P.eq "a")++    it "returns a list matching the given predicates" $+      myFunc 1 2 `shouldSatisfy` P.list [P.eq "a", P.anything, P.anything]++    prop "myFunc 0 x == []" $ do+      x <- gen $ Gen.int (Range.linear 0 100)+      myFunc 0 x `shouldBe` ""++    prop "myFunc x y == myFunc y x" $ do+      x <- gen $ Gen.int (Range.linear 0 100)+      y <- gen $ Gen.int (Range.linear 0 100)+      myFunc x y `shouldBe` myFunc y x++  -- top-level property that's not grouped under+  -- either myFunc nor otherFunc+  prop "myFunc x . otherFunc === id" $ do+    x <- gen $ Gen.int (Range.linear 0 100)+    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++  describe "ioFunc" $ do+    it "returns the correct string" $ do+      DbConnFixture conn <- getFixture+      ioFunc conn 1 `shouldSatisfy` P.returns (P.eq "hello world")++    it "errors on bad input" $ do+      DbConnFixture conn <- getFixture+      ioFunc conn (-1) `shouldSatisfy` P.throws (P.eq MyException)++    it "returns the expected result" $ do+      DbConnFixture conn <- getFixture+      ioFunc conn 100 `shouldSatisfy` P.matchesSnapshot++  describe "getUser" $ do+    it "returns a matching user" $ do+      getUser "user1" `shouldSatisfy` P.con User{name = P.eq "user1", email = P.contains "@"}++newtype DbConnFixture = DbConnFixture Connection++instance Fixture DbConnFixture where+  fixtureAction = do+    conn <- initDBConn+    setupTestTables conn+    pure . withCleanup (DbConnFixture conn) $ do+      destroyTestTables conn+      closeConn conn+```++## Quickstart++1. If you're using Skeletest as a standalone library, add the following to your cabal file:++    ```cabal+    test-suite my-tests+      ghc-options: -F -pgmF=skeletest-preprocessor+      build-tool-depends: skeletest:skeletest-preprocessor+    ```++1. Add `Main.hs`:++    ```haskell+    import Skeletest.Main+    ```++1. To test some module `MyLib.Foo`, add a new file `MyLib/FooSpec.hs`:++    ```haskell+    module MyLib.FooSpec (spec) where++    import Skeletest+    import qualified Skeletest.Predicate as P++    spec :: Spec+    spec = do+      describe "myFunc" $ do+        it "does a thing" $ do+          myFunc 1 `shouldBe` 2+    ```++## Guide++### Defining tests++Tests should be defined in a `spec` identifier with the type `Spec`. A `Spec` is defined as a tree of tests, written using do-notation. The entire `Spec` is wrapped in an implicit `describe` containing the name of the module without the `Spec` suffix. The `describe` and `it` functions are intended to read nicely if you use types or function names as `describe` groups.++```haskell+spec :: Spec+spec = do+  -- A property test, grouped under the implicit module group.+  -- See the "Property tests" section.+  prop "encodeUser . decodeUser === id" $ do+    ...++  describe "encodeUser" $ do+    -- A unit test testing a particular aspect of the encodeUser function.+    -- See the "Unit tests" section.+    it "encodes a user with a name" $ do+      ...++    it "encodes an empty user" $ do+      ...+```++Tests can also be marked as `xfail` or `skip`. `xfail` tests will succeed if the test fails, or fail if the test unexpectedly passes. `skip` tests will skip running the test entirely. Both `xfail` and `skip` require a message explaining the reason it; this is a good place to put links to the relevant ticket or issue.++```haskell+-- xfail a single test+xfail "https://github.com/my-company/my-repo/issues/123" . it "does a thing" $ do+  ...++-- xfail multiple tests+xfail "https://github.com/my-company/my-repo/issues/123" $ do+  it "does a thing" $ do+    ...++  it "does another thing" $ do+    ...++-- skip a whole describe+skip "https://github.com/my-company/my-repo/issues/123" . describe "myFunc" $ do+  it "does a thing" $ do+    ...+```++`markManual` marks tests in the given section as manual tests, which means they won't be run when no tests are selected (see the "Test selection" section).++```haskell+markManual $ do+  ...+```++### Test selection++Test targets are specified as plain positional arguments, with the following syntax:++| Target | Explanation |+|--------|-------------|+| `*`                     | Selects all tests (useful to include manual tests) |+| `[myFooFunc]`           | Tests including substring      |+| `@fast`                 | Tests tagged with marker       |+| `test/MyLib/FooSpec.hs` | Tests in file, relative to CWD |+| `test/MyLib/FooSpec.hs[myFooFunc]` | Syntax sugar for `(test/MyLib/FooSpec.hs and [myFooFunc])` |+| `[func1] and @fast`     | Tests matching both targets    |+| `[func1] or @fast`      | Tests matching either target   |+| `not [func1]`           | Tests not matching target      |++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++All assertions in Skeletest use the following functions:++* `shouldSatisfy`+* `shouldNotSatisfy` - equivalent to `shouldSatisfy` with `P.not`+* `shouldBe` - equivalent to `shouldSatisfy` with `P.eq`+* `shouldNotBe` - equivalent to `shouldNotSatisfy` with `P.eq`++`shouldSatisfy` is the most general function, but the others are provided for convenience. `shouldSatisfy` takes in the value being tested on the left, and a predicate on the right. Predicates should be imported from `Skeletest.Predicate`, qualified as `P`.++Some notable predicates are listed here. See the [Haddocks](https://hackage.haskell.org/package/aeson-schemas/docs/Skeletest-Predicate.html) for a full list of available predicates.++* `P.eq 10`+    * Satisfied when the actual value is equal to `10`.++* `P.just (P.gt 10)`+    * Satisfied when the actual value is a `Just` containing a value greater than `10`.++* `P.tup (P.eq 10, P.anything)`+    * Satisfied when the actual value is a tuple where the first element is `10` and the second element is anything. `P.tup` works for any tuple up to 6 elements.++* `P.con User{name = P.hasPrefix "user_"}`+    * Satisfied when the actual value is a `User` whose `name` field starts with `user_`. Omitted fields are not checked and can contain anything. `P.con` also works for positional constructors, except all arguments must contain predicates.++* `P.eq 10 P.<<< f`+    * Satisfied when the actual value is equal to `10` after being applied to `f`.++* `P.approx P.tol 0.5`+    * Satisfied when the actual value is approximately equal to `0.5`. Useful for floating point values. See docs for an explanation of how to adjust the tolerance with `P.tol`.++* `P.and [P.gt 0, P.lt 10]`+    * Satisfied when the actual value satisfies all of the given predicates. For just two predicates, `P.&&` can be used. Also see: `P.or`, `P.||`++* `P.returns (P.gt 10)`+    * Satisfied when the left hand side is an `IO` action that returns a value greater than `10`.++* `P.throws MyException`+    * Satisfied when the left hand side is an `IO` action that throws the given exception.++### Unit and Integration tests++Unit and integration tests are written with `it`, and run in `IO`.++```haskell+describe "mkUser" $ do+  it "creates a user with the given name" $ do+    let x = mkUser (Just "alice")+    x `shouldBe` User{name = "alice"}++    mkUser (Just "alice") `shouldBe` User{name = "alice"}++  it "creates a user with a default name" $ do+    mkUser Nothing `shouldSatisfy` P.con User{name = P.hasPrefix "user_"}++describe "addService" $ do+  it "queries the addition service" $ do+    x <- addService 1 2+    x `shouldBe` 3++    addService 1 2 `shouldSatisfy` P.returns (P.eq 3)+```++### Snapshot tests++[Snapshot tests](https://ro-che.info/articles/2017-12-04-golden-tests) can be done in any kind of test, although it's usually done in unit tests. Snapshot tests are best suited for testing that behavior doesn't change; they aren't great for testing _correctness_.++To write a snapshot test, simply use the `P.matchesSnapshot` predicate.++```haskell+myFunc 1 `shouldSatisfy` P.matchesSnapshot++-- can also snapshot within a nested predicate+fetchUserFromDb "alice" `shouldSatisfy` P.returns (P.just P.matchesSnapshot)+```++When running for the first time, or when the snapshot is changing, use the `-u`/`--update` flag. For a given test file `MyLib/FooSpec.hs`, snapshots are stored at `MyLib/__snapshots__/FooSpec.snap.md`. Snapshots are stored in a Markdown file that's easy to visually inspect in an editor or on GitHub.++Values will be rendered via their internal heap representation; even if the type has a `Show` instance, it won't be used. To use the show instance, add the following to `Main.hs`:++```haskell+snapshotRenderers =+  [ renderWithShow @User+  ]+```++You can also specify a custom renderer by implementing a `SnapshotRenderer` yourself, probably using `plainRenderer`.++Currently, old snapshots are not cleaned up, so you'll have to manually clean up snapshots if you rename or remove a test. ([Issue #24](https://github.com/brandonchinn178/skeletest/issues/24))++### Property tests++Property tests are written with `prop` and run in the `PropertyM` monad (`Property` is an alias for `PropertyM ()`). To write property tests, add the following imports:++```haskell+import qualified Skeletest.Prop.Gen as Gen+import qualified Skeletest.Prop.Range as Range+```++Property tests consist of two things: generating random data with `forAll` and checking properties using the usual `shouldSatisfy` assertions. See the [Haddocks](https://hackage.haskell.org/package/skeletest/docs/Skeletest-Prop-Gen.html) for the different ways to generate data.++```haskell+prop "reverse does not change the length" $ do+  xs <- forAll $ Gen.list (Gen.range 0 10) Gen.int+  length (reverse xs) `shouldBe` length xs+```++One common usecase is to verify that two functions are isomorphic. This can be tested with the `P.===` operator:++```haskell+prop "decodeUser . encodeUser === pure" $ do+  let genUser = User <$> Gen.text (Gen.range 0 10) Gen.unicode+  (decodeUser . encodeUser) P.=== pure `shouldSatisfy` P.isoWith genUser+```++If a test fails, it'll say something like `Rerun with --seed=6430645105429331403:9929029875326664391 to reproduce`. Rerunning with that flag will generate the same random value for debugging.++To ignore certain values, use `discard`:++```haskell+x <- Gen.int (Gen.range (-10) 10)+when (x == 0) discard+...+```++Property tests can also be configured with the following functions. These must be called at the very beginning of the test, before any `forAll` calls. Values specified with CLI flags take precedence over the values in the code.++* `setDiscardLimit`+    * The max number of values to discard before reporting a failure+    * Default: `100`++* `setShrinkLimit`+    * The max number of shrinks before giving up+    * Default: `1000`++* `setShrinkRetries`+    * The number of times to re-run a test during shrinking. This is useful if you are testing something which fails non-deterministically and you want to increase the change of getting a good shrink. e.g. `10` means a test must pass 10 times before trying a different shrink+    * Default: `0`++* `setConfidence`+    * The acceptable occurrence of false positives. e.g. `10^9` means accepting a false positive for 1 in 10^9 tests+    * Default: don't check confidence++* `setVerifiedTermination`+    * Validate confidence is reached+    * Default: disabled++* `setTestLimit`+    * The number of tests to run before reporting success+    * Default: `100`+    * CLI flag: `--prop-test-limit`++Internally, Skeletest uses Hedgehog to run property tests, but the API is intended to stay the same, even if the underlying engine changes.++### Fixtures++Fixtures are a useful way to reuse setup logic between tests. They're commonly used to initialize a database connection, set up users, etc. Fixtures can also use other fixtures. Fixtures are cached for the given scope and cleaned up when that scope is exited.++```haskell+data DbConnFixture = DbConnFixture Connection++instance Fixture DbConnFixture where+  -- defaults to per-test+  fixtureScope = PerSessionFixture++  fixtureAction = do+    conn <- initDBConn+    pure . withCleanup (DbConnFixture conn) $ do+      closeConn conn++spec :: Spec+spec = do+  it "creates a user" $ do+    DbConnFixture conn <- getFixture+    createUser conn "alice" `shouldSatisfy` P.not (P.throws P.anything)++  it "fetches a user" $ do+    -- reuses the same connection initialized in the first test+    DbConnFixture conn <- getFixture+    getUser conn "alice" `shouldSatisfy` P.just (P.con User{name = P.eq "alice"})+```++#### Built-in fixtures++The following fixtures are available out of the box:++* `FixtureTmpDir` - Contains a temporary directory that is cleaned up between tests.++    ```haskell+    FixtureTmpDir tmpDir <- getFixture+    writeFile (tmpDir </> "myfile.txt") "test"+    ````++### Markers++Markers are a useful way to mark tests for selection (see "Test selection"). There are two ways to mark a test:++1. With anonymous markers:++    ```haskell+    withMarkers ["foo", "bar"] $ do+      ...+    ```++    All tests in the given section will be marked with anonymous markers named "foo" and "bar", which can be selected with `@foo` and `@bar`, respectively.++1. With typed markers:++    ```haskell+    data MyMarker = MyMarker Int+    instance IsMarker MyMarker where+      getMarkerName _ = "my-marker"++    withMarker (MyMarker 10) $ do+      ...+    ```++    All tests in the given section will be marked with the given marker, which can be selected with `@my-marker`. You can see if a test has a marker with `findMarkers` (see the "Hooks" section).++### Custom CLI flags++To register and use your own CLI flags, do the following:++1. Create an instance of `IsFlag`++1. In `Main.hs`, add the following:++    ```haskell+    import TestUtils.Flags (MyFlag)++    cliFlags =+      [ flag @MyFlag+      ]+    ```++1. In a fixture or test, do the following:++    ```haskell+    MyFlag flagVal <- getFlag+    ```++### Hooks++Skeletest lets you hook into specific parts of test execution. Skeletest currently supports the following hooks:++* `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`.++### Plugins++Skeletest is fully pluggable; any configuration specified in `Main.hs` (e.g. `cliFlags` or `snapshotRenderer`) can be defined in a `Plugin` that you can import from another module or even another package.++```haskell+module TestUtils.Plugins (myPlugin) where++import Skeletest.Plugin++myPlugin :: Plugin+myPlugin =+  defaultPlugin+    { hooks =+        defaultHooks+          { hookRunTest = \testInfo runTest -> do+              putStrLn "before test"+              result <- runTest+              putStrLn "after test"+              pure result+          }+    }+```++```haskell+import TestUtils.Plugins (myPlugin)++plugins =+  [ myPlugin+  ]+```
+ skeletest.cabal view
@@ -0,0 +1,133 @@+cabal-version: 3.0++name: skeletest+version: 0.1.0+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+bug-reports: https://github.com/brandonchinn178/skeletest/issues+author: Brandon Chinn <brandonchinn178@gmail.com>+maintainer: Brandon Chinn <brandonchinn178@gmail.com>+license: BSD-3-Clause+license-file: LICENSE.md+category: Testing+build-type: Simple+extra-source-files:+  README.md+  CHANGELOG.md+  test/__snapshots__/ExampleSpec.snap.md+  test/Skeletest/__snapshots__/AssertionsSpec.snap.md+  test/Skeletest/__snapshots__/PropSpec.snap.md+  test/Skeletest/__snapshots__/MainSpec.snap.md+  test/Skeletest/__snapshots__/PredicateSpec.snap.md+  test/Skeletest/Internal/__snapshots__/SnapshotSpec.snap.md+  test/Skeletest/Internal/__snapshots__/CLISpec.snap.md+  test/Skeletest/Internal/__snapshots__/FixturesSpec.snap.md+  test/Skeletest/Internal/__snapshots__/TestTargetsSpec.snap.md+  test/Skeletest/Internal/__snapshots__/SpecSpec.snap.md++source-repository head+  type: git+  location: https://github.com/brandonchinn178/skeletest++library+  hs-source-dirs: src+  exposed-modules:+    Skeletest+    Skeletest.Assertions+    Skeletest.Internal.CLI+    Skeletest.Internal.Constants+    Skeletest.Internal.Error+    Skeletest.Internal.Fixtures+    Skeletest.Internal.GHC+    Skeletest.Internal.GHC.Compat+    Skeletest.Internal.Markers+    Skeletest.Internal.Plugin+    Skeletest.Internal.Predicate+    Skeletest.Internal.Preprocessor+    Skeletest.Internal.Snapshot+    Skeletest.Internal.Spec+    Skeletest.Internal.TestInfo+    Skeletest.Internal.TestRunner+    Skeletest.Internal.TestTargets+    Skeletest.Internal.Utils.Color+    Skeletest.Internal.Utils.Diff+    Skeletest.Internal.Utils.HList+    Skeletest.Internal.Utils.Map+    Skeletest.Main+    Skeletest.Plugin+    Skeletest.Predicate+    Skeletest.Prop.Gen+    Skeletest.Prop.Internal+    Skeletest.Prop.Range+  if impl(ghc >= 9.6) && impl(ghc < 9.8)+    other-modules:+        Skeletest.Internal.GHC.Compat_9_6+  if impl(ghc >= 9.8) && impl(ghc < 9.10)+    other-modules:+        Skeletest.Internal.GHC.Compat_9_8+  if impl(ghc >= 9.10) && impl(ghc < 9.12)+    other-modules:+        Skeletest.Internal.GHC.Compat_9_10+  build-depends:+      base < 5+    , aeson+    , aeson-pretty+    , ansi-terminal >= 0.4.0+    , containers+    , Diff >= 0.5+    , directory+    , filepath+    , ghc ^>= 9.6 || ^>= 9.8 || ^>= 9.10+    , hedgehog+    , megaparsec+    , ordered-containers >= 0.2.4+    , parser-combinators+    , pretty+    , recover-rtti+    , template-haskell+    , text+    , transformers+    , unliftio >= 0.2.17+  default-language: GHC2021+  ghc-options: -Wall -Wcompat++executable skeletest-preprocessor+  main-is: src/bin/skeletest-preprocessor.hs+  build-depends:+      base+    , skeletest+    , text+  default-language: GHC2021+  ghc-options: -Wall -Wcompat++test-suite skeletest-tests+  type: exitcode-stdio-1.0+  ghc-options: -F -pgmF=skeletest-preprocessor+  build-tool-depends: skeletest:skeletest-preprocessor+  hs-source-dirs: test+  main-is: Main.hs+  other-modules:+    ExampleSpec+    Skeletest.AssertionsSpec+    Skeletest.Internal.CLISpec+    Skeletest.Internal.FixturesSpec+    Skeletest.Internal.SnapshotSpec+    Skeletest.Internal.SpecSpec+    Skeletest.Internal.TestTargetsSpec+    Skeletest.MainSpec+    Skeletest.PredicateSpec+    Skeletest.PropSpec+    Skeletest.TestUtils.Integration+  build-depends:+      base+    , aeson+    , containers+    , directory+    , filepath+    , skeletest+    , process+    , text+    , unliftio+  default-language: GHC2021+  ghc-options: -Wall -Wcompat
+ src/Skeletest.hs view
@@ -0,0 +1,70 @@+module Skeletest (+  -- * Spec+  Spec,+  describe,+  it,+  prop,++  -- ** Modifiers+  xfail,+  skip,+  markManual,++  -- ** Markers+  IsMarker (..),+  withMarkers,+  withMarker,++  -- * Assertions+  shouldBe,+  shouldNotBe,+  shouldSatisfy,+  shouldNotSatisfy,+  context,+  failTest,+  HasCallStack,+  Predicate,+  Testable,++  -- * Properties+  Property,+  PropertyM,+  Gen,+  forAll,+  discard,++  -- ** Settings+  setDiscardLimit,+  setShrinkLimit,+  setShrinkRetries,+  setConfidence,+  setVerifiedTermination,+  setTestLimit,++  -- * Fixtures+  Fixture (..),+  FixtureScope (..),+  FixtureCleanup (..),+  getFixture,+  noCleanup,+  withCleanup,++  -- ** Built-in fixtures+  FixtureTmpDir (..),++  -- * CLI flags+  Flag (..),+  IsFlag (..),+  FlagSpec (..),+  getFlag,+) where++import GHC.Stack (HasCallStack)++import Skeletest.Assertions+import Skeletest.Internal.CLI+import Skeletest.Internal.Fixtures+import Skeletest.Internal.Spec+import Skeletest.Predicate+import Skeletest.Prop.Gen (Gen)+import Skeletest.Prop.Internal
+ src/Skeletest/Assertions.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Skeletest.Assertions (+  shouldBe,+  shouldNotBe,+  shouldSatisfy,+  shouldNotSatisfy,+  context,+  failTest,+  AssertionFail (..),++  -- * Testable+  Testable,+  runTestable,+) where++import Data.Text (Text)+import Data.Text qualified as Text+import GHC.Stack (HasCallStack)+import GHC.Stack qualified as GHC+import System.IO.Unsafe (unsafePerformIO)+import UnliftIO.Exception (bracket_, throwIO)+import UnliftIO.IORef (IORef, modifyIORef, newIORef, readIORef)++import Skeletest.Internal.Predicate (+  Predicate,+  PredicateResult (..),+  runPredicate,+ )+import Skeletest.Internal.Predicate qualified as P+import Skeletest.Internal.TestInfo (getTestInfo)+import Skeletest.Internal.TestRunner (AssertionFail (..), FailContext, Testable (..))++instance Testable IO where+  runTestable = id+  context = contextIO+  throwFailure = throwIO++infix 1 `shouldBe`, `shouldNotBe`, `shouldSatisfy`, `shouldNotSatisfy`++shouldBe :: (HasCallStack, Testable m, Eq a) => a -> a -> m ()+actual `shouldBe` expected = GHC.withFrozenCallStack $ actual `shouldSatisfy` P.eq expected++shouldNotBe :: (HasCallStack, Testable m, Eq a) => a -> a -> m ()+actual `shouldNotBe` expected = GHC.withFrozenCallStack $ actual `shouldNotSatisfy` P.eq expected++shouldSatisfy :: (HasCallStack, Testable m) => a -> Predicate m a -> m ()+actual `shouldSatisfy` p =+  GHC.withFrozenCallStack $+    runPredicate p actual >>= \case+      PredicateSuccess -> pure ()+      PredicateFail msg -> failTest' msg++shouldNotSatisfy :: (HasCallStack, Testable m) => a -> Predicate m a -> m ()+actual `shouldNotSatisfy` p = GHC.withFrozenCallStack $ actual `shouldSatisfy` P.not p++contextIO :: String -> IO a -> IO a+contextIO msg =+  bracket_+    (modifyIORef failContextRef (Text.pack msg :))+    (modifyIORef failContextRef (drop 1))++failTest :: (HasCallStack, Testable m) => String -> m a+failTest = GHC.withFrozenCallStack $ failTest' . Text.pack++failTest' :: (HasCallStack, Testable m) => Text -> m a+failTest' msg = do+  testInfo <- getTestInfo+  ctx <- readIORef failContextRef+  throwFailure+    AssertionFail+      { testInfo+      , testFailMessage = msg+      , testFailContext = ctx+      , callStack = GHC.callStack+      }++failContextRef :: IORef FailContext+failContextRef = unsafePerformIO $ newIORef []+{-# NOINLINE failContextRef #-}
+ src/Skeletest/Internal/CLI.hs view
@@ -0,0 +1,369 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoFieldSelectors #-}++module Skeletest.Internal.CLI (+  Flag (..),+  flag,+  IsFlag (..),+  FlagSpec (..),+  getFlag,+  loadCliArgs,++  -- * Internal+  parseCliArgs,+  CLIParseResult (..),+  CLIFlagStore,+) where++import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Class qualified as Trans+import Control.Monad.Trans.Except qualified as Trans+import Control.Monad.Trans.State qualified as Trans+import Data.Bifunctor (first, second)+import Data.Dynamic (Dynamic, fromDynamic, toDyn)+import Data.Foldable1 qualified as Foldable1+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Proxy (Proxy (..))+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.IO qualified as Text+import Data.Typeable (TypeRep, Typeable, typeOf, typeRep)+import System.Environment (getArgs)+import System.Exit (exitFailure, exitSuccess)+import System.IO (stderr)+import System.IO.Unsafe (unsafePerformIO)+import UnliftIO.Exception (throwIO)++import Skeletest.Internal.Error (SkeletestError (..), invariantViolation)+import Skeletest.Internal.TestTargets (TestTargets, parseTestTargets)++-- | Register a CLI flag.+--+-- Usage:+--+-- @+-- {- MyFixture.hs -}+-- import Skeletest+--+-- newtype MyFlag = MyFlag String+-- instance IsFlag MyFlag where+--   flagName = "my-flag"+--   flagHelp = "The value for MyFixture"+--   flagSpec =+--     OptionalFlag+--       { flagDefault = "foo"+--       , flagParse = \case+--           "illegal" -> Left "invalid flag value"+--           s -> Right (MyFlag s)+--       }+--+-- instance Fixture MyFixture where+--   fixtureAction = do+--     MyFlag val <- getFlag+--     ...+--+-- {- Main.hs -}+-- import MyFixture+--+-- cliFlags =+--   [ flag @MyFlag+--   ]+-- @+data Flag = forall a. (IsFlag a) => Flag (Proxy a)++flag :: forall a. (IsFlag a) => Flag+flag = Flag (Proxy @a)++class (Typeable a) => IsFlag a where+  flagName :: String++  flagShort :: Maybe Char+  flagShort = Nothing++  -- | The placeholder for the flag to show in the help text, if+  -- the flag takes an argument.+  flagMetaVar :: String+  flagMetaVar = "VAR"++  flagHelp :: String++  flagSpec :: FlagSpec a++data FlagSpec a+  = SwitchFlag+      { flagFromBool :: Bool -> a+      }+  | RequiredFlag+      { flagParse :: String -> Either String a+      }+  | OptionalFlag+      { flagDefault :: a+      , flagParse :: String -> Either String a+      }++getFlag :: forall a m. (MonadIO m, IsFlag a) => m a+getFlag =+  liftIO $+    lookupCliFlag rep >>= \case+      Just dyn ->+        case fromDynamic dyn of+          Just a -> pure a+          Nothing ->+            invariantViolation . unwords $+              [ "CLI flag store contained incorrect types."+              , "Expected: " <> show rep <> "."+              , "Got: " <> show dyn+              ]+      Nothing -> throwIO $ CliFlagNotFound (Text.pack $ flagName @a)+  where+    rep = typeRep (Proxy @a)++{----- Load CLI arguments -----}++-- | Parse the CLI arguments using the given user-defined flags, then+-- stores the flags in the global state and returns the positional+-- arguments.+loadCliArgs :: [Flag] -> [Flag] -> IO TestTargets+loadCliArgs builtinFlags flags = do+  args0 <- getArgs+  case parseCliArgs (builtinFlags <> flags) args0 of+    CLISetupFailure msg -> do+      Text.hPutStrLn stderr $ "ERROR: " <> msg+      exitFailure+    CLIHelpRequested -> do+      Text.putStrLn helpText+      exitSuccess+    CLIParseFailure msg -> do+      Text.hPutStrLn stderr $ msg <> "\n\n" <> helpText+      exitFailure+    CLIParseSuccess{testTargets, flagStore} -> do+      setCliFlagStore flagStore+      pure testTargets+  where+    helpText = getHelpText builtinFlags flags++getHelpText :: [Flag] -> [Flag] -> Text+getHelpText builtinFlags customFlags =+  Text.intercalate "\n\n" $+    "Usage: skeletest [OPTIONS] [--] [TARGETS]" : map (uncurry renderSection) helpSections+  where+    helpSections =+      filter (not . Text.null . snd) $+        [ ("TEST SELECTION", testSelectionDocs)+        , ("BUILTIN OPTIONS", renderFlagList builtinFlagDocs)+        , ("CUSTOM OPTIONS", renderFlagList customFlagDocs)+        ]++    testSelectionDocs =+      Text.intercalate "\n" $+        [ "Test targets may be specified as plain positional arguments, with the following syntax:"+        , "    * Tests including substring:      '[myFooFunc]'"+        , "    * Tests tagged with marker:       '@fast'"+        , "    * Tests in file, relative to CWD: 'test/MyLib/FooSpec.hs'"+        , "    * Tests matching pattern in file: 'test/MyLib/FooSpec.hs[myFooFunc]'"+        , "        * Syntax sugar for '(test/MyLib/FooSpec.hs and [myFooFunc])'"+        , "    * Tests matching both targets:    '[func1] and [func2]'"+        , "    * Tests matching either target:   '[func1] or [func2]'"+        , "    * Tests not matching target:      'not [func1]'"+        , ""+        , "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'."+        ]++    builtinFlagDocs = ("help", Just 'h', Nothing, "Display this help text") : fromFlags builtinFlags+    customFlagDocs = fromFlags customFlags+    fromFlags flags =+      [ (Text.pack (flagName @a), flagShort @a, mMetaVar, Text.pack (flagHelp @a))+      | Flag (Proxy :: Proxy a) <- flags+      , let mMetaVar =+              case flagSpec @a of+                SwitchFlag{} -> Nothing+                RequiredFlag{} -> Just $ Text.pack (flagMetaVar @a)+                OptionalFlag{} -> Just $ Text.pack (flagMetaVar @a)+      ]++    renderSection title body =+      Text.intercalate "\n" $+        [ "===== " <> title+        , ""+        , body+        ]++    renderFlagList flagList =+      Text.intercalate "\n" . mkTabular $+        [ (shortName <> renderLongFlag longName <> metaVar, help)+        | (longName, mShortName, mMetaVar, help) <- flagList+        , let+            shortName =+              case mShortName of+                Just short -> renderShortFlag short <> ", "+                Nothing -> ""+            metaVar =+              case mMetaVar of+                Just meta -> " <" <> meta <> ">"+                Nothing -> ""+        ]++    mkTabular rows0 =+      case NonEmpty.nonEmpty rows0 of+        Nothing -> []+        Just rows ->+          let fstColWidth = Foldable1.maximum $ NonEmpty.map (Text.length . fst) rows+              margin = 2 -- space between columns+           in [ a <> Text.replicate (fstColWidth - Text.length a + margin) " " <> b+              | (a, b) <- NonEmpty.toList rows+              ]++{----- Parse args -----}++data CLIParseResult+  = CLISetupFailure Text+  | CLIHelpRequested+  | CLIParseFailure Text+  | CLIParseSuccess+      { testTargets :: TestTargets+      , flagStore :: CLIFlagStore+      }++parseCliArgs :: [Flag] -> [String] -> CLIParseResult+parseCliArgs flags args = either id id $ do+  longFlags <- extractLongFlags+  shortFlags <- extractShortFlags++  -- quick sweep for --help/-h after flag validation; skip parsing flags if so+  when (any (`elem` ["--help", "-h"]) args) $ Left CLIHelpRequested++  (args', flagStore) <- first CLIParseFailure $ parseCliArgsWith longFlags shortFlags args+  testTargets <- first CLIParseFailure $ parseTestTargets args'+  flagStore' <- first CLIParseFailure $ resolveFlags flags flagStore+  pure CLIParseSuccess{testTargets, flagStore = flagStore'}+  where+    extractLongFlags =+      toFlagMap renderLongFlag $+        [ (Text.pack $ flagName @a, f)+        | f@(Flag (Proxy :: Proxy a)) <- flags+        ]++    extractShortFlags =+      toFlagMap renderShortFlag $+        [ (shortFlag, f)+        | f@(Flag (Proxy :: Proxy a)) <- flags+        , Just shortFlag <- pure $ flagShort @a+        ]++    toFlagMap :: (Ord name) => (name -> Text) -> [(name, a)] -> Either CLIParseResult (Map name a)+    toFlagMap renderFlag vals =+      let go seen = \case+            [] -> Right $ Map.fromList vals+            (name, _) : xs+              | name `Set.member` seen -> Left . CLISetupFailure $ "Flag registered multiple times: " <> renderFlag name+              | otherwise -> go (Set.insert name seen) xs+       in go Set.empty vals++type ArgParserM = Trans.StateT ([Text], CLIFlagStore) (Trans.Except Text)++parseCliArgsWith :: Map Text Flag -> Map Char Flag -> [String] -> Either Text ([Text], CLIFlagStore)+parseCliArgsWith longFlags shortFlags = Trans.runExcept . flip Trans.execStateT ([], Map.empty) . parseArgs+  where+    parseArgs = \case+      [] -> pure ()+      "--" : rest -> addArgs rest+      curr : rest+        | Just longFlag <- Text.stripPrefix "--" (Text.pack curr) -> parseLongFlag longFlag rest+        | Just chars <- Text.stripPrefix "-" (Text.pack curr) ->+            case Text.unpack chars of+              [] -> argError "Invalid flag: -"+              [shortFlag] -> parseShortFlag shortFlag rest+              _ -> argError $ "Invalid flag: -" <> chars+        | otherwise -> addArgs [curr] >> parseArgs rest++    parseLongFlag name args =+      let (name', args') =+            case Text.breakOn "=" name of+              (_, "") -> (name, args)+              (n, post) -> (n, (drop 1 . Text.unpack) post : args)+       in parseFlag renderLongFlag longFlags name' args'+    parseShortFlag = parseFlag renderShortFlag shortFlags++    parseFlag :: (Ord name) => (name -> Text) -> Map name Flag -> name -> [String] -> ArgParserM ()+    parseFlag renderFlag flagMap name args = do+      Flag (Proxy :: Proxy a) <-+        case Map.lookup name flagMap of+          Nothing -> argError $ "Unknown flag: " <> renderFlag name+          Just f -> pure f+      let parseFlagArg parseArg =+            case args of+              [] -> argError $ "Flag requires argument: " <> renderFlag name+              curr : rest -> parseArg curr >>= addFlagStore >> parseArgs rest+      case flagSpec @a of+        SwitchFlag{flagFromBool} -> addFlagStore (flagFromBool True) >> parseArgs args+        RequiredFlag{flagParse} -> parseFlagArg (Trans.lift . Trans.except . first Text.pack . flagParse)+        OptionalFlag{flagParse} -> parseFlagArg (Trans.lift . Trans.except . first Text.pack . flagParse)++    argError = Trans.lift . Trans.throwE++    addArgs :: [String] -> ArgParserM ()+    addArgs args = Trans.modify (first (<> map Text.pack args))++    addFlagStore :: (Typeable a) => a -> ArgParserM ()+    addFlagStore x = Trans.modify (second (insertFlagStore x))++resolveFlags :: [Flag] -> CLIFlagStore -> Either Text CLIFlagStore+resolveFlags = flip (foldlM go)+  where+    go flagStore (Flag (Proxy :: Proxy a)) = do+      let rep = typeRep (Proxy @a)+      case flagSpec @a of+        SwitchFlag{flagFromBool} ->+          pure $+            if rep `Map.member` flagStore+              then flagStore+              else insertFlagStore (flagFromBool False) flagStore+        RequiredFlag{} ->+          if rep `Map.member` flagStore+            then pure flagStore+            else Left $ "Required flag not set: " <> renderLongFlag (Text.pack $ flagName @a)+        OptionalFlag{flagDefault} ->+          pure $+            if rep `Map.member` flagStore+              then flagStore+              else insertFlagStore flagDefault flagStore++    foldlM f z = \case+      [] -> pure z+      x : xs -> do+        z' <- f z x+        foldlM f z' xs++renderLongFlag :: Text -> Text+renderLongFlag = ("--" <>)++renderShortFlag :: Char -> Text+renderShortFlag c = Text.pack ['-', c]++{----- CLIFlagStore -----}++type CLIFlagStore = Map TypeRep Dynamic++insertFlagStore :: (Typeable a) => a -> CLIFlagStore -> CLIFlagStore+insertFlagStore x = Map.insert (typeOf x) (toDyn x)++cliFlagStoreRef :: IORef CLIFlagStore+cliFlagStoreRef = unsafePerformIO $ newIORef Map.empty+{-# NOINLINE cliFlagStoreRef #-}++setCliFlagStore :: CLIFlagStore -> IO ()+setCliFlagStore = writeIORef cliFlagStoreRef++lookupCliFlag :: TypeRep -> IO (Maybe Dynamic)+lookupCliFlag rep = Map.lookup rep <$> readIORef cliFlagStoreRef
+ src/Skeletest/Internal/Constants.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedStrings #-}++{-| This module defines all the constants used in skeletest.++These constants should all be considered arbitrary. Users should+not use any of these identifiers directly.+-}+module Skeletest.Internal.Constants (+  mainFileSpecsListIdentifier,+) where++import Data.Text++-- | The name of the list of Specs collected from test modules+-- in the Main module.+mainFileSpecsListIdentifier :: Text+mainFileSpecsListIdentifier = "skeletest_all_specs"
+ src/Skeletest/Internal/Error.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Skeletest.Internal.Error (+  SkeletestError (..),+  skeletestPluginError,+  invariantViolation,+) where++import Data.List (dropWhileEnd)+import Data.Text (Text)+import Data.Text qualified as Text+import GHC.Utils.Panic (pgmError)+import UnliftIO.Exception (Exception (..))++data SkeletestError+  = TestInfoNotFound+  | CliFlagNotFound Text+  | FixtureCircularDependency [Text]+  | SnapshotFileCorrupted FilePath+  deriving (Show)++instance Exception SkeletestError where+  displayException =+    Text.unpack . \case+      TestInfoNotFound ->+        "Could not find test info"+      CliFlagNotFound name ->+        "CLI flag '" <> name <> "' was not registered. Did you add it to cliFlags in Main.hs?"+      FixtureCircularDependency fixtures ->+        "Found circular dependency when resolving fixtures: " <> Text.intercalate " -> " fixtures+      SnapshotFileCorrupted fp ->+        "Snapshot file was corrupted: " <> Text.pack fp++-- | Throw a user error during compilation, e.g. during the preprocessor or plugin phases.+skeletestPluginError :: String -> a+skeletestPluginError msg =+  pgmError . dropWhileEnd (== '\n') . unlines $+    [ ""+    , "******************** skeletest failure ********************"+    , msg+    ]++-- | Throw an error in a situation that should never happen, and indicates a bug.+invariantViolation :: String -> a+invariantViolation msg =+  error . unlines $+    [ "Invariant violation: " <> msg+    , "**** This is a skeletest bug. Please report it at https://github.com/brandonchinn178/skeletest/issues"+    ]
+ src/Skeletest/Internal/Fixtures.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}++module Skeletest.Internal.Fixtures (+  Fixture (..),+  FixtureScope (..),+  FixtureScopeKey (..),+  getFixture,++  -- * Cleanup+  FixtureCleanup (..),+  noCleanup,+  withCleanup,+  cleanupFixtures,++  -- * Built-in fixtures+  FixtureTmpDir (..),+) where++import Control.Concurrent (ThreadId, myThreadId)+import Control.Monad (forM)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.IORef (IORef, atomicModifyIORef, newIORef)+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Map.Ordered (OMap)+import Data.Map.Ordered qualified as OMap+import Data.Maybe (catMaybes)+import Data.Proxy (Proxy (..))+import Data.Text qualified as Text+import Data.Typeable (TypeRep, Typeable, eqT, typeOf, typeRep, (:~:) (Refl))+import System.Directory (createDirectory, getTemporaryDirectory, removePathForcibly)+import System.FilePath ((</>))+import System.IO.Unsafe (unsafePerformIO)+import UnliftIO.Exception (throwIO, tryAny)++import Skeletest.Internal.Error (SkeletestError (..), invariantViolation)+import Skeletest.Internal.TestInfo (+  TestInfo (testFile),+  getTestInfo,+ )+import Skeletest.Internal.Utils.Map qualified as Map.Utils++class (Typeable a) => Fixture a where+  -- | The scope of the fixture, defaults to per-test+  fixtureScope :: FixtureScope+  fixtureScope = PerTestFixture++  fixtureAction :: IO (a, FixtureCleanup)++data FixtureScope+  = PerTestFixture+  | PerFileFixture+  | PerSessionFixture+  deriving (Show)++data FixtureCleanup+  = NoCleanup+  | CleanupFunc (IO ())++data FixtureScopeKey+  = PerTestFixtureKey ThreadId+  | PerFileFixtureKey FilePath+  | PerSessionFixtureKey+  deriving (Show)++-- | A helper for specifying no cleanup.+noCleanup :: a -> (a, FixtureCleanup)+noCleanup a = (a, NoCleanup)++-- | A helper for defining the cleanup function in-line.+withCleanup :: a -> IO () -> (a, FixtureCleanup)+withCleanup a cleanup = (a, CleanupFunc cleanup)++-- | Load a fixture, initializing it if it hasn't been cached already.+getFixture :: forall a m. (Fixture a, MonadIO m) => m a+getFixture = liftIO $ do+  (getScopedFixtures, updateScopedFixtures) <-+    fmap getScopedAccessors $+      case fixtureScope @a of+        PerTestFixture -> PerTestFixtureKey <$> myThreadId+        PerFileFixture -> PerFileFixtureKey . testFile <$> getTestInfo+        PerSessionFixture -> pure PerSessionFixtureKey++  let insertFixture state = updateScopedFixtures (OMap.>| (rep, state))++  cachedFixture <-+    modifyFixtureRegistry $ \registry ->+      case OMap.lookup rep $ getScopedFixtures registry of+        -- fixture has not been requested yet+        Nothing -> (insertFixture FixtureInProgress registry, Right Nothing)+        -- fixture has already been requested+        Just (FixtureLoaded (fixture :: ty, _)) ->+          case eqT @a @ty of+            Just Refl -> (registry, Right $ Just fixture)+            Nothing ->+              invariantViolation . unwords $+                [ "fixture registry contained incorrect types."+                , "Expected: " <> show rep <> "."+                , "Got: " <> show (typeOf fixture)+                ]+        Just FixtureInProgress ->+          -- get list of fixtures causing a circular dependency+          let fixtures = map fst . filter (isInProgress . snd) . OMap.assocs $ getScopedFixtures registry+           in (registry, Left $ FixtureCircularDependency $ map (Text.pack . show) (fixtures <> [rep]))++  case cachedFixture of+    -- error when getting fixture+    Left e -> throwIO e+    -- fixture was cached, return it+    Right (Just fixture) -> pure fixture+    -- otherwise, execute it (allowing it to request other fixtures) and cache the result.+    Right Nothing -> do+      result@(fixture, _) <- fixtureAction @a+      modifyFixtureRegistry $ \registry -> (insertFixture (FixtureLoaded result) registry, ())+      pure fixture+  where+    rep = typeRep (Proxy @a)+    isInProgress = \case+      FixtureInProgress -> True+      _ -> False++-- | Clean up fixtures in the given scope.+--+-- Clean up functions are run in the reverse order the fixtures finished in.+-- For example, if a test asks for fixtures A and C, A asks for B, and C asks+-- for D, the fixtures should finish loading in order: B, A, D, C.+-- Cleanup should then go in order: C, D, A, B.+cleanupFixtures :: FixtureScopeKey -> IO ()+cleanupFixtures scopeKey = do+  -- get fixtures in the given scope and clear+  fixtures <-+    modifyFixtureRegistry $ \registry ->+      (updateScopedFixtures (const OMap.empty) registry, getScopedFixtures registry)++  errors <-+    forM (reverse . map snd . OMap.assocs $ fixtures) $ \case+      FixtureInProgress -> pure Nothing+      FixtureLoaded (_, NoCleanup) -> pure Nothing+      FixtureLoaded (_, CleanupFunc io) -> fromLeft <$> tryAny io++  -- throw the first error we encountered+  case catMaybes errors of+    e : _ -> throwIO e+    [] -> pure ()+  where+    (getScopedFixtures, updateScopedFixtures) = getScopedAccessors scopeKey+    fromLeft = \case+      Left x -> Just x+      Right _ -> Nothing++{----- Fixtures registry -----}++-- | The registry of active fixtures, in order of activation.+data FixtureRegistry = FixtureRegistry+  { sessionFixtures :: FixtureMap+  , fileFixtures :: Map FilePath FixtureMap+  , testFixtures :: Map ThreadId FixtureMap+  }++type FixtureMap = OMap TypeRep FixtureStatus++data FixtureStatus+  = FixtureInProgress+  | forall a. (Typeable a) => FixtureLoaded (a, FixtureCleanup)++fixtureRegistryRef :: IORef FixtureRegistry+fixtureRegistryRef = unsafePerformIO $ newIORef emptyFixtureRegistry+  where+    emptyFixtureRegistry =+      FixtureRegistry+        { sessionFixtures = OMap.empty+        , fileFixtures = Map.empty+        , testFixtures = Map.empty+        }+{-# NOINLINE fixtureRegistryRef #-}++modifyFixtureRegistry :: (FixtureRegistry -> (FixtureRegistry, a)) -> IO a+modifyFixtureRegistry = atomicModifyIORef fixtureRegistryRef++getScopedAccessors ::+  FixtureScopeKey+  -> ( FixtureRegistry -> FixtureMap+     , (FixtureMap -> FixtureMap) -> FixtureRegistry -> FixtureRegistry+     )+getScopedAccessors scopeKey =+  case scopeKey of+    PerTestFixtureKey tid ->+      ( Map.Utils.findOrEmpty tid . testFixtures+      , \f registry -> registry{testFixtures = Map.Utils.adjustNested f tid (testFixtures registry)}+      )+    PerFileFixtureKey fp ->+      ( Map.Utils.findOrEmpty fp . fileFixtures+      , \f registry -> registry{fileFixtures = Map.Utils.adjustNested f fp (fileFixtures registry)}+      )+    PerSessionFixtureKey ->+      ( sessionFixtures+      , \f registry -> registry{sessionFixtures = f (sessionFixtures registry)}+      )++{----- Built-in fixtures -----}++-- | A fixture that provides a temporary directory that can be used in a test.+newtype FixtureTmpDir = FixtureTmpDir FilePath++instance Fixture FixtureTmpDir where+  fixtureAction = do+    tmpdir <- getTemporaryDirectory+    let dir = tmpdir </> "skeletest-tmp-dir"+    removePathForcibly dir+    createDirectory dir+    pure . withCleanup (FixtureTmpDir dir) $+      removePathForcibly dir
+ src/Skeletest/Internal/GHC.hs view
@@ -0,0 +1,675 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++{-| Provide a pure API for GHC internals.++All GHC operations should go through this API, to isolate+the rest of the logic from GHC internals logic, which can+include breaking changes between versions.+-}+module Skeletest.Internal.GHC (+  Plugin,+  PluginDef (..),+  Ctx (..),+  GhcRn,+  mkPlugin,++  -- * ParsedModule+  ParsedModule (..),+  FunDef (..),++  -- ** Expressions+  HsExpr,+  HsExprData (..),+  hsExprCon,+  hsExprVar,+  hsExprApps,+  hsExprList,+  hsExprRecordCon,+  hsExprLitString,+  hsExprLam,+  hsExprCase,+  getExpr,+  renderHsExpr,++  -- ** Types+  HsType (..),++  -- ** Patterns+  HsPat (..),++  -- ** Names+  HsName,+  hsName,+  hsVarName,+  getHsName,+) where++import Control.Monad.Trans.Class qualified as Trans+import Control.Monad.Trans.State (StateT, evalStateT)+import Control.Monad.Trans.State qualified as State+import Data.Data (Data)+import Data.Data qualified as Data+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Typeable qualified as Typeable+import GHC (+  GenLocated (..),+  GhcPass (..),+  GhcPs,+  GhcRn,+  IsPass,+  unLoc,+ )+import GHC qualified as GHC+import GHC.Driver.Main qualified as GHC+import GHC.Plugins qualified as GHC hiding (getHscEnv)+import GHC.Tc.Utils.Monad qualified as GHC+import GHC.Types.Name qualified as GHC.Name+import GHC.Types.Name.Cache qualified as GHC (NameCache)+import GHC.Types.SourceText qualified as GHC.SourceText+import Language.Haskell.TH.Syntax qualified as TH+import System.IO.Unsafe (unsafePerformIO)++#if !MIN_VERSION_base(4, 20, 0)+import Data.Foldable (foldl')+#endif++import Skeletest.Internal.Error (invariantViolation, skeletestPluginError)+import Skeletest.Internal.GHC.Compat (genLoc)+import Skeletest.Internal.GHC.Compat qualified as GHC.Compat++-- Has to be exactly GHC's Plugin type, for GHC to register it correctly.+type Plugin = GHC.Plugin++-- | Our pure definition of PluginDef, agnostic of GHC version.+data PluginDef = PluginDef+  { isPure :: Bool+  , modifyParsed :: ModuleName -> ParsedModule -> ParsedModule+  , onRename :: Ctx -> ModuleName -> HsExpr GhcRn -> HsExpr GhcRn+  }++data Ctx = Ctx+  { matchesName :: HsName GhcRn -> HsName GhcRn -> Bool+  }++type ModuleName = Text++mkPlugin :: PluginDef -> Plugin+mkPlugin PluginDef{..} =+  GHC.defaultPlugin+    { GHC.pluginRecompile = if isPure then GHC.purePlugin else GHC.impurePlugin+    , GHC.parsedResultAction = \_ modInfo result -> do+        let+          moduleName = getModuleName $ GHC.ms_mod modInfo+          parsedModule = initParsedModule . GHC.hpm_module . GHC.parsedResultModule $ result+          ParsedModule{moduleFuncs} = modifyParsed moduleName parsedModule+        newDecls <-+          runCompilePs . fmap concat . sequence $+            [ compileFunDef funName funDef+            | (funName, Just funDef) <- moduleFuncs+            ]+        pure+          . (modifyParsedResultModule . modifyHpmModule . fmap . modifyModDecls) (newDecls <>)+          $ result+    , GHC.renamedResultAction = \_ gblEnv group -> do+        nameCache <- GHC.hsc_NC . GHC.env_top <$> GHC.getEnv+        let+          moduleName = getModuleName $ GHC.tcg_mod gblEnv+          ctx =+            Ctx+              { matchesName = matchesNameImpl nameCache+              }+        group' <- runCompileRn $ modifyModuleExprs (onRename ctx moduleName) group+        pure (gblEnv, group')+    }+  where+    getModuleName GHC.Module{moduleName} = Text.pack $ GHC.moduleNameString moduleName++    modifyParsedResultModule f x = x{GHC.parsedResultModule = f $ GHC.parsedResultModule x}+    modifyHpmModule f x = x{GHC.hpm_module = f $ GHC.hpm_module x}+    modifyModDecls f x = x{GHC.hsmodDecls = f $ GHC.hsmodDecls x}++{----- ParsedModule -----}++data ParsedModule = ParsedModule+  { moduleFuncs :: [(HsName GhcPs, Maybe FunDef)]+  }++data FunDef = FunDef+  { funType :: HsType GhcPs+  , funPats :: [HsPat GhcPs]+  , funBody :: HsExpr GhcPs+  }++initParsedModule :: GHC.Located (GHC.HsModule GhcPs) -> ParsedModule+initParsedModule (L _ GHC.HsModule{hsmodDecls}) =+  ParsedModule+    { moduleFuncs =+        [ (funName, Nothing)+        | Just funName <- map (getValName . unLoc) hsmodDecls+        ]+    }+  where+    getValName = \case+      GHC.ValD _ GHC.FunBind{fun_id} -> Just . hsGhcName . unLoc $ fun_id+      _ -> Nothing++{----- modifyModuleExprs -----}++modifyModuleExprs ::+  forall m.+  (MonadCompile m GhcRn) =>+  (HsExpr GhcRn -> HsExpr GhcRn)+  -> GHC.HsGroup GhcRn+  -> m (GHC.HsGroup GhcRn)+modifyModuleExprs f = go+  where+    go :: (Data a) => a -> m a+    go = Data.gmapM $ \x -> updateExpr x >>= go++    updateExpr :: (Data a) => a -> m a+    updateExpr (x :: a) =+      case Typeable.eqT @(GHC.LHsExpr GhcRn) @a of+        Just Typeable.Refl -> compileHsExpr . f . parseHsExpr $ x+        Nothing -> pure x++{----- HsExpr -----}++-- | A Haskell expression that is either:+--     1. A parsed expression from the compiler+--          * ghcExpr is Just+--          * hsExpr is not HsExprOther if the expression is something+--            we care about parsing, otherwise HsExprOther+--     3. A new expression we're creating+--          * ghcExpr is Nothing+--          * hsExpr is not HsExprOther+--+-- Invariants:+--   * If ghcExpr is Just, hsExpr must not have been modified+--   * if ghcExpr is Nothing, hsExpr is not HsExprOther+data HsExpr p = HsExprUnsafe+  { ghcExpr :: Maybe (GhcLHsExpr p)+  , hsExpr :: HsExprData p+  }+  deriving (Show)++data HsExprData p+  = HsExprCon (HsName p)+  | HsExprVar (HsName p)+  | HsExprApps (HsExpr p) [HsExpr p]+  | HsExprOp (HsExpr p) (HsExpr p) (HsExpr p) -- lhs op rhs+  | HsExprList [HsExpr p]+  | HsExprRecordCon (HsName p) [(HsName p, HsExpr p)]+  | HsExprLitString Text+  | HsExprLam [HsPat p] (HsExpr p)+  | HsExprCase (HsExpr p) [(HsPat p, HsExpr p)]+  | HsExprOther+  deriving (Show)++getExpr :: HsExpr p -> HsExprData p+getExpr HsExprUnsafe{hsExpr} = hsExpr++renderHsExpr :: HsExpr GhcRn -> Text+renderHsExpr = \case+  HsExprUnsafe{ghcExpr = Just e} -> Text.pack $ show e+  HsExprUnsafe{hsExpr = e} -> Text.pack $ show e++newHsExpr :: HsExprData p -> HsExpr p+newHsExpr e =+  HsExprUnsafe+    { ghcExpr = Nothing+    , hsExpr = e+    }++hsExprCon :: HsName p -> HsExpr p+hsExprCon = newHsExpr . HsExprCon++hsExprVar :: HsName p -> HsExpr p+hsExprVar = newHsExpr . HsExprVar++hsExprApps :: HsExpr p -> [HsExpr p] -> HsExpr p+hsExprApps f xs = newHsExpr $ HsExprApps f xs++hsExprList :: [HsExpr p] -> HsExpr p+hsExprList = newHsExpr . HsExprList++hsExprRecordCon :: HsName p -> [(HsName p, HsExpr p)] -> HsExpr p+hsExprRecordCon conName fields = newHsExpr $ HsExprRecordCon conName fields++hsExprLitString :: Text -> HsExpr p+hsExprLitString = newHsExpr . HsExprLitString++hsExprLam :: [HsPat p] -> HsExpr p -> HsExpr p+hsExprLam args body = newHsExpr $ HsExprLam args body++hsExprCase :: HsExpr p -> [(HsPat p, HsExpr p)] -> HsExpr p+hsExprCase e branches = newHsExpr $ HsExprCase e branches++parseHsExpr :: GHC.LHsExpr GhcRn -> HsExpr GhcRn+parseHsExpr = goExpr+  where+    goExpr e =+      HsExprUnsafe+        { ghcExpr = Just $ GhcLHsExprRn e+        , hsExpr = goData e+        }++    goData = \case+      L _ (GHC.HsVar _ (L _ name)) ->+        if (GHC.occNameSpace . GHC.occName) name == GHC.Name.dataName+          then HsExprCon (hsGhcName name)+          else HsExprVar (hsGhcName name)+      e@(L _ GHC.HsApp{}) ->+        let (f, xs) = collectApps e+         in HsExprApps (goExpr f) (map goExpr xs)+      L _ (GHC.OpApp _ lhs op rhs) ->+        HsExprOp (goExpr lhs) (goExpr op) (goExpr rhs)+      L _ (GHC.RecordCon _ conName GHC.HsRecFields{rec_flds}) ->+        HsExprRecordCon (hsGhcName $ unLoc conName) $ map (getRecField . unLoc) rec_flds+      L _ par@GHC.HsPar{} -> goData $ GHC.Compat.unHsPar par+      _ -> HsExprOther++    getRecField GHC.HsFieldBind{hfbLHS = field, hfbRHS = expr} =+      (hsGhcName . GHC.foExt . unLoc $ field, goExpr expr)++    -- Collect an application of the form `((f a) b) c` and return `f [a, b, c]`+    collectApps = \case+      L _ (GHC.HsApp _ l r) -> let (f, xs) = collectApps l in (f, xs <> [r])+      e -> (e, [])++{----- HsType -----}++data HsType p+  = HsTypeCon (HsName p)+  | HsTypeApps (HsType p) [HsType p]+  | HsTypeTuple [HsType p]++{----- HsPat -----}++data HsPat p+  = HsPatCon (HsName p) [HsPat p]+  | HsPatVar (HsName p)+  | HsPatRecord (HsName p) [(HsName p, HsPat p)]+  | HsPatWild+  deriving (Show)++{----- HsName -----}++data HsName p+  = HsName TH.Name+  | HsVarName Text+  | HsGhcName (GhcIdP p)+  deriving (Show, Eq)++hsName :: TH.Name -> HsName p+hsName = HsName++hsVarName :: Text -> HsName p+hsVarName = HsVarName++hsGhcName :: forall p. (IsPass p) => GHC.IdP (GhcPass p) -> HsName (GhcPass p)+hsGhcName = HsGhcName . onPsOrRn @p GhcIdPs GhcIdRn++fromTHName :: GHC.NameCache -> TH.Name -> GHC.Name+fromTHName nameCache name =+  case unsafePerformIO $ GHC.thNameToGhcNameIO nameCache name of+    Just n -> n+    Nothing -> skeletestPluginError $ "Could not get Name for `" <> show name <> "`"++matchesNameImpl :: GHC.NameCache -> HsName GhcRn -> HsName GhcRn -> Bool+matchesNameImpl nameCache n1 n2 = fromMaybe False $ (==) <$> go n1 <*> go n2+  where+    go = \case+      HsName name -> Just $ fromTHName nameCache name+      HsVarName _ -> Nothing -- new names will never match+      HsGhcName name -> Just $ unGhcIdP name++getHsName :: HsName p -> Text+getHsName = \case+  HsName name -> Text.pack . TH.nameBase $ name+  HsVarName name -> name+  HsGhcName (GhcIdPs name) -> Text.pack . GHC.occNameString . GHC.rdrNameOcc $ name+  HsGhcName (GhcIdRn name) -> Text.pack . GHC.occNameString . GHC.nameOccName $ name++{----- Compilation -----}++class (Monad m) => MonadHasNameCache m where+  getNameCache :: m GHC.NameCache+class (Monad m) => MonadCompileName m p where+  mkIdP :: Text -> m (GHC.IdP p)++type MonadCompile m p = (MonadHasNameCache m, MonadCompileName m p)++newtype CompilePs a = CompilePs (GHC.Hsc a)+  deriving (Functor, Applicative, Monad)++runCompilePs :: CompilePs a -> GHC.Hsc a+runCompilePs (CompilePs m) = m++instance MonadHasNameCache CompilePs where+  getNameCache = GHC.hsc_NC <$> CompilePs GHC.getHscEnv+instance MonadCompileName CompilePs GhcPs where+  mkIdP = pure . GHC.mkUnqual GHC.Name.varName . fsText++newtype CompileRn a = CompileRn (StateT (Map Text GHC.Name) GHC.TcM a)+  deriving (Functor, Applicative, Monad)++runCompileRn :: CompileRn a -> GHC.TcM a+runCompileRn (CompileRn m) = evalStateT m Map.empty++instance MonadHasNameCache CompileRn where+  getNameCache = GHC.hsc_NC . GHC.env_top <$> (CompileRn . Trans.lift) GHC.getEnv+instance MonadCompileName CompileRn GhcRn where+  mkIdP name = do+    nameMap <- CompileRn State.get+    case Map.lookup name nameMap of+      Just name' -> pure name'+      Nothing -> do+        uniq <- (CompileRn . Trans.lift) GHC.getUniqueM+        let name' = GHC.mkSystemVarName uniq (fsText name)+        CompileRn $ State.put (Map.insert name name' nameMap)+        pure name'++compileHsName ::+  forall p m.+  (GHC.IsPass p, MonadCompile m (GhcPass p)) =>+  HsName (GhcPass p)+  -> m (GHC.IdP (GhcPass p))+compileHsName = \case+  HsName name -> do+    nameCache <- getNameCache+    pure . onPsOrRn @p GHC.getRdrName id $ fromTHName nameCache name+  HsVarName name -> mkIdP @_ @(GhcPass p) name+  HsGhcName name -> pure $ unGhcIdP name++compileFunDef :: (MonadCompile m GhcPs) => HsName GhcPs -> FunDef -> m [GHC.LHsDecl GhcPs]+compileFunDef funName FunDef{..} = do+  name <- compileHsName funName+  ty <- compileHsType funType+  pats <- mapM compileHsPat funPats+  body <- compileHsExpr funBody+  pure+    [ mkSigD name ty+    , genLoc . GHC.ValD GHC.noExtField $+        GHC.FunBind GHC.noExtField (genLoc name) . GHC.MG GHC.FromSource . genLoc $+          [ genLoc $+              GHC.Match+                GHC.noAnn+                (GHC.FunRhs (genLoc name) GHC.Prefix GHC.NoSrcStrict)+                pats+                ( GHC.GRHSs+                    GHC.emptyComments+                    [genLoc $ GHC.GRHS GHC.noAnn [] body]+                    (GHC.EmptyLocalBinds GHC.noExtField)+                )+          ]+    ]+  where+    mkSigD name ty =+      genLoc+        . GHC.SigD GHC.noExtField+        . GHC.TypeSig GHC.noAnn [genLoc name]+        . GHC.HsWC GHC.noExtField+        . genLoc+        $ GHC.HsSig GHC.noExtField (GHC.HsOuterImplicit GHC.noExtField) ty++compileHsType :: (MonadCompile m GhcPs) => HsType GhcPs -> m (GHC.LHsType GhcPs)+compileHsType = go+  where+    go = \case+      HsTypeCon name -> do+        genLoc . GHC.HsTyVar GHC.noAnn GHC.NotPromoted . genLoc <$> compileHsName name+      HsTypeApps ty0 tys -> do+        ty0' <- go ty0+        tys' <- mapM go tys+        pure $ foldl' (\l r -> genLoc $ GHC.HsAppTy GHC.noExtField l r) ty0' tys'+      HsTypeTuple tys -> do+        tys' <- mapM go tys+        pure . genLoc $ GHC.HsTupleTy GHC.noAnn GHC.HsBoxedOrConstraintTuple tys'++compileHsPat ::+  forall p m.+  (IsPass p, MonadCompile m (GhcPass p)) =>+  HsPat (GhcPass p)+  -> m (GHC.LPat (GhcPass p))+compileHsPat = go+  where+    go = \case+      HsPatCon conName args -> do+        conName' <- fromConName conName+        con <- GHC.PrefixCon [] <$> mapM go args+        pure . genLoc $+          GHC.ConPat+            (onPsOrRn @p GHC.noAnn GHC.noExtField)+            conName'+            con+      HsPatVar name -> do+        name' <- onPsOrRn @p genLoc genLoc <$> compileHsName name+        pure . genLoc $ GHC.VarPat GHC.noExtField name'+      HsPatRecord conName fields -> do+        conName' <- fromConName conName+        con <- GHC.RecCon <$> compileRecFields go fields+        pure . genLoc $+          GHC.ConPat+            (onPsOrRn @p GHC.noAnn GHC.noExtField)+            conName'+            con+      HsPatWild -> do+        pure . genLoc $ GHC.WildPat $ onPsOrRn @p GHC.noExtField GHC.noExtField++    fromConName = fmap (onPsOrRn @p genLoc genLoc) . compileHsName++compileHsExpr ::+  forall p m.+  (IsPass p, MonadCompile m (GhcPass p)) =>+  HsExpr (GhcPass p)+  -> m (GHC.LHsExpr (GhcPass p))+compileHsExpr = goExpr+  where+    goExpr :: HsExpr (GhcPass p) -> m (GHC.LHsExpr (GhcPass p))+    goExpr = \case+      HsExprUnsafe{ghcExpr = Just e} -> pure $ unGhcLHsExpr e+      HsExprUnsafe{hsExpr = e} -> goData e++    goData :: HsExprData (GhcPass p) -> m (GHC.LHsExpr (GhcPass p))+    goData = \case+      HsExprCon name -> do+        genLoc . GHC.HsVar GHC.noExtField . genLocIdP @p <$> compileHsName name+      HsExprVar name -> do+        genLoc . GHC.HsVar GHC.noExtField . genLocIdP @p <$> compileHsName name+      HsExprApps f xs -> do+        f' <- goExpr f+        xs' <- mapM goExpr xs+        pure $ foldl' (\l r -> genLoc $ GHC.Compat.hsApp l r) (parens f') (map parens xs')+      HsExprOp _ _ _ ->+        invariantViolation "Compiling HsExprOp not yet supported"+      HsExprList exprs -> do+        exprs' <- mapM goExpr exprs+        pure . genLoc $+          GHC.ExplicitList+            (onPsOrRn @p GHC.noAnn GHC.noExtField)+            exprs'+      HsExprRecordCon con fields -> do+        con' <- genLocConLikeP @p <$> compileHsName con+        fields' <- compileRecFields goExpr fields+        pure . genLoc $+          GHC.RecordCon+            (onPsOrRn @p GHC.noAnn GHC.noExtField)+            con'+            fields'+      HsExprLitString s -> do+        pure . genLoc . GHC.Compat.hsLit $+          GHC.HsString GHC.SourceText.NoSourceText (fsText s)+      HsExprLam pats expr -> do+        pats' <- mapM compileHsPat pats+        expr' <- goExpr expr+        pure . genLoc . GHC.Compat.hsLamSingle $+          GHC.MG origin . genLoc $+            [ genLoc $+                GHC.Match+                  { m_ext = GHC.noAnn+                  , m_ctxt = GHC.Compat.lamAltSingle+                  , m_pats = pats'+                  , m_grhss =+                      GHC.GRHSs+                        { grhssExt = GHC.emptyComments+                        , grhssGRHSs = [genLoc $ GHC.GRHS GHC.noAnn [] expr']+                        , grhssLocalBinds = GHC.EmptyLocalBinds GHC.noExtField+                        }+                  }+            ]+      HsExprCase expr matches -> do+        expr' <- goExpr expr+        matches' <-+          sequence+            [ do+                pat' <- compileHsPat pat+                body' <- goExpr body+                pure . genLoc $+                  GHC.Match+                    { m_ext = GHC.noAnn+                    , m_ctxt = GHC.CaseAlt+                    , m_pats = [pat']+                    , m_grhss =+                        GHC.GRHSs+                          { grhssExt = GHC.emptyComments+                          , grhssGRHSs = [genLoc $ GHC.GRHS GHC.noAnn [] body']+                          , grhssLocalBinds = GHC.EmptyLocalBinds GHC.noExtField+                          }+                    }+            | (pat, body) <- matches+            ]+        pure+          . genLoc+          . GHC.HsCase (onPsOrRn @p GHC.noAnn GHC.Compat.xCaseRn) expr'+          $ GHC.MG origin (genLoc matches')+      HsExprOther ->+        invariantViolation "Compiling HsExprOther not supported"++    origin = onPsOrRn @p GHC.FromSource GHC.FromSource++    parens :: (IsPass p) => GHC.LHsExpr (GhcPass p) -> GHC.LHsExpr (GhcPass p)+    parens = \case+      e@(L _ GHC.HsPar{}) -> e+      e@(L _ GHC.HsApp{}) -> genLoc $ GHC.Compat.hsPar e+      e@(L _ GHC.SectionL{}) -> genLoc $ GHC.Compat.hsPar e+      e@(L _ GHC.SectionR{}) -> genLoc $ GHC.Compat.hsPar e+      e -> e++{----- FastString -----}++fsText :: Text -> GHC.FastString+fsText = GHC.fsLit . Text.unpack++{----- Utilities -----}++data GhcIdP p where+  GhcIdPs :: GHC.RdrName -> GhcIdP GhcPs+  GhcIdRn :: GHC.Name -> GhcIdP GhcRn++instance Show (GhcIdP p) where+  show = \case+    GhcIdPs name -> renderOutputable name+    GhcIdRn name -> renderOutputable name++instance Eq (GhcIdP p) where+  GhcIdPs n1 == GhcIdPs n2 = n1 == n2+  GhcIdRn n1 == GhcIdRn n2 = n1 == n2++unGhcIdP :: GhcIdP p -> GHC.IdP p+unGhcIdP = \case+  GhcIdPs n -> n+  GhcIdRn n -> n++data GhcLHsExpr p where+  GhcLHsExprPs :: GHC.LHsExpr GhcPs -> GhcLHsExpr GhcPs+  GhcLHsExprRn :: GHC.LHsExpr GhcRn -> GhcLHsExpr GhcRn++instance Show (GhcLHsExpr p) where+  show = \case+    GhcLHsExprPs e -> renderOutputable e+    GhcLHsExprRn e -> renderOutputable e++unGhcLHsExpr :: GhcLHsExpr p -> GHC.LHsExpr p+unGhcLHsExpr = \case+  GhcLHsExprPs e -> e+  GhcLHsExprRn e -> e++newtype GhcFixity = GhcFixity GHC.Fixity++instance Show GhcFixity where+  show (GhcFixity fixity) = renderOutputable fixity++renderOutputable :: (GHC.Outputable a) => a -> String+renderOutputable = GHC.showSDocUnsafe . GHC.ppr++onPsOrRn :: forall p a. (IsPass p) => ((p ~ 'GHC.Parsed) => a) -> ((p ~ 'GHC.Renamed) => a) -> a+onPsOrRn ps rn =+  case GHC.ghcPass @p of+    GhcPs -> ps+    GhcRn -> rn+    GhcTc -> invariantViolation "onPsOrRn found GhcTc"++compileRecFields ::+  forall p m arg x.+  (IsPass p, MonadCompile m (GhcPass p)) =>+  (x -> m arg)+  -> [(HsName (GhcPass p), x)]+  -> m (GHC.HsRecFields (GhcPass p) arg)+compileRecFields f fields = do+  fields' <-+    sequence+      [ do+          field' <- compileFieldOcc field+          x' <- f x+          pure . genLoc $+            GHC.HsFieldBind+              { hfbAnn = GHC.noAnn+              , hfbLHS = genLoc field'+              , hfbRHS = x'+              , hfbPun = False+              }+      | (field, x) <- fields+      ]+  pure+    GHC.HsRecFields+      { rec_flds = fields'+      , rec_dotdot = Nothing+      }+  where+    compileFieldOcc field = do+      name <- compileHsName field+      pure $+        onPsOrRn @p+          GHC.FieldOcc+            { foExt = GHC.noExtField+            , foLabel = genLoc name+            }+          GHC.FieldOcc+            { foExt = name+            , foLabel = genLoc $ GHC.getRdrName name+            }++genLocConLikeP ::+  forall p.+  (IsPass p) =>+  GHC.IdP (GhcPass p)+  -> GHC.XRec (GhcPass p) (GHC.ConLikeP (GhcPass p))+genLocConLikeP idp = onPsOrRn @p (genLoc idp) (genLoc idp)++genLocIdP ::+  forall p.+  (IsPass p) =>+  GHC.IdP (GhcPass p)+  -> GHC.LIdP (GhcPass p)+genLocIdP idp = onPsOrRn @p (genLoc idp) (genLoc idp)
+ src/Skeletest/Internal/GHC/Compat.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE CPP #-}++module Skeletest.Internal.GHC.Compat (module X) where++#if __GLASGOW_HASKELL__ == 906+import Skeletest.Internal.GHC.Compat_9_6 as X+#elif __GLASGOW_HASKELL__ == 908+import Skeletest.Internal.GHC.Compat_9_8 as X+#elif __GLASGOW_HASKELL__ == 910+import Skeletest.Internal.GHC.Compat_9_10 as X+#endif
+ src/Skeletest/Internal/GHC/Compat_9_10.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}++module Skeletest.Internal.GHC.Compat_9_10 (+  module Skeletest.Internal.GHC.Compat_9_10,+) where++import Data.Data (toConstr)+import GHC++import Skeletest.Internal.Error (invariantViolation)++hsLamSingle :: MatchGroup (GhcPass p) (LHsExpr (GhcPass p)) -> HsExpr (GhcPass p)+hsLamSingle = HsLam noAnn LamSingle++lamAltSingle :: HsMatchContext fn+lamAltSingle = LamAlt LamSingle++xCaseRn :: XCase GhcRn+xCaseRn = CaseAlt++hsLit :: HsLit (GhcPass p) -> HsExpr (GhcPass p)+hsLit = HsLit noExtField++hsPar :: forall p. (IsPass p) => LHsExpr (GhcPass p) -> HsExpr (GhcPass p)+hsPar =+  HsPar $+    case ghcPass @p of+      GhcPs -> noAnn+      GhcRn -> noExtField+      GhcTc -> invariantViolation "hsPar called in GhcTc"++unHsPar :: HsExpr GhcRn -> LHsExpr GhcRn+unHsPar = \case+  HsPar _ e -> e+  e -> invariantViolation $ "unHsPar called on " <> (show . toConstr) e++hsTupPresent :: LHsExpr (GhcPass p) -> HsTupArg (GhcPass p)+hsTupPresent = Present noExtField++hsApp :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> HsExpr (GhcPass p)+hsApp = HsApp noExtField++genLoc :: (NoAnn ann) => e -> GenLocated (EpAnn ann) e+genLoc = L noAnn
+ src/Skeletest/Internal/GHC/Compat_9_6.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE LambdaCase #-}++module Skeletest.Internal.GHC.Compat_9_6 (+  module Skeletest.Internal.GHC.Compat_9_6,+) where++import Data.Data (toConstr)+import GHC+import GHC.Types.SrcLoc++import Skeletest.Internal.Error (invariantViolation)++hsLamSingle :: MatchGroup (GhcPass p) (LHsExpr (GhcPass p)) -> HsExpr (GhcPass p)+hsLamSingle = HsLam noExtField++lamAltSingle :: HsMatchContext fn+lamAltSingle = LambdaExpr++xCaseRn :: XCase GhcRn+xCaseRn = noExtField++hsLit :: HsLit (GhcPass p) -> HsExpr (GhcPass p)+hsLit = HsLit noAnn++hsPar :: LHsExpr (GhcPass p) -> HsExpr (GhcPass p)+hsPar e = HsPar noAnn (L NoTokenLoc HsTok) e (L NoTokenLoc HsTok)++unHsPar :: HsExpr GhcRn -> LHsExpr GhcRn+unHsPar = \case+  HsPar _ _ e _ -> e+  e -> invariantViolation $ "unHsPar called on " <> (show . toConstr) e++hsTupPresent :: LHsExpr (GhcPass p) -> HsTupArg (GhcPass p)+hsTupPresent = Present noAnn++hsApp :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> HsExpr (GhcPass p)+hsApp = HsApp noAnn++genLoc :: e -> GenLocated (SrcAnn ann) e+genLoc = L (SrcSpanAnn noAnn generatedSrcSpan)
+ src/Skeletest/Internal/GHC/Compat_9_8.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE LambdaCase #-}++module Skeletest.Internal.GHC.Compat_9_8 (+  module Skeletest.Internal.GHC.Compat_9_8,+) where++import Data.Data (toConstr)+import GHC+import GHC.Types.SrcLoc++import Skeletest.Internal.Error (invariantViolation)++hsLamSingle :: MatchGroup (GhcPass p) (LHsExpr (GhcPass p)) -> HsExpr (GhcPass p)+hsLamSingle = HsLam noExtField++lamAltSingle :: HsMatchContext fn+lamAltSingle = LambdaExpr++xCaseRn :: XCase GhcRn+xCaseRn = CaseAlt++hsLit :: HsLit (GhcPass p) -> HsExpr (GhcPass p)+hsLit = HsLit noAnn++hsPar :: LHsExpr (GhcPass p) -> HsExpr (GhcPass p)+hsPar e = HsPar noAnn (L NoTokenLoc HsTok) e (L NoTokenLoc HsTok)++unHsPar :: HsExpr GhcRn -> LHsExpr GhcRn+unHsPar = \case+  HsPar _ _ e _ -> e+  e -> invariantViolation $ "unHsPar called on " <> (show . toConstr) e++hsTupPresent :: LHsExpr (GhcPass p) -> HsTupArg (GhcPass p)+hsTupPresent = Present noAnn++hsApp :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> HsExpr (GhcPass p)+hsApp = HsApp noAnn++genLoc :: e -> GenLocated (SrcAnn ann) e+genLoc = L (SrcSpanAnn noAnn generatedSrcSpan)
+ src/Skeletest/Internal/Markers.hs view
@@ -0,0 +1,36 @@+module Skeletest.Internal.Markers (+  IsMarker (..),+  AnonMarker (..),+  SomeMarker (..),+  findMarker,+  hasMarkerNamed,+) where++import Data.Maybe (listToMaybe, mapMaybe)+import Data.Typeable (Typeable, cast)++class (Show a, Typeable a) => IsMarker a where+  -- | The name of the marker that can be selected with @@name@ syntax.+  --+  -- Marker names must only include alphanumeric characters, hyphens,+  -- underscores, and periods.+  getMarkerName :: a -> String++-- | A marker that can be used for bespoke marker definitions.+newtype AnonMarker = AnonMarker String+  deriving (Show)++instance IsMarker AnonMarker where+  getMarkerName (AnonMarker name) = name++data SomeMarker = forall a. (IsMarker a) => SomeMarker a++deriving instance Show SomeMarker++-- | 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)++-- | Return true if the given marker name is present.+hasMarkerNamed :: String -> [SomeMarker] -> Bool+hasMarkerNamed name = any (\(SomeMarker m) -> getMarkerName m == name)
+ src/Skeletest/Internal/Plugin.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE ViewPatterns #-}++module Skeletest.Internal.Plugin (+  plugin,+) where++import Data.Functor.Const (Const (..))+import Data.Maybe (fromMaybe, listToMaybe)+import Data.Text qualified as Text++#if !MIN_VERSION_base(4, 20, 0)+import Data.Foldable (foldl')+#endif++import Skeletest.Internal.Constants (mainFileSpecsListIdentifier)+import Skeletest.Internal.Error (skeletestPluginError)+import Skeletest.Internal.GHC+import Skeletest.Internal.Predicate qualified as P+import Skeletest.Internal.Utils.HList (HList (..))+import Skeletest.Main qualified as Main+import Skeletest.Plugin qualified as Plugin++-- | The plugin to convert a module in the tests directory.+-- Injected by the preprocessor.+plugin :: Plugin+plugin =+  mkPlugin+    PluginDef+      { isPure = True+      , modifyParsed = \modName modl ->+          if modName == "Main"+            then transformMainModule modl+            else modl+      , onRename = \ctx modName expr ->+          if "Spec" `Text.isSuffixOf` modName+            then transformTestModule ctx expr+            else expr+      }++-- | Add 'main' function.+transformMainModule :: ParsedModule -> ParsedModule+transformMainModule modl = modl{moduleFuncs = (hsVarName "main", Just mainFun) : moduleFuncs modl}+  where+    findVar name =+      fmap hsExprVar . listToMaybe $+        [ funName+        | (funName, _) <- moduleFuncs modl+        , getHsName funName == name+        ]++    cliFlagsExpr = fromMaybe (hsExprList []) $ findVar "cliFlags"+    snapshotRenderersExpr = fromMaybe (hsExprList []) $ findVar "snapshotRenderers"+    hooksExpr = fromMaybe (hsExprVar $ hsName 'Plugin.defaultHooks) $ findVar "hooks"+    pluginsExpr = fromMaybe (hsExprList []) $ findVar "plugins"++    mainFun =+      FunDef+        { funType = HsTypeApps (HsTypeCon $ hsName ''IO) [HsTypeTuple []]+        , funPats = []+        , funBody =+            hsExprApps+              (hsExprVar $ hsName 'Main.runSkeletest)+              [ hsExprApps (hsExprVar (hsName '(:))) $+                  [ hsExprRecordCon+                      (hsName 'Plugin.Plugin)+                      [ (hsName 'Plugin.cliFlags, cliFlagsExpr)+                      , (hsName 'Plugin.snapshotRenderers, snapshotRenderersExpr)+                      , (hsName 'Plugin.hooks, hooksExpr)+                      ]+                  , pluginsExpr+                  ]+              , hsExprVar $ hsVarName mainFileSpecsListIdentifier+              ]+        }++transformTestModule :: Ctx -> HsExpr GhcRn -> HsExpr GhcRn+transformTestModule ctx =+  foldl' (.) id $+    [ replaceConMatch ctx+    , replaceIsoChecker ctx+    ]++-- | Replace all uses of P.con with P.conMatches. See P.con.+--+-- P.con $ User (P.eq "user1") (P.contains "@")+-- ====>+-- P.conMatches+--   "User"+--   Nothing+--   ( \case+--       User x0 x1 -> Just (HCons (pure x0) $ HCons (pure x1) $ HNil)+--       _ -> Nothing+--   )+--   (HCons (H.eq "user1") $ HCons (P.contains "@") $ HNil)+--+-- P.con User{name = P.eq "user1", email = P.contains "@"}+-- ====>+-- P.conMatches+--   "User"+--   (Just (HCons (Const "user") $ HCons (Const "email") $ HNil))+--   ( \case+--       User{name, email} -> Just (HCons (pure name) $ HCons (pure email) $ HNil)+--       _ -> Nothing+--   )+--   (HCons (P.eq "user1") $ HCons (P.contains "@") $ HNil)+replaceConMatch :: Ctx -> HsExpr GhcRn -> HsExpr GhcRn+replaceConMatch ctx e =+  case getExpr e of+    -- Matches:+    --   P.con User{name = ...}+    --   P.con (User "...")+    HsExprApps (getExpr -> HsExprVar name) [arg]+      | isCon name ->+          convertCon arg+    -- Matches:+    --   P.con $ User "..."+    HsExprOp (getExpr -> HsExprVar name) (getExpr -> HsExprVar dollar) arg+      | matchesName ctx (hsName '($)) dollar+      , isCon name ->+          convertCon arg+    -- Check if P.con is by itself+    HsExprVar name+      | isCon name ->+          skeletestPluginError "P.con must be applied to a constructor"+    -- Check if P.con is being applied more than once+    HsExprApps (getExpr -> HsExprVar name) (_ : _ : _)+      | isCon name ->+          skeletestPluginError "P.con must be applied to exactly one argument"+    _ -> e+  where+    isCon = matchesName ctx (hsName 'P.con)++    convertCon con =+      case getExpr con of+        HsExprCon conName -> convertPrefixCon conName []+        HsExprApps (getExpr -> HsExprCon conName) preds -> convertPrefixCon conName preds+        HsExprRecordCon conName fields -> convertRecordCon conName fields+        _ -> skeletestPluginError "P.con must be applied to a constructor"+    convertPrefixCon conName preds =+      let+        exprNames = mkVarNames preds+       in+        hsExprApps (hsExprVar $ hsName 'P.conMatches) $+          [ hsExprLitString $ getHsName conName+          , hsExprCon $ hsName 'Nothing+          , mkDeconstruct (HsPatCon conName $ map HsPatVar exprNames) exprNames+          , mkPredList preds+          ]+    convertRecordCon conName fields =+      let+        (fieldNames, preds) = unzip fields+        fieldPats = [(field, HsPatVar field) | field <- fieldNames]+       in+        hsExprApps (hsExprVar $ hsName 'P.conMatches) $+          [ hsExprLitString $ getHsName conName+          , hsExprApps (hsExprCon $ hsName 'Just) [mkNamesList fieldNames]+          , mkDeconstruct (HsPatRecord conName fieldPats) fieldNames+          , mkPredList preds+          ]++    -- Generate variable names like x0, x1, ... for each element in the given list.+    mkVarNames =+      let mkVar i = "x" <> (Text.pack . show) i+       in zipWith (\i _ -> hsVarName (mkVar i)) [0 :: Int ..]++    -- Create the deconstruction function:+    --+    -- \actual ->+    --   case actual of+    --     User{name} -> Just (HCons (pure name) HNil)+    --     _ -> Nothing+    --+    -- However, if 'User' is the only constructor, GHC complains about the wildcard+    -- being redundant. So we'll obfuscate it a bit with+    --+    -- \actual ->+    --   case pure actual of+    --     Just User{name} -> Just (HCons (pure name) HNil)+    --     _ -> Nothing+    mkDeconstruct pat argNames =+      hsExprLam [HsPatVar $ hsVarName "actual"] $+        hsExprCase (hsExprApps (hsExprVar $ hsName 'pure) [hsExprVar $ hsVarName "actual"]) $+          [ (HsPatCon (hsName 'Just) [pat], hsExprApps (hsExprCon $ hsName 'Just) [mkValsList argNames])+          , (HsPatWild, hsExprCon $ hsName 'Nothing)+          ]++    mkHList f = \case+      [] -> hsExprCon (hsName 'HNil)+      x : xs ->+        hsExprApps (hsExprCon $ hsName 'HCons) $+          [ f x+          , mkHList f xs+          ]++    mkNamesList = mkHList $ \name -> hsExprApps (hsExprCon $ hsName 'Const) [hsExprLitString $ getHsName name]+    mkValsList = mkHList $ \val -> hsExprApps (hsExprVar $ hsName 'pure) [hsExprVar val]+    mkPredList = mkHList id++-- | Replace all uses of P.=== with inlined IsoChecker value, with+-- function name filled in.+--+-- (encode . decode) P.=== id+-- ====>+-- IsoChecker (Fun "encode . decode" (encode . decode)) (Fun "id" id)+replaceIsoChecker :: Ctx -> HsExpr GhcRn -> HsExpr GhcRn+replaceIsoChecker ctx e =+  case getExpr e of+    HsExprOp l (getExpr -> HsExprVar eqeqeq) r+      | matchesName ctx (hsName '(P.===)) eqeqeq ->+          inlineIsoChecker l r+    _ -> e+  where+    inlineIsoChecker l r = hsExprApps (hsExprCon $ hsName 'P.IsoChecker) [mkFun l, mkFun r]+    mkFun f = hsExprApps (hsExprCon $ hsName 'P.Fun) [hsExprLitString $ renderHsExpr f, f]
+ src/Skeletest/Internal/Predicate.hs view
@@ -0,0 +1,814 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeData #-}+{-# LANGUAGE TypeFamilies #-}++module Skeletest.Internal.Predicate (+  Predicate,+  PredicateResult (..),+  runPredicate,+  renderPredicate,++  -- * General+  anything,++  -- * Ord+  eq,+  gt,+  gte,+  lt,+  lte,++  -- * Data types+  just,+  nothing,+  left,+  right,+  IsPredTuple (..),+  tup,+  con,+  conMatches,++  -- * Numeric+  approx,+  tol,+  Tolerance (..),++  -- * Combinators+  (<<<),+  (>>>),+  not,+  (&&),+  (||),+  and,+  or,++  -- * Containers+  any,+  all,+  elem,++  -- * Subsequences+  HasSubsequences (..),+  hasPrefix,+  hasInfix,+  hasSuffix,++  -- * IO+  returns,+  throws,++  -- * Functions+  Fun (..),+  IsoChecker (..),+  (===),+  isoWith,++  -- * Snapshot testing+  matchesSnapshot,+) where++import Control.Monad.IO.Class (MonadIO)+import Data.Foldable (toList)+import Data.Foldable1 qualified as Foldable1+import Data.Functor.Const (Const (..))+import Data.Functor.Identity (Identity (..))+import Data.Kind (Type)+import Data.List qualified as List+import Data.List.NonEmpty qualified as NonEmpty+import Data.Maybe (isJust, isNothing, listToMaybe)+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Typeable (Typeable)+import Debug.RecoverRTTI (anythingToString)+import GHC.Generics ((:*:) (..))+import GHC.Stack qualified as GHC+import UnliftIO (MonadUnliftIO)+import UnliftIO.Exception (Exception, displayException, try)+import Prelude hiding (abs, all, and, any, elem, not, or, (&&), (||))+import Prelude qualified++import Skeletest.Internal.CLI (getFlag)+import Skeletest.Internal.Error (invariantViolation)+import Skeletest.Internal.Snapshot (+  SnapshotContext (..),+  SnapshotResult (..),+  SnapshotUpdateFlag (..),+  checkSnapshot,+  getAndIncSnapshotIndex,+  getSnapshotRenderers,+  updateSnapshot,+ )+import Skeletest.Internal.TestInfo (getTestInfo)+import Skeletest.Internal.Utils.Diff (showLineDiff)+import Skeletest.Internal.Utils.HList (HList (..))+import Skeletest.Internal.Utils.HList qualified as HList+import Skeletest.Prop.Gen (Gen)+import Skeletest.Prop.Internal (PropertyM, forAll)++data Predicate m a = Predicate+  { predicateFunc :: a -> m PredicateFuncResult+  , predicateDisp :: Text+  -- ^ The rendered representation of the predicate+  , predicateDispNeg :: Text+  -- ^ The rendered representation of the negation of the predicate+  }++data PredicateResult+  = PredicateSuccess+  | PredicateFail Text++runPredicate :: (Monad m) => Predicate m a -> a -> m PredicateResult+runPredicate Predicate{..} val = do+  PredicateFuncResult{..} <- predicateFunc val+  pure $+    if predicateSuccess+      then PredicateSuccess+      else+        let failCtx =+              FailCtx+                { failCtxExpected = predicateDisp+                , failCtxActual = render val+                }+         in PredicateFail . withFailCtx failCtx predicateShowFailCtx $ predicateExplain++renderPredicate :: Predicate m a -> Text+renderPredicate = predicateDisp++data PredicateFuncResult = PredicateFuncResult+  { predicateSuccess :: Bool+  , predicateExplain :: Text+  -- ^ The explanation of the result.+  --+  -- If predicateSuccess is true, this is the message to show if the+  -- success is unexpected. If predicatesSuccess is false, this is+  -- the message to show on the failure.+  , predicateShowFailCtx :: ShowFailCtx+  -- ^ See 'ShowFailCtx'.+  }++-- | Should a predicate show the context of the failure?+--+-- When failing `P.left (P.eq 1)`, the failure should show just the specific+-- thing that failed, e.g. `1 ≠ 2`, but we should show the general context+-- as well, e.g. `Expected: Left (= 1), Got: Left 2`. Primitive predicates+-- should generally start as NoFailCtx, then higher-order predicates should+-- upgrade it to ShowFailCtx. Predicates that explicitly want to hide the+-- context should set HideFailCtx.+data ShowFailCtx+  = NoFailCtx+  | ShowFailCtx+  | HideFailCtx+  deriving (Eq, Ord)++shouldShowFailCtx :: ShowFailCtx -> Bool+shouldShowFailCtx = \case+  NoFailCtx -> False+  ShowFailCtx -> True+  HideFailCtx -> False++data FailCtx = FailCtx+  { failCtxExpected :: Text+  , failCtxActual :: Text+  }++renderFailCtx :: FailCtx -> Text+renderFailCtx FailCtx{..} =+  Text.intercalate "\n" $+    [ "Expected:"+    , indent failCtxExpected+    , ""+    , "Got:"+    , indent failCtxActual+    ]++withFailCtx :: FailCtx -> ShowFailCtx -> Text -> Text+withFailCtx failCtx ctx s =+  if shouldShowFailCtx ctx+    then Text.intercalate "\n" [s, "", renderFailCtx failCtx]+    else s++noCtx :: ShowFailCtx+noCtx = NoFailCtx++showMergedCtxs :: [PredicateFuncResult] -> ShowFailCtx+showMergedCtxs = max ShowFailCtx . maybe NoFailCtx Foldable1.maximum . NonEmpty.nonEmpty . map predicateShowFailCtx++showCtx :: PredicateFuncResult -> PredicateFuncResult+showCtx result = result{predicateShowFailCtx = max ShowFailCtx $ predicateShowFailCtx result}++{----- General -----}++anything :: (Monad m) => Predicate m a+anything =+  Predicate+    { predicateFunc = \_ ->+        pure+          PredicateFuncResult+            { predicateSuccess = True+            , predicateExplain = "anything"+            , predicateShowFailCtx = noCtx+            }+    , predicateDisp = "anything"+    , predicateDispNeg = "not anything"+    }++{----- Ord -----}++eq :: (Eq a, Monad m) => a -> Predicate m a+eq = mkPredicateOp "=" "≠" $ \actual expected -> actual == expected++gt :: (Ord a, Monad m) => a -> Predicate m a+gt = mkPredicateOp ">" "≯" $ \actual expected -> actual > expected++gte :: (Ord a, Monad m) => a -> Predicate m a+gte = mkPredicateOp "≥" "≱" $ \actual expected -> actual > expected Prelude.|| actual == expected++lt :: (Ord a, Monad m) => a -> Predicate m a+lt = mkPredicateOp "<" "≮" $ \actual expected -> actual < expected++lte :: (Ord a, Monad m) => a -> Predicate m a+lte = mkPredicateOp "≤" "≰" $ \actual expected -> actual < expected Prelude.|| actual == expected++{----- Data types -----}++just :: (Monad m) => Predicate m a -> Predicate m (Maybe a)+just p = conMatches "Just" fieldNames toFields preds+  where+    fieldNames = Nothing+    toFields = \case+      Just x -> Just . HCons (pure x) $ HNil+      _ -> Nothing+    preds = HCons p HNil++nothing :: (Monad m) => Predicate m (Maybe a)+nothing = conMatches "Nothing" fieldNames toFields preds+  where+    fieldNames = Nothing+    toFields = \case+      Nothing -> Just HNil+      _ -> Nothing+    preds = HNil++left :: (Monad m) => Predicate m a -> Predicate m (Either a b)+left p = conMatches "Left" fieldNames toFields preds+  where+    fieldNames = Nothing+    toFields = \case+      Left x -> Just . HCons (pure x) $ HNil+      _ -> Nothing+    preds = HCons p HNil++right :: (Monad m) => Predicate m b -> Predicate m (Either a b)+right p = conMatches "Right" fieldNames toFields preds+  where+    fieldNames = Nothing+    toFields = \case+      Right x -> Just . HCons (pure x) $ HNil+      _ -> Nothing+    preds = HCons p HNil++class IsTuple a where+  type TupleArgs a :: [Type]+  toHList :: a -> HList Identity (TupleArgs a)+instance IsTuple (a, b) where+  type TupleArgs (a, b) = '[a, b]+  toHList (a, b) = HCons (pure a) . HCons (pure b) $ HNil+instance IsTuple (a, b, c) where+  type TupleArgs (a, b, c) = '[a, b, c]+  toHList (a, b, c) = HCons (pure a) . HCons (pure b) . HCons (pure c) $ HNil+instance IsTuple (a, b, c, d) where+  type TupleArgs (a, b, c, d) = '[a, b, c, d]+  toHList (a, b, c, d) = HCons (pure a) . HCons (pure b) . HCons (pure c) . HCons (pure d) $ HNil+instance IsTuple (a, b, c, d, e) where+  type TupleArgs (a, b, c, d, e) = '[a, b, c, d, e]+  toHList (a, b, c, d, e) = HCons (pure a) . HCons (pure b) . HCons (pure c) . HCons (pure d) . HCons (pure e) $ HNil+instance IsTuple (a, b, c, d, e, f) where+  type TupleArgs (a, b, c, d, e, f) = '[a, b, c, d, e, f]+  toHList (a, b, c, d, e, f) = HCons (pure a) . HCons (pure b) . HCons (pure c) . HCons (pure d) . HCons (pure e) . HCons (pure f) $ HNil++class (IsTuple a) => IsPredTuple m a where+  type ToPredTuple m a+  toHListPred :: proxy a -> ToPredTuple m a -> HList (Predicate m) (TupleArgs a)+instance IsPredTuple m (a, b) where+  type ToPredTuple m (a, b) = (Predicate m a, Predicate m b)+  toHListPred _ (a, b) = HCons a . HCons b $ HNil+instance IsPredTuple m (a, b, c) where+  type ToPredTuple m (a, b, c) = (Predicate m a, Predicate m b, Predicate m c)+  toHListPred _ (a, b, c) = HCons a . HCons b . HCons c $ HNil+instance IsPredTuple m (a, b, c, d) where+  type ToPredTuple m (a, b, c, d) = (Predicate m a, Predicate m b, Predicate m c, Predicate m d)+  toHListPred _ (a, b, c, d) = HCons a . HCons b . HCons c . HCons d $ HNil+instance IsPredTuple m (a, b, c, d, e) where+  type ToPredTuple m (a, b, c, d, e) = (Predicate m a, Predicate m b, Predicate m c, Predicate m d, Predicate m e)+  toHListPred _ (a, b, c, d, e) = HCons a . HCons b . HCons c . HCons d . HCons e $ HNil+instance IsPredTuple m (a, b, c, d, e, f) where+  type ToPredTuple m (a, b, c, d, e, f) = (Predicate m a, Predicate m b, Predicate m c, Predicate m d, Predicate m e, Predicate m f)+  toHListPred _ (a, b, c, d, e, f) = HCons a . HCons b . HCons c . HCons d . HCons e . HCons f $ HNil++-- | Matches a tuple satisfying the given predicates. Works for tuples up to 6 elements.+--+-- @+-- P.tup (P.eq 1, P.gt 2, P.hasPrefix "hello ")+-- @+tup :: forall a m. (IsPredTuple m a, Monad m) => ToPredTuple m a -> Predicate m a+tup predTup =+  Predicate+    { predicateFunc = \actual ->+        verifyAll tupify <$> runPredicates preds (toHList actual)+    , predicateDisp = disp+    , predicateDispNeg = dispNeg+    }+  where+    preds = toHListPred (Proxy @a) predTup+    tupify vals = "(" <> Text.intercalate ", " vals <> ")"+    disp = tupify $ HList.toListWith predicateDisp preds+    dispNeg = "not " <> disp++-- | A predicate for checking that a value matches the given constructor.+--+-- It takes one argument, which is the constructor, except with all fields+-- taking a Predicate instead of the normal value. Skeletest will rewrite+-- the expression so it typechecks correctly.+--+-- >>> user `shouldSatisfy` P.con User{name = P.eq "user1", email = P.contains "@"}+--+-- Record fields that are omitted are not checked at all; i.e.+-- @P.con Foo{}@ and @P.con Foo{a = P.anything}@ are equivalent.+con :: a -> Predicate m a+con =+  -- A placeholder that will be replaced with conMatches in the plugin.+  invariantViolation "P.con was not replaced"++-- | A predicate for checking that a value matches the given constructor.+-- Assumes that the arguments correctly match the constructor being tested,+-- so it should not be written directly, only generated from `con`.+conMatches ::+  (Monad m) =>+  String+  -> Maybe (HList (Const String) fields)+  -> (a -> Maybe (HList Identity fields))+  -> HList (Predicate m) fields+  -> Predicate m a+conMatches conNameS mFieldNames deconstruct preds =+  Predicate+    { predicateFunc = \actual ->+        case deconstruct actual of+          Just fields -> verifyAll consify <$> runPredicates preds fields+          Nothing ->+            pure+              PredicateFuncResult+                { predicateSuccess = False+                , predicateExplain = render actual <> " " <> dispNeg+                , predicateShowFailCtx = noCtx+                }+    , predicateDisp = disp+    , predicateDispNeg = dispNeg+    }+  where+    conName = Text.pack conNameS+    disp = "matches " <> predsDisp+    dispNeg = "does not match " <> predsDisp+    predsDisp = consify $ HList.toListWith predicateDisp preds++    -- consify ["= 1", "anything"] => User{id = (= 1), name = anything}+    -- consify ["= 1", "anything"] => Foo (= 1) anything+    consify vals =+      case HList.uncheck <$> mFieldNames of+        Nothing -> Text.unwords $ conName : map parens vals+        Just fieldNames ->+          let fields = zipWith (\field v -> Text.pack field <> " = " <> parens v) fieldNames vals+           in conName <> "{" <> Text.intercalate ", " fields <> "}"++{----- Numeric -----}++-- | A predicate for checking that a value is equal within some tolerance.+--+-- Useful for checking equality with floats, which might not be exactly equal.+-- For more information, see: https://jvns.ca/blog/2023/01/13/examples-of-floating-point-problems/.+--+-- >>> (0.1 + 0.2) `shouldSatisfy` P.approx P.tol 0.3+-- >>> (0.1 + 0.2) `shouldSatisfy` P.approx P.tol{P.rel = Just 1e-6} 0.3+-- >>> (0.1 + 0.2) `shouldSatisfy` P.approx P.tol{P.abs = 1e-12} 0.3+-- >>> (0.1 + 0.2) `shouldSatisfy` P.approx P.tol{P.rel = Just 1e-6, P.abs = 1e-12} 0.3+-- >>> (0.1 + 0.2) `shouldSatisfy` P.approx P.tol{P.rel = Nothing} 0.3+-- >>> (0.1 + 0.2) `shouldSatisfy` P.approx P.tol{P.rel = Nothing, P.abs = 1e-12} 0.3+approx :: (Fractional a, Ord a, Monad m) => Tolerance -> a -> Predicate m a+approx Tolerance{..} =+  mkPredicateOp "≈" "≉" $ \actual expected ->+    Prelude.abs (actual - expected) <= getTolerance expected+  where+    mRelTol = fromTol <$> rel+    absTol = fromTol abs+    getTolerance expected =+      case mRelTol of+        Just relTol -> max (relTol * Prelude.abs expected) absTol+        Nothing -> absTol++    fromTol x+      | x < 0 = error $ "tolerance can't be negative: " <> show x+      | otherwise = fromRational x++data Tolerance = Tolerance+  { rel :: Maybe Rational+  , abs :: Rational+  }++tol :: Tolerance+tol = Tolerance{rel = Just 1e-6, abs = 1e-12}++{----- Combinators -----}++infixr 1 <<<, >>>++(<<<) :: (Monad m) => Predicate m a -> (b -> a) -> Predicate m b+Predicate{..} <<< f =+  Predicate+    { predicateFunc = fmap showCtx . predicateFunc . f+    , predicateDisp+    , predicateDispNeg+    }++(>>>) :: (Monad m) => (b -> a) -> Predicate m a -> Predicate m b+(>>>) = flip (<<<)++not :: (Monad m) => Predicate m a -> Predicate m a+not Predicate{..} =+  Predicate+    { predicateFunc = \actual -> do+        result <- showCtx <$> predicateFunc actual+        pure result{predicateSuccess = Prelude.not $ predicateSuccess result}+    , predicateDisp = predicateDispNeg+    , predicateDispNeg = predicateDisp+    }++(&&) :: (Monad m) => Predicate m a -> Predicate m a -> Predicate m a+p1 && p2 = and [p1, p2]++(||) :: (Monad m) => Predicate m a -> Predicate m a -> Predicate m a+p1 || p2 = or [p1, p2]++and :: (Monad m) => [Predicate m a] -> Predicate m a+and preds =+  Predicate+    { predicateFunc = \actual ->+        verifyAll (const "All predicates passed") <$> mapM (\p -> predicateFunc p actual) preds+    , predicateDisp = andify predList+    , predicateDispNeg = "At least one failure:\n" <> andify predList+    }+  where+    andify = Text.intercalate "\nand "+    predList = map (parens . predicateDisp) preds++or :: (Monad m) => [Predicate m a] -> Predicate m a+or preds =+  Predicate+    { predicateFunc = \actual ->+        verifyAny (const "No predicates passed") <$> mapM (\p -> predicateFunc p actual) preds+    , predicateDisp = orify predList+    , predicateDispNeg = "All failures:\n" <> orify predList+    }+  where+    orify = Text.intercalate "\nor "+    predList = map (parens . predicateDisp) preds++{----- Containers -----}++any :: (Foldable t, Monad m) => Predicate m a -> Predicate m (t a)+any Predicate{..} =+  Predicate+    { predicateFunc = \actual ->+        verifyAny (const "No values matched") <$> mapM predicateFunc (toList actual)+    , predicateDisp = "at least one element matching " <> parens predicateDisp+    , predicateDispNeg = "no elements matching " <> parens predicateDisp+    }++all :: (Foldable t, Monad m) => Predicate m a -> Predicate m (t a)+all Predicate{..} =+  Predicate+    { predicateFunc = \actual ->+        verifyAll (const "All values matched") <$> mapM predicateFunc (toList actual)+    , predicateDisp = "all elements matching " <> parens predicateDisp+    , predicateDispNeg = "some elements not matching " <> parens predicateDisp+    }++elem :: (Eq a, Foldable t, Monad m) => a -> Predicate m (t a)+elem = any . eq++{----- Subsequences -----}++class HasSubsequences a where+  isPrefixOf :: a -> a -> Bool+  isInfixOf :: a -> a -> Bool+  isSuffixOf :: a -> a -> Bool+instance (Eq a) => HasSubsequences [a] where+  isPrefixOf = List.isPrefixOf+  isInfixOf = List.isInfixOf+  isSuffixOf = List.isSuffixOf+instance HasSubsequences Text where+  isPrefixOf = Text.isPrefixOf+  isInfixOf = Text.isInfixOf+  isSuffixOf = Text.isSuffixOf++hasPrefix :: (HasSubsequences a, Monad m) => a -> Predicate m a+hasPrefix prefix =+  Predicate+    { predicateFunc = \val -> do+        let success = prefix `isPrefixOf` val+        pure+          PredicateFuncResult+            { predicateSuccess = success+            , predicateExplain =+                if success+                  then render val <> " " <> disp+                  else render val <> " " <> dispNeg+            , predicateShowFailCtx = noCtx+            }+    , predicateDisp = disp+    , predicateDispNeg = dispNeg+    }+  where+    disp = "has prefix " <> render prefix+    dispNeg = "does not have prefix " <> render prefix++hasInfix :: (HasSubsequences a, Monad m) => a -> Predicate m a+hasInfix elems =+  Predicate+    { predicateFunc = \val -> do+        let success = elems `isInfixOf` val+        pure+          PredicateFuncResult+            { predicateSuccess = success+            , predicateExplain =+                if success+                  then render val <> " " <> disp+                  else render val <> " " <> dispNeg+            , predicateShowFailCtx = noCtx+            }+    , predicateDisp = disp+    , predicateDispNeg = dispNeg+    }+  where+    disp = "has infix " <> render elems+    dispNeg = "does not have infix " <> render elems++hasSuffix :: (HasSubsequences a, Monad m) => a -> Predicate m a+hasSuffix suffix =+  Predicate+    { predicateFunc = \val -> do+        let success = suffix `isSuffixOf` val+        pure+          PredicateFuncResult+            { predicateSuccess = success+            , predicateExplain =+                if success+                  then render val <> " " <> disp+                  else render val <> " " <> dispNeg+            , predicateShowFailCtx = noCtx+            }+    , predicateDisp = disp+    , predicateDispNeg = dispNeg+    }+  where+    disp = "has suffix " <> render suffix+    dispNeg = "does not have suffix " <> render suffix++{----- IO -----}++returns :: (MonadIO m) => Predicate m a -> Predicate m (m a)+returns Predicate{..} =+  Predicate+    { predicateFunc = \io -> do+        x <- io+        PredicateFuncResult{..} <- predicateFunc x+        pure+          PredicateFuncResult+            { predicateSuccess = predicateSuccess+            , predicateExplain =+                if predicateSuccess+                  then predicateExplain+                  else+                    let failCtx =+                          FailCtx+                            { failCtxExpected = predicateDisp+                            , failCtxActual = render x+                            }+                     in withFailCtx failCtx predicateShowFailCtx predicateExplain+            , predicateShowFailCtx = HideFailCtx+            }+    , predicateDisp = predicateDisp+    , predicateDispNeg = predicateDispNeg+    }++throws :: (Exception e, MonadUnliftIO m) => Predicate m e -> Predicate m (m a)+throws Predicate{..} =+  Predicate+    { predicateFunc = \io ->+        try io >>= \case+          Left e -> do+            PredicateFuncResult{..} <- predicateFunc e+            pure+              PredicateFuncResult+                { predicateSuccess = predicateSuccess+                , predicateExplain =+                    if predicateSuccess+                      then predicateExplain+                      else+                        let failCtx =+                              FailCtx+                                { failCtxExpected = disp+                                , failCtxActual = Text.pack $ displayException e+                                }+                         in withFailCtx failCtx predicateShowFailCtx predicateExplain+                , predicateShowFailCtx = HideFailCtx+                }+          Right x ->+            pure+              PredicateFuncResult+                { predicateSuccess = False+                , predicateExplain =+                    renderFailCtx+                      FailCtx+                        { failCtxExpected = disp+                        , failCtxActual = render x+                        }+                , predicateShowFailCtx = HideFailCtx+                }+    , predicateDisp = disp+    , predicateDispNeg = dispNeg+    }+  where+    disp = "throws (" <> predicateDisp <> ")"+    dispNeg = "does not throw (" <> predicateDisp <> ")"++{----- Functions -----}++data Fun a b = Fun String (a -> b)+data IsoChecker a b = IsoChecker (Fun a b) (Fun a b)++-- | Verify if two functions are isomorphic.+--+-- @+-- prop "reverse . reverse === id" $ do+--   let genList = Gen.list (Gen.linear 0 10) $ Gen.int (Gen.linear 0 1000)+--   (reverse . reverse) === id \`shouldSatisfy\` P.isoWith genList+-- @+(===) :: (a -> b) -> (a -> b) -> IsoChecker a b+f === g = IsoChecker (Fun "lhs" f) (Fun "rhs" g)++infix 2 ===++-- | See '(===)'.+isoWith :: (GHC.HasCallStack, Show a, Eq b) => Gen a -> Predicate PropertyM (IsoChecker a b)+isoWith gen =+  Predicate+    { predicateFunc = \(IsoChecker (Fun f1DispS f1) (Fun f2DispS f2)) -> do+        a <- GHC.withFrozenCallStack $ forAll gen+        let+          f1Disp = Text.pack f1DispS+          f2Disp = Text.pack f2DispS+          b1 = f1 a+          b2 = f2 a+          aDisp = parens $ render a+          b1Disp = parens $ render b1+          b2Disp = parens $ render b2+        pure+          PredicateFuncResult+            { predicateSuccess = b1 == b2+            , predicateExplain =+                Text.intercalate "\n" $+                  [ b1Disp <> " " <> (if b1 == b2 then "=" else "≠") <> " " <> b2Disp+                  , "where"+                  , indent $ b1Disp <> " = " <> f1Disp <> " " <> aDisp+                  , indent $ b2Disp <> " = " <> f2Disp <> " " <> aDisp+                  ]+            , predicateShowFailCtx = HideFailCtx+            }+    , predicateDisp = disp+    , predicateDispNeg = dispNeg+    }+  where+    disp = "isomorphic"+    dispNeg = "not isomorphic"++{----- Snapshot -----}++matchesSnapshot :: (Typeable a, MonadIO m) => Predicate m a+matchesSnapshot =+  Predicate+    { predicateFunc = \actual -> do+        SnapshotUpdateFlag doUpdate <- getFlag+        testInfo <- getTestInfo+        snapshotIndex <- getAndIncSnapshotIndex+        renderers <- getSnapshotRenderers+        let ctx =+              SnapshotContext+                { snapshotRenderers = renderers+                , snapshotTestInfo = testInfo+                , snapshotIndex+                }++        result <-+          if doUpdate+            then updateSnapshot ctx actual >> pure SnapshotMatches+            else checkSnapshot ctx actual++        pure+          PredicateFuncResult+            { predicateSuccess = result == SnapshotMatches+            , predicateExplain =+                case result of+                  SnapshotMissing -> "Snapshot does not exist. Update snapshot with --update."+                  SnapshotMatches -> "Matches snapshot"+                  SnapshotDiff snapshot renderedActual ->+                    Text.intercalate "\n" $+                      [ "Result differed from snapshot. Update snapshot with --update."+                      , showLineDiff ("expected", snapshot) ("actual", renderedActual)+                      ]+            , predicateShowFailCtx = HideFailCtx+            }+    , predicateDisp = "matches snapshot"+    , predicateDispNeg = "does not match snapshot"+    }++{----- Utilities -----}++mkPredicateOp ::+  (Monad m) =>+  Text+  -- ^ operator+  -> Text+  -- ^ negative operator+  -> (a -> a -> Bool)+  -- ^ actual -> expected -> success+  -> a+  -- ^ expected+  -> Predicate m a+mkPredicateOp op negOp f expected =+  Predicate+    { predicateFunc = \actual -> do+        let success = f actual expected+        pure+          PredicateFuncResult+            { predicateSuccess = success+            , predicateExplain =+                if success+                  then render actual <> " " <> disp+                  else render actual <> " " <> dispNeg+            , predicateShowFailCtx = noCtx+            }+    , predicateDisp = disp+    , predicateDispNeg = dispNeg+    }+  where+    disp = op <> " " <> render expected+    dispNeg = negOp <> " " <> render expected++runPredicates :: (Monad m) => HList (Predicate m) xs -> HList Identity xs -> m [PredicateFuncResult]+runPredicates preds = HList.toListWithM run . HList.hzip preds+  where+    run :: (Predicate m :*: Identity) a -> m PredicateFuncResult+    run (p :*: Identity x) = predicateFunc p x++verifyAll :: ([Text] -> Text) -> [PredicateFuncResult] -> PredicateFuncResult+verifyAll mergeMessages results =+  PredicateFuncResult+    { predicateSuccess = isNothing firstFailure+    , predicateExplain =+        case firstFailure of+          Just p -> predicateExplain p+          Nothing -> mergeMessages $ map predicateExplain results+    , predicateShowFailCtx = showMergedCtxs results+    }+  where+    firstFailure = listToMaybe $ filter (Prelude.not . predicateSuccess) results++verifyAny :: ([Text] -> Text) -> [PredicateFuncResult] -> PredicateFuncResult+verifyAny mergeMessages results =+  PredicateFuncResult+    { predicateSuccess = isJust firstSuccess+    , predicateExplain =+        case firstSuccess of+          Just p -> predicateExplain p+          Nothing -> mergeMessages $ map predicateExplain results+    , predicateShowFailCtx = showMergedCtxs results+    }+  where+    firstSuccess = listToMaybe $ filter predicateSuccess results++render :: a -> Text+render = Text.pack . anythingToString++-- | Add parentheses if the given input contains spaces.+parens :: Text -> Text+parens s =+  if " " `Text.isInfixOf` s+    then "(" <> s <> ")"+    else s++indent :: Text -> Text+indent = Text.intercalate "\n" . map ("  " <>) . Text.splitOn "\n"
+ src/Skeletest/Internal/Preprocessor.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE OverloadedStrings #-}++module Skeletest.Internal.Preprocessor (+  processFile,+) where++import Control.Monad (guard)+import Data.Char (isDigit, isLower, isUpper)+import Data.List (sort)+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import Data.Text qualified as Text+import System.Directory (doesDirectoryExist, listDirectory)+import System.FilePath (makeRelative, splitExtensions, takeDirectory, (</>))++import Skeletest.Internal.Constants (mainFileSpecsListIdentifier)+import Skeletest.Internal.Error (skeletestPluginError)++-- | Preprocess the given Haskell file. See Main.hs+processFile :: FilePath -> Text -> IO Text+processFile path file = do+  file' <- if isMain file then updateMainFile path file else pure file+  pure+    . addLine pluginPragma+    . addLine linePragma+    $ file'+  where+    addLine line f = line <> "\n" <> f+    quoted s = "\"" <> s <> "\""++    pluginPragma = "{-# OPTIONS_GHC -fplugin=Skeletest.Internal.Plugin #-}"+    linePragma =+      -- this is needed to tell GHC to use original path in error messages+      "{-# LINE 1 " <> quoted (Text.pack path) <> " #-}"++isMain :: Text -> Bool+isMain file =+  case mapMaybe getModuleName $ Text.lines file of+    -- there was a module line+    [name] -> name == "Main"+    -- there were no module lines, it's the main module+    [] -> True+    -- something else? just silently ignore it+    _ -> False+  where+    getModuleName s =+      case Text.words s of+        "module" : name : _ -> Just name+        _ -> Nothing++updateMainFile :: FilePath -> Text -> IO Text+updateMainFile path file = do+  modules <- findTestModules path+  pure+    . addSpecsList modules+    . insertImports modules+    $ file++-- | Find all test modules using the given path to the Main module.+--+-- >>> findTestModules "test/Main.hs"+-- ["My.Module.Test1", "My.Module.Test2", ...]+findTestModules :: FilePath -> IO [(FilePath, Text)]+findTestModules path = mapMaybe toTestModule <$> listDirectoryRecursive testDir+  where+    testDir = takeDirectory path++    toTestModule fp = do+      guard (fp /= path)+      (fpNoExt, ".hs") <- pure $ splitExtensions fp+      guard ("Spec" `Text.isSuffixOf` Text.pack fpNoExt)+      name <- moduleNameFromPath $ Text.pack $ makeRelative testDir fpNoExt+      pure (fp, name)++    moduleNameFromPath = fmap (Text.intercalate ".") . mapM validateModuleName . Text.splitOn "/"++    -- https://www.haskell.org/onlinereport/syntax-iso.html+    -- large { small | large | digit | ' }+    validateModuleName name = do+      (first, rest) <- Text.uncons name+      guard $ isUpper first+      guard $ Text.all (\c -> isUpper c || isLower c || isDigit c || c == '\'') rest+      pure name++addSpecsList :: [(FilePath, Text)] -> Text -> Text+addSpecsList testModules file =+  Text.unlines+    [ file+    , mainFileSpecsListIdentifier <> " :: [(FilePath, String, Spec)]"+    , mainFileSpecsListIdentifier <> " = " <> renderSpecList specsList+    ]+  where+    specsList =+      [ (quote $ Text.pack fp, quote modName, modName <> ".spec")+      | (fp, modName) <- testModules+      ]+    quote s = "\"" <> s <> "\""+    renderSpecList xs = "[" <> (Text.intercalate ", " . map renderSpecInfo) xs <> "]"+    renderSpecInfo (fp, name, spec) = "(" <> fp <> ", " <> name <> ", " <> spec <> ")"++-- | Add imports after the Skeletest.Main import, which should always be present in the Main module.+insertImports :: [(FilePath, Text)] -> Text -> Text+insertImports testModules file =+  let (pre, post) = break isSkeletestImport $ Text.lines file+   in if null post+        then skeletestPluginError "Could not find Skeletest.Main import in Main module"+        else Text.unlines $ pre <> importTests <> post+  where+    isSkeletestImport line =+      case Text.words line of+        "import" : "Skeletest.Main" : _ -> True+        _ -> False++    importTests =+      [ "import qualified " <> name+      | (_, name) <- testModules+      ]++{----- Helpers -----}++listDirectoryRecursive :: FilePath -> IO [FilePath]+listDirectoryRecursive fp = fmap (sort . concat) . mapM (go . (fp </>)) =<< listDirectory fp+  where+    go child = do+      isDir <- doesDirectoryExist child+      if isDir+        then listDirectoryRecursive child+        else pure [child]
+ src/Skeletest/Internal/Snapshot.hs view
@@ -0,0 +1,407 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoFieldSelectors #-}++module Skeletest.Internal.Snapshot (+  -- * Running snapshot+  SnapshotContext (..),+  SnapshotResult (..),+  updateSnapshot,+  checkSnapshot,++  -- * Rendering+  SnapshotRenderer (..),+  defaultSnapshotRenderers,+  setSnapshotRenderers,+  getSnapshotRenderers,+  plainRenderer,+  renderWithShow,++  -- ** SnapshotFile+  SnapshotFile (..),+  SnapshotValue (..),+  decodeSnapshotFile,+  encodeSnapshotFile,+  normalizeSnapshotFile,++  -- * Infrastructure+  getAndIncSnapshotIndex,+  SnapshotUpdateFlag (..),+) where++import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Except (runExceptT, throwE)+import Data.Aeson qualified as Aeson+import Data.Aeson.Encode.Pretty qualified as Aeson+import Data.Char (isAlpha, isPrint)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.IO qualified as Text+import Data.Text.Lazy qualified as TextL+import Data.Text.Lazy.Encoding qualified as TextL+import Data.Typeable (Typeable)+import Data.Typeable qualified as Typeable+import Data.Void (absurd)+import Debug.RecoverRTTI (anythingToString)+import System.Directory (createDirectoryIfMissing)+import System.FilePath (replaceExtension, splitFileName, takeDirectory, (</>))+import System.IO.Error (isDoesNotExistError)+import System.IO.Unsafe (unsafePerformIO)+import UnliftIO.Exception (throwIO, try)+import UnliftIO.IORef (+  IORef,+  atomicModifyIORef',+  modifyIORef',+  newIORef,+  readIORef,+  writeIORef,+ )++import Skeletest.Internal.CLI (FlagSpec (..), IsFlag (..))+import Skeletest.Internal.Error (SkeletestError (..), invariantViolation)+import Skeletest.Internal.Fixtures (+  Fixture (..),+  FixtureScope (..),+  getFixture,+  noCleanup,+  withCleanup,+ )+import Skeletest.Internal.TestInfo (TestInfo (..), getTestInfo)+import Skeletest.Internal.Utils.Map qualified as Map.Utils++{----- Infrastructure -----}++data SnapshotTestFixture = SnapshotTestFixture+  { snapshotIndexRef :: IORef Int+  }++instance Fixture SnapshotTestFixture where+  fixtureAction = do+    snapshotIndexRef <- newIORef 0+    pure . noCleanup $ SnapshotTestFixture{..}++getAndIncSnapshotIndex :: (MonadIO m) => m Int+getAndIncSnapshotIndex = do+  SnapshotTestFixture{snapshotIndexRef} <- getFixture+  atomicModifyIORef' snapshotIndexRef $ \i -> (i + 1, i)++data SnapshotFileFixture = SnapshotFileFixture+  { snapshotFileRef :: IORef (Maybe SnapshotFile)+  }++instance Fixture SnapshotFileFixture where+  fixtureScope = PerFileFixture+  fixtureAction = do+    TestInfo{testFile} <- getTestInfo+    let snapshotPath = getSnapshotPath testFile++    mSnapshotFile <-+      try (Text.readFile snapshotPath) >>= \case+        Left e+          | isDoesNotExistError e -> pure Nothing+          | otherwise -> throwIO e+        Right contents ->+          case decodeSnapshotFile contents of+            Just snapshotFile -> pure $ Just snapshotFile+            Nothing -> throwIO $ SnapshotFileCorrupted snapshotPath+    let snapshotChanged newSnapshot = mSnapshotFile /= Just newSnapshot++    snapshotFileRef <- newIORef mSnapshotFile+    pure . withCleanup SnapshotFileFixture{..} $+      -- write snapshot back out when file is done+      readIORef snapshotFileRef >>= \case+        Just snapshotFile | snapshotChanged snapshotFile -> do+          createDirectoryIfMissing True (takeDirectory snapshotPath)+          Text.writeFile snapshotPath $ encodeSnapshotFile $ normalizeSnapshotFile snapshotFile+        _ -> pure ()++newtype SnapshotUpdateFlag = SnapshotUpdateFlag Bool++instance IsFlag SnapshotUpdateFlag where+  flagName = "update"+  flagShort = Just 'u'+  flagHelp = "Update snapshots"+  flagSpec = SwitchFlag SnapshotUpdateFlag++{----- Running snapshot -----}++data SnapshotContext = SnapshotContext+  { snapshotRenderers :: [SnapshotRenderer]+  , snapshotTestInfo :: TestInfo+  , snapshotIndex :: Int+  }++updateSnapshot :: (Typeable a, MonadIO m) => SnapshotContext -> a -> m ()+updateSnapshot snapshotContext testResult = do+  SnapshotFileFixture{snapshotFileRef} <- getFixture+  modifyIORef' snapshotFileRef (Just . setSnapshot . fromMaybe emptySnapshotFile)+  where+    SnapshotContext+      { snapshotRenderers = renderers+      , snapshotTestInfo = testInfo@TestInfo{testModule}+      , snapshotIndex+      } = snapshotContext++    emptySnapshotFile =+      SnapshotFile+        { moduleName = testModule+        , snapshots = Map.empty+        }++    testIdentifier = toTestIdentifier testInfo+    renderedTestResult = renderVal renderers testResult+    setSnapshot snapshotFile@SnapshotFile{snapshots} =+      let setForTest = Map.Utils.adjustNested (setAt snapshotIndex renderedTestResult) testIdentifier+       in snapshotFile{snapshots = setForTest snapshots}++    -- Set the given snapshot at the given index. If the index is too large,+    -- fill in with empty snapshots.+    --+    -- >>> setAt 3 "x" ["a"] == ["a", "", "", "x"]+    setAt i0 v =+      let go = \cases+            i [] -> replicate i emptySnapshotVal <> [v]+            0 (_ : xs) -> v : xs+            i (x : xs) -> x : go (i - 1) xs+       in if i0 < 0+            then invariantViolation $ "Got negative snapshot index: " <> show i0+            else go i0+    emptySnapshotVal = SnapshotValue{snapshotContent = "", snapshotLang = Nothing}++data SnapshotResult+  = SnapshotMissing+  | SnapshotMatches+  | SnapshotDiff+      { snapshotContent :: Text+      , renderedTestResult :: Text+      }+  deriving (Show, Eq)++checkSnapshot :: (Typeable a, MonadIO m) => SnapshotContext -> a -> m SnapshotResult+checkSnapshot snapshotContext testResult =+  fmap (either id absurd) . runExceptT $ do+    SnapshotFileFixture{snapshotFileRef} <- getFixture+    fileSnapshots <-+      readIORef snapshotFileRef >>= \case+        Nothing -> returnE SnapshotMissing+        Just SnapshotFile{snapshots} -> pure snapshots++    let snapshots = Map.Utils.findOrEmpty (toTestIdentifier testInfo) fileSnapshots+    snapshot <- maybe (returnE SnapshotMissing) pure $ safeIndex snapshots snapshotIndex++    let (snapshotContent, renderedTestResult) = (getContent snapshot, getContent renderedTestResultVal)+    returnE $+      if snapshotContent == renderedTestResult+        then SnapshotMatches+        else SnapshotDiff{snapshotContent, renderedTestResult}+  where+    SnapshotContext+      { snapshotRenderers = renderers+      , snapshotTestInfo = testInfo+      , snapshotIndex+      } = snapshotContext++    returnE = throwE+    renderedTestResultVal = renderVal renderers testResult++    safeIndex xs0 i0 =+      let go = \cases+            _ [] -> Nothing+            0 (x : _) -> Just x+            i (_ : xs) -> go (i - 1) xs+       in if i0 < 0 then Nothing else go i0 xs0++{----- Snapshot file -----}++data SnapshotFile = SnapshotFile+  { moduleName :: Text+  , snapshots :: Map TestIdentifier [SnapshotValue]+  -- ^ full test identifier => snapshots+  -- e.g. ["group1", "group2", "returns val1 and val2"] => ["val1", "val2"]+  }+  deriving (Show, Eq)++data SnapshotValue = SnapshotValue+  { snapshotContent :: Text+  , snapshotLang :: Maybe Text+  }+  deriving (Show, Eq)++getContent :: SnapshotValue -> Text+getContent SnapshotValue{snapshotContent} = snapshotContent++type TestIdentifier = [Text]++getSnapshotPath :: FilePath -> FilePath+getSnapshotPath testFile = testDir </> "__snapshots__" </> snapshotFileName+  where+    (testDir, testFileName) = splitFileName testFile+    snapshotFileName = replaceExtension testFileName ".snap.md"++toTestIdentifier :: TestInfo -> TestIdentifier+toTestIdentifier TestInfo{testContexts, testName} = testContexts <> [testName]++decodeSnapshotFile :: Text -> Maybe SnapshotFile+decodeSnapshotFile = parseFile . Text.lines+  where+    parseFile = \case+      line : rest+        | Just moduleName <- Text.stripPrefix "# " line -> do+            let snapshotFile =+                  SnapshotFile+                    { moduleName = Text.strip moduleName+                    , snapshots = Map.empty+                    }+            parseSections snapshotFile Nothing rest+      _ -> Nothing++    parseSections ::+      SnapshotFile+      -- \^ The parsed snapshot file so far+      -> Maybe [Text]+      -- \^ The current test identifier, if one is set+      -> [Text]+      -- \^ The rest of the lines to process+      -> Maybe SnapshotFile+    parseSections snapshotFile@SnapshotFile{snapshots} mTest = \case+      [] -> pure snapshotFile+      line : rest+        -- ignore empty lines+        | "" <- Text.strip line -> parseSections snapshotFile mTest rest+        -- found a test section+        | Just sectionName <- Text.stripPrefix "## " line -> do+            let testIdentifier = map Text.strip $ Text.splitOn " / " sectionName+            let snapshotFile' = snapshotFile{snapshots = Map.insert testIdentifier [] snapshots}+            parseSections snapshotFile' (Just testIdentifier) rest+        -- found the beginning of a snapshot+        | Just lang <- (Text.stripPrefix "```" . Text.strip) line -> do+            testIdentifier <- mTest+            (snapshot, rest') <- parseSnapshot [] rest+            let+              snapshotVal =+                SnapshotValue+                  { snapshotContent = snapshot+                  , snapshotLang = if Text.null lang then Nothing else Just lang+                  }+              snapshotFile' = snapshotFile{snapshots = Map.adjust (<> [snapshotVal]) testIdentifier snapshots}+            parseSections snapshotFile' mTest rest'+        -- anything else is invalid+        | otherwise -> Nothing++    parseSnapshot snapshot = \case+      [] -> Nothing+      line : rest+        | "```" <- Text.strip line -> pure (Text.unlines snapshot, rest)+        | otherwise -> parseSnapshot (snapshot <> [line]) rest++encodeSnapshotFile :: SnapshotFile -> Text+encodeSnapshotFile SnapshotFile{..} =+  Text.intercalate "\n" $+    h1 moduleName : concatMap toSection (Map.toList snapshots)+  where+    toSection (testIdentifier, snaps) =+      h2 (Text.intercalate " / " testIdentifier) : map codeBlock snaps++    h1 s = "# " <> s <> "\n"+    h2 s = "## " <> s <> "\n"+    codeBlock SnapshotValue{..} =+      Text.concat+        [ "```" <> fromMaybe "" snapshotLang <> "\n"+        , snapshotContent+        , "```\n"+        ]++normalizeSnapshotFile :: SnapshotFile -> SnapshotFile+normalizeSnapshotFile file@SnapshotFile{snapshots} =+  file+    { snapshots = Map.fromList . map normalize . Map.toList $ snapshots+    }+  where+    normalize (testIdentifier, vals) =+      ( map (sanitizeNonPrint . sanitizeSlashes . Text.strip) testIdentifier+      , map normalizeSnapshotVal vals+      )++    sanitizeSlashes = Text.replace " /" " \\/"++    sanitizeNonPrint = Text.concatMap $ \case+      c | (not . isPrint) c -> Text.drop 1 . Text.dropEnd 1 . Text.pack . show $ c+      c -> Text.singleton c++{----- Renderers -----}++data SnapshotRenderer+  = forall a.+  (Typeable a) =>+  SnapshotRenderer+  { render :: a -> Text+  , snapshotLang :: Maybe Text+  }++plainRenderer :: (Typeable a) => (a -> Text) -> SnapshotRenderer+plainRenderer render =+  SnapshotRenderer+    { render+    , snapshotLang = Nothing+    }++renderWithShow :: forall a. (Typeable a, Show a) => SnapshotRenderer+renderWithShow = plainRenderer (Text.pack . show @a)++defaultSnapshotRenderers :: [SnapshotRenderer]+defaultSnapshotRenderers =+  [ plainRenderer @String Text.pack+  , plainRenderer @Text id+  , jsonRenderer+  ]+  where+    jsonRenderer =+      SnapshotRenderer+        { render = TextL.toStrict . TextL.decodeUtf8 . Aeson.encodePretty @Aeson.Value+        , snapshotLang = Just "json"+        }++renderVal :: (Typeable a) => [SnapshotRenderer] -> a -> SnapshotValue+renderVal renderers a =+  normalizeSnapshotVal $+    case mapMaybe tryRender renderers of+      [] ->+        SnapshotValue+          { snapshotContent = Text.pack $ anythingToString a+          , snapshotLang = Nothing+          }+      rendered : _ -> rendered+  where+    tryRender SnapshotRenderer{..} =+      let toValue v = SnapshotValue{snapshotContent = render v, snapshotLang}+       in toValue <$> Typeable.cast a++normalizeSnapshotVal :: SnapshotValue -> SnapshotValue+normalizeSnapshotVal SnapshotValue{..} =+  SnapshotValue+    { snapshotContent = normalizeTrailingNewlines snapshotContent+    , snapshotLang = collapse $ Text.filter isAlpha <$> snapshotLang+    }+  where+    collapse = \case+      Just "" -> Nothing+      m -> m++    -- Ensure there's exactly one trailing newline.+    normalizeTrailingNewlines s = Text.dropWhileEnd (== '\n') s <> "\n"++snapshotRenderersRef :: IORef [SnapshotRenderer]+snapshotRenderersRef = unsafePerformIO $ newIORef []+{-# NOINLINE snapshotRenderersRef #-}++setSnapshotRenderers :: [SnapshotRenderer] -> IO ()+setSnapshotRenderers = writeIORef snapshotRenderersRef++getSnapshotRenderers :: (MonadIO m) => m [SnapshotRenderer]+getSnapshotRenderers = readIORef snapshotRenderersRef
+ src/Skeletest/Internal/Spec.hs view
@@ -0,0 +1,377 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Skeletest.Internal.Spec (+  -- * Spec interface+  Spec,+  SpecTree (..),+  runSpecs,++  -- ** Entrypoint+  SpecRegistry,+  SpecInfo (..),+  pruneSpec,+  applyTestSelections,++  -- ** Defining a Spec+  describe,+  Testable (..),+  test,+  it,+  prop,++  -- ** Modifiers+  xfail,+  skip,+  markManual,++  -- ** Markers+  IsMarker (..),+  withMarkers,+  withMarker,+) 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 Data.Text qualified as Text+import Data.Text.IO qualified as Text+import UnliftIO.Exception (+  finally,+  fromException,+  try,+ )++import Skeletest.Assertions (Testable, runTestable)+import Skeletest.Internal.Fixtures (FixtureScopeKey (..), cleanupFixtures)+import Skeletest.Internal.Markers (+  AnonMarker (..),+  IsMarker (..),+  SomeMarker (..),+  findMarker,+ )+import Skeletest.Internal.TestInfo (TestInfo (TestInfo), withTestInfo)+import Skeletest.Internal.TestInfo qualified as TestInfo+import Skeletest.Internal.TestRunner (+  TestResult (..),+  TestResultMessage (..),+  testResultFromAssertionFail,+  testResultFromError,+  testResultPass,+ )+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)++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++data SpecTree+  = SpecGroup+      { groupLabel :: Text+      , groupTrees :: [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 ()+      }++-- | 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 =+  (`finally` cleanupFixtures PerSessionFixtureKey) $+    fmap and . forM specs $ \SpecInfo{..} ->+      (`finally` cleanupFixtures (PerFileFixtureKey specPath)) $ do+        let emptyTestInfo =+              TestInfo+                { testModule = specName+                , testContexts = []+                , testName = ""+                , testMarkers = []+                , testFile = specPath+                }+        Text.putStrLn specName+        runTrees emptyTestInfo $ getSpecTrees specSpec+  where+    Hooks{..} = builtinHooks <> hooks0+    builtinHooks = xfailHook <> skipHook++    runTrees baseTestInfo = fmap and . mapM (runTree baseTestInfo)+    runTree baseTestInfo = \case+      SpecGroup{..} -> do+        let lvl = getIndentLevel baseTestInfo+        Text.putStrLn $ indent lvl groupLabel+        runTrees baseTestInfo{TestInfo.testContexts = TestInfo.testContexts baseTestInfo <> [groupLabel]} groupTrees+      SpecTest{..} -> do+        let lvl = getIndentLevel baseTestInfo+        Text.putStr $ indent lvl (testName <> ": ")++        let testInfo =+              baseTestInfo+                { TestInfo.testName = testName+                , TestInfo.testMarkers = testMarkers+                }+        TestResult{..} <-+          withTestInfo testInfo $ do+            tid <- myThreadId+            runTest testInfo testAction `finally` cleanupFixtures (PerTestFixtureKey tid)++        Text.putStrLn testResultLabel+        case testResultMessage of+          TestResultMessageNone -> pure ()+          TestResultMessageInline msg -> Text.putStrLn $ indent (lvl + 1) msg+          TestResultMessageSection msg -> Text.putStrLn $ withBorder msg+        pure testResultSuccess++    runTest info action =+      hookRunTest info $ do+        try action >>= \case+          Right () -> pure testResultPass+          Left e+            | Just e' <- fromException e -> testResultFromAssertionFail e'+            | otherwise -> pure $ testResultFromError e++    getIndentLevel testInfo = length (TestInfo.testContexts testInfo) + 1 -- +1 to include the module name+    indent lvl = Text.intercalate "\n" . map (Text.replicate (lvl * 4) " " <>) . Text.splitOn "\n"++    border = Text.replicate 80 "-"+    withBorder msg = Text.intercalate "\n" [border, msg, border]++{----- Entrypoint -----}++type SpecRegistry = [SpecInfo]++data SpecInfo = SpecInfo+  { specPath :: FilePath+  , specName :: Text+  , 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++{----- Defining a Spec -----}++describe :: String -> Spec -> Spec+describe name = runIdentity . withSpecTrees (pure . (: []) . mkGroup)+  where+    mkGroup trees =+      SpecGroup+        { groupLabel = Text.pack name+        , groupTrees = trees+        }++test :: (Testable m) => String -> m () -> Spec+test name t = Spec $ tell [mkTest]+  where+    mkTest =+      SpecTest+        { testName = Text.pack name+        , testMarkers = []+        , testAction = runTestable t+        }++it :: String -> IO () -> Spec+it = test++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++xfailHook :: Hooks+xfailHook =+  defaultHooks+    { hookRunTest = \testInfo runTest ->+        case findMarker (TestInfo.testMarkers testInfo) of+          Just (MarkerXFail reason) -> modify reason <$> runTest+          Nothing -> runTest+    }+  where+    modify reason TestResult{..} =+      if testResultSuccess+        then+          TestResult+            { testResultSuccess = False+            , testResultLabel = Color.red "XPASS"+            , testResultMessage = TestResultMessageInline reason+            }+        else+          TestResult+            { testResultSuccess = True+            , testResultLabel = Color.yellow "XFAIL"+            , 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+          Just (MarkerSkip reason) ->+            pure+              TestResult+                { testResultSuccess = True+                , testResultLabel = Color.yellow "SKIP"+                , testResultMessage = TestResultMessageInline reason+                }+          Nothing -> runTest+    }++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))+  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
+ src/Skeletest/Internal/TestInfo.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE LambdaCase #-}++module Skeletest.Internal.TestInfo (+  TestInfo (..),+  withTestInfo,+  getTestInfo,+  lookupTestInfo,+) where++import Control.Monad.IO.Class (MonadIO)+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Text (Text)+import System.IO.Unsafe (unsafePerformIO)+import UnliftIO (MonadUnliftIO)+import UnliftIO.Concurrent (ThreadId, myThreadId)+import UnliftIO.Exception (bracket_)+import UnliftIO.IORef (IORef, modifyIORef, newIORef, readIORef)++import Skeletest.Internal.Error (invariantViolation)+import Skeletest.Internal.Markers (SomeMarker)++data TestInfo = TestInfo+  { testModule :: Text+  , testContexts :: [Text]+  , testName :: Text+  , testMarkers :: [SomeMarker]+  , testFile :: FilePath+  -- ^ Relative to CWD+  }+  deriving (Show)++type TestInfoMap = Map ThreadId TestInfo++testInfoMapRef :: IORef TestInfoMap+testInfoMapRef = unsafePerformIO $ newIORef Map.empty+{-# NOINLINE testInfoMapRef #-}++withTestInfo :: (MonadUnliftIO m) => TestInfo -> m a -> m a+withTestInfo info m = do+  tid <- myThreadId+  bracket_ (set tid) (unset tid) m+  where+    set tid = modifyIORef testInfoMapRef $ Map.insert tid info+    unset tid = modifyIORef testInfoMapRef $ Map.delete tid++lookupTestInfo :: (MonadIO m) => m (Maybe TestInfo)+lookupTestInfo = do+  tid <- myThreadId+  Map.lookup tid <$> readIORef testInfoMapRef++getTestInfo :: (MonadIO m) => m TestInfo+getTestInfo =+  lookupTestInfo >>= \case+    Just info -> pure info+    -- it's not possible for a user to write code that's executed within a test,+    -- because we define the entire main function.+    Nothing -> invariantViolation "test info not initialized"
+ src/Skeletest/Internal/TestRunner.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Skeletest.Internal.TestRunner (+  -- * Testable+  Testable (..),++  -- * TestResult+  TestResult (..),+  TestResultMessage (..),+  testResultPass,+  testResultFromAssertionFail,+  testResultFromError,++  -- * AssertionFail+  AssertionFail (..),+  FailContext,+) where++import Control.Monad.IO.Class (MonadIO)+import Data.Maybe (listToMaybe)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.IO qualified as Text+import GHC.Stack (CallStack)+import GHC.Stack qualified as GHC+import UnliftIO.Exception (+  Exception,+  SomeException,+  displayException,+  fromException,+  try,+ )++import Skeletest.Internal.Error (SkeletestError)+import Skeletest.Internal.TestInfo (TestInfo)+import Skeletest.Internal.Utils.Color qualified as Color++{----- Testable -----}++class (MonadIO m) => Testable m where+  runTestable :: m () -> IO ()+  context :: String -> m a -> m a+  throwFailure :: AssertionFail -> m a++{----- TestResult -----}++data TestResult = TestResult+  { testResultSuccess :: Bool+  , testResultLabel :: Text+  , testResultMessage :: TestResultMessage+  }++data TestResultMessage+  = TestResultMessageNone+  | TestResultMessageInline Text+  | TestResultMessageSection Text++testResultPass :: TestResult+testResultPass =+  TestResult+    { testResultSuccess = True+    , testResultLabel = Color.green "OK"+    , testResultMessage = TestResultMessageNone+    }++testResultFromAssertionFail :: AssertionFail -> IO TestResult+testResultFromAssertionFail e = do+  msg <- renderAssertionFail e+  pure+    TestResult+      { testResultSuccess = False+      , testResultLabel = Color.red "FAIL"+      , testResultMessage = TestResultMessageSection msg+      }++testResultFromError :: SomeException -> TestResult+testResultFromError e =+  TestResult+    { testResultSuccess = False+    , testResultLabel = Color.red "ERROR"+    , testResultMessage = TestResultMessageInline $ Text.pack msg+    }+  where+    msg =+      case fromException e of+        -- In GHC 9.10+, SomeException shows the callstack, which we don't+        -- want to see for known Skeletest errors+        Just (err :: SkeletestError) -> displayException err+        Nothing -> displayException e++{----- AssertionFail -----}++data AssertionFail = AssertionFail+  { testInfo :: TestInfo+  , testFailMessage :: Text+  , testFailContext :: FailContext+  , callStack :: CallStack+  }+  deriving (Show)++instance Exception AssertionFail++-- | Context for failures, in order of most recently added -> least recently added+type FailContext = [Text]++-- | Render a test failure like:+--+-- @+-- At test/Skeletest/Internal/TestTargetsSpec.hs:19:+-- |+-- |           parseTestTargets input `shouldBe` Right (Just expected)+-- |                                   ^^^^^^^^+--+-- Right 1 ≠ Left 1+-- @+renderAssertionFail :: AssertionFail -> IO Text+renderAssertionFail AssertionFail{..} = do+  prettyStackTrace <- mapM renderCallLine . reverse $ GHC.getCallStack callStack+  pure . Text.intercalate "\n\n" . concat $+    [ prettyStackTrace+    , if null testFailContext+        then []+        else [Text.intercalate "\n" $ reverse testFailContext]+    , [testFailMessage]+    ]+  where+    renderCallLine (_, loc) = do+      let+        path = GHC.srcLocFile loc+        lineNum = GHC.srcLocStartLine loc+        startCol = GHC.srcLocStartCol loc+        endCol = GHC.srcLocEndCol loc++      mLine <-+        try (Text.readFile path) >>= \case+          Right srcFile -> pure $ getLineNum lineNum srcFile+          Left (_ :: SomeException) -> pure Nothing+      let (srcLine, pointerLine) =+            case mLine of+              Just line ->+                ( line+                , Text.replicate (startCol - 1) " " <> Text.replicate (endCol - startCol) "^"+                )+              Nothing ->+                ( "<unknown line>"+                , ""+                )++      pure . Text.intercalate "\n" $+        [ Text.pack path <> ":" <> (Text.pack . show) lineNum <> ":"+        , "|"+        , "| " <> srcLine+        , "| " <> pointerLine+        ]++    getLineNum n = listToMaybe . take 1 . drop (n - 1) . Text.lines
+ src/Skeletest/Internal/TestTargets.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Skeletest.Internal.TestTargets (+  TestTargets,+  TestTarget (..),+  TestAttrs (..),+  matchesTest,+  parseTestTargets,+) where++import Control.Monad.Combinators.Expr qualified as Parser+import Data.Bifunctor (first)+import Data.Char (isAlphaNum)+import Data.Foldable1 qualified as Foldable1+import Data.List.NonEmpty qualified as NonEmpty+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Void (Void)+import Text.Megaparsec (Parsec)+import Text.Megaparsec qualified as Parser+import Text.Megaparsec.Char qualified as Parser+import Text.Megaparsec.Char.Lexer qualified as Parser.L++type TestTargets = Maybe TestTarget++data TestTarget+  = -- | Useful for selecting all tests, whether manual or not.+    TestTargetEverything+  | TestTargetFile FilePath+  | TestTargetName Text+  | TestTargetMarker Text+  | TestTargetNot TestTarget+  | TestTargetAnd TestTarget TestTarget+  | TestTargetOr TestTarget TestTarget+  deriving (Eq)++data TestAttrs = TestAttrs+  { testPath :: FilePath+  , testIdentifier :: [Text]+  , testMarkers :: [Text]+  }++matchesTest :: TestTarget -> TestAttrs -> Bool+matchesTest selection TestAttrs{..} = go selection+  where+    go = \case+      TestTargetEverything -> True+      TestTargetFile path -> testPath == path+      TestTargetName s -> s `Text.isInfixOf` Text.unwords testIdentifier+      TestTargetMarker marker -> marker `elem` testMarkers+      TestTargetNot e -> not $ go e+      TestTargetAnd l r -> go l && go r+      TestTargetOr l r -> go l || go r++{----- Parsing -----}++parseTestTargets :: [Text] -> Either Text TestTargets+parseTestTargets args =+  case NonEmpty.nonEmpty args of+    Nothing -> pure Nothing+    Just args' -> Just . Foldable1.foldr1 TestTargetOr <$> mapM parseTestTarget args'+  where+    parseTestTarget = first showTestTargetParseError . Parser.parse (testTargetParser <* Parser.eof) ""++type Parser = Parsec Void Text+type ParseErrorBundle = Parser.ParseErrorBundle Text Void++testTargetParser :: Parser TestTarget+testTargetParser =+  Parser.makeExprParser+    ( Parser.choice+        [ parens testTargetParser+        , everythingParser+        , nameParser+        , markerParser+        , do+            selectFile <- fileParser+            -- syntax sugar: FooSpec.hs[abc] == (FooSpec.hs and [abc])+            withName <- maybe id (flip TestTargetAnd) <$> Parser.optional nameParser+            pure $ withName selectFile+        ]+    )+    [ [prefix "not" TestTargetNot]+    , [binary "and" TestTargetAnd, binary "or" TestTargetOr]+    ]+  where+    prefix name f = Parser.Prefix (f <$ symbol name)+    binary name f = Parser.InfixL (f <$ symbol name)++    symbol = Parser.L.symbol Parser.space+    parens = Parser.between (symbol "(") (symbol ")")++    everythingParser = TestTargetEverything <$ symbol "*"++    nameParser =+      Parser.label "test name" $+        fmap TestTargetName . Parser.between (symbol "[") (symbol "]") $+          Parser.takeWhile1P Nothing (/= ']')++    markerParser =+      Parser.label "marker" . ignoreSpacesAfter $ do+        _ <- symbol "@"+        fmap TestTargetMarker . Parser.takeWhile1P Nothing $+          (||) <$> isAlphaNum <*> (`elem` ("-_." :: [Char]))++    fileParser =+      Parser.label "test file" . ignoreSpacesAfter $+        fmap (TestTargetFile . Text.unpack) . Parser.takeWhile1P Nothing $+          (||) <$> isAlphaNum <*> (`elem` ("-_./" :: [Char]))++    ignoreSpacesAfter m = m <* Parser.space++showTestTargetParseError :: ParseErrorBundle -> Text+showTestTargetParseError bundle =+  let+    line = Parser.pstateInput $ Parser.bundlePosState bundle+    err = NonEmpty.head $ Parser.bundleErrors bundle+    pointerLen =+      case err of+        Parser.TrivialError _ (Just (Parser.Tokens s)) _ -> length s+        _ -> 1+   in+    Text.concat+      [ "Could not parse test target: " <> Text.pack (Parser.parseErrorTextPretty err)+      , " |\n"+      , " | " <> line <> "\n"+      , " | " <> Text.replicate (Parser.errorOffset err) " " <> Text.replicate pointerLen "^"+      ]
+ src/Skeletest/Internal/Utils/Color.hs view
@@ -0,0 +1,21 @@+module Skeletest.Internal.Utils.Color (+  green,+  red,+  yellow,+) where++import Data.Text (Text)+import Data.Text qualified as Text+import System.Console.ANSI qualified as ANSI++withANSI :: [ANSI.SGR] -> Text -> Text+withANSI codes s = Text.pack (ANSI.setSGRCode codes) <> s <> Text.pack (ANSI.setSGRCode [ANSI.Reset])++green :: Text -> Text+green = withANSI [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Green]++red :: Text -> Text+red = withANSI [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Red]++yellow :: Text -> Text+yellow = withANSI [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Yellow]
+ src/Skeletest/Internal/Utils/Diff.hs view
@@ -0,0 +1,16 @@+module Skeletest.Internal.Utils.Diff (+  showLineDiff,+) where++import Data.Algorithm.DiffContext (getContextDiffNew, prettyContextDiff)+import Data.Text (Text)+import Data.Text qualified as Text+import Text.PrettyPrint qualified as PP++showLineDiff :: (Text, Text) -> (Text, Text) -> Text+showLineDiff (fromName, fromContent) (toName, toContent) =+  Text.pack . PP.render $+    prettyContextDiff (ppText fromName) (ppText toName) ppText $+      getContextDiffNew (Just 5) (Text.lines fromContent) (Text.lines toContent)+  where+    ppText = PP.text . Text.unpack
+ src/Skeletest/Internal/Utils/HList.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}++module Skeletest.Internal.Utils.HList (+  HList (..),+  uncheck,+  toListWith,+  toListWithM,+  hzip,+  hzipWithM,+) where++import Data.Functor.Const (Const (..))+import Data.Functor.Identity (runIdentity)+import GHC.Generics ((:*:) (..))++data HList f xs where+  HNil :: HList f '[]+  HCons :: f x -> HList f xs -> HList f (x ': xs)++uncheck :: HList (Const a) xs -> [a]+uncheck = toListWith getConst++toListWith :: (forall x. f x -> y) -> HList f xs -> [y]+toListWith f = runIdentity . toListWithM (pure . f)++toListWithM :: (Monad m) => (forall x. f x -> m y) -> HList f xs -> m [y]+toListWithM f = \case+  HNil -> pure []+  HCons x xs -> (:) <$> f x <*> toListWithM f xs++hzip :: HList f xs -> HList g xs -> HList (f :*: g) xs+hzip = \cases+  HNil HNil -> HNil+  (HCons f fs) (HCons g gs) -> HCons (f :*: g) (hzip fs gs)++hzipWithM ::+  (Monad m) =>+  (forall x. f x -> g x -> m (h x))+  -> HList f xs+  -> HList g xs+  -> m (HList h xs)+hzipWithM k = \cases+  HNil HNil -> pure HNil+  (HCons f fs) (HCons g gs) -> HCons <$> k f g <*> hzipWithM k fs gs
+ src/Skeletest/Internal/Utils/Map.hs view
@@ -0,0 +1,19 @@+module Skeletest.Internal.Utils.Map (+  findOrEmpty,+  adjustNested,+) where++import Data.Map (Map)+import Data.Map qualified as Map+import Data.Maybe (fromMaybe)+import GHC.Exts (IsList, fromList)++findOrEmpty :: (Ord k, IsList (t a)) => k -> Map k (t a) -> t a+findOrEmpty = Map.findWithDefault (fromList [])++-- | Same as 'adjust', except defaulting to an empty structure if it doesn't+-- exist, and deleting the key if the adjusted value is empty.+adjustNested :: (Ord k, Foldable t, IsList (t a)) => (t a -> t a) -> k -> Map k (t a) -> Map k (t a)+adjustNested f =+  let prune m = if null m then Nothing else Just m+   in Map.alter (prune . f . fromMaybe (fromList []))
+ src/Skeletest/Main.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Skeletest.Main (+  runSkeletest,++  -- * CLI flags+  Flag,+  flag,++  -- * Snapshots+  SnapshotRenderer (..),+  renderWithShow,++  -- * Plugins+  Plugin,++  -- * Re-exports+  Spec,+) where++import Control.Monad (unless)+import Data.Maybe (fromMaybe)+import Data.Text qualified as Text+import System.Exit (exitFailure)++import Skeletest.Internal.CLI (Flag, flag, loadCliArgs)+import Skeletest.Internal.Snapshot (+  SnapshotRenderer (..),+  SnapshotUpdateFlag,+  defaultSnapshotRenderers,+  renderWithShow,+  setSnapshotRenderers,+ )+import Skeletest.Internal.Spec (+  Spec,+  SpecInfo (..),+  applyTestSelections,+  pruneSpec,+  runSpecs,+ )+import Skeletest.Plugin (Plugin (..))+import Skeletest.Prop.Internal (PropLimitFlag, PropSeedFlag)++runSkeletest :: [Plugin] -> [(FilePath, String, Spec)] -> IO ()+runSkeletest = runSkeletest' . mconcat++runSkeletest' :: Plugin -> [(FilePath, String, Spec)] -> IO ()+runSkeletest' Plugin{..} testModules = do+  selections <- loadCliArgs builtinFlags cliFlags+  setSnapshotRenderers (snapshotRenderers <> defaultSnapshotRenderers)++  let initialSpecs = map mkSpec testModules+  success <- runSpecs hooks . pruneSpec . applyTestSelections selections $ initialSpecs+  unless success exitFailure+  where+    builtinFlags =+      [ flag @SnapshotUpdateFlag+      , flag @PropSeedFlag+      , flag @PropLimitFlag+      ]++    mkSpec (specPath, name, specSpec) =+      SpecInfo+        { specPath+        , specName = stripSuffix "Spec" $ Text.pack name+        , specSpec+        }++    -- same as Text.stripSuffix, except return original string if not match+    stripSuffix suf s = fromMaybe s $ Text.stripSuffix suf s
+ src/Skeletest/Plugin.hs view
@@ -0,0 +1,71 @@+module Skeletest.Plugin (+  Plugin (..),+  defaultPlugin,++  -- * Hooks+  Hooks (..),+  defaultHooks,++  -- * Re-exports++  -- ** TestResult+  TestResult (..),+  TestResultMessage (..),++  -- ** TestInfo+  TestInfo (..),++  -- ** Markers+  findMarker,+  hasMarkerNamed,+) where++import Skeletest.Internal.CLI (Flag)+import Skeletest.Internal.Markers (findMarker, hasMarkerNamed)+import Skeletest.Internal.Snapshot (SnapshotRenderer)+import Skeletest.Internal.TestInfo (TestInfo (..))+import Skeletest.Internal.TestRunner (TestResult (..), TestResultMessage (..))++data Plugin = Plugin+  { cliFlags :: [Flag]+  , snapshotRenderers :: [SnapshotRenderer]+  , hooks :: Hooks+  }++instance Semigroup Plugin where+  plugin1 <> plugin2 =+    Plugin+      { cliFlags = cliFlags plugin1 <> cliFlags plugin2+      , snapshotRenderers = snapshotRenderers plugin1 <> snapshotRenderers plugin2+      , hooks = hooks plugin1 <> hooks plugin2+      }++instance Monoid Plugin where+  mempty = defaultPlugin++defaultPlugin :: Plugin+defaultPlugin =+  Plugin+    { cliFlags = []+    , snapshotRenderers = []+    , hooks = defaultHooks+    }++data Hooks = Hooks+  { hookRunTest :: TestInfo -> IO TestResult -> IO TestResult+  }++instance Semigroup Hooks where+  hooks1 <> hooks2 =+    Hooks+      { hookRunTest = \testInfo -> hookRunTest hooks2 testInfo . hookRunTest hooks1 testInfo+      }++instance Monoid Hooks where+  mempty = defaultHooks++defaultHooks :: Hooks+defaultHooks =+  Hooks+    { hookRunTest = \_ -> id+    }
+ src/Skeletest/Predicate.hs view
@@ -0,0 +1,60 @@+module Skeletest.Predicate (+  Predicate,++  -- * General+  anything,++  -- * Ord+  eq,+  gt,+  gte,+  lt,+  lte,++  -- * Data types+  just,+  nothing,+  left,+  right,+  tup,+  con,++  -- * Numeric+  approx,+  tol,+  Tolerance (..),++  -- * Combinators+  (<<<),+  (>>>),+  not,+  (&&),+  (||),+  and,+  or,++  -- * Containers+  any,+  all,+  elem,++  -- * Subsequences+  HasSubsequences (..),+  hasPrefix,+  hasInfix,+  hasSuffix,++  -- * IO+  returns,+  throws,++  -- * Functions+  (===),+  isoWith,++  -- * Snapshot testing+  matchesSnapshot,+) where++import Skeletest.Internal.Predicate+import Prelude ()
+ src/Skeletest/Prop/Gen.hs view
@@ -0,0 +1,7 @@+module Skeletest.Prop.Gen (+  Gen,+  module Hedgehog.Gen,+) where++import Hedgehog+import Hedgehog.Gen
+ src/Skeletest/Prop/Internal.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++module Skeletest.Prop.Internal (+  Property,+  PropertyM,+  runProperty,++  -- * Test+  forAll,+  discard,++  -- * Configuring properties+  setDiscardLimit,+  setShrinkLimit,+  setShrinkRetries,+  setConfidence,+  setVerifiedTermination,+  setTestLimit,++  -- * CLI flags+  PropSeedFlag,+  PropLimitFlag,+) where++import Control.Monad (ap)+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Class qualified as Trans+import Control.Monad.Trans.Reader qualified as Trans+import Data.List qualified as List+import Data.Maybe (catMaybes)+import Data.Text qualified as Text+import GHC.Stack qualified as GHC+import Hedgehog qualified+import Hedgehog.Internal.Property qualified as Hedgehog+import Hedgehog.Internal.Report qualified as Hedgehog hiding (defaultConfig)+import Hedgehog.Internal.Runner qualified as Hedgehog+import Hedgehog.Internal.Seed qualified as Hedgehog.Seed+import Hedgehog.Internal.Source qualified as Hedgehog+import Text.Read (readEither, readMaybe)+import UnliftIO.Exception (throwIO)+import UnliftIO.IORef (IORef, newIORef, readIORef, writeIORef)++#if !MIN_VERSION_base(4, 20, 0)+import Data.Foldable (foldl')+#endif++import Skeletest.Internal.CLI (FlagSpec (..), IsFlag (..), getFlag)+import Skeletest.Internal.TestInfo (getTestInfo)+import Skeletest.Internal.TestRunner (AssertionFail (..), Testable (..))++-- | A property to run, with optional configuration settings specified up front.+--+-- Settings should be specified before any 'forAll' or IO calls; any settings+-- specified afterwards are ignored.+type Property = PropertyM ()++data PropertyM a+  = PropertyPure [PropertyConfig] a+  | PropertyIO [PropertyConfig] (Trans.ReaderT FailureRef (Hedgehog.PropertyT IO) a)++type FailureRef = IORef (Maybe AssertionFail)++instance Functor PropertyM where+  fmap f = \case+    PropertyPure cfg a -> PropertyPure cfg (f a)+    PropertyIO cfg m -> PropertyIO cfg (f <$> m)+instance Applicative PropertyM where+  pure = PropertyPure []+  (<*>) = ap+instance Monad PropertyM where+  PropertyPure cfg1 a >>= k =+    case k a of+      PropertyPure cfg2 b -> PropertyPure (cfg1 <> cfg2) b+      PropertyIO cfg2 m -> PropertyIO (cfg1 <> cfg2) m+  PropertyIO cfg1 fa >>= k =+    PropertyIO cfg1 $ do+      a <- fa+      case k a of+        PropertyPure _ b -> pure b+        PropertyIO _ mb -> mb+instance MonadIO PropertyM where+  liftIO = PropertyIO [] . liftIO++instance Testable PropertyM where+  runTestable = runProperty+  context msg m = PropertyIO [] (Hedgehog.annotate msg) >> m+  throwFailure e = PropertyIO [] $ do+    failureRef <- Trans.ask+    writeIORef failureRef (Just e)+    Trans.lift Hedgehog.failure++propConfig :: PropertyConfig -> Property+propConfig cfg = PropertyPure [cfg] ()++propM :: Hedgehog.PropertyT IO a -> PropertyM a+propM = PropertyIO [] . Trans.lift++data PropertyConfig+  = DiscardLimit Int+  | ShrinkLimit Int+  | ShrinkRetries Int+  | SetConfidence Int+  | SetVerifiedTermination+  | SetTestLimit Int++resolveConfig :: [PropertyConfig] -> Hedgehog.PropertyConfig+resolveConfig = foldl' go defaultConfig+  where+    defaultConfig =+      Hedgehog.PropertyConfig+        { propertyDiscardLimit = 100+        , propertyShrinkLimit = 1000+        , propertyShrinkRetries = 0+        , propertyTerminationCriteria = Hedgehog.NoConfidenceTermination 100+        , propertySkip = Nothing+        }++    go cfg = \case+      DiscardLimit x -> cfg{Hedgehog.propertyDiscardLimit = Hedgehog.DiscardLimit x}+      ShrinkLimit x -> cfg{Hedgehog.propertyShrinkLimit = Hedgehog.ShrinkLimit x}+      ShrinkRetries x -> cfg{Hedgehog.propertyShrinkRetries = Hedgehog.ShrinkRetries x}+      SetConfidence x ->+        cfg+          { Hedgehog.propertyTerminationCriteria =+              case Hedgehog.propertyTerminationCriteria cfg of+                Hedgehog.NoEarlyTermination _ tests -> Hedgehog.NoEarlyTermination (Hedgehog.Confidence $ fromIntegral x) tests+                Hedgehog.NoConfidenceTermination tests -> Hedgehog.NoEarlyTermination (Hedgehog.Confidence $ fromIntegral x) tests+                Hedgehog.EarlyTermination _ tests -> Hedgehog.EarlyTermination (Hedgehog.Confidence $ fromIntegral x) tests+          }+      SetVerifiedTermination ->+        cfg+          { Hedgehog.propertyTerminationCriteria =+              case Hedgehog.propertyTerminationCriteria cfg of+                Hedgehog.NoEarlyTermination c tests -> Hedgehog.EarlyTermination c tests+                Hedgehog.NoConfidenceTermination tests -> Hedgehog.EarlyTermination Hedgehog.defaultConfidence tests+                Hedgehog.EarlyTermination c tests -> Hedgehog.EarlyTermination c tests+          }+      SetTestLimit x ->+        cfg+          { Hedgehog.propertyTerminationCriteria =+              case Hedgehog.propertyTerminationCriteria cfg of+                Hedgehog.NoEarlyTermination c _ -> Hedgehog.NoEarlyTermination c (Hedgehog.TestLimit x)+                Hedgehog.NoConfidenceTermination _ -> Hedgehog.NoConfidenceTermination (Hedgehog.TestLimit x)+                Hedgehog.EarlyTermination c _ -> Hedgehog.EarlyTermination c (Hedgehog.TestLimit x)+          }++runProperty :: Property -> IO ()+runProperty = \case+  PropertyPure cfg () -> runProperty $ PropertyIO cfg (pure ())+  PropertyIO cfg m -> do+    failureRef <- newIORef Nothing+    (seed, extraConfig) <- loadPropFlags+    report <-+      Hedgehog.checkReport+        (resolveConfig $ cfg <> extraConfig)+        0+        seed+        (Trans.runReaderT m failureRef)+        reportProgress++    let+      Hedgehog.TestCount testCount = Hedgehog.reportTests report+      Hedgehog.DiscardCount discards = Hedgehog.reportDiscards report++    case Hedgehog.reportStatus report of+      Hedgehog.OK ->+        -- TODO: show details+        -- https://github.com/brandonchinn178/skeletest/issues/19+        pure ()+      Hedgehog.GaveUp -> do+        testInfo <- getTestInfo+        throwIO+          AssertionFail+            { testInfo+            , testFailMessage =+                Text.pack . List.intercalate "\n" $+                  [ "Gave up after " <> show discards <> " discards."+                  , "Passed " <> show testCount <> " tests."+                  ]+            , testFailContext = []+            , callStack = GHC.fromCallSiteList []+            }+      Hedgehog.Failed Hedgehog.FailureReport{..} ->+        readIORef failureRef >>= \case+          Nothing -> do+            testInfo <- getTestInfo+            throwIO+              AssertionFail+                { testInfo+                , testFailMessage = Text.pack failureMessage+                , testFailContext = []+                , callStack = toCallStack failureLocation+                }+          Just failure -> do+            let+              info =+                map Text.pack . concat $+                  [+                    [ "Failed after " <> show testCount <> " tests."+                    , "Rerun with --seed=" <> renderSeed report <> " to reproduce."+                    , ""+                    ]+                  , [ let loc =+                            case failedSpan of+                              Just Hedgehog.Span{..} ->+                                List.intercalate ":" $+                                  [ spanFile+                                  , show . Hedgehog.unLineNo $ spanStartLine+                                  , show . Hedgehog.unColumnNo $ spanStartColumn+                                  ]+                              Nothing -> "<unknown loc>"+                       in loc <> " ==> " <> failedValue+                    | Hedgehog.FailedAnnotation{..} <- failureAnnotations+                    ]+                  ]++            throwIO+              failure+                { testFailContext =+                    -- N.B. testFailContext is reversed!+                    testFailContext failure <> reverse info+                }+  where+    reportProgress _ = pure ()+    renderSeed Hedgehog.Report{reportSeed = Hedgehog.Seed value gamma} = show value <> ":" <> show gamma+    toCallStack mSpan =+      GHC.fromCallSiteList $+        case mSpan of+          Nothing -> []+          Just Hedgehog.Span{..} ->+            let loc =+                  GHC.SrcLoc+                    { srcLocPackage = ""+                    , srcLocModule = ""+                    , srcLocFile = spanFile+                    , srcLocStartLine = Hedgehog.unLineNo spanStartLine+                    , srcLocStartCol = Hedgehog.unColumnNo spanStartColumn+                    , srcLocEndLine = Hedgehog.unLineNo spanEndLine+                    , srcLocEndCol = Hedgehog.unColumnNo spanEndColumn+                    }+             in [("<unknown>", loc)]++loadPropFlags :: IO (Hedgehog.Seed, [PropertyConfig])+loadPropFlags = do+  PropSeedFlag mSeed <- getFlag+  seed <- maybe Hedgehog.Seed.random pure mSeed++  PropLimitFlag mLimit <- getFlag++  let extraConfig =+        [ SetTestLimit <$> mLimit+        ]+  pure (seed, catMaybes extraConfig)++{----- Test -----}++forAll :: (GHC.HasCallStack, Show a) => Hedgehog.Gen a -> PropertyM a+forAll gen = GHC.withFrozenCallStack $ propM (Hedgehog.forAll gen)++discard :: PropertyM a+discard = propM Hedgehog.discard++{----- Configuring properties -----}++setDiscardLimit :: Int -> Property+setDiscardLimit = propConfig . DiscardLimit++setShrinkLimit :: Int -> Property+setShrinkLimit = propConfig . ShrinkLimit++setShrinkRetries :: Int -> Property+setShrinkRetries = propConfig . ShrinkRetries++setConfidence :: Int -> Property+setConfidence = propConfig . SetConfidence++setVerifiedTermination :: Property+setVerifiedTermination = propConfig SetVerifiedTermination++setTestLimit :: Int -> Property+setTestLimit = propConfig . SetTestLimit++{----- CLI flags -----}++newtype PropSeedFlag = PropSeedFlag (Maybe Hedgehog.Seed)++instance IsFlag PropSeedFlag where+  flagName = "seed"+  flagMetaVar = "SEED"+  flagHelp = "The seed to use for property tests"+  flagSpec =+    OptionalFlag+      { flagDefault = PropSeedFlag Nothing+      , flagParse = parse+      }+    where+      parse s = maybe (Left $ "Invalid seed: " <> s) Right $ do+        (valS, ':' : gammaS) <- pure $ break (== ':') s+        val <- readMaybe valS+        gamma <- readMaybe gammaS+        pure . PropSeedFlag . Just $ Hedgehog.Seed val gamma++newtype PropLimitFlag = PropLimitFlag (Maybe Int)++instance IsFlag PropLimitFlag where+  flagName = "prop-test-limit"+  flagMetaVar = "N"+  flagHelp = "The number of tests to run per property test"+  flagSpec =+    OptionalFlag+      { flagDefault = PropLimitFlag Nothing+      , flagParse = fmap (PropLimitFlag . Just) . readEither+      }
+ src/Skeletest/Prop/Range.hs view
@@ -0,0 +1,5 @@+module Skeletest.Prop.Range (+  module Hedgehog.Range,+) where++import Hedgehog.Range
+ src/bin/skeletest-preprocessor.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE LambdaCase #-}++{-| A preprocessor that registers skeletest in a test suite.++We need to use a preprocessor for Main.hs because GHC plugins don't+seem to support dynamically registering other modules as imports (GHC+already knows what order it's going to compile the modules in, because+plugins run per module).++But GHC's plugin interface is much nicer for inspecting and manipulating+the code. So what we'll do here is:++1. Always register the plugin by adding `{\-# OPTIONS_GHC -fplugin=... #-\}` to+   the top of the file. The plugin will then inspect the file to see if it's+   a test file or the main file, and if so, process it.++2. If the file is the main file, insert the appropriate imports.+-}+module Main where++import Data.Text.IO qualified as Text+import GHC.IO.Encoding (setLocaleEncoding, utf8)+import System.Environment (getArgs)++import Skeletest.Internal.Preprocessor (processFile)++main :: IO ()+main = do+  -- just to be extra sure we don't run into encoding issues+  setLocaleEncoding utf8++  getArgs >>= \case+    -- https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/phases.html#options-affecting-a-haskell-pre-processor+    [fp, input, output] -> Text.readFile input >>= processFile fp >>= Text.writeFile output+    _ -> error "The skeletest preprocessor does not accept any additional arguments."
+ test/ExampleSpec.hs view
@@ -0,0 +1,129 @@+module ExampleSpec (+  spec,+) where++import Data.IORef (IORef, modifyIORef', newIORef, readIORef)+import Data.Text qualified as Text++import Skeletest+import Skeletest.Predicate qualified as P+import Skeletest.Prop.Gen qualified as Gen+import Skeletest.Prop.Range qualified as Range++spec :: Spec+spec = do+  describe "predicates" $ do+    it "checks approximate equality" $ do+      let x = 0.1 + 0.2 :: Double+      x `shouldSatisfy` P.approx P.tol 0.3+      x `shouldSatisfy` P.approx P.tol{P.rel = Just 1e-8} 0.3+      x `shouldSatisfy` P.approx P.tol{P.abs = 1e-12} 0.3+      x `shouldSatisfy` P.approx P.tol{P.rel = Just 1e-8, P.abs = 1e-12} 0.3+      x `shouldSatisfy` P.approx P.tol{P.rel = Nothing} 0.3+      x `shouldSatisfy` P.approx P.tol{P.rel = Nothing, P.abs = 1e-12} 0.3++    it "matches constructors" $ do+      ConA `shouldSatisfy` P.con ConA+      ConB 1 2 `shouldSatisfy` P.con (ConB (P.eq 1) P.anything)++      -- record field order doesn't matter+      ConC{conC1 = 1, conC2 = 2} `shouldSatisfy` P.con ConC{conC1 = P.eq 1, conC2 = P.eq 2}+      ConC{conC1 = 1, conC2 = 2} `shouldSatisfy` P.con ConC{conC2 = P.eq 2, conC1 = P.eq 1}+      ConC{conC2 = 2, conC1 = 1} `shouldSatisfy` P.con ConC{conC1 = P.eq 1, conC2 = P.eq 2}+      ConC{conC2 = 2, conC1 = 1} `shouldSatisfy` P.con ConC{conC2 = P.eq 2, conC1 = P.eq 1}++      -- missing records always match+      ConC{conC1 = 1, conC2 = 2} `shouldSatisfy` P.con ConC{conC1 = P.eq 1}++      -- check some failures+      ConC{conC1 = 1, conC2 = 2} `shouldNotSatisfy` P.con ConA+      ConC{conC1 = 1, conC2 = 2} `shouldNotSatisfy` P.con ConC{conC1 = P.eq 123}+      ConA `shouldNotSatisfy` P.con ConC{conC1 = P.eq 2}++      -- works for type with one constructor+      UserNoShow{name = "user1", age = 18} `shouldSatisfy` P.con UserNoShow{age = P.gt 10}++    it "matches snapshots" $ do+      (1 :: Int) `shouldSatisfy` P.matchesSnapshot+      "a \"quoted\" string" `shouldSatisfy` P.matchesSnapshot+      Text.pack "a \"quoted\" text" `shouldSatisfy` P.matchesSnapshot++    it "matches snapshots without Show instance" $+      UserNoShow{name = "user1", age = 18} `shouldSatisfy` P.matchesSnapshot++  prop "reverse does not drop elements" $ do+    input <-+      forAll $+        Gen.list (Range.linear 0 10) $+          Gen.string (Range.linear 0 100) Gen.unicode+    length (reverse input) `shouldBe` length input++  prop "read . show === id" $+    (read . show) P.=== id `shouldSatisfy` P.isoWith (Gen.int $ Range.linear 0 100)++  describe "fixtures example" $ do+    it "allows using fixtures inside fixtures" $ do+      FixtureD <- getFixture+      TraceFixture traceRef <- getFixture+      readIORef traceRef `shouldSatisfy` P.returns (P.eq ["A", "B", "C", "D"])++data MyType+  = ConA+  | ConB Int Int+  | ConC {conC1 :: Int, conC2 :: Int}++-- Do not add a Show instance+data UserNoShow = UserNoShow+  { name :: String+  , age :: Int+  }++-- | A helper for tracing fixtures+newtype TraceFixture = TraceFixture (IORef [String])++instance Fixture TraceFixture where+  fixtureAction = do+    traceRef <- newIORef []+    pure . noCleanup $ TraceFixture traceRef++{-----+Fixtures example:+Create a diamond fixture:+  A+ / \+B   C+ \ /+  D+-----}++data FixtureA = FixtureA+instance Fixture FixtureA where+  fixtureAction = do+    TraceFixture traceRef <- getFixture+    modifyIORef' traceRef (<> ["A"])+    pure . noCleanup $ FixtureA++data FixtureB = FixtureB+instance Fixture FixtureB where+  fixtureAction = do+    FixtureA <- getFixture+    TraceFixture traceRef <- getFixture+    modifyIORef' traceRef (<> ["B"])+    pure . noCleanup $ FixtureB++data FixtureC = FixtureC+instance Fixture FixtureC where+  fixtureAction = do+    FixtureA <- getFixture+    TraceFixture traceRef <- getFixture+    modifyIORef' traceRef (<> ["C"])+    pure . noCleanup $ FixtureC++data FixtureD = FixtureD+instance Fixture FixtureD where+  fixtureAction = do+    FixtureB <- getFixture+    FixtureC <- getFixture+    TraceFixture traceRef <- getFixture+    modifyIORef' traceRef (<> ["D"])+    pure . noCleanup $ FixtureD
+ test/Main.hs view
@@ -0,0 +1,1 @@+import Skeletest.Main
+ test/Skeletest/AssertionsSpec.hs view
@@ -0,0 +1,142 @@+module Skeletest.AssertionsSpec (spec) where++import Skeletest+import Skeletest.Predicate qualified as P++import Skeletest.TestUtils.Integration++spec :: Spec+spec = do+  describe "shouldBe" $ do+    it "should pass" $+      1 `shouldBe` (1 :: Int)++    integration . it "should show helpful failure" $ do+      runner <- getFixture+      addTestFile runner "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , ""+        , "spec = it \"should fail\" $ 1 `shouldBe` (2 :: Int)"+        ]++      (code, stdout, stderr) <- runTests runner []+      code `shouldBe` ExitFailure 1+      stderr `shouldBe` ""+      stdout `shouldSatisfy` P.matchesSnapshot++  describe "shouldNotBe" $ do+    it "should pass" $+      1 `shouldNotBe` (2 :: Int)++    integration . it "should show helpful failure" $ do+      runner <- getFixture+      addTestFile runner "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , ""+        , "spec = it \"should fail\" $ 1 `shouldNotBe` (1 :: Int)"+        ]++      (code, stdout, stderr) <- runTests runner []+      code `shouldBe` ExitFailure 1+      stderr `shouldBe` ""+      stdout `shouldSatisfy` P.matchesSnapshot++  describe "shouldSatisfy" $ do+    it "should pass" $+      1 `shouldSatisfy` P.gt (0 :: Int)++    integration . it "should show helpful failure" $ do+      runner <- getFixture+      addTestFile runner "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , "import qualified Skeletest.Predicate as P"+        , ""+        , "spec = it \"should fail\" $ (-1) `shouldSatisfy` P.gt (0 :: Int)"+        ]++      (code, stdout, stderr) <- runTests runner []+      code `shouldBe` ExitFailure 1+      stderr `shouldBe` ""+      stdout `shouldSatisfy` P.matchesSnapshot++  describe "shouldNotSatisfy" $ do+    it "should pass" $+      (-1) `shouldNotSatisfy` P.gt (0 :: Int)++    integration . it "should show helpful failure" $ do+      runner <- getFixture+      addTestFile runner "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , "import qualified Skeletest.Predicate as P"+        , ""+        , "spec = it \"should fail\" $ 1 `shouldNotSatisfy` P.gt (0 :: Int)"+        ]++      (code, stdout, stderr) <- runTests runner []+      code `shouldBe` ExitFailure 1+      stderr `shouldBe` ""+      stdout `shouldSatisfy` P.matchesSnapshot++  describe "context" $ do+    integration . it "should show failure context" $ do+      runner <- getFixture+      addTestFile runner "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , ""+        , "spec = it \"should fail\" $ do"+        , "  context \"hello\" . context \"world\" $"+        , "    1 `shouldBe` (2 :: Int)"+        ]++      (code, stdout, stderr) <- runTests runner []+      code `shouldBe` ExitFailure 1+      stderr `shouldBe` ""+      stdout `shouldSatisfy` P.matchesSnapshot++  describe "failTest" $ do+    integration . it "should show failure" $ do+      runner <- getFixture+      addTestFile runner "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , ""+        , "spec = it \"should fail\" $ failTest \"error message\""+        ]++      (code, stdout, stderr) <- runTests runner []+      code `shouldBe` ExitFailure 1+      stderr `shouldBe` ""+      stdout `shouldSatisfy` P.matchesSnapshot++  integration . it "shows backtrace of failed assertions" $ do+    runner <- getFixture+    addTestFile runner "ExampleSpec.hs" $+      [ "module ExampleSpec (spec) where"+      , ""+      , "import Skeletest"+      , "import qualified Skeletest.Predicate as P"+      , ""+      , "spec = it \"should fail\" $ expectPositive (-1)"+      , ""+      , "expectPositive :: HasCallStack => Int -> IO ()"+      , "expectPositive = expectGT 0"+      , ""+      , "expectGT :: HasCallStack => Int -> Int -> IO ()"+      , "expectGT x actual = actual `shouldSatisfy` P.gt x"+      ]++    (code, stdout, stderr) <- runTests runner []+    code `shouldBe` ExitFailure 1+    stderr `shouldBe` ""+    stdout `shouldSatisfy` P.matchesSnapshot
+ test/Skeletest/Internal/CLISpec.hs view
@@ -0,0 +1,94 @@+module Skeletest.Internal.CLISpec (spec) where++import Control.Monad ((>=>))+import Data.Dynamic (fromDynamic)+import Data.Map qualified as Map+import Data.Typeable (Typeable, typeOf)+import Skeletest+import Skeletest.Predicate qualified as P++import Skeletest.Internal.CLI (+  CLIFlagStore,+  CLIParseResult (..),+  flag,+  parseCliArgs,+ )+import Skeletest.TestUtils.Integration++newtype FooFlag = FooFlag String+  deriving (Eq)+instance IsFlag FooFlag where+  flagName = "foo"+  flagHelp = "test"+  flagSpec =+    OptionalFlag+      { flagDefault = FooFlag ""+      , flagParse = Right . FooFlag+      }++spec :: Spec+spec = do+  describe "parseCliArgs" $ do+    it "parses long flag" $ do+      parseCliArgs [flag @FooFlag] ["--foo", "1"]+        `shouldSatisfy` P.con CLIParseSuccess{flagStore = containsFlag (FooFlag "1")}++    it "parses long flag with equal sign" $ do+      parseCliArgs [flag @FooFlag] ["--foo=1"]+        `shouldSatisfy` P.con CLIParseSuccess{flagStore = containsFlag (FooFlag "1")}++    it "parses long flag containing equal sign" $ do+      parseCliArgs [flag @FooFlag] ["--foo=1=2"]+        `shouldSatisfy` P.con CLIParseSuccess{flagStore = containsFlag (FooFlag "1=2")}++  describe "getFlag" $ do+    integration . it "reads registered flag" $ do+      runner <- getFixture+      setMainFile runner $+        [ "import Skeletest.Main"+        , "import ExampleSpec (MyFlag)"+        , "cliFlags = [flag @MyFlag]"+        ]+      addTestFile runner "ExampleSpec.hs" $+        [ "module ExampleSpec (MyFlag, spec) where"+        , "import Skeletest"+        , ""+        , "newtype MyFlag = MyFlag String"+        , "instance IsFlag MyFlag where"+        , "  flagName = \"my-flag\""+        , "  flagHelp = \"example\""+        , "  flagSpec = RequiredFlag (Right . MyFlag)"+        , ""+        , "spec = it \"should get flag\" $ do"+        , "  MyFlag s <- getFlag"+        , "  s `shouldBe` \"hello world\""+        ]++      _ <- expectSuccess $ runTests runner ["--my-flag", "hello world"]+      pure ()++    integration . it "errors if flag is not registered" $ do+      runner <- getFixture+      addTestFile runner "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , ""+        , "newtype MyFlag = MyFlag Bool"+        , "instance IsFlag MyFlag where"+        , "  flagName = \"my-flag\""+        , "  flagHelp = \"example\""+        , "  flagSpec = SwitchFlag MyFlag"+        , ""+        , "spec = it \"should error\" $ do"+        , "  MyFlag _ <- getFlag"+        , "  pure ()"+        ]++      (code, stdout, stderr) <- runTests runner []+      code `shouldBe` ExitFailure 1+      stderr `shouldBe` ""+      stdout `shouldSatisfy` P.matchesSnapshot++containsFlag :: (Typeable a, Eq a) => a -> Predicate IO CLIFlagStore+containsFlag f = (Map.lookup (typeOf f) >=> fromDynamic) P.>>> P.just (P.eq f)
+ test/Skeletest/Internal/FixturesSpec.hs view
@@ -0,0 +1,58 @@+module Skeletest.Internal.FixturesSpec (spec) where++import Skeletest+import Skeletest.Predicate qualified as P++import Skeletest.TestUtils.Integration++spec :: Spec+spec = do+  describe "getFixture" $ do+    integration . it "detects circular dependencies" $ do+      runner <- getFixture++      -- Fixture graph:+      --   A+      --   -> B+      --      -> C+      --      -> D+      --         -> A+      addTestFile runner "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , ""+        , "data FixtureA = FixtureA"+        , "data FixtureB = FixtureB"+        , "data FixtureC = FixtureC"+        , "data FixtureD = FixtureD"+        , ""+        , "instance Fixture FixtureA where"+        , "  fixtureAction = do"+        , "    FixtureB <- getFixture"+        , "    pure . noCleanup $ FixtureA"+        , ""+        , "instance Fixture FixtureB where"+        , "  fixtureAction = do"+        , "    FixtureC <- getFixture"+        , "    FixtureD <- getFixture"+        , "    pure . noCleanup $ FixtureB"+        , ""+        , "instance Fixture FixtureC where"+        , "  fixtureAction = do"+        , "    pure . noCleanup $ FixtureC"+        , ""+        , "instance Fixture FixtureD where"+        , "  fixtureAction = do"+        , "    FixtureA <- getFixture"+        , "    pure . noCleanup $ FixtureD"+        , ""+        , "spec = it \"should error\" $ do"+        , "  FixtureA <- getFixture"+        , "  pure ()"+        ]++      (code, stdout, stderr) <- runTests runner []+      code `shouldBe` ExitFailure 1+      stderr `shouldBe` ""+      stdout `shouldSatisfy` P.matchesSnapshot
+ test/Skeletest/Internal/SnapshotSpec.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE RecordWildCards #-}++module Skeletest.Internal.SnapshotSpec (spec) where++import Data.Aeson qualified as Aeson+import Data.String (fromString)+import Skeletest+import Skeletest.Predicate qualified as P+import Skeletest.Prop.Gen qualified as Gen+import Skeletest.Prop.Range qualified as Range++import Skeletest.Internal.Snapshot (+  SnapshotFile (..),+  SnapshotValue (..),+  decodeSnapshotFile,+  encodeSnapshotFile,+  normalizeSnapshotFile,+ )+import Skeletest.TestUtils.Integration++spec :: Spec+spec = do+  prop "decodeSnapshotFile . encodeSnapshotFile === pure" $ do+    (decodeSnapshotFile . encodeSnapshotFile) P.=== pure `shouldSatisfy` P.isoWith genSnapshotFile++  prop "normalizeSnapshotFile is idempotent" $ do+    file <- forAll genSnapshotFileRaw+    n <- forAll $ Gen.int (Range.linear 1 10)+    let normalizeSnapshotFile' = foldr (.) id $ replicate n normalizeSnapshotFile+    normalizeSnapshotFile' file `shouldBe` normalizeSnapshotFile file++  integration . it "detects corrupted snapshot files" $ do+    runner <- getFixture+    addTestFile runner "ExampleSpec.hs" $+      [ "module ExampleSpec (spec) where"+      , ""+      , "import Skeletest"+      , "import qualified Skeletest.Predicate as P"+      , ""+      , "spec = it \"should error\" $ do"+      , "  \"\" `shouldSatisfy` P.matchesSnapshot"+      ]+    addTestFile runner "__snapshots__/ExampleSpec.snap.md" ["asdf"]++    (code, stdout, stderr) <- runTests runner []+    code `shouldBe` ExitFailure 1+    stderr `shouldBe` ""+    stdout `shouldSatisfy` P.matchesSnapshot++  integration . it "uses registered snapshot renderers" $ do+    runner <- getFixture+    setMainFile runner $+      [ "import Skeletest.Main"+      , "import Lib.User"+      , "snapshotRenderers ="+      , "  [ renderWithShow @User"+      , "  ]"+      ]+    addTestFile runner "Lib/User.hs" $+      [ "module Lib.User (User (..)) where"+      , "data User = User {name :: String, age :: Int} deriving (Show)"+      ]+    addTestFile runner "ExampleSpec.hs" $+      [ "module ExampleSpec (spec) where"+      , ""+      , "import Lib.User"+      , "import Skeletest"+      , "import qualified Skeletest.Predicate as P"+      , ""+      , "spec = it \"test user\" $ do"+      , "  let testUser = User {name = \"Alice\", age = 30}"+      , "  testUser `shouldSatisfy` P.matchesSnapshot"+      ]++    _ <- expectSuccess $ runTests runner ["-u"]+    snapshot <- readTestFile runner "__snapshots__/ExampleSpec.snap.md"+    snapshot `shouldSatisfy` P.hasInfix "User {name = \"Alice\", age = 30}"++  it "renders JSON values" $ do+    let result = Aeson.decode $ fromString "{\"hello\": [\"world\", 1]}"+    (result :: Maybe Aeson.Value) `shouldSatisfy` P.just P.matchesSnapshot++  integration . it "shows helpful failure messages" $ do+    runner <- getFixture+    addTestFile runner "ExampleSpec.hs" $+      [ "module ExampleSpec (spec) where"+      , ""+      , "import Skeletest"+      , "import qualified Skeletest.Predicate as P"+      , ""+      , "spec = it \"fails\" $ do"+      , "  unlines [\"new1\", \"same1\", \"same2\", \"new2\"] `shouldSatisfy` P.matchesSnapshot"+      ]+    addTestFile runner "__snapshots__/ExampleSpec.snap.md" $+      [ "# Example"+      , ""+      , "## fails"+      , ""+      , "```"+      , "same1"+      , "old1"+      , "same2"+      , "old2"+      , "```"+      ]++    (code, stdout, stderr) <- runTests runner []+    code `shouldBe` ExitFailure 1+    stderr `shouldBe` ""+    stdout `shouldSatisfy` P.matchesSnapshot++genSnapshotFileRaw :: Gen SnapshotFile+genSnapshotFileRaw = do+  moduleName <- Gen.text (Range.linear 0 100) genHsModuleChar+  snapshots <- Gen.map rangeNumTests genSnapshot+  pure SnapshotFile{..}+  where+    rangeNumTests = Range.linear 0 10+    rangeSnapshotsPerTest = Range.linear 0 5+    rangeSnapshotSize = Range.linear 0 1000++    genHsModuleChar = Gen.choice [Gen.alphaNum, pure '\'']++    genSnapshot = do+      ident <- Gen.list (Range.linear 1 10) (Gen.text (Range.linear 1 100) Gen.unicode)+      vals <- Gen.list rangeSnapshotsPerTest genSnapshotVal+      pure (ident, vals)++    genSnapshotVal = do+      snapshotContent <- Gen.text rangeSnapshotSize Gen.unicode+      snapshotLang <- Gen.maybe $ Gen.text (Range.linear 1 5) Gen.unicode+      pure SnapshotValue{..}++genSnapshotFile :: Gen SnapshotFile+genSnapshotFile = normalizeSnapshotFile <$> genSnapshotFileRaw
+ test/Skeletest/Internal/SpecSpec.hs view
@@ -0,0 +1,165 @@+module Skeletest.Internal.SpecSpec (spec) where++import Skeletest+import Skeletest.Predicate qualified as P++import Skeletest.TestUtils.Integration++spec :: Spec+spec = do+  describe "skip" $ do+    integration . it "skips tests completely" $ do+      runner <- getFixture+      addTestFile runner "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , ""+        , "spec = skip \"broken tests\" $ do"+        , "  it \"should not run\" $ undefined"+        , "  it \"should not run either\" $ undefined"+        ]++      (stdout, stderr) <- expectSuccess $ runTests runner []+      stderr `shouldBe` ""+      stdout `shouldSatisfy` P.matchesSnapshot++  describe "xfail" $ do+    integration . it "checks for expected failures" $ do+      runner <- getFixture+      addTestFile runner "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , ""+        , "spec = xfail \"broken tests\" $ do"+        , "  it \"should fail\" $ undefined"+        , "  it \"should fail too\" $ undefined"+        ]++      (stdout, stderr) <- expectSuccess $ runTests runner []+      stderr `shouldBe` ""+      stdout `shouldSatisfy` P.matchesSnapshot++    integration . it "errors on unexpected passes" $ do+      runner <- getFixture+      addTestFile runner "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , ""+        , "spec = xfail \"broken tests\" $ do"+        , "  it \"should fail\" $ pure ()"+        , "  it \"should fail too\" $ pure ()"+        ]++      (code, stdout, stderr) <- runTests runner []+      code `shouldBe` ExitFailure 1+      stderr `shouldBe` ""+      stdout `shouldSatisfy` P.matchesSnapshot++  describe "markManual" $ do+    integration . it "skips manual tests by default" $ do+      runner <- getFixture+      addTestFile runner "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , ""+        , "spec = do"+        , "  markManual . withMarkers [\"foo\"] $ do"+        , "    it \"foo1\" $ pure ()"+        , "    it \"foo2\" $ pure ()"+        , "  it \"bar1\" $ pure ()"+        , "  it \"bar2\" $ pure ()"+        ]++      (stdout, stderr) <- expectSuccess $ runTests runner []+      stderr `shouldBe` ""+      stdout+        `shouldSatisfy` P.and+          [ P.not $ P.hasInfix "foo1"+          , P.not $ P.hasInfix "foo2"+          , P.hasInfix "bar1"+          , P.hasInfix "bar2"+          ]++    integration . it "runs selected manual tests" $ do+      runner <- getFixture+      addTestFile runner "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , ""+        , "spec = do"+        , "  markManual . withMarkers [\"foo\"] $ do"+        , "    it \"foo1\" $ pure ()"+        , "    it \"foo2\" $ pure ()"+        , "  it \"bar1\" $ pure ()"+        , "  it \"bar2\" $ pure ()"+        ]++      (stdout, stderr) <- expectSuccess $ runTests runner ["*"]+      stderr `shouldBe` ""+      stdout+        `shouldSatisfy` P.and+          [ P.hasInfix "foo1"+          , P.hasInfix "foo2"+          , P.hasInfix "bar1"+          , P.hasInfix "bar2"+          ]++  describe "withMarkers" $ do+    integration . it "allows selecting from command line" $ do+      runner <- getFixture+      addTestFile runner "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , ""+        , "spec = do"+        , "  withMarkers [\"foo\"] $ do"+        , "    it \"foo1\" $ pure ()"+        , "    it \"foo2\" $ pure ()"+        , "  it \"bar1\" $ pure ()"+        , "  it \"bar2\" $ pure ()"+        ]++      (stdout, stderr) <- expectSuccess $ runTests runner ["@foo"]+      stderr `shouldBe` ""+      stdout+        `shouldSatisfy` P.and+          [ P.hasInfix "foo1"+          , P.hasInfix "foo2"+          , P.not $ P.hasInfix "bar1"+          , P.not $ P.hasInfix "bar2"+          ]++  describe "withMarker" $ do+    integration . it "allows selecting from command line" $ do+      runner <- getFixture+      addTestFile runner "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , ""+        , "data MyMarker = MyMarker deriving (Show)"+        , "instance IsMarker MyMarker where getMarkerName _ = \"my-marker\""+        , ""+        , "spec = do"+        , "  withMarker MyMarker $ do"+        , "    it \"foo1\" $ pure ()"+        , "    it \"foo2\" $ pure ()"+        , "  it \"bar1\" $ pure ()"+        , "  it \"bar2\" $ pure ()"+        ]++      (stdout, stderr) <- expectSuccess $ runTests runner ["@my-marker"]+      stderr `shouldBe` ""+      stdout+        `shouldSatisfy` P.and+          [ P.hasInfix "foo1"+          , P.hasInfix "foo2"+          , P.not $ P.hasInfix "bar1"+          , P.not $ P.hasInfix "bar2"+          ]
+ test/Skeletest/Internal/TestTargetsSpec.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE OverloadedStrings #-}++module Skeletest.Internal.TestTargetsSpec (spec) where++import Skeletest+import Skeletest.Predicate qualified as P++import Skeletest.Internal.TestTargets++spec :: Spec+spec = do+  describe "matchesTest" $ do+    let someAttrs =+          TestAttrs+            { testPath = "MyTestSpec.hs"+            , testIdentifier = ["a", "b", "test name"]+            , testMarkers = ["mark1", "mark2"]+            }++    sequence_+      [ it label $+          matchesTest selection attrs `shouldBe` True+      | (label, selection, attrs) <-+          [+            ( "matches any test"+            , TestTargetEverything+            , someAttrs+            )+          ,+            ( "matches tests in file"+            , TestTargetFile "FooSpec.hs"+            , someAttrs{testPath = "FooSpec.hs"}+            )+          ,+            ( "matches test name substring"+            , TestTargetName "foo"+            , someAttrs{testIdentifier = ["group1", "group2", "my foo test"]}+            )+          ,+            ( "matches group name substring"+            , TestTargetName "fooFunc"+            , someAttrs{testIdentifier = ["fooFunction", "does a thing"]}+            )+          ,+            ( "matches a marker exactly"+            , TestTargetMarker "fast"+            , someAttrs{testMarkers = ["fast", "slow"]}+            )+          ,+            ( "matches a NOT target when target does not match"+            , TestTargetNot (TestTargetFile "FooSpec.hs")+            , someAttrs{testPath = "BarSpec.hs"}+            )+          ,+            ( "matches an AND target when target matches both"+            , TestTargetAnd (TestTargetFile "FooSpec.hs") (TestTargetMarker "fast")+            , someAttrs{testPath = "FooSpec.hs", testMarkers = ["fast"]}+            )+          ,+            ( "matches an OR target when target matches one"+            , TestTargetOr (TestTargetFile "FooSpec.hs") (TestTargetMarker "fast")+            , someAttrs{testPath = "FooSpec.hs", testMarkers = []}+            )+          ]+      ]++    sequence_+      [ it label $+          matchesTest selection attrs `shouldBe` False+      | (label, selection, attrs) <-+          [+            ( "does not match test in another file"+            , TestTargetFile "FooSpec.hs"+            , someAttrs{testPath = "BarSpec.hs"}+            )+          ,+            ( "does not match test not containing name"+            , TestTargetName "foo"+            , someAttrs{testIdentifier = ["group1", "group2", "other test"]}+            )+          ,+            ( "does not match marker substring"+            , TestTargetMarker "fastish"+            , someAttrs{testMarkers = ["fast"]}+            )+          ,+            ( "does not match a NOT target when target matches"+            , TestTargetNot (TestTargetFile "FooSpec.hs")+            , someAttrs{testPath = "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"]}+            )+          ,+            ( "does not match an OR target when target does not match either"+            , TestTargetOr (TestTargetFile "FooSpec.hs") (TestTargetMarker "fast")+            , someAttrs{testPath = "BarSpec.hs", testMarkers = []}+            )+          ]+      ]++  describe "parseTestTargets" $ do+    sequence_+      [ it label $+          parseTestTargets input `shouldBe` Right (Just expected)+      | (label, input, expected) <-+          [+            ( "parses everything"+            , ["*"]+            , TestTargetEverything+            )+          ,+            ( "parses file name"+            , ["test/MyLib/FooSpec.hs"]+            , TestTargetFile "test/MyLib/FooSpec.hs"+            )+          ,+            ( "parses test name"+            , ["[test]"]+            , TestTargetName "test"+            )+          ,+            ( "parses test name with spaces"+            , ["[foo test]"]+            , TestTargetName "foo test"+            )+          ,+            ( "parses test marker"+            , ["@fast"]+            , TestTargetMarker "fast"+            )+          ,+            ( "parses file name with test name"+            , ["test/FooSpec.hs[fooFunc]"]+            , TestTargetAnd (TestTargetFile "test/FooSpec.hs") (TestTargetName "fooFunc")+            )+          ,+            ( "parses not operations"+            , ["not [fooFunc]"]+            , TestTargetNot (TestTargetName "fooFunc")+            )+          ,+            ( "parses and operations between test names"+            , ["[fooFunc] and [barFunc]"]+            , TestTargetAnd (TestTargetName "fooFunc") (TestTargetName "barFunc")+            )+          ,+            ( "parses and operations between markers"+            , ["@foo and @fast"]+            , TestTargetAnd (TestTargetMarker "foo") (TestTargetMarker "fast")+            )+          ,+            ( "parses or operations between test names"+            , ["[fooFunc] or [barFunc]"]+            , TestTargetOr (TestTargetName "fooFunc") (TestTargetName "barFunc")+            )+          ,+            ( "parses or operations between markers"+            , ["@foo or @fast"]+            , TestTargetOr (TestTargetMarker "foo") (TestTargetMarker "fast")+            )+          ,+            ( "parses or operations between files"+            , ["FooSpec.hs or BarSpec.hs"]+            , TestTargetOr (TestTargetFile "FooSpec.hs") (TestTargetFile "BarSpec.hs")+            )+          ,+            ( "joins multiple targets with or"+            , ["[fooFunc]", "test/BarSpec.hs"]+            , TestTargetOr (TestTargetName "fooFunc") (TestTargetFile "test/BarSpec.hs")+            )+          ,+            ( "parses multiple binary operations"+            , ["[a] or [b] and [c] or [d]"]+            , TestTargetOr+                ( TestTargetAnd+                    (TestTargetOr (TestTargetName "a") (TestTargetName "b"))+                    (TestTargetName "c")+                )+                (TestTargetName "d")+            )+          ,+            ( "parses parenthesized expressions"+            , ["([a] or [b]) and ([c] or [d])"]+            , TestTargetAnd+                (TestTargetOr (TestTargetName "a") (TestTargetName "b"))+                (TestTargetOr (TestTargetName "c") (TestTargetName "d"))+            )+          ]+      ]++    it "fails with a helpful error message" $+      parseTestTargets ["test/Example!Spec.hs"] `shouldSatisfy` P.left P.matchesSnapshot
+ test/Skeletest/Internal/__snapshots__/CLISpec.snap.md view
@@ -0,0 +1,9 @@+# Skeletest.Internal.CLI++## getFlag / errors if flag is not registered++```+Example+    should error: ERROR+        CLI flag 'my-flag' was not registered. Did you add it to cliFlags in Main.hs?+```
+ test/Skeletest/Internal/__snapshots__/FixturesSpec.snap.md view
@@ -0,0 +1,9 @@+# Skeletest.Internal.Fixtures++## getFixture / detects circular dependencies++```+Example+    should error: ERROR+        Found circular dependency when resolving fixtures: FixtureA -> FixtureB -> FixtureD -> FixtureA+```
+ test/Skeletest/Internal/__snapshots__/SnapshotSpec.snap.md view
@@ -0,0 +1,45 @@+# Skeletest.Internal.Snapshot++## detects corrupted snapshot files++```+Example+    should error: ERROR+        Snapshot file was corrupted: ./__snapshots__/ExampleSpec.snap.md+```++## renders JSON values++```json+{+    "hello": [+        "world",+        1+    ]+}+```++## shows helpful failure messages++```+Example+    fails: FAIL+--------------------------------------------------------------------------------+./ExampleSpec.hs:7:+|+|   unlines ["new1", "same1", "same2", "new2"] `shouldSatisfy` P.matchesSnapshot+|                                              ^^^^^^^^^^^^^^^++Result differed from snapshot. Update snapshot with --update.+--- expected++++ actual+@@++new1+ same1+-old1+ same2+-old2++new2++--------------------------------------------------------------------------------+```
+ test/Skeletest/Internal/__snapshots__/SpecSpec.snap.md view
@@ -0,0 +1,31 @@+# Skeletest.Internal.Spec++## skip / skips tests completely++```+Example+    should not run: SKIP+        broken tests+    should not run either: SKIP+        broken tests+```++## xfail / checks for expected failures++```+Example+    should fail: XFAIL+        broken tests+    should fail too: XFAIL+        broken tests+```++## xfail / errors on unexpected passes++```+Example+    should fail: XPASS+        broken tests+    should fail too: XPASS+        broken tests+```
+ test/Skeletest/Internal/__snapshots__/TestTargetsSpec.snap.md view
@@ -0,0 +1,11 @@+# Skeletest.Internal.TestTargets++## parseTestTargets / fails with a helpful error message++```+Could not parse test target: unexpected '!'+expecting "and", "or", end of input, test name, or white space+ |+ | test/Example!Spec.hs+ |             ^+```
+ test/Skeletest/MainSpec.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE CPP #-}++module Skeletest.MainSpec (spec) where++import Data.Text qualified as Text+import Skeletest+import Skeletest.Predicate qualified as P++import Skeletest.TestUtils.Integration++spec :: Spec+spec = do+  integration . it "errors if Skeletest.Main not imported" $ do+    runner <- getFixture+    setMainFile runner []+    addTestFile runner "ExampleSpec.hs" (minimalTest "ExampleSpec")++    (code, stdout, stderr) <- runTests runner []+    code `shouldBe` ExitFailure 1+    stdout `shouldBe` ""+    normalizePluginError stderr `shouldSatisfy` P.matchesSnapshot++  integration . it "ignores non-test files" $ do+    runner <- getFixture+    addTestFile runner "ExampleSpec.hs" $+      [ "module ExampleSpec (spec) where"+      , "import Skeletest"+      , "import TestUtils"+      , "spec = it \"should run\" $ testUserName `shouldBe` \"Alice\""+      ]+    addTestFile runner "TestUtils.hs" $+      [ "module TestUtils where"+      , "testUserName = \"Alice\""+      ]++    _ <- expectSuccess $ runTests runner []+    pure ()++  integration . it "errors if main function defined" $ do+    runner <- getFixture+    setMainFile runner $+      [ "import Skeletest.Main"+      , ""+      , "main = putStrLn \"hello world\""+      ]+    addTestFile runner "ExampleSpec.hs" (minimalTest "ExampleSpec")++    (code, stdout, stderr) <- runTests runner []+    code `shouldBe` ExitFailure 1+    stdout `shouldBe` ""+    normalizeGhc29916 stderr `shouldSatisfy` P.matchesSnapshot++minimalTest :: String -> FileContents+minimalTest name =+  [ "module " <> name <> " (spec) where"+  , "import Skeletest"+  , "spec = it \"should run\" $ pure ()"+  ]++normalizePluginError, normalizeGhc29916 :: String -> String+#if __GLASGOW_HASKELL__ == 906+normalizePluginError =+  Text.unpack+    . Text.replace (Text.pack "*** Exception: ExitFailure 1") (Text.pack "\n*** Exception: ExitFailure 1")+    . Text.pack+normalizeGhc29916 =+  Text.unpack+    . Text.replace (Text.pack "error:\n") (Text.pack "error: [GHC-29916]\n")+    . Text.replace (Text.pack "<generated>") (Text.pack "<no location info>")+    . Text.pack+#elif __GLASGOW_HASKELL__ == 908+normalizePluginError =+  Text.unpack+    . Text.replace (Text.pack "*** Exception: ExitFailure 1") (Text.pack "\n*** Exception: ExitFailure 1")+    . Text.pack+normalizeGhc29916 =+  Text.unpack+    . Text.replace (Text.pack "<generated>") (Text.pack "<no location info>")+    . Text.pack+#else+normalizePluginError = Text.unpack . Text.pack+normalizeGhc29916 = Text.unpack . Text.pack+#endif
+ test/Skeletest/PredicateSpec.hs view
@@ -0,0 +1,510 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}++module Skeletest.PredicateSpec (spec) where++import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Text qualified as Text+import Skeletest+import Skeletest.Predicate qualified as P+import UnliftIO.Exception (Exception, throwIO)++import Skeletest.Internal.Predicate (PredicateResult (..), runPredicate)+import Skeletest.TestUtils.Integration++data User = User+  { name :: String+  , age :: Maybe Int+  }++data HttpException = HttpException Int+  deriving (Show)++instance Exception HttpException++spec :: Spec+spec = do+  describe "General" $ do+    describe "anything" $ do+      it "matches anything" $ do+        1 `shouldSatisfy` P.anything+        "hello" `shouldSatisfy` P.anything++  describe "Ord" $ do+    describe "eq" $ do+      it "checks equality" $ do+        1 `shouldSatisfy` P.eq 1+        1 `shouldNotSatisfy` P.eq 2++      it "shows helpful failure messages" $ do+        snapshotFailure (P.eq 1) 2+        snapshotFailure (P.not $ P.eq 1) 1++    describe "gt" $ do+      it "checks inequality" $ do+        1 `shouldSatisfy` P.gt 0+        1 `shouldNotSatisfy` P.gt 1+        1 `shouldNotSatisfy` P.gt 2++    describe "gte" $ do+      it "checks inequality" $ do+        1 `shouldSatisfy` P.gte 0+        1 `shouldSatisfy` P.gte 1+        1 `shouldNotSatisfy` P.gte 2++    describe "lt" $ do+      it "checks inequality" $ do+        1 `shouldSatisfy` P.lt 2+        1 `shouldNotSatisfy` P.lt 1+        1 `shouldNotSatisfy` P.lt 0++    describe "lte" $ do+      it "checks inequality" $ do+        1 `shouldSatisfy` P.lte 2+        1 `shouldSatisfy` P.lte 1+        1 `shouldNotSatisfy` P.lte 0++  describe "Data types" $ do+    describe "just" $ do+      it "checks Maybe" $ do+        Just 1 `shouldSatisfy` P.just (P.gt 0)+        Just 1 `shouldNotSatisfy` P.just (P.gt 2)+        Nothing `shouldNotSatisfy` P.just P.anything++    describe "nothing" $ do+      it "checks Maybe" $ do+        Nothing `shouldSatisfy` P.nothing+        Just 1 `shouldNotSatisfy` P.nothing++    describe "left" $ do+      it "checks Either" $ do+        Left 1 `shouldSatisfy` P.left (P.gt 0)+        Left 1 `shouldNotSatisfy` P.left (P.gt 2)+        Right 1 `shouldNotSatisfy` P.left P.anything++    describe "right" $ do+      it "checks Either" $ do+        Right 1 `shouldSatisfy` P.right (P.gt 0)+        Right 1 `shouldNotSatisfy` P.right (P.gt 2)+        Left 1 `shouldNotSatisfy` P.right P.anything++    describe "tup" $ do+      it "checks all predicates" $ do+        (1, "hello") `shouldSatisfy` P.tup (P.eq 1, P.hasPrefix "he")+        (1, "hello") `shouldNotSatisfy` P.tup (P.eq 1, P.hasPrefix "xx")+        (1, "hello") `shouldNotSatisfy` P.tup (P.eq 0, P.hasPrefix "he")+        (1, "hello") `shouldNotSatisfy` P.tup (P.eq 0, P.hasPrefix "xx")++        -- some longer tuples+        (1, True, "hello") `shouldSatisfy` P.tup (P.eq 1, P.eq True, P.eq "hello")+        (1, True, "hello", 1.2) `shouldSatisfy` P.tup (P.eq 1, P.eq True, P.eq "hello", P.gt 0)++      it "shows helpful failure messages" $ do+        snapshotFailure (P.tup (P.eq 0, P.eq "")) (1, "")+        snapshotFailure (P.not $ P.tup (P.eq 1, P.eq "")) (1, "")++    describe "con" $ do+      it "checks record fields" $ do+        User "alice" (Just 10) `shouldSatisfy` P.con User{name = P.eq "alice", age = P.just (P.gt 0)}+        User "alice" (Just 10) `shouldNotSatisfy` P.con User{name = P.eq "", age = P.just (P.gt 0)}++      it "accepts anything in omitted record fields" $ do+        User "alice" (Just 10) `shouldSatisfy` P.con User{age = P.just (P.gt 0)}++      it "checks positional fields" $ do+        User "alice" (Just 10) `shouldSatisfy` P.con (User (P.eq "alice") (P.just (P.gt 0)))+        User "alice" (Just 10) `shouldNotSatisfy` P.con (User (P.eq "") (P.just (P.gt 0)))++        -- works with dollar sign+        User "alice" (Just 10) `shouldSatisfy` (P.con $ User (P.eq "alice") (P.just (P.gt 0)))++      integration . it "shows a helpful failure message" $ do+        runner <- getFixture+        addTestFile runner "ExampleSpec.hs" $+          [ "module ExampleSpec (spec) where"+          , ""+          , "import Skeletest"+          , "import qualified Skeletest.Predicate as P"+          , ""+          , "data User = User { name :: String }"+          , ""+          , "spec = it \"should error\" $ do"+          , "  User \"alice\" `shouldSatisfy` P.con User{name = P.eq \"\"}"+          ]++        (code, stdout, stderr) <- runTests runner []+        code `shouldBe` ExitFailure 1+        stderr `shouldBe` ""+        stdout `shouldSatisfy` P.matchesSnapshot++      integration . it "fails to compile with unknown record field" $ do+        runner <- getFixture+        addTestFile runner "ExampleSpec.hs" $+          [ "module ExampleSpec (spec) where"+          , ""+          , "import Skeletest"+          , "import qualified Skeletest.Predicate as P"+          , ""+          , "data User = User { name :: String }"+          , ""+          , "spec = it \"should error\" $ do"+          , "  User \"alice\" `shouldSatisfy` P.con User{foo = P.eq \"\"}"+          ]++        (code, stdout, stderr) <- runTests runner []+        code `shouldBe` ExitFailure 1+        stdout `shouldBe` ""+        stderr `shouldSatisfy` P.matchesSnapshot++      integration . it "fails to compile with omitted positional fields" $ do+        runner <- getFixture+        addTestFile runner "ExampleSpec.hs" $+          [ "module ExampleSpec (spec) where"+          , ""+          , "import Skeletest"+          , "import qualified Skeletest.Predicate as P"+          , ""+          , "data User = User { name :: String, age :: Maybe Int }"+          , ""+          , "spec = it \"should error\" $ do"+          , "  User \"alice\" (Just 1) `shouldSatisfy` P.con (User (P.eq \"\"))"+          ]++        (code, stdout, stderr) <- runTests runner []+        code `shouldBe` ExitFailure 1+        stdout `shouldBe` ""+        (normalizeConFailure . normalizeVars) stderr `shouldSatisfy` P.matchesSnapshot++      integration . it "fails to compile with non-constructor" $ do+        runner <- getFixture+        addTestFile runner "ExampleSpec.hs" $+          [ "module ExampleSpec (spec) where"+          , ""+          , "import Skeletest"+          , "import qualified Skeletest.Predicate as P"+          , ""+          , "spec = it \"should error\" $ do"+          , "  \"\" `shouldSatisfy` P.con \"\""+          ]++        (code, stdout, stderr) <- runTests runner []+        code `shouldBe` ExitFailure 1+        stdout `shouldBe` ""+        stderr `shouldSatisfy` P.matchesSnapshot++      integration . it "fails to compile when not applied to anything" $ do+        runner <- getFixture+        addTestFile runner "ExampleSpec.hs" $+          [ "module ExampleSpec (spec) where"+          , ""+          , "import Skeletest"+          , "import qualified Skeletest.Predicate as P"+          , ""+          , "spec = it \"should error\" $ do"+          , "  \"\" `shouldSatisfy` P.con"+          ]++        (code, stdout, stderr) <- runTests runner []+        code `shouldBe` ExitFailure 1+        stdout `shouldBe` ""+        stderr `shouldSatisfy` P.matchesSnapshot++      integration . it "fails to compile when applied to multiple arguments" $ do+        runner <- getFixture+        addTestFile runner "ExampleSpec.hs" $+          [ "module ExampleSpec (spec) where"+          , ""+          , "import Skeletest"+          , "import qualified Skeletest.Predicate as P"+          , ""+          , "spec = it \"should error\" $ do"+          , "  \"\" `shouldSatisfy` P.con 1 2"+          ]++        (code, stdout, stderr) <- runTests runner []+        code `shouldBe` ExitFailure 1+        stdout `shouldBe` ""+        stderr `shouldSatisfy` P.matchesSnapshot++  describe "Numeric" $ do+    describe "approx" $ do+      let x = 0.1 + 0.2 :: Double++      it "checks approximate equality" $ do+        x `shouldSatisfy` P.approx P.tol 0.3+        x `shouldNotSatisfy` P.approx P.tol 0.5++      it "allows setting tolerance" $ do+        -- with relative+        x `shouldSatisfy` P.approx P.tol{P.rel = Just 1e-6} 0.3+        x `shouldSatisfy` P.approx P.tol{P.abs = 1e-12} 0.3+        x `shouldSatisfy` P.approx P.tol{P.rel = Just 1e-6, P.abs = 1e-12} 0.3++        -- without relative+        x `shouldSatisfy` P.approx P.tol{P.rel = Nothing} 0.3+        x `shouldSatisfy` P.approx P.tol{P.rel = Nothing, P.abs = 1e-12} 0.3++  describe "Combinators" $ do+    describe "<<<" $ do+      it "transforms the input" $ do+        1 `shouldSatisfy` (P.gt 5 P.<<< (* 10))++      it "shows a helpful failure message" $ do+        snapshotFailure (P.gt 10 P.<<< (* 2)) 1++    describe ">>>" $ do+      it "transforms the input" $ do+        1 `shouldSatisfy` (show P.>>> P.eq "1")++      it "shows a helpful failure message" $ do+        snapshotFailure (show P.>>> P.eq "2") 1++    describe "not" $ do+      it "negates a predicate" $ do+        1 `shouldSatisfy` P.not (P.gt 10)+        1 `shouldNotSatisfy` P.not (P.gt 0)++    describe "&&" $ do+      it "checks both predicates are true" $ do+        1 `shouldSatisfy` (P.eq 1 P.&& P.gt 0)+        1 `shouldNotSatisfy` (P.eq 1 P.&& P.gt 10)+        1 `shouldNotSatisfy` (P.eq 2 P.&& P.gt 0)+        1 `shouldNotSatisfy` (P.eq 2 P.&& P.gt 10)++      it "shows helpful failure messages" $ do+        snapshotFailure (P.eq 2 P.&& P.gt 0) 1+        snapshotFailure (P.not $ P.eq 1 P.&& P.gt 0) 1++    describe "||" $ do+      it "checks either predicate is true" $ do+        1 `shouldSatisfy` (P.eq 1 P.|| P.gt 0)+        1 `shouldSatisfy` (P.eq 1 P.|| P.gt 10)+        1 `shouldSatisfy` (P.eq 2 P.|| P.gt 0)+        1 `shouldNotSatisfy` (P.eq 2 P.|| P.gt 10)++      it "shows helpful failure messages" $ do+        snapshotFailure (P.eq 2 P.|| P.gt 1) 1+        snapshotFailure (P.not $ P.eq 2 P.|| P.gt 0) 1++    describe "and" $ do+      it "checks all predicates are true" $ do+        1 `shouldSatisfy` P.and [P.eq 1, P.gt 0]+        1 `shouldNotSatisfy` P.and [P.eq 1, P.gt 10]+        1 `shouldNotSatisfy` P.and [P.eq 2, P.gt 0]+        1 `shouldNotSatisfy` P.and [P.eq 2, P.gt 10]++      it "shows helpful failure messages" $ do+        snapshotFailure (P.and [P.eq 2, P.gt 0, P.lt 10]) 1+        snapshotFailure (P.not $ P.and [P.eq 1, P.gt 0, P.lt 10]) 1++    describe "or" $ do+      it "checks any predicate is true" $ do+        1 `shouldSatisfy` P.or [P.eq 1, P.gt 0]+        1 `shouldSatisfy` P.or [P.eq 1, P.gt 10]+        1 `shouldSatisfy` P.or [P.eq 2, P.gt 0]+        1 `shouldNotSatisfy` P.or [P.eq 2, P.gt 10]++      it "shows helpful failure messages" $ do+        snapshotFailure (P.or [P.eq 2, P.gt 1, P.lt 0]) 1+        snapshotFailure (P.not $ P.or [P.eq 2, P.gt 0, P.lt 0]) 1++  describe "Containers" $ do+    describe "any" $ do+      it "checks predicate is true for any value" $ do+        [1, 2, 3] `shouldSatisfy` P.any (P.eq 2)+        [1, 2, 3] `shouldNotSatisfy` P.any (P.eq 10)+        [] `shouldNotSatisfy` P.any (P.eq 10)++      it "shows helpful failure messages" $ do+        snapshotFailure (P.any (P.eq 2)) []+        snapshotFailure (P.not $ P.any (P.eq 2)) [1, 2, 3]++    describe "all" $ do+      it "checks predicate is true for all values" $ do+        [] `shouldSatisfy` P.all (P.gt 0)+        [1, 2, 3] `shouldSatisfy` P.all (P.gt 0)+        [1, 2, 3] `shouldNotSatisfy` P.all (P.lt 3)++      it "shows helpful failure messages" $ do+        snapshotFailure (P.all (P.gt 10)) [1, 2]+        snapshotFailure (P.not $ P.all (P.gt 0)) [1, 2, 3]++    describe "elem" $ do+      it "checks element is in the given container" $ do+        [1, 2, 3] `shouldSatisfy` P.elem 1+        [1, 2, 3] `shouldNotSatisfy` P.elem 10++      it "shows helpful failure messages" $ do+        snapshotFailure (P.elem 1) []+        snapshotFailure (P.not $ P.elem 1) [1]++  describe "Subsequences" $ do+    describe "hasPrefix" $ do+      it "checks prefix" $ do+        "hello world" `shouldSatisfy` P.hasPrefix "hello"+        "hello world" `shouldNotSatisfy` P.hasPrefix "world"++    describe "hasInfix" $ do+      it "checks infix" $ do+        ">> hello world <<" `shouldSatisfy` P.hasInfix "hello"+        ">> hello world <<" `shouldNotSatisfy` P.hasInfix "!!"++    describe "hasSuffix" $ do+      it "checks suffix" $ do+        "hello world" `shouldSatisfy` P.hasSuffix "world"+        "hello world" `shouldNotSatisfy` P.hasSuffix "hello"++  describe "IO" $ do+    describe "returns" $ do+      it "checks result" $ do+        let action = do+              ref <- newIORef Nothing+              writeIORef ref (Just 1)+              readIORef ref+        action `shouldSatisfy` P.returns (P.just (P.gt 0))+        action `shouldNotSatisfy` P.returns (P.just (P.gt 10))++      it "shows helpful failure messages" $ do+        snapshotFailure (P.returns (P.left $ P.eq 0)) (pure $ Left 1)+        snapshotFailure (P.not $ P.returns (P.left $ P.eq 0)) (pure $ Left 0)++    describe "throws" $ do+      let throw404 = throwIO $ HttpException 404+      let exc code = P.con $ HttpException (P.eq code)++      it "checks exception" $ do+        throw404 `shouldSatisfy` P.throws (exc 404)+        throw404 `shouldNotSatisfy` P.throws (exc 500)++      it "shows helpful failure messages" $ do+        snapshotFailure (P.throws (exc 500)) throw404+        snapshotFailure (P.throws (exc 500)) (pure 1)+        snapshotFailure (P.not $ P.throws (exc 404)) throw404++snapshotFailure :: (HasCallStack) => Predicate IO a -> a -> IO ()+snapshotFailure p x = runPredicate p x `shouldSatisfy` P.returns (P.con $ PredicateFail P.matchesSnapshot)++normalizeVars :: String -> String+normalizeVars = go+  where+    go = \case+      [] -> []+      'x' : '0' : '_' : cs -> "x0" <> go (drop 4 cs)+      'a' : 'c' : 't' : 'u' : 'a' : 'l' : '_' : cs -> "actual" <> go (drop 4 cs)+      c : cs -> c : go cs++normalizeConFailure :: String -> String+#if __GLASGOW_HASKELL__ == 906+normalizeConFailure = Text.unpack . Text.replace old new . Text.pack+  where+    old =+      Text.pack . unlines $+        [ "ExampleSpec.hs:9:3: error:"+        , "    • The constructor ‘User’ should have 2 arguments, but has been given 1"+        , "    • In a stmt of a 'do' block:"+        , "        User \"alice\" (Just 1)"+        , "          `shouldSatisfy`"+        , "            Skeletest.Internal.Predicate.conMatches"+        , "              \"User\" Nothing"+        , "              \\ actual"+        , "                -> case pure actual of"+        , "                     Just (User x0)"+        , "                       -> Just"+        , "                            (Skeletest.Internal.Utils.HList.HCons"+        , "                               (pure x0) Skeletest.Internal.Utils.HList.HNil)"+        , "                     _ -> Nothing"+        , "              (Skeletest.Internal.Utils.HList.HCons"+        , "                 (P.eq \"\") Skeletest.Internal.Utils.HList.HNil)"+        , "      In the second argument of ‘($)’, namely"+        , "        ‘do User \"alice\" (Just 1)"+        , "              `shouldSatisfy`"+        , "                Skeletest.Internal.Predicate.conMatches"+        , "                  \"User\" Nothing"+        , "                  \\ actual"+        , "                    -> case pure actual of"+        , "                         Just (User x0) -> ..."+        , "                         _ -> ..."+        , "                  (Skeletest.Internal.Utils.HList.HCons"+        , "                     (P.eq \"\") Skeletest.Internal.Utils.HList.HNil)’"+        , "      In the expression:"+        , "        it \"should error\""+        , "          $ do User \"alice\" (Just 1)"+        , "                 `shouldSatisfy`"+        , "                   Skeletest.Internal.Predicate.conMatches"+        , "                     \"User\" Nothing"+        , "                     \\ actual"+        , "                       -> case pure actual of"+        , "                            Just (User x0) -> ..."+        , "                            _ -> ..."+        , "                     (Skeletest.Internal.Utils.HList.HCons"+        , "                        (P.eq \"\") Skeletest.Internal.Utils.HList.HNil)"+        ]+    new =+      Text.pack . unlines $+        [ "ExampleSpec.hs:9:3: error: [GHC-27346]"+        , "    • The data constructor ‘User’ should have 2 arguments, but has been given 1"+        , "    • In the pattern: User x0"+        , "      In the pattern: Just (User x0)"+        , "      In a case alternative:"+        , "          Just (User x0)"+        , "            -> Just"+        , "                 (Skeletest.Internal.Utils.HList.HCons"+        , "                    (pure x0) Skeletest.Internal.Utils.HList.HNil)"+        ]+#elif __GLASGOW_HASKELL__ == 908+normalizeConFailure = Text.unpack . Text.replace old new . Text.pack+  where+    old =+      Text.pack . unlines $+        [ "    • In a stmt of a 'do' block:"+        , "        User \"alice\" (Just 1)"+        , "          `shouldSatisfy`"+        , "            Skeletest.Internal.Predicate.conMatches"+        , "              \"User\" Nothing"+        , "              \\ actual"+        , "                -> case pure actual of"+        , "                     Just (User x0)"+        , "                       -> Just"+        , "                            (Skeletest.Internal.Utils.HList.HCons"+        , "                               (pure x0) Skeletest.Internal.Utils.HList.HNil)"+        , "                     _ -> Nothing"+        , "              (Skeletest.Internal.Utils.HList.HCons"+        , "                 (P.eq \"\") Skeletest.Internal.Utils.HList.HNil)"+        , "      In the second argument of ‘($)’, namely"+        , "        ‘do User \"alice\" (Just 1)"+        , "              `shouldSatisfy`"+        , "                Skeletest.Internal.Predicate.conMatches"+        , "                  \"User\" Nothing"+        , "                  \\ actual"+        , "                    -> case pure actual of"+        , "                         Just (User x0) -> ..."+        , "                         _ -> ..."+        , "                  (Skeletest.Internal.Utils.HList.HCons"+        , "                     (P.eq \"\") Skeletest.Internal.Utils.HList.HNil)’"+        , "      In the expression:"+        , "        it \"should error\""+        , "          $ do User \"alice\" (Just 1)"+        , "                 `shouldSatisfy`"+        , "                   Skeletest.Internal.Predicate.conMatches"+        , "                     \"User\" Nothing"+        , "                     \\ actual"+        , "                       -> case pure actual of"+        , "                            Just (User x0) -> ..."+        , "                            _ -> ..."+        , "                     (Skeletest.Internal.Utils.HList.HCons"+        , "                        (P.eq \"\") Skeletest.Internal.Utils.HList.HNil)"+        ]+    new =+      Text.pack . unlines $+        [ "    • In the pattern: User x0"+        , "      In the pattern: Just (User x0)"+        , "      In a case alternative:"+        , "          Just (User x0)"+        , "            -> Just"+        , "                 (Skeletest.Internal.Utils.HList.HCons"+        , "                    (pure x0) Skeletest.Internal.Utils.HList.HNil)"+        ]+#else+normalizeConFailure = Text.unpack . Text.pack+#endif
+ test/Skeletest/PropSpec.hs view
@@ -0,0 +1,55 @@+module Skeletest.PropSpec (spec) where++import Skeletest+import Skeletest.Predicate qualified as P+import Skeletest.Prop.Gen qualified as Gen+import Skeletest.Prop.Range qualified as Range++import Skeletest.TestUtils.Integration++spec :: Spec+spec = do+  describe "setDiscardLimit" $ do+    integration . it "sets discard limit" $ do+      runner <- getFixture+      addTestFile runner "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , ""+        , "spec = prop \"discards\" $ do"+        , "  setDiscardLimit 10"+        , "  discard"+        ]++      (code, stdout, stderr) <- runTests runner []+      code `shouldBe` ExitFailure 1+      stderr `shouldBe` ""+      stdout `shouldSatisfy` P.matchesSnapshot++  describe "===" $ do+    prop "checks two functions" $ do+      (read . show) P.=== id `shouldSatisfy` P.isoWith (Gen.int $ Range.exponential 0 10000000)+      (read . show) P.=== (+ 1) `shouldNotSatisfy` P.isoWith (Gen.int $ Range.exponential 0 10000000)++    integration . it "shows a helpful failure message" $ do+      runner <- getFixture+      addTestFile runner "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , "import qualified Skeletest.Predicate as P"+        , "import qualified Skeletest.Prop.Gen as Gen"+        , "import qualified Skeletest.Prop.Range as Range"+        , ""+        , "spec = do"+        , "  prop \"is isomorphic\" $ do"+        , "    (read . show) P.=== (+ 1) `shouldSatisfy` P.isoWith (Gen.int $ Range.linear 0 10)"+        , "  prop \"is not isomorphic\" $ do"+        , "    (read . show) P.=== id `shouldNotSatisfy` P.isoWith (Gen.int $ Range.linear 0 10)"+        ]++      (code, stdout, stderr) <- runTests runner ["--seed=0:0"]+      code `shouldBe` ExitFailure 1+      stderr `shouldBe` ""+      stdout `shouldSatisfy` P.matchesSnapshot
+ test/Skeletest/TestUtils/Integration.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Skeletest.TestUtils.Integration (+  integration,++  -- * Test runner+  FixtureTestRunner,+  FileContents,+  setMainFile,+  addTestFile,+  readTestFile,++  -- * runTests+  runTests,+  expectSuccess,++  -- * Re-exports+  ExitCode (..),+) where++import Data.IORef (IORef, modifyIORef, newIORef, readIORef)+import Data.Text qualified as Text+import Skeletest+import System.Directory (createDirectoryIfMissing)+import System.Exit (ExitCode (..))+import System.FilePath (takeDirectory, (</>))+import System.Process (CreateProcess (..), proc, readCreateProcessWithExitCode)++data MarkerIntegration = MarkerIntegration+  deriving (Show)++instance IsMarker MarkerIntegration where+  getMarkerName _ = "integration"++integration :: Spec -> Spec+integration = markManual . withMarker MarkerIntegration++{----- runTests -----}++data FixtureTestRunner = FixtureTestRunner+  { testRunnerDir :: FilePath+  , testRunnerSettingsRef :: IORef TestRunnerSettings+  }++data TestRunnerSettings = TestRunnerSettings+  { mainFile :: FileContents+  , testFiles :: [(FilePath, FileContents)]+  }++-- | File contents as a list of lines.+type FileContents = [String]++instance Fixture FixtureTestRunner where+  fixtureAction = do+    FixtureTmpDir tmpdir <- getFixture+    settingsRef <- newIORef defaultSettings+    pure . noCleanup $+      FixtureTestRunner+        { testRunnerDir = tmpdir+        , testRunnerSettingsRef = settingsRef+        }+    where+      defaultSettings =+        TestRunnerSettings+          { mainFile = ["import Skeletest.Main"]+          , testFiles = []+          }++setMainFile :: FixtureTestRunner -> FileContents -> IO ()+setMainFile FixtureTestRunner{testRunnerSettingsRef} contents =+  modifyIORef testRunnerSettingsRef $ \settings -> settings{mainFile = contents}++addTestFile :: FixtureTestRunner -> FilePath -> FileContents -> IO ()+addTestFile FixtureTestRunner{testRunnerSettingsRef} fp contents =+  modifyIORef testRunnerSettingsRef $ \settings ->+    settings{testFiles = (fp, contents) : testFiles settings}++readTestFile :: FixtureTestRunner -> FilePath -> IO String+readTestFile FixtureTestRunner{testRunnerDir} fp = readFile $ testRunnerDir </> fp++runTests :: FixtureTestRunner -> [String] -> IO (ExitCode, String, String)+runTests FixtureTestRunner{..} args = do+  TestRunnerSettings{..} <- readIORef testRunnerSettingsRef+  addFile "Main.hs" mainFile+  mapM_ (uncurry addFile) testFiles++  (code, stdout, stderr) <-+    flip readCreateProcessWithExitCode "" $+      setCWD testRunnerDir . proc "runghc" . concat $+        [ "--" : ghcArgs+        , "--" : "Main.hs" : args+        ]++  pure (code, sanitize stdout, sanitize stderr)+  where+    addFile fp contents = do+      let path = testRunnerDir </> fp+      createDirectoryIfMissing True (takeDirectory path)+      writeFile path (unlines contents)++    ghcArgs =+      concat+        [ ["-hide-all-packages"]+        , ["-F", "-pgmF=skeletest-preprocessor"]+        , ["-package skeletest"]+        ]+    setCWD dir p = p{cwd = Just dir}++    sanitize = Text.unpack . stripControlChars . Text.strip . Text.pack+    stripControlChars s =+      case Text.breakOn "\x1b" s of+        (_, "") -> s+        (pre, post) -> pre <> stripControlChars (Text.drop 1 . Text.dropWhile (/= 'm') $ post)++expectSuccess :: (HasCallStack) => IO (ExitCode, String, String) -> IO (String, String)+expectSuccess m = do+  (code, stdout, stderr) <- m+  context (unlines ["===== stdout =====", stdout, "===== stderr =====", stderr]) $+    code `shouldBe` ExitSuccess+  pure (stdout, stderr)
+ test/Skeletest/__snapshots__/AssertionsSpec.snap.md view
@@ -0,0 +1,131 @@+# Skeletest.Assertions++## context / should show failure context++```+Example+    should fail: FAIL+--------------------------------------------------------------------------------+./ExampleSpec.hs:7:+|+|     1 `shouldBe` (2 :: Int)+|       ^^^^^^^^^^++hello+world++1 ≠ 2+--------------------------------------------------------------------------------+```++## failTest / should show failure++```+Example+    should fail: FAIL+--------------------------------------------------------------------------------+./ExampleSpec.hs:5:+|+| spec = it "should fail" $ failTest "error message"+|                           ^^^^^^^^++error message+--------------------------------------------------------------------------------+```++## shouldBe / should show helpful failure++```+Example+    should fail: FAIL+--------------------------------------------------------------------------------+./ExampleSpec.hs:5:+|+| spec = it "should fail" $ 1 `shouldBe` (2 :: Int)+|                             ^^^^^^^^^^++1 ≠ 2+--------------------------------------------------------------------------------+```++## shouldNotBe / should show helpful failure++```+Example+    should fail: FAIL+--------------------------------------------------------------------------------+./ExampleSpec.hs:5:+|+| spec = it "should fail" $ 1 `shouldNotBe` (1 :: Int)+|                             ^^^^^^^^^^^^^++1 = 1++Expected:+  ≠ 1++Got:+  1+--------------------------------------------------------------------------------+```++## shouldNotSatisfy / should show helpful failure++```+Example+    should fail: FAIL+--------------------------------------------------------------------------------+./ExampleSpec.hs:6:+|+| spec = it "should fail" $ 1 `shouldNotSatisfy` P.gt (0 :: Int)+|                             ^^^^^^^^^^^^^^^^^^++1 > 0++Expected:+  ≯ 0++Got:+  1+--------------------------------------------------------------------------------+```++## shouldSatisfy / should show helpful failure++```+Example+    should fail: FAIL+--------------------------------------------------------------------------------+./ExampleSpec.hs:6:+|+| spec = it "should fail" $ (-1) `shouldSatisfy` P.gt (0 :: Int)+|                                ^^^^^^^^^^^^^^^++-1 ≯ 0+--------------------------------------------------------------------------------+```++## shows backtrace of failed assertions++```+Example+    should fail: FAIL+--------------------------------------------------------------------------------+./ExampleSpec.hs:6:+|+| spec = it "should fail" $ expectPositive (-1)+|                           ^^^^^^^^^^^^^^++./ExampleSpec.hs:9:+|+| expectPositive = expectGT 0+|                  ^^^^^^^^++./ExampleSpec.hs:12:+|+| expectGT x actual = actual `shouldSatisfy` P.gt x+|                            ^^^^^^^^^^^^^^^++-1 ≯ 0+--------------------------------------------------------------------------------+```
+ test/Skeletest/__snapshots__/MainSpec.snap.md view
@@ -0,0 +1,23 @@+# Skeletest.Main++## errors if Skeletest.Main not imported++```+skeletest-preprocessor: +******************** skeletest failure ********************+Could not find Skeletest.Main import in Main module++Main.hs:1:1: error:+    `skeletest-preprocessor' failed in phase `Haskell pre-processor'. (Exit code: 1)++*** Exception: ExitFailure 1+```++## errors if main function defined++```+<no location info>: error: [GHC-29916]+    Multiple declarations of ‘main’+    Declared at: Main.hs:4:1+                 <no location info>+```
+ test/Skeletest/__snapshots__/PredicateSpec.snap.md view
@@ -0,0 +1,347 @@+# Skeletest.Internal.Predicate++## Combinators / && / shows helpful failure messages++```+1 ≠ 2++Expected:+  (= 2)+  and (> 0)++Got:+  1+```++```+All predicates passed++Expected:+  At least one failure:+  (= 1)+  and (> 0)++Got:+  1+```++## Combinators / <<< / shows a helpful failure message++```+2 ≯ 10++Expected:+  > 10++Got:+  1+```++## Combinators / >>> / shows a helpful failure message++```+"1" ≠ "2"++Expected:+  = "2"++Got:+  1+```++## Combinators / and / shows helpful failure messages++```+1 ≠ 2++Expected:+  (= 2)+  and (> 0)+  and (< 10)++Got:+  1+```++```+All predicates passed++Expected:+  At least one failure:+  (= 1)+  and (> 0)+  and (< 10)++Got:+  1+```++## Combinators / or / shows helpful failure messages++```+No predicates passed++Expected:+  (= 2)+  or (> 1)+  or (< 0)++Got:+  1+```++```+1 > 0++Expected:+  All failures:+  (= 2)+  or (> 0)+  or (< 0)++Got:+  1+```++## Combinators / || / shows helpful failure messages++```+No predicates passed++Expected:+  (= 2)+  or (> 1)++Got:+  1+```++```+1 > 0++Expected:+  All failures:+  (= 2)+  or (> 0)++Got:+  1+```++## Containers / all / shows helpful failure messages++```+1 ≯ 10++Expected:+  all elements matching (> 10)++Got:+  [1,2]+```++```+All values matched++Expected:+  some elements not matching (> 0)++Got:+  [1,2,3]+```++## Containers / any / shows helpful failure messages++```+No values matched++Expected:+  at least one element matching (= 2)++Got:+  []+```++```+2 = 2++Expected:+  no elements matching (= 2)++Got:+  [1,2,3]+```++## Containers / elem / shows helpful failure messages++```+No values matched++Expected:+  at least one element matching (= 1)++Got:+  []+```++```+1 = 1++Expected:+  no elements matching (= 1)++Got:+  [1]+```++## Data types / con / fails to compile when applied to multiple arguments++```+<no location info>: error:+    +******************** skeletest failure ********************+P.con must be applied to exactly one argument+```++## Data types / con / fails to compile when not applied to anything++```+<no location info>: error:+    +******************** skeletest failure ********************+P.con must be applied to a constructor+```++## Data types / con / fails to compile with non-constructor++```+<no location info>: error:+    +******************** skeletest failure ********************+P.con must be applied to a constructor+```++## Data types / con / fails to compile with omitted positional fields++```+ExampleSpec.hs:9:3: error: [GHC-27346]+    • The data constructor ‘User’ should have 2 arguments, but has been given 1+    • In the pattern: User x0+      In the pattern: Just (User x0)+      In a case alternative:+          Just (User x0)+            -> Just+                 (Skeletest.Internal.Utils.HList.HCons+                    (pure x0) Skeletest.Internal.Utils.HList.HNil)+  |+9 |   User "alice" (Just 1) `shouldSatisfy` P.con (User (P.eq ""))+  |   ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+```++## Data types / con / fails to compile with unknown record field++```+ExampleSpec.hs:9:43: error: [GHC-76037] Not in scope: ‘foo’+  |+9 |   User "alice" `shouldSatisfy` P.con User{foo = P.eq ""}+  |                                           ^^^+```++## Data types / con / shows a helpful failure message++```+Example+    should error: FAIL+--------------------------------------------------------------------------------+./ExampleSpec.hs:9:+|+|   User "alice" `shouldSatisfy` P.con User{name = P.eq ""}+|                ^^^^^^^^^^^^^^^++"alice" ≠ []++Expected:+  matches User{name = (= [])}++Got:+  User "alice"+--------------------------------------------------------------------------------+```++## Data types / tup / shows helpful failure messages++```+1 ≠ 0++Expected:+  (= 0, = [])++Got:+  (1,[])+```++```+(1 = 1, [] = [])++Expected:+  not (= 1, = [])++Got:+  (1,[])+```++## IO / returns / shows helpful failure messages++```+1 ≠ 0++Expected:+  matches Left (= 0)++Got:+  Left 1+```++```+Left (0 = 0)+```++## IO / throws / shows helpful failure messages++```+404 ≠ 500++Expected:+  throws (matches HttpException (= 500))++Got:+  HttpException 404+```++```+Expected:+  throws (matches HttpException (= 500))++Got:+  1+```++```+HttpException (404 = 404)+```++## Ord / eq / shows helpful failure messages++```+2 ≠ 1+```++```+1 = 1++Expected:+  ≠ 1++Got:+  1+```
+ test/Skeletest/__snapshots__/PropSpec.snap.md view
@@ -0,0 +1,52 @@+# Skeletest.Prop++## === / shows a helpful failure message++```+Example+    is isomorphic: FAIL+--------------------------------------------------------------------------------+./ExampleSpec.hs:10:+|+|     (read . show) P.=== (+ 1) `shouldSatisfy` P.isoWith (Gen.int $ Range.linear 0 10)+|                               ^^^^^^^^^^^^^^^++Failed after 1 tests.+Rerun with --seed=0:0 to reproduce.++./ExampleSpec.hs:10:47 ==> 0++0 ≠ 1+where+  0 = (read . show) 0+  1 = (+ 1) 0+--------------------------------------------------------------------------------+    is not isomorphic: FAIL+--------------------------------------------------------------------------------+./ExampleSpec.hs:12:+|+|     (read . show) P.=== id `shouldNotSatisfy` P.isoWith (Gen.int $ Range.linear 0 10)+|                            ^^^^^^^^^^^^^^^^^^++Failed after 1 tests.+Rerun with --seed=0:0 to reproduce.++./ExampleSpec.hs:12:47 ==> 0++0 = 0+where+  0 = (read . show) 0+  0 = id 0+--------------------------------------------------------------------------------+```++## setDiscardLimit / sets discard limit++```+Example+    discards: FAIL+--------------------------------------------------------------------------------+Gave up after 10 discards.+Passed 0 tests.+--------------------------------------------------------------------------------+```
+ test/__snapshots__/ExampleSpec.snap.md view
@@ -0,0 +1,21 @@+# Example++## predicates / matches snapshots++```+1+```++```+a "quoted" string+```++```+a "quoted" text+```++## predicates / matches snapshots without Show instance++```+UserNoShow "user1" 18+```