diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2013, Paul Chiusano + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/easytest.cabal b/easytest.cabal new file mode 100644 --- /dev/null +++ b/easytest.cabal @@ -0,0 +1,111 @@ +name: easytest +category: Testing +version: 0.1 +license: MIT +cabal-version: >= 1.8 +license-file: LICENSE +author: Joel Burget, Paul Chiusano +maintainer: Joel Burget +stability: provisional +homepage: https://github.com/joelburget/easytest +bug-reports: https://github.com/joelburget/easytest/issues +copyright: Copyright (C) 2017-2018 Joel Burget, Copyright (C) 2016 Paul Chiusano and contributors +synopsis: Simple, expressive testing library +description: + EasyTest is a simple testing toolkit, meant to replace most uses of QuickCheck, SmallCheck, HUnit, and frameworks like Tasty, etc. Here's an example usage: + . + > module Main where + > + > import EasyTest + > import Control.Applicative + > import Control.Monad + > + > suite :: Test () + > suite = tests + > [ scope "addition.ex1" $ expect (1 + 1 == 2) + > , scope "addition.ex2" $ expect (2 + 3 == 5) + > , scope "list.reversal" . fork $ do + > -- generate lists from size 0 to 10, of Ints in (0,43) + > -- shorthand: listsOf [0..10] (int' 0 43) + > ns <- [0..10] `forM` \n -> replicateM n (int' 0 43) + > ns `forM_` \ns -> expect (reverse (reverse ns) == ns) + > -- equivalent to `scope "addition.ex3"` + > , scope "addition" . scope "ex3" $ expect (3 + 3 == 6) + > , scope "always passes" $ do + > note "I'm running this test, even though it always passes!" + > ok -- like `pure ()`, but records a success result + > , scope "failing test" $ crash "oh noes!!" ] + > + > -- NB: `run suite` would run all tests, but we only run + > -- tests whose scopes are prefixed by "addition" + > main = runOnly "addition" suite + . + This generates the output: + . + > Randomness seed for this run is 5104092164859451056 + > Raw test output to follow ... + > ------------------------------------------------------------ + > OK addition.ex1 + > OK addition.ex2 + > OK addition.ex3 + > ------------------------------------------------------------ + > ✅ 3 tests passed, no failures! 👍 🎉 + The idea here is to write tests with ordinary Haskell code, with control flow explicit and under programmer control. + +build-type: Simple +extra-source-files: +data-files: +tested-with: GHC == 8.0.2, GHC == 8.2.1 + +source-repository head + type: git + location: git@github.com:joelburget/easytest.git + +-- `cabal install -foptimized` enables optimizations +flag optimized + manual: True + default: False + +flag quiet + manual: True + default: False + +library + hs-source-dirs: src + + exposed-modules: + EasyTest + EasyTest.Internal + + other-modules: + EasyTest.Generators + EasyTest.Porcelain + + -- these bounds could probably be made looser + build-depends: + async >= 2.1 && <= 2.2, + base >= 4.5 && <= 5, + mtl >= 2.0.1 && < 2.3, + containers >= 0.4.0 && < 0.6, + stm >= 2.4 && < 3, + random >= 1.1 && < 2, + text >= 1.2 && < 1.3 + + ghc-options: -Wall -fno-warn-name-shadowing + + if flag(optimized) + ghc-options: -funbox-strict-fields -O2 + + if flag(quiet) + ghc-options: -v0 + +-- I really have no idea why you'd ever use this, just use an executable as above +test-suite tests + type: exitcode-stdio-1.0 + main-is: Suite.hs + ghc-options: -w -threaded -rtsopts -with-rtsopts=-N -v0 + hs-source-dirs: tests + other-modules: + build-depends: + base, + easytest diff --git a/src/EasyTest.hs b/src/EasyTest.hs new file mode 100644 --- /dev/null +++ b/src/EasyTest.hs @@ -0,0 +1,272 @@ +{-| +Module : EasyTest +Copyright : (c) Joel Burget, 2018 +License : MIT +Maintainer : joelburget@gmail.com +Stability : provisional + +EasyTest is a simple testing toolkit, meant to replace most uses of QuickCheck, SmallCheck, HUnit, and frameworks like Tasty, etc. Here's an example usage: + +@ +module Main where + +import EasyTest +import Control.Applicative +import Control.Monad + +suite :: Test () +suite = tests + [ scope "addition.ex1" $ expect (1 + 1 == 2) + , scope "addition.ex2" $ expect (2 + 3 == 5) + , scope "list.reversal" . fork $ do + -- generate lists from size 0 to 10, of Ints in (0,43) + -- shorthand: listsOf [0..10] (int' 0 43) + ns @<-@ [0..10] @`@forM@`@ \\n -> replicateM n (int' 0 43) + ns @`@forM_@`@ \\ns -> expect (reverse (reverse ns) == ns) + -- equivalent to `scope "addition.ex3"` + , scope "addition" . scope "ex3" $ expect (3 + 3 == 6) + , scope "always passes" $ do + note "I'm running this test, even though it always passes!" + ok -- like `pure ()`, but records a success result + , scope "failing test" $ crash "oh noes!!" ] + +-- NB: `run suite` would run all tests, but we only run +-- tests whose scopes are prefixed by "addition" +main = runOnly "addition" suite +@ + +This generates the output: + +@ +Randomness seed for this run is 5104092164859451056 +Raw test output to follow ... +------------------------------------------------------------ +OK addition.ex1 +OK addition.ex2 +OK addition.ex3 +------------------------------------------------------------ +✅ 3 tests passed, no failures! 👍 🎉 +@ + +The idea here is to write tests with ordinary Haskell code, with control flow explicit and under programmer control. Tests are values of type @Test a@, and @Test@ forms a monad with access to: + +* repeatable randomness (the @random@ and @random'@ functions for @random@ and bounded random values, or handy specialized @int@, @int'@, @double@, @double'@, etc) + +* I/O (via @liftIO@ or @EasyTest.io@, which is an alias for @liftIO@) + +* failure (via @crash@, which yields a stack trace, or @fail@, which does not) + +* logging (via @note@, @noteScoped@, or @note'@) + +* hierarchically-named subcomputations which can be switched on and off (in the above code, notice that only the tests scoped under "addition" are run, and we could do @run@ instead of @runOnly@ if we wanted to run the whole suite) + +* parallelism (note the fork which runs that subtree of the test suite in a parallel thread). + +* conjunction of tests via @MonadPlus@ (the @<|>@ operation runs both tests, even if the first test fails, and the tests function used above is just @msum@). + +* Using any or all of these capabilities, you assemble @Test@ values into a "test suite" (just another @Test@ value) using ordinary Haskell code, not framework magic. Notice that to generate a list of random values, we just @replicateM@ and @forM@ as usual. If this gets tedious... we can factor this logic out into helper functions! For instance: + +@ +listOf :: Int -> Test a -> Test [a] +listOf = replicateM + +listsOf :: [Int] -> Test a -> Test [[a]] +listsOf sizes gen = sizes @`@forM@`@ \\n -> listOf n gen + +ex :: Test () +ex = do + ns <- listsOf [0..100] int + ns @`@forM_@`@ \\ns -> expect (reverse (reverse ns) == ns) +This library is opinionated and might not be for everyone. If you're curious about any of the design decisions made, see my rationale for writing it. +@ + += User guide + +The simplest tests are @ok@, @crash@, and @expect@: + +@ +-- Record a success +ok :: Test () + +-- Record a failure +crash :: String -> Test a + +-- Record a success if True, otherwise record a failure +expect :: Bool -> Test () +@ + +NB: @fail@ is equivalent to @crash@, but doesn't provide a stack trace on failure. + +We can lift I/O into @Test@ using @io@ (or @liftIO@, but I always forget where to import that from): + +@ +io :: IO a -> Test a +@ + +@Test@ is also a @Monad@. Note that @return@ and @pure@ do not record a result. Use @ok@, @expect@, or @crash@ for that purpose. + +We often want to label tests so we can see when they succeed or fail. For that we use @scope@: + +@ +-- | Label a test. Can be nested. A `'.'` is placed between nested +-- scopes, so `scope "foo" . scope "bar"` is equivalent to `scope "foo.bar"` +scope :: String -> Test a -> Test a +@ + +Here's an example usage, putting all these primitives together: + +@ +module Main where + +import EasyTest (ok, scope, crash, expect, run) + +suite :: Test () +suite = do + ok + scope "test-crash" $ crash "oh noes!" + expect (1 + 1 == 2) + +main = run suite +@ + +This example is sequencing the @ok@, @crash@, and @expect@ monadically, so the test halts at the first failure. The output is: + +@ +Randomness seed for this run is 1830293182471192517 +Raw test output to follow ... +------------------------------------------------------------ +test-crash FAILURE oh noes! CallStack (from HasCallStack): + crash, called at @/@Users@/@pchiusano@/@code@/@easytest@/@tests@/@Suite.hs:10:24 in main:Main +OK +FAILED test-crash +------------------------------------------------------------ + + + 1 passed + 1 FAILED (failed scopes below) + "test-crash" + + To rerun with same random seed: + + EasyTest.rerun 1830293182471192517 + EasyTest.rerunOnly 1830293182471192517 "test-crash" + + +------------------------------------------------------------ +❌ +@ + +In the output (which is streamed to the console), we get a stack trace pointing to the line where crash was called (@..tests/Suite.hs:10:24@), information about failing tests, and instructions for rerunning the tests with an identical random seed (in this case, there's no randomness, so @rerun@ would work fine, but if our test generated random data, we might want to rerun with the exact same random numbers). + +The last line of the output always indicates success or failure of the overall suite... and information about any failing tests is immediately above that. You should NEVER have to scroll through a bunch of test output just to find out which tests actually failed! Also, the streaming output always has @OK@ or @FAILED@ as the leftmost text for ease of scanning. + +If you try running a test suite that has no results recorded (like if you have a typo in a call to runOnly, or you forget to use ok or expect to record a test result), you'll see a warning like this: + +@ +😶 hmm ... no test results recorded +Tip: use @`@ok@`@, @`@expect@`@, or @`@crash@`@ to record results +Tip: if running via @`@runOnly@`@ or @`@rerunOnly@`@, check for typos +@ + +The various run functions (@run@, @runOnly@, @rerun@, and @rerunOnly@) all exit the process with a nonzero status in the event of a failure, so they can be used for continuous integration or test running tools that key off the process exit code to determine whether the suite succeeded or failed. For instance, here's the relevant portion of a typical cabal file: + +@ +-- Preferred way to run EasyTest-based test suite +executable runtests + main-is: NameOfYourTestSuite.hs + ghc-options: -w -threaded -rtsopts -with-rtsopts=-N -v0 + hs-source-dirs: tests + other-modules: + build-depends: + base, + easytest + +-- I really have no idea why you'd ever use this, unless you +-- really feel the need to run your tests via cabal's "test runner" +-- which "conveniently" hides all output unless you pass it some +-- random flag I never remember +test-suite tests + type: exitcode-stdio-1.0 + main-is: NameOfYourTestSuite.hs + ghc-options: -w -threaded -rtsopts -with-rtsopts=-N -v0 + hs-source-dirs: tests + other-modules: + build-depends: + base, + easytest +@ + +For tests that are logically separate, we usually combine them into a suite using @tests@ (which is just @msum@), as in: + +@ +suite = tests + [ scope "ex1" $ expect (1 + 1 == 2) + , scope "ex2" $ expect (2 + 2 == 4) ] + +-- equivalently +suite = + (scope "ex1" $ expect (1 + 1 == 2)) '<|>' + (scope "ex2" $ expect (2 + 2 == 4)) +@ + +Importantly, each branch of a '<|>' or tests gets its own copy of the randomness source, so even when branches of the test suite are switched on or off, the randomness received by a branch is the same. This is important for being able to quickly iterate on a test failure! + +Sometimes, tests take a while to run and we want to make use of parallelism. For that, use @EasyTest.fork@ or @fork'@: + +@ +-- | Run a test in a separate thread, not blocking for its result. +fork :: Test a -> Test () + +-- | Run a test in a separate thread, not blocking for its result, but +-- return a future which can be used to block on the result. +fork' :: Test a -> Test (Test a) +@ + +Note: There's no "framework global" parallelism configuration setting. + +We often want to generate random data for testing purposes: + +@ +reverseTest :: Test () +reverseTest = scope "list reversal" $ do + nums <- listsOf [0..100] (int' 0 99) + nums `forM_` \nums -> expect (reverse (reverse nums) == nums) +@ + +Tip: generate your test cases in order of increasing size. If you get a failure, your test case is closer to "minimal". + +The above code generates lists of sizes 0 through 100, consisting of @Int@ values in the range 0 through 99. @int' :: Int -> Int -> Test Int@, and there are analogous functions for @Double@, @Word@, etc. The most general functions are: + +@ +random :: Random a => Test a +random' :: Random a => a -> a -> Test a +@ + +The functions @int@, @char@, @bool@, @double@, etc are just specialized aliases for @random@, and @int'@, @char'@, etc are just aliases for @random'@. The aliases are sometimes useful in situations where use of the generic @random@ or @random'@ would require type annotations. + +If our list reversal test failed, we might use @runOnly "list reversal"@ or @rerunOnly \ "list reversal"@ to rerun just that subtree of the test suite, and we might add some additional diagnostics to see what was going on: + +@ +reverseTest :: Test () +reverseTest = scope "list reversal" $ do + nums <- listsOf [0..100] (int' 0 99) + nums `forM_` \nums -> do + note $ "nums: " ++ show nums + let r = reverse (reverse nums) + note $ "reverse (reverse nums): " ++ show r + expect (r == nums) +@ + +The idea is that these sorts of detailed diagnostics are added lazily (and temporarily) to find and fix failing tests. You can also add diagnostics via @io (putStrLn "blah")@, but if you have tests running in parallel this can sometimes get confusing. + +That's it! Just use ordinary monadic code to generate any testing data and to run your tests. + +-} + +module EasyTest ( + module EasyTest.Porcelain, + module EasyTest.Generators + ) where + +import EasyTest.Generators +import EasyTest.Porcelain diff --git a/src/EasyTest/Generators.hs b/src/EasyTest/Generators.hs new file mode 100644 --- /dev/null +++ b/src/EasyTest/Generators.hs @@ -0,0 +1,143 @@ +{-# language Rank2Types #-} +{-# language ScopedTypeVariables #-} +module EasyTest.Generators + ( -- * Generators + random + , random' + , bool + , word8 + , char + , int + , double + , word + , int' + , char' + , double' + , word' + , word8' + , pick + , listOf + , listsOf + , pair + , mapOf + , mapsOf + ) where + +import Control.Applicative +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Reader +import Data.Map (Map) +import Data.Word +import System.Random (Random) +import qualified Data.Map as Map +import qualified System.Random as Random + +import EasyTest.Internal + +-- | Generate a random value +random :: forall a. Random a => Test a +random = do + rng <- asks envRng + liftIO . atomically $ do + rng0 <- readTVar rng + let (a :: a, rng1) = Random.random rng0 + writeTVar rng rng1 + pure a + +-- | Generate a bounded random value. Inclusive on both sides. +random' :: Random a => a -> a -> Test a +random' lower upper = do + rng <- asks envRng + liftIO . atomically $ do + rng0 <- readTVar rng + let (a, rng1) = Random.randomR (lower,upper) rng0 + writeTVar rng rng1 + pure a + +bool :: Test Bool +bool = random + +word8 :: Test Word8 +word8 = random + +-- | Generate a random 'Char' +char :: Test Char +char = random + +-- | Generate a random 'Int' +int :: Test Int +int = random + +-- | Generate a random 'Double' +double :: Test Double +double = random + +-- | Generate a random 'Word' +word :: Test Word +word = random + +-- | Generate a random 'Int' in the given range +-- Note: @int' 0 5@ includes both @0@ and @5@ +int' :: Int -> Int -> Test Int +int' = random' + +-- | Generate a random 'Char' in the given range +-- Note: @char' 'a' 'z'@ includes both @'a'@ and @'z'@. +char' :: Char -> Char -> Test Char +char' = random' + +-- | Generate a random 'Double' in the given range +-- Note: @double' 0 1@ includes both @0@ and @1@. +double' :: Double -> Double -> Test Double +double' = random' + +-- | Generate a random 'Double' in the given range +-- Note: @word' 0 10@ includes both @0@ and @10@. +word' :: Word -> Word -> Test Word +word' = random' + +-- | Generate a random 'Double' in the given range +-- Note: @word8' 0 10@ includes both @0@ and @10@. +word8' :: Word8 -> Word8 -> Test Word8 +word8' = random' + +-- | Sample uniformly from the given list of possibilities +pick :: [a] -> Test a +pick as = let n = length as; ind = picker n as in do + i <- int' 0 (n - 1) + Just a <- pure (ind i) + pure a + +picker :: Int -> [a] -> (Int -> Maybe a) +picker _ [] = const Nothing +picker _ [a] = \i -> if i == 0 then Just a else Nothing +picker size as = go where + lsize = size `div` 2 + rsize = size - lsize + (l,r) = splitAt lsize as + lpicker = picker lsize l + rpicker = picker rsize r + go i = if i < lsize then lpicker i else rpicker (i - lsize) + +-- | Alias for 'replicateM' +listOf :: Int -> Test a -> Test [a] +listOf = replicateM + +-- | Generate a list of lists of the given sizes, +-- an alias for @sizes \`forM\` \\n -> listOf n gen@ +listsOf :: [Int] -> Test a -> Test [[a]] +listsOf sizes gen = sizes `forM` \n -> listOf n gen + +-- | Alias for @liftA2 (,)@. +pair :: Test a -> Test b -> Test (a,b) +pair = liftA2 (,) + +-- | Generate a @Data.Map k v@ of the given size. +mapOf :: Ord k => Int -> Test k -> Test v -> Test (Map k v) +mapOf n k v = Map.fromList <$> listOf n (pair k v) + +-- | Generate a @[Data.Map k v]@ of the given sizes. +mapsOf :: Ord k => [Int] -> Test k -> Test v -> Test [Map k v] +mapsOf sizes k v = sizes `forM` \n -> mapOf n k v diff --git a/src/EasyTest/Internal.hs b/src/EasyTest/Internal.hs new file mode 100644 --- /dev/null +++ b/src/EasyTest/Internal.hs @@ -0,0 +1,208 @@ +{-# language BangPatterns #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language NamedFieldPuns #-} +{-# language OverloadedStrings #-} +{-# language ScopedTypeVariables #-} + +module EasyTest.Internal + ( -- * Core + crash + , note + , scope + , -- * Internal + Status(..) + , Env(..) + , Test(..) + , actionAllowed + , putResult + , runWrap + , combineStatus + ) where + +import Control.Applicative +import Control.Concurrent.STM +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Reader +import Data.List (isPrefixOf) +import Data.Semigroup +import Data.String (IsString(..)) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Stack +import qualified System.Random as Random + +-- | Status of a test +data Status = Failed | Passed !Int | Skipped + +combineStatus :: Status -> Status -> Status +combineStatus Skipped s = s +combineStatus s Skipped = s +combineStatus Failed _ = Failed +combineStatus _ Failed = Failed +combineStatus (Passed n) (Passed m) = Passed (n + m) + +instance Semigroup Status where + (<>) = combineStatus + +instance Monoid Status where + mempty = Passed 0 + mappend = combineStatus + +data Env = + Env { envRng :: TVar Random.StdGen + , envMessages :: [Text] + , envResults :: TBQueue (Maybe (TMVar ([Text], Status))) + , envNote :: Text -> IO () + , envAllow :: [Text] } + +-- | Tests are values of type @Test a@, and 'Test' forms a monad with access to: +-- +-- * repeatable randomness (the 'EasyTest.random' and 'EasyTest.random'' functions for random and bounded random values, or handy specialized 'EasyTest.int', 'EasyTest.int'', 'EasyTest.double', 'EasyTest.double'', etc) +-- +-- * I/O (via 'liftIO' or 'EasyTest.io', which is an alias for 'liftIO') +-- +-- * failure (via 'crash', which yields a stack trace, or 'fail', which does not) +-- +-- * logging (via 'EasyTest.note', 'EasyTest.noteScoped', or 'EasyTest.note'') +-- +-- * hierarchically-named subcomputations (under 'EasyTest.scope') which can be switched on and off via 'EasyTest.runOnly' +-- +-- * parallelism (via 'EasyTest.fork') +-- +-- * conjunction of tests via 'MonadPlus' (the '<|>' operation runs both tests, even if the first test fails, and the tests function used above is just 'msum'). +-- +-- Using any or all of these capabilities, you assemble 'Test' values into a "test suite" (just another 'Test' value) using ordinary Haskell code, not framework magic. Notice that to generate a list of random values, we just 'replicateM' and 'forM' as usual. +newtype Test a = Test (ReaderT Env IO (Maybe a)) + +-- | Record a failure at the current scope +crash :: HasCallStack => Text -> Test a +crash msg = do + let trace = callStack + msg' = msg <> " " <> T.pack (prettyCallStack trace) + Test (Just <$> putResult Failed) + noteScoped ("FAILURE " <> msg') + Test (pure Nothing) + +putResult :: Status -> ReaderT Env IO () +putResult passed = do + msgs <- asks envMessages + allow <- asks envAllow + r <- liftIO . atomically $ newTMVar + (msgs, if allow `isPrefixOf` msgs then passed else Skipped) + q <- asks envResults + lift . atomically $ writeTBQueue q (Just r) + +-- | Label a test. Can be nested. A "." is placed between nested +-- scopes, so @scope "foo" . scope "bar"@ is equivalent to @scope "foo.bar"@ +scope :: Text -> Test a -> Test a +scope msg (Test t) = Test $ do + env <- ask + let msg' = T.splitOn "." msg + messages' = envMessages env <> msg' + env' = env { envMessages = messages' } + passes = actionAllowed env' + + if passes + then liftIO $ runReaderT t env' + else putResult Skipped >> pure Nothing + +-- | Prepend the current scope to a logging message +noteScoped :: Text -> Test () +noteScoped msg = do + s <- currentScope + note (T.intercalate "." s <> (if null s then "" else " ") <> msg) + +-- | Log a message +note :: Text -> Test () +note msg = do + note_ <- asks envNote + liftIO $ note_ msg + pure () + +-- | The current scope +currentScope :: Test [Text] +currentScope = asks envMessages + +-- | Catch all exceptions that could occur in the given `Test` +wrap :: Test a -> Test a +wrap (Test t) = Test $ do + env <- ask + lift $ runWrap env t + +runWrap :: Env -> ReaderT Env IO (Maybe a) -> IO (Maybe a) +runWrap env t = do + result <- try $ runReaderT t env + case result of + Left e -> do + envNote env $ + T.intercalate "." (envMessages env) + <> " EXCEPTION: " + <> T.pack (show (e :: SomeException)) + runReaderT (putResult Failed) env + pure Nothing + Right a -> pure a + +-- * @allow' `isPrefixOf` messages'@: we're messaging within the allowed range +-- * @messages' `isPrefixOf` allow'@: we're still building a prefix of the +-- allowed range but could go deeper +actionAllowed :: Env -> Bool +actionAllowed Env{envMessages = messages, envAllow = allow} + = allow `isPrefixOf` messages || messages `isPrefixOf` allow + +instance MonadReader Env Test where + ask = Test $ do + allowed <- asks actionAllowed + if allowed + then Just <$> ask + else pure Nothing + local f (Test t) = Test (local f t) + reader f = Test (Just <$> reader f) + +instance Monad Test where + fail = crash . T.pack + return a = Test $ do + allowed <- asks actionAllowed + pure $ if allowed + then Just a + else Nothing + Test a >>= f = Test $ do + a' <- a + case a' of + Nothing -> pure Nothing + Just a'' -> let Test t = f a'' in t + +instance Functor Test where + fmap = liftM + +instance Applicative Test where + pure = return + (<*>) = ap + +instance MonadIO Test where + liftIO action = do + allowed <- asks actionAllowed + if allowed + then wrap $ Test (Just <$> liftIO action) + else Test (pure Nothing) + +instance Alternative Test where + empty = Test (pure Nothing) + Test t1 <|> Test t2 = Test $ do + env <- ask + (rng1, rng2) <- liftIO . atomically $ do + currentRng <- readTVar (envRng env) + let (rng1, rng2) = Random.split currentRng + (,) <$> newTVar rng1 <*> newTVar rng2 + lift $ do + _ <- runWrap (env { envRng = rng1 }) t1 + runWrap (env { envRng = rng2 }) t2 + +instance MonadPlus Test where + mzero = empty + mplus = (<|>) + +instance IsString (Test a -> Test a) where + fromString str = scope (T.pack str) diff --git a/src/EasyTest/Porcelain.hs b/src/EasyTest/Porcelain.hs new file mode 100644 --- /dev/null +++ b/src/EasyTest/Porcelain.hs @@ -0,0 +1,215 @@ +{-# language OverloadedStrings #-} +{-# language BangPatterns #-} +module EasyTest.Porcelain + ( -- * Tests + Test + , expect + , expectJust + , expectRight + , expectEq + , tests + , using + , runOnly + , rerunOnly + , run + , rerun + , scope + , note' + , ok + , skip + , fork + , fork' + , crash + , note + , io + ) where + +import Control.Applicative +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Reader +import Data.Semigroup +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import GHC.Stack +import System.Exit +import qualified Control.Concurrent.Async as A +import qualified Data.Map as Map +import qualified System.Random as Random + +import EasyTest.Internal + +-- | Convenient alias for 'liftIO' +io :: IO a -> Test a +io = liftIO + +expect :: HasCallStack => Bool -> Test () +expect False = crash "unexpected" +expect True = ok + +expectJust :: HasCallStack => Maybe a -> Test a +expectJust Nothing = crash "expected Just, got Nothing" +expectJust (Just a) = ok >> pure a + +expectRight :: HasCallStack => Either e a -> Test a +expectRight (Left _) = crash "expected Right, got Left" +expectRight (Right a) = ok >> pure a + +expectEq :: (Eq a, Show a, HasCallStack) => a -> a -> Test () +expectEq x y = if x == y then ok else crash $ + "expected to be equal: (" <> show' x <> "), (" <> show' y <> ")" + +-- | Run a list of tests +-- +-- This specializes 'msum', 'Data.Foldable.asum', and 'sequence_'. +tests :: [Test ()] -> Test () +tests = msum + +atomicLogger :: IO (Text -> IO ()) +atomicLogger = do + lock <- newMVar () + pure $ \msg -> + -- force msg before acquiring lock + let dummy = T.foldl' (\_ ch -> ch == 'a') True msg + in dummy `seq` bracket (takeMVar lock) (\_ -> putMVar lock ()) (\_ -> T.putStrLn msg) + +-- | A test with a setup and teardown +using :: IO r -> (r -> IO ()) -> (r -> Test a) -> Test a +using r cleanup use = Test $ do + r' <- liftIO r + env <- ask + let Test t = use r' + a <- liftIO (runWrap env t) + liftIO (cleanup r') + pure a + +-- | Run all tests whose scope starts with the given prefix +runOnly :: Text -> Test a -> IO () +runOnly prefix t = do + logger <- atomicLogger + seed <- abs <$> Random.randomIO :: IO Int + let allowed = filter (not . T.null) $ T.splitOn "." prefix + run' seed logger allowed t + +-- | Rerun all tests with the given seed and whose scope starts with the given prefix +rerunOnly :: Int -> Text -> Test a -> IO () +rerunOnly seed prefix t = do + logger <- atomicLogger + let allowed = filter (not . T.null) $ T.splitOn "." prefix + run' seed logger allowed t + +-- | Run all tests +run :: Test a -> IO () +run = runOnly "" + +-- | Rerun all tests with the given seed +rerun :: Int -> Test a -> IO () +rerun seed = rerunOnly seed "" + +run' :: Int -> (Text -> IO ()) -> [Text] -> Test a -> IO () +run' seed note_ allowed (Test t) = do + let !rng_ = Random.mkStdGen seed + resultsQ <- atomically (newTBQueue 50) + rngVar <- newTVarIO rng_ + note_ $ "Randomness seed for this run is " <> show' seed <> "" + results <- atomically $ newTVar Map.empty + rs <- A.async . forever $ do + -- note, totally fine if this bombs once queue is empty + Just result <- atomically $ readTBQueue resultsQ + (msgs, passed) <- atomically $ takeTMVar result + let msgs' = T.intercalate "." msgs + atomically $ modifyTVar results (Map.insertWith combineStatus msgs' passed) + resultsMap <- readTVarIO results + case Map.findWithDefault Skipped msgs' resultsMap of + Skipped -> pure () + Passed n -> note_ $ "OK " <> (if n <= 1 then msgs' else "(" <> show' n <> ") " <> msgs') + Failed -> note_ $ "FAILED " <> msgs' + let line = "------------------------------------------------------------" + note_ "Raw test output to follow ... " + note_ line + result <- try (runReaderT (void t) (Env rngVar [] resultsQ note_ allowed)) + :: IO (Either SomeException ()) + case result of + Left e -> note_ $ "Exception while running tests: " <> show' e + Right () -> pure () + atomically $ writeTBQueue resultsQ Nothing + _ <- A.waitCatch rs + resultsMap <- readTVarIO results + let + resultsList = Map.toList resultsMap + succeededList = [ n | (_, Passed n) <- resultsList ] + succeeded = length succeededList + -- totalTestCases = foldl' (+) 0 succeededList + failures = [ a | (a, Failed) <- resultsList ] + failed = length failures + case failures of + [] -> do + note_ line + case succeeded of + 0 -> do + note_ $ T.unlines + [ "😶 hmm ... no test results recorded" + , "Tip: use `ok`, `expect`, or `crash` to record results" + , "Tip: if running via `runOnly` or `rerunOnly`, check for typos" + ] + 1 -> note_ "✅ 1 test passed, no failures! 👍 🎉" + _ -> note_ $ "✅ " <> show' succeeded <> " tests passed, no failures! 👍 🎉" + hd:_ -> do + note_ $ T.unlines + [ line + , "\n" + , " " <> show' succeeded <> (if failed == 0 then " PASSED" else " passed") + , " " <> show' (length failures) <> (if failed == 0 then " failed" else " FAILED (failed scopes below)") + , " " <> T.intercalate "\n " (map show' failures) + , "" + , " To rerun with same random seed:\n" + , " EasyTest.rerun " <> show' seed + , " EasyTest.rerunOnly " <> show' seed <> " " <> "\"" <> hd <> "\"" + , "\n" + , line + , "❌" + ] + exitWith (ExitFailure 1) + +-- TODO: replace with show-text? +show' :: Show a => a -> Text +show' = T.pack . show + +-- | Log a showable value +note' :: Show s => s -> Test () +note' = note . show' + +-- | Record a successful test at the current scope +ok :: Test () +ok = Test (Just <$> putResult (Passed 1)) + +-- | Explicitly skip this test +skip :: Test () +skip = Test (Nothing <$ putResult Skipped) + +-- | Run a test in a separate thread, not blocking for its result. +fork :: Test a -> Test () +fork t = void (fork' t) + +-- | Run a test in a separate thread, return a future which can be used +-- to block on its result. +fork' :: Test a -> Test (Test a) +fork' (Test t) = do + env <- ask + tmvar <- liftIO newEmptyTMVarIO + liftIO . atomically $ writeTBQueue (envResults env) (Just tmvar) + r <- liftIO . A.async $ runWrap env t + waiter <- liftIO . A.async $ do + e <- A.waitCatch r + _ <- atomically $ tryPutTMVar tmvar (envMessages env, Skipped) + case e of + Left _ -> pure Nothing + Right a -> pure a + pure $ do + a <- liftIO (A.wait waiter) + case a of Nothing -> empty + Just a' -> pure a' diff --git a/tests/Suite.hs b/tests/Suite.hs new file mode 100644 --- /dev/null +++ b/tests/Suite.hs @@ -0,0 +1,38 @@ +{-# language OverloadedStrings #-} +module Main where + +import EasyTest +import Control.Monad + +suite1 :: Test () +suite1 = tests + [ scope "a" ok + , scope "b.c" ok + , scope "b" ok + , scope "b" . scope "c" . scope "d" $ ok + + -- you can also drop the "scope" + , "c" ok + ] + +reverseTest :: Test () +reverseTest = scope "list reversal" $ do + lists <- listsOf [0..100] (int' 0 99) + forM_ lists $ \nums -> expect (reverse (reverse nums) == nums) + +main :: IO () +main = do + run suite1 + runOnly "a" suite1 + runOnly "b" suite1 + runOnly "b" $ tests [suite1, scope "xyz" (crash "never run")] + runOnly "b.c" $ tests [suite1, scope "b" (crash "never run")] + runOnly "x.go" $ tests + [ scope "x.go to" (crash "never run") + , scope "x.go" ok + ] + runOnly "x.go to" $ tests + [ scope "x.go to" ok + , scope "x.go" (crash "never run") + ] + run reverseTest