new testing library

stack.yaml

@@ -2,6 +2,7 @@ flags: {}
 
 packages:
 - yaks/parsec-layout
+- yaks/easytest
 - shared
 - node
 

yaks/easytest/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.

yaks/easytest/README.markdown

@@ -0,0 +1,41 @@
+EasyTest is a simple testing toolkit, meant to replace QuickCheck, SmallCheck, HUnit, Tasty, etc. Here's an example usage:
+
+```Haskell
+import EasyTest
+import Control.Monad
+import Control.Applicative
+
+main = runOnly "addition" $ do
+  expect (1 + 1 == 2)
+  fork $ do
+    ns <- [0..10] `forM` \n -> replicateM n (randomBetween (0 :: Int, 10))
+    ns `forM_` \ns -> expect (reverse (reverse ns) == ns)
+  scope "addition" $ 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!!"
+```
+
+The library is simple: you just write ordinary Haskell code in the `Test` monad, which has access to:
+
+* random numbers (the `random` and `randomBetween` functions)
+* I/O (via `liftIO`)
+* failure (via `crash`)
+* logging (via `note` or `noteScoped`)
+* hierarchically-named subcomputations which can be switched on and off (in the above code, only the `"addition"`-scoped test would be run, and we could do `run` instead if we wanted to run the whole suite)
+* parallelism (note the `fork` which runs that subtree of the test suite in a parallel thread).
+
+`Test` is an instance of everything through `MonadPlus` (the `<|>` operation runs both tests, even if the first test fails). You assemble `Test` values into a test suite 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!
+
+This library is opinionated and might not be for everyone. But here's some of my thinking in writing it:
+
+* Testing should uncomplicated, minimal friction, and ideally: FUN.
+* A lot of testing frameworks are weirdly optimized for adding lots of diagnostic information up front, as if just whatever diagnostic information you happen to think to capture will magically allow you to fix whatever bugs your tests reveal. EastTest takes the opposite approach: be lazy about adding diagnostics and labeling subexpressions, but make it trivial to reproduce failing tests without running your entire suite. If a test fails, you can easily rerun just that test, with the same random seed, and add whatever diagnostics or print statements you need to track down what's wrong.
+* Another reason not to add diagnostics up front: you avoid needing to remember two different versions of every function or operator (the one you use in your regular code, and the one you use with your testing "framework" to supply diagnostics). HUnit has operators named `(@=?)`, `(~?=)`, and a bunch of others for asserting equality with diagnostics on failure. QuickCheck has `(.&&.)` and `(.||.)`. Just... no.
+* HUnit, QuickCheck, SmallCheck, Tasty, and whatever else are frameworks that hide control flow from the programmer and make some forms of control flow difficult or impossible to specify (for instance, you can't do I/O in your QuickCheck tests!). In contrast, EasyTest is just a single data type with a monadic API and a few helper functions. You assemble your tests using ordinary monadic code, and there is never any magic. Want to abstract over something? _Write a regular function._ Need to generate some testing data? Write regular functions.
+* "How do I modify the number of generated test cases for QuickCheck for just one of my properties?" Or control the maximum size for these `Gen` and `Arbitrary` types? Some arbitrary "configuration setting" that you have to look up every time.
+* Global configuration settings are evil. I want fine-grained control over the amount of parallelism, test case sizes, and so on.
+* Most of the functionality of QuickCheck is overkill anyway! There's no need for `Arbitrary` instances (explicit generation is totally fine, and even preferred in most cases), `Coarbitrary` (cute, but not useful when the HOF you are testing is parametric), or shrinking (just generate your test cases in increasing sizes, and your first failure will be the smallest).
+
+I hope that you enjoy the library and that it proves useful.

yaks/easytest/easytest.cabal

@@ -0,0 +1,62 @@
+name:          easytest
+category:      Compiler
+version:       0.1
+license:       MIT
+cabal-version: >= 1.8
+license-file:  LICENSE
+author:        Paul Chiusano
+maintainer:    Paul Chiusano <paul.chiusano@gmail.com>
+stability:     provisional
+homepage:      http://unisonweb.org
+bug-reports:   https://github.com/unisonweb/unison/issues
+copyright:     Copyright (C) 2016 Paul Chiusano and contributors
+synopsis:      Simple, expressive testing library
+
+build-type:    Simple
+extra-source-files:
+data-files:
+
+source-repository head
+  type: git
+  location: git://github.com/unisonweb/unison.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
+
+  -- 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
+
+  ghc-options: -Wall -fno-warn-name-shadowing
+
+  if flag(optimized)
+    ghc-options: -funbox-strict-fields -O2
+
+  if flag(quiet)
+    ghc-options: -v0
+
+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:
+    easytest

yaks/easytest/src/EasyTest.hs

@@ -0,0 +1,264 @@
+{-# Language BangPatterns #-}
+{-# Language FunctionalDependencies #-}
+{-# Language GeneralizedNewtypeDeriving #-}
+
+module EasyTest (Test, crash, currentScope, noteScoped, skip, ok, fork, fork', scope, note, expect, tests, random, randomBetween, run', runOnly, run, rerun, rerunOnly, parseMessages, module Control.Monad.IO.Class) 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.List
+import GHC.Stack
+import qualified System.Random as Random
+import System.Random (Random)
+import System.Exit
+import qualified Control.Concurrent.Async as A
+import qualified Data.Map as Map
+
+data Status = Failed | Passed | Skipped
+
+combineStatus :: Status -> Status -> Status
+combineStatus Skipped s = s
+combineStatus s Skipped = s
+combineStatus Failed _ = Failed
+combineStatus _ Failed = Failed
+combineStatus Passed Passed = Passed
+
+data Env =
+  Env { rng :: TVar Random.StdGen
+      , messages :: [String]
+      , results :: TQueue (Maybe (TMVar ([String], Status)))
+      , note_ :: String -> IO ()
+      , allow :: [String] }
+
+newtype Test a = Test (ReaderT Env IO (Maybe a))
+
+atomicLogger :: IO (String -> IO ())
+atomicLogger = do
+  lock <- newMVar ()
+  pure $ \msg -> bracket (takeMVar lock) (\_ -> putMVar lock ()) (\_ -> putStrLn msg)
+
+expect :: HasCallStack => Bool -> Test ()
+expect False = crash "unexpected"
+expect True = ok
+
+tests :: [Test ()] -> Test ()
+tests = msum
+
+runOnly :: String -> Test a -> IO ()
+runOnly allow t = do
+  logger <- atomicLogger
+  seed <- abs <$> Random.randomIO :: IO Int
+  run' seed logger (parseMessages allow) t
+
+rerunOnly :: Int -> String -> Test a -> IO ()
+rerunOnly seed allow t = do
+  logger <- atomicLogger
+  run' seed logger (parseMessages allow) t
+
+run :: Test a -> IO ()
+run = runOnly ""
+
+rerun :: Int -> Test a -> IO ()
+rerun seed = rerunOnly seed []
+
+run' :: Int -> (String -> IO ()) -> [String] -> Test a -> IO ()
+run' seed note allow (Test t) = do
+  let !rng = Random.mkStdGen seed
+  resultsQ <- atomically newTQueue
+  rngVar <- newTVarIO rng
+  note $ "Random number generation (RNG) state 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 $ readTQueue resultsQ
+    (msgs, passed) <- atomically $ takeTMVar result
+    atomically $ modifyTVar results (Map.insertWith combineStatus msgs passed)
+    case passed of
+      Skipped -> pure ()
+      Passed -> note $ "OK " ++ showMessages msgs
+      Failed -> note $ "FAILED " ++ showMessages msgs
+  let line = "------------------------------------------------------------"
+  note "Raw test output to follow ... "
+  note line
+  e <- try (runReaderT (void t) (Env rngVar [] resultsQ note allow)) :: IO (Either SomeException ())
+  case e of
+    Left e -> note $ "Exception while running tests: " ++ show e
+    Right () -> note $ "Waiting for any asynchronously spawned tests to complete ..."
+  atomically $ writeTQueue resultsQ Nothing
+  _ <- A.waitCatch rs
+  note line
+  note "\n"
+  resultsMap <- readTVarIO results
+  let
+    resultsList = Map.toList resultsMap
+    succeeded = length [ a | a@(_, Passed) <- resultsList ]
+    failures = [ a | (a, Failed) <- resultsList ]
+    failed = length failures
+  note $ "  " ++ show succeeded ++ (if failed == 0 then " PASSED" else " passed")
+  note $ "  " ++ show (length failures) ++ (if failed == 0 then " failed" else " FAILED (failed scopes below)")
+  case failures of
+    [] -> do
+      note "\n"
+      note line
+      note "✅  all tests passed! 👍 🎉"
+    (hd:_) -> do
+      note $ "    " ++ intercalate "\n    " (map showMessages failures)
+      note ""
+      note $ "  To rerun with same random seed:\n"
+      note $ "    EasyTest.rerun " ++ show seed
+      note $ "    EasyTest.rerunOnly " ++ show seed ++ " " ++ "\"" ++ showMessages hd ++ "\""
+      note "\n"
+      note line
+      note "❌"
+      exitWith (ExitFailure 1)
+
+showMessages :: [String] -> String
+showMessages = intercalate "." . reverse
+
+parseMessages :: String -> [String]
+parseMessages s = reverse (go s) where
+  go "" = []
+  go s = case span (/= '.') s of
+    (hd, tl) -> hd : go (drop 1 tl)
+
+scope :: String -> Test a -> Test a
+scope msg (Test t) = Test $ do
+  env <- ask
+  let messages' = msg : messages env
+      dropRight1 [] = []
+      dropRight1 xs = init xs
+  case (null (allow env) || [msg] `isSuffixOf` allow env) of
+    False -> putResult Skipped >> pure Nothing
+    True -> liftIO $ runReaderT t (env { messages = messages', allow = dropRight1 (allow env) })
+
+note :: String -> Test ()
+note msg = do
+  note_ <- asks note_
+  liftIO $ note_ msg
+  pure ()
+
+random :: Random a => Test a
+random = do
+  rng <- asks rng
+  liftIO . atomically $ do
+    rng0 <- readTVar rng
+    let (a, rng1) = Random.random rng0
+    writeTVar rng rng1
+    pure a
+
+randomBetween :: Random a => (a,a) -> Test a
+randomBetween bounds = do
+  rng <- asks rng
+  liftIO . atomically $ do
+    rng0 <- readTVar rng
+    let (a, rng1) = Random.randomR bounds rng0
+    writeTVar rng rng1
+    pure a
+
+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
+  e <- liftIO . try $ runReaderT t env
+  case e of
+    Left e -> do
+      note_ env (showMessages (messages env) ++ " EXCEPTION: " ++ show (e :: SomeException))
+      pure Nothing
+    Right a -> pure a
+
+currentScope :: Test String
+currentScope = do
+  msgs <- asks messages
+  pure (showMessages msgs)
+
+noteScoped :: String -> Test ()
+noteScoped msg = do
+  s <- currentScope
+  note (s ++ ": " ++ msg)
+
+ok :: Test ()
+ok = Test (Just <$> putResult Passed)
+
+skip :: Test ()
+skip = Test (Nothing <$ putResult Skipped)
+
+crash :: HasCallStack => String -> Test a
+crash msg = do
+  let trace = callStack
+      msg' = msg ++ " " ++ prettyCallStack trace
+  Test (Just <$> putResult Failed) >> noteScoped ("FAILURE " ++ msg') >> Test (pure Nothing)
+
+putResult :: Status -> ReaderT Env IO ()
+putResult passed = do
+  msgs <- asks messages
+  r <- liftIO . atomically $ newTMVar (msgs, passed)
+  q <- asks results
+  lift . atomically $ writeTQueue q (Just r)
+
+instance MonadReader Env Test where
+  ask = Test (Just <$> ask)
+  local f (Test t) = Test (local f t)
+  reader f = Test (Just <$> reader f)
+
+instance Monad Test where
+  fail = crash
+  return a = Test (pure (Just a))
+  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 io = wrap $ Test (Just <$> liftIO io)
+
+instance Alternative Test where
+  empty = Test (pure Nothing)
+  Test t1 <|> Test t2 = Test $ do
+    env <- ask
+    (rng1, rng2) <- liftIO . atomically $ do
+      currentRng <- readTVar (rng env)
+      let (rng1, rng2) = Random.split currentRng
+      (,) <$> newTVar rng1 <*> newTVar rng2
+    lift $ do
+      _ <- runWrap (env { rng = rng1 }) t1
+      runWrap (env { rng = rng2 }) t2
+
+instance MonadPlus Test where
+  mzero = empty
+  mplus = (<|>)
+
+fork :: Test a -> Test ()
+fork t = void (fork' t)
+
+fork' :: Test a -> Test (Test a)
+fork' (Test t) = do
+  env <- ask
+  tmvar <- liftIO newEmptyTMVarIO
+  liftIO . atomically $ writeTQueue (results env) (Just tmvar)
+  r <- liftIO . A.async $ runWrap env t
+  waiter <- liftIO . A.async $ do
+    e <- A.waitCatch r
+    _ <- atomically $ tryPutTMVar tmvar (messages 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