easytest-0.2.1/0000755000000000000000000000000000000000000011502 5ustar0000000000000000easytest-0.2.1/CHANGES.md0000755000000000000000000000247300000000000013105 0ustar0000000000000000## 0.2.1 (10/24/2018) * [Fix build errors for GHC 8.6](https://github.com/joelburget/easytest/commit/9bb30ec16671c0ec74835a52290b6508143a368f), [prevent building on GHC before 7.10](https://github.com/joelburget/easytest/pull/15/commits/f6d0ac50fa5a351a30b576567306121d67c0973a) * [Only print emojis for Unicode-capable terminals](https://github.com/joelburget/easytest/commit/e3f12612df46a6367693fd4ad47eedf91c35a079) ## 0.2 (3/27/2018) * [`expectRight` now shows `Left`s. `expectRightNoShow` replicates the old functionality.](https://github.com/joelburget/easytest/commit/c2d5dccc97dcdb925ebc39c36fcde9ff8d894f77) * [Call stacks now longer show EasyTest porcelain.](https://github.com/joelburget/easytest/commit/0b7064915a5b9c9de0115ebb6fc2fa49b2c4776e) * [`expectJust` and `expectRight` now return unit](https://github.com/joelburget/easytest/commit/ef5d4e9fd03c1008c810ee09a4f4c459d4e26bdb) ## 0.1.1 (3/25/2018) * [Add ghc 7.10.3 compatibility.](https://github.com/joelburget/easytest/commit/4acfad507cefc3fb2c0d588f1fbe0e4d583a762d) * [allow async 2.2, ghc 8.4 compatibility](https://github.com/joelburget/easytest/commit/6c20c18988dd756d8088c9d0318b597be15c9229) * [build with latest stackage nightly](https://github.com/joelburget/easytest/commit/2ea7f7520b39ac74b576414e4e1df75f596ed7b4) ## 0.1 (3/6/2018) Initial release. easytest-0.2.1/LICENSE0000644000000000000000000000204200000000000012505 0ustar0000000000000000Copyright (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. easytest-0.2.1/easytest.cabal0000644000000000000000000000723600000000000014337 0ustar0000000000000000name: easytest category: Testing version: 0.2.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: CHANGES.md data-files: tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.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.3, base >= 4.8 && <= 5, mtl >= 2.0.1 && < 2.3, containers >= 0.4.0 && < 0.7, stm >= 2.4 && < 3, random >= 1.1 && < 2, text >= 1.2 && < 1.3, transformers >= 0.4.2, call-stack >= 0.1 if !impl(ghc >= 8.0) build-depends: semigroups == 0.18.* 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 easytest-0.2.1/src/0000755000000000000000000000000000000000000012271 5ustar0000000000000000easytest-0.2.1/src/EasyTest.hs0000644000000000000000000002441300000000000014372 0ustar0000000000000000{-| 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 easytest-0.2.1/src/EasyTest/0000755000000000000000000000000000000000000014032 5ustar0000000000000000easytest-0.2.1/src/EasyTest/Generators.hs0000644000000000000000000000675200000000000016511 0ustar0000000000000000{-# 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.Maybe ( fromJust ) 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) a <- pure (ind i) pure (fromJust a) -- TODO: fromJust is not a total function 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 easytest-0.2.1/src/EasyTest/Internal.hs0000644000000000000000000001513000000000000016142 0ustar0000000000000000{-# language BangPatterns #-} {-# language CPP #-} {-# language FlexibleContexts #-} {-# 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) #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup #endif import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as T import GHC.Exts (fromList, toList) #if MIN_VERSION_base(4,9,0) import GHC.Stack #else import Data.CallStack #endif 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 #if !MIN_VERSION_base(4,11,0) -- This is redudant starting with base-4.11 / GHC 8.4. mappend = combineStatus #endif 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)) #if !MIN_VERSION_base(4,9,0) prettyCallStack :: CallStack -> String prettyCallStack = show #endif -- | Record a failure at the current scope crash :: HasCallStack => Text -> Test a crash msg = do let trace = callStack trace' = fromList $ filter (\(_msg, loc) -> srcLocFile loc /= "src/EasyTest/Porcelain.hs") $ toList trace 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) easytest-0.2.1/src/EasyTest/Porcelain.hs0000644000000000000000000001700100000000000016301 0ustar0000000000000000{-# language BangPatterns #-} {-# language CPP #-} {-# language FlexibleContexts #-} {-# language OverloadedStrings #-} module EasyTest.Porcelain ( -- * Tests Test , expect , expectJust , expectRight , expectRightNoShow , expectLeft , expectLeftNoShow , 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 #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup #endif import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.CallStack import System.Exit import System.IO 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 () expectJust Nothing = crash "expected Just, got Nothing" expectJust (Just _) = ok expectRight :: (Show e, HasCallStack) => Either e a -> Test () expectRight (Left e) = crash $ "expected Right, got (Left " <> T.pack (show e) <> ")" expectRight (Right _) = ok expectRightNoShow :: HasCallStack => Either e a -> Test () expectRightNoShow (Left _) = crash $ "expected Right, got Left" expectRightNoShow (Right _) = ok expectLeft :: (Show a, HasCallStack) => Either e a -> Test () expectLeft (Right a) = crash $ "expected Left, got (Right " <> T.pack (show a) <> ")" expectLeft (Left _) = ok expectLeftNoShow :: HasCallStack => Either e a -> Test () expectLeftNoShow (Right _) = crash $ "expected Left, got Right" expectLeftNoShow (Left _) = ok 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 $ sanitize msg) sanitize :: Text -> Text sanitize msg = if isUnicodeLocale then msg else T.replace "✅" "!" . T.replace "❌" "X" . T.replace "😶" ":/" . T.replace "👍" ":D" . T.replace "🎉" ":P" $ msg isUnicodeLocale :: Bool isUnicodeLocale = elem (show localeEncoding) $ map show [utf8, utf8_bom, utf16, utf16le, utf16be, utf32, utf32le, utf32be] -- | 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' easytest-0.2.1/tests/0000755000000000000000000000000000000000000012644 5ustar0000000000000000easytest-0.2.1/tests/Suite.hs0000644000000000000000000000210200000000000014264 0ustar0000000000000000{-# 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 run $ tests [ expectLeft (Left 1 :: Either Int ()) , expectLeftNoShow (Left 2 :: Either Int ()) , expectRight (Right () :: Either Int ()) , expectRightNoShow (Right () :: Either Int ()) ]