[darcs-users] darcs patch: Add Test.Runner module to run the unit t... (and 5 more)
Jason Dagit
dagit at codersbase.com
Wed May 13 17:05:25 UTC 2009
On Tue, May 12, 2009 at 2:51 PM, Eric Kow <kowey at darcs.net> wrote:
> Hi Jason,
>
> Is there any chance I could reactivate you as part of the review team?
> or if not, if you would be interested in reviewing this bundle? I'm
> aware that things are a bit busy on your end though, so forgive me
> if I'm asking too much :-)
How about we compromise on a partial review now instead of a full review
later :) I don't want to give you an unconditional "No", but I'm also not
ready to come back to darcs dev in full force yet. I'm still healing from
the near burnout that resulted from finishing up my degree.
On Tue, May 12, 2009 at 17:59:07 +0200, Reinier Lamers wrote:
> > Hi all,
> >
> > Here's a bundle of unit test stuff I've done since the sprint. It's about
> > creating a unified API for running darcs' tests. It is my intention to
> spin
> > off this test running API to hackage. Therefore, I've used the Test top
> > level module instead of Darcs.
>
Reinier, that sounds like a nice goal. Grow the framework out of the
existing usage and then farm it off to a separate library.
>
> >
> > What it does now:
> > * Run tests in parallel. For running with $i threads, use the command
> > "dist/build/unit/unit -j $i +RTS -N$i"
> >
> > Todos:
> > * Move logic in the main function to Test.Runner
> > * Add possibility to select tests to run with command line flags (I'm
> > thinking of using regexps matchin test names)
> > * Add possibility to replay quickcheck test using the seed and size
> > reported upon failure.
> >
> > I can't use my right arm now because I broke my collar bone :-(. Thus
> > progress is slow and I'm sending what I have. I can attack the code full
> > force again in a few weeks, if all goes well.
>
Yikes! Hmm...do we need to take out an insurance policy on our devs? ;)
>
> > Tue Apr 28 22:04:50 CEST 2009 Reinier Lamers <tux_rocker at reinier.de>
> > * Add Test.Runner module to run the unit tests
> >
> > This module will provide things like running the unit tests in parallel
> and
> > producing a report of the entire test run. I hope it can be split off
> into a
> > separate package in the not-too-distant future.
> >
> >
> > Tue Apr 28 22:09:43 CEST 2009 Reinier Lamers <tux_rocker at reinier.de>
> > * Refactor unit.lhs to use Test.Runner
> >
> > Thu Apr 30 00:44:25 CEST 2009 Reinier Lamers <tux_rocker at reinier.de>
> > * Make Test.Runner capable of tracking failure reasons
> >
> > Thu Apr 30 20:57:29 CEST 2009 Reinier Lamers <tux_rocker at reinier.de>
> > * Make Darcs.Patch.Unit use Test.Runner
> >
> > This includes a semantic change: unit testing no longer stops after the
> patch
> > unit tests if one of those fails. I can't see a reason why that would
> be very
> > bad.
>
Sometimes tests depend on other tests so it may be useful to have a way to
abort? Some testing frameworks allow you to organize your tests into suites
and other groupings where some failures allow the testing to continue and
others cause that logical unit to abort. CPP Unit has this and I think
boost's unit test framework also allows it. Have you looked at the HUnit
framework? You may be reinventing the wheel.
>
> >
> > Fri May 8 23:45:44 CEST 2009 Reinier Lamers <tux_rocker at reinier.de>
> > * Add command line options for unit to set no. of threads
> >
> > Tue May 12 17:47:53 CEST 2009 Reinier Lamers <tux_rocker at reinier.de>
> > * Give enough information to reproduce failing Quickcheck tests
> >
>
> Add Test.Runner module to run the unit tests
> --------------------------------------------
> > Reinier Lamers <tux_rocker at reinier.de>**20090428200450
> > Ignore-this: e2bc2b5d775fa95eaeadd283e2f6dfe7
> >
> > This module will provide things like running the unit tests in parallel
> and
> > producing a report of the entire test run. I hope it can be split off
> into a
> > separate package in the not-too-distant future.
> >
> > ] hunk ./darcs.cabal 564
> > parsec >= 2.0 && < 3.1,
> > html == 1.0.*,
> > filepath == 1.1.*,
> > - QuickCheck >= 2.1.0.0
> > + QuickCheck >= 2.1.0.0,
> > + stm
> >
> >
> > if !flag(zlib)
> > hunk ./darcs.cabal 642
> > RankNTypes,
> > GeneralizedNewtypeDeriving,
> > MultiParamTypeClasses
> > + OverlappingInstances
> > + IncoherentInstances
I'm mostly okay with overlapping instances, but incoherent instances worries
me. I haven't looked far enough to know why they are there, but well, I'm a
bit uncomfortable with it :( (hint: Give me a reason to be comfortable.)
Would it be possible to use fundeps instead? Could you point me at some
reference as that explains your usage is safe? Also, where do you use it?
>
> > adddir ./src/Test
> > addfile ./src/Test/Runner.hs
> > hunk ./src/Test/Runner.hs 1
> > +-- Copyright (C) 2009 Reinier Lamers
> > +--
> > +-- This program is free software; you can redistribute it and/or modify
> > +-- it under the terms of the GNU General Public License as published by
> > +-- the Free Software Foundation; either version 2, or (at your option)
> > +-- any later version.
> > +--
> > +-- This program is distributed in the hope that it will be useful,
> > +-- but WITHOUT ANY WARRANTY; without even the implied warranty of
> > +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
> > +-- GNU General Public License for more details.
> > +--
> > +-- You should have received a copy of the GNU General Public License
> > +-- along with this program; see the file COPYING. If not, write to
> > +-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
> > +-- Boston, MA 02110-1301, USA.
> > +
> > +-- | Test.Runner contains utility functions for running tests, like
> running
> > +-- them in parallel.
> > +module Test.Runner ( runTests, runTestsParallel, Result(..),
> > + TestRunnerTest(..), RunnableTest(..) ) where
> > +
> > +import qualified Test.QuickCheck as QC ( Testable(..), quickCheckResult,
> > + Result(..) )
> > +import Control.Concurrent ( forkIO )
> > +import Control.Concurrent.STM ( newTVar, readTVar, writeTVar,
> atomically,
> > + retry, TVar )
> > +
> > +-- * Classes and types for tests
> > +
> > +class RunnableTest a where
> > + run :: a -> IO Bool
> > +
> > +-- | Any @IO@ action that returns @True@ upon success and @False@ upon
> failure
> > +-- can be treated as a test by testrunner.
> > +instance RunnableTest (IO Bool) where
> > + run = id
> > +
> > +-- | QuickCheck properties can be run by testrunner.
> > +-- You do lose a lot of information on the result though; only whether
> the
> > +-- test succeeded or not is returned.
Perhaps it would be better to use a type class for the result of a
RunnableTest. For example, instead of IO Bool, it could be (this is
untested, just thinking outloud about future improvements):
class TestResult a where
-- Put some thing here based on how you use test results
instance TestResult Bool where
instance QC.TestResult where -- not sure what the type of a quick check is,
so I call it QC.TestResult
class RunnableTest a where
run :: (MonadIO m, TestResult r) => a -> m r
This would allow us the freedom at a later date to replace IO with some
other IO-like monad that does other stuff like logging or simulates a
particular machine state or whatever you can imagine. Also, by making test
result polymorphic we may be able to make the result have more rich
information. Some of the things to consider:
1) Is it better to put the "rich" information into the MonadIO instance or
is it better to store it in the return type?
2) If we create an instance of TestResult for Bool and quickcheck results
then what is the lowest common denominator? Can we actually make both
instances useful?
> > +--
> > +-- Note that this also provides a @RunnableTest@ instance for @Bool at .
> > +instance (QC.Testable a) => RunnableTest a where
> > + run t = do
> > + r <- QC.quickCheckResult t
> > + return $ case r of
> > + QC.Failure _ _ _ _ -> False
> > + _ -> True
> > +
> > +-- | A TestRunnerTest is a data type that hides the actual type of the
> test -
> > +-- QuickCheck, plain IO action, or any other RunnableTest. This is
> required to
> > +-- be able to put tests of different types in a single list.
> > +data TestRunnerTest where
> > + TestRunnerTest :: (RunnableTest a) => a -> TestRunnerTest
Here you may want to consider making all tests be instances of some monad,
say MonadIO instances. Or make your data type a MonadIO instance. I have a
bit of trouble justifying this, but I think as you work with it you'll see
why. Otherwise, looks like a use of existential types here with a type
class constraint in the GADT and I have no complaints with the code itself.
I keep talking about doing something more general, but it is certainly
valuable to code up something that works now instead of thinking about the
most general way from the start.
>
> > +
> > +-- * Running tests
> > +-- | Shows a name, runs the test, and then shows whether it failed or
> not by
> > +-- printing either "OK" or "FAIL!" to standard output.
> > +run_showing_name :: (String, TestRunnerTest) -> IO Bool
> > +run_showing_name (name, TestRunnerTest t) = do
> > + putStr name
> > + r <- run t
> > + putStrLn (if r then "OK" else "FAIL!")
> > + return r
Seems straightforward. My brain naturally wants to think of clever one
liners, but that's more of a fun puzzle -- I don't think maintainable code
is composed of clever one liners!
>
> > +
> > +
> > +-- | The result of the test runner mentions how many tests passed, and
> the names
> > +-- and number of the tests that failed.
> > +data Result = Result { numPassed :: Int
> > + , failedNames :: [String]
> > + }
> > +
Nice use of a record.
>
> > +-- | Run a list of named tests.
> > +runTests :: [(String, TestRunnerTest)] -> IO Result
> > +runTests namedTests = do
> > + results <- mapM run_showing_name namedTests
> > + let namedResults = zip names results
> > + passed = length (filter (==True) results)
> > + failed = map fst $ filter (not . snd) namedResults
> > + return (Result passed failed)
> > + where (names, _) = unzip namedTests
Looks good.
>
> > +
> > +-- * Running tests in parallel
> > +
> > +data RunnerState = RunnerState { testsToDo :: [(String, TestRunnerTest)]
> > + , passedTests :: [String]
> > + , failedTests :: [String]
> > + , numDone :: Int
> > + }
> > +
> > +-- | Creates an initial test runner state given the list of named tests
> > +initial_runner_state :: [(String, TestRunnerTest)] -> RunnerState
> > +initial_runner_state ts = RunnerState ts [] [] 0
I'm partial to the style of naming like, mkFoo, for functions that construct
records:
mkRunnerState :: [(String, TestRunnerTest)] -> RunnerState
I haven't yet seen another function in your patch that uses underscores, so
even this would be preferrable to me, initialRunnerState. This is a minor
nitpick and I wouldn't want to halt the acceptance of these patches on this
item.
>
> > +
> > +-- | Uses multiple threads to run a set of unit tests.
> > +runTestsParallel :: Int -- ^ Number of worker threads to use
> > + -> [(String, TestRunnerTest)] -- ^ The tests with their
> names
> > + -> IO Result
Yay! Haddock.
>
> > +runTestsParallel n namedTests = do
> > + let numToDo = length namedTests
> > + stateRef <- atomically (newTVar (initial_runner_state namedTests))
> > + sequence_ (replicate n (forkIO (test_runner_thread stateRef)))
> > + -- now wait until the threads have completed
> > + atomically $ do
> > + state <- readTVar stateRef
> > + if numDone state == numToDo
> > + then return $ Result (length (passedTests state)) (failedTests
> state)
> > + else retry
I don't feel like I can comment on the above. I have too little experience
with Haskell threading.
>
> > +
> > +-- | The main loop of a worker thread when doing a parallel run
> > +test_runner_thread :: TVar RunnerState -> IO ()
> > +test_runner_thread stateRef = do
> > + nextTest <- getNextTest
> > + case nextTest of
> > + Just t -> run_one_test stateRef t >> test_runner_thread stateRef
> > + Nothing -> return () -- ready
> > + where getNextTest = atomically $ do
> > + state <- readTVar stateRef
> > + let tests_to_do = testsToDo state
> > + case tests_to_do of
> > + doNow:doLater -> do writeTVar stateRef (state { testsToDo =
> doLater })
> > + return (Just doNow)
> > + [] -> return Nothing
> > +
> > +-- | Runs one test as a part of a parallel test run, and updates the
> global
> > +-- state after it's done.
> > +run_one_test :: TVar RunnerState -> (String, TestRunnerTest) -> IO ()
> > +run_one_test stateRef (name, TestRunnerTest t) = do
> > + passed <- run t
> > + putStrLn (name ++ ": " ++ (if passed then "OK" else "FAIL!"))
> > + atomically $ do
> > + state <- readTVar stateRef
> > + let state' = state { numDone = numDone state + 1 }
> > + state'' = if passed
> > + then state' { passedTests = name : passedTests
> state }
> > + else state' { failedTests = name : failedTests
> state }
> > + writeTVar stateRef state''
> > +
>
These last few functions use threading which I'm not comfortable reviewing,
and the identifiers seem to switch from camel case to underscores. Other
than that, I would look at what you do here with the test results and try to
figure out what could go into a TestResult type class if you make one.
>
> Refactor unit.lhs to use Test.Runner
> ------------------------------------
> > Reinier Lamers <tux_rocker at reinier.de>**20090428200943
> > Ignore-this: 171170a16f39c2519e99a05d1ddf4513
> > ] hunk ./src/unit.lhs 49
> >
> > module Main (main) where
> >
> > -import Control.Monad (when)
> > import System.IO.Unsafe ( unsafePerformIO )
> > import ByteStringUtils
> > import qualified Data.ByteString.Char8 as BC ( unpack, pack )
> > hunk ./src/unit.lhs 59
> > import Darcs.Patch.Test
> > import Darcs.Patch.Unit ( run_patch_unit_tests )
> > import Lcs ( shiftBoundaries )
> > -import Test.QuickCheck
> > +import Test.QuickCheck hiding ( Result(..) )
> > import System.Exit ( ExitCode(..), exitWith )
> > import System.IO ( hSetBuffering, stdout, BufferMode(..) )
> > hunk ./src/unit.lhs 62
> > -import Data.IORef ( IORef, newIORef, readIORef, modifyIORef )
> > import Printer ( renderPS, text )
> > import Darcs.Patch.Commute
> > import Data.Array.Base
> > hunk ./src/unit.lhs 70
> > import Darcs.Ordered
> > import Darcs.Sealed ( Sealed(Sealed), unsafeUnseal )
> > import Darcs.Email ( make_email, read_email, formatHeader )
> > +import Test.Runner ( TestRunnerTest(..), Result(..), RunnableTest(..),
> > + runTestsParallel )
> >
> > #include "impossible.h"
> > \end{code}
> > hunk ./src/unit.lhs 82
> > main :: IO ()
> > main = do
> > hSetBuffering stdout NoBuffering
> > - returnval <- newIORef 0
> > patch_failures <- run_patch_unit_tests
> > if patch_failures > 0
> > then do putStrLn $ show patch_failures ++ " failures in
> Darcs.Patch.Unit."
> > hunk ./src/unit.lhs 87
> > exitWith $ ExitFailure 1
> > else putStrLn "No failures in Darcs.Patch.Unit."
> > - when (unpackPSfromUTF8 (BC.pack "hello world") /= "hello world") $
> > - do putStr "Problem with unpackPSfromUTF8\n"
> > - putStr $ "hello world isn't '" ++
> > - unpackPSfromUTF8 (BC.pack "hello world")++"'\n"
> > - exitWith $ ExitFailure 1
> > - when (BC.unpack (fromHex2PS $ fromPS2Hex $ BC.pack "hello world")
> > - /= "hello world") $
> > - do putStr "Problem with binary to hex conversion and back
> again\n"
> > - exitWith $ ExitFailure 1
> > - putStr "Checking that email can be parsed... "
> > - quickCheck $ \s ->
> > - unlines ("":s++["", ""]) ==
> > - BC.unpack (read_email (renderPS
> > - $ make_email "reponame" [] (Just (text
> "contents\n"))
> > - (text $ unlines s) (Just "filename")))
> > - putStr "Checking email header line length... "
> > - quickCheck email_header_no_long_lines
> > - putStr "Checking email for illegal characters... "
> > - quickCheck email_header_ascii_chars
> > - putStr "Checking for spaces at beginning of folded email header
> lines... "
> > - quickCheck email_header_lines_start
> > - putStr "Checking that there are no empty lines in email headers... "
> > - quickCheck email_header_no_empty_lines
> > - --putStr $ test_patch
> > - --exitWith ExitSuccess
> > - case run_tests returnval of
> > - run -> do
> > - putStr ("There are a total of "++(show (length
> primitive_test_patches))
> > - ++" primitive patches.\n")
> > - putStr ("There are a total of "++
> > - (show (length test_patches))++" patches.\n")
> > - putStr "Checking that B.concat works... "
> > - runQuickCheckTest returnval prop_concatPS
> > - putStr "Checking that hex conversion works... "
> > - runQuickCheckTest returnval prop_hex_conversion
> > - putStr "Checking that show and read work right... "
> > - runQuickCheckTest returnval prop_read_show
> > - run "Checking known commutes... " commute_tests
> > - run "Checking known merges... " merge_tests
> > - run "Checking known canons... " canonization_tests
> > - check_subcommutes returnval subcommutes_inverse "patch and inverse
> both commutex"
> > - check_subcommutes returnval subcommutes_nontrivial_inverse
> > - "nontrivial commutes are correct"
> > - check_subcommutes returnval subcommutes_failure "inverses fail"
> > - putStr "Checking that commuting by patch and its inverse is ok...
> "
> > - runQuickCheckTest returnval prop_commute_inverse
> > - --putStr "Checking that conflict resolution is valid... "
> > - --runQuickCheckTest returnval prop_resolve_conflicts_valid
> > - putStr "Checking that a patch followed by its inverse is
> identity... "
> > - runQuickCheckTest returnval prop_patch_and_inverse_is_identity
> > - -- The following tests are "wrong" with the Conflictor code.
> > - --putStr "Checking that a simple smart_merge is sufficient... "
> > - --runQuickCheckTest returnval prop_simple_smart_merge_good_enough
> > - --putStr "Checking that an elegant merge is sufficient... "
> > - --runQuickCheckTest returnval prop_elegant_merge_good_enough
> > - putStr "Checking that commutes are equivalent... "
> > - runQuickCheckTest returnval prop_commute_equivalency
> > - putStr "Checking that merges are valid... "
> > - runQuickCheckTest returnval prop_merge_valid
> > - putStr "Checking inverses being valid... "
> > - runQuickCheckTest returnval prop_inverse_valid
> > - putStr "Checking other inverse being valid... "
> > - runQuickCheckTest returnval prop_other_inverse_valid
> > - run "Checking merge swaps... " merge_swap_tests
> > - -- The patch generator isn't smart enough to generate correct test
> > - -- cases for the following: (which will be obsoleted soon, anyhow)
> > - --putStr "Checking the order dependence of unravel... "
> > - --runQuickCheckTest returnval prop_unravel_order_independent
> > - --putStr "Checking the unravelling of three merges... "
> > - --runQuickCheckTest returnval prop_unravel_three_merge
> > - --putStr "Checking the unravelling of a merge of a sequence... "
> > - --runQuickCheckTest returnval prop_unravel_seq_merge
> > - putStr "Checking inverse of inverse... "
> > - runQuickCheckTest returnval prop_inverse_composition
> > - putStr "Checking the order of commutes... "
> > - runQuickCheckTest returnval prop_commute_either_order
> > - putStr "Checking commutex either way... "
> > - runQuickCheckTest returnval prop_commute_either_way
> > - putStr "Checking the double commutex... "
> > - runQuickCheckTest returnval prop_commute_twice
> > - putStr "Checking that merges commutex and are well behaved... "
> > - runQuickCheckTest returnval prop_merge_is_commutable_and_correct
> > - putStr "Checking that merges can be swapped... "
> > - runQuickCheckTest returnval prop_merge_is_swapable
> > - putStr "Checking again that merges can be swapped (I'm paranoid)
> ... "
> > - runQuickCheckTest returnval prop_merge_is_swapable
> > - run "Checking that the patch validation works... " test_check
> > - run "Checking commutex/recommute... " commute_recommute_tests
> > - run "Checking merge properties... " generic_merge_tests
> > - run "Testing the lcs code... " show_lcs_tests
> > - run "Checking primitive patch IO functions... "
> primitive_show_read_tests
> > - run "Checking IO functions... " show_read_tests
> > - run "Checking primitive commutex/recommute... "
> > - primitive_commute_recommute_tests
> > - trv <- readIORef returnval
> > - if trv == 0
> > - then exitWith ExitSuccess
> > - else exitWith $ ExitFailure trv
> > -\end{code}
> > -
> > -\section{run\_tests}
> > -
> > -run\_tests is used to run a series of tests (which return a list of
> strings
> > -describing their failures) and then update n IORef so the program can
> exit
> > -with an error if one of the tests failed.
> > + putStr ("There are a total of "++(show (length
> primitive_test_patches))
> > + ++" primitive patches.\n")
> > + putStr ("There are a total of "++
> > + (show (length test_patches))++" patches.\n")
> > + results <- runTestsParallel 2 tests
> > + putStrLn (show (numPassed results) ++ " tests passed. Failing tests:")
> > + mapM_ (putStrLn . (" "++)) (failedNames results)
> >
> > hunk ./src/unit.lhs 95
> > -\begin{code}
> > -run_tests :: (IORef Int) -> String -> [String] -> IO ()
> > -run_tests return_val s ss = do
> > - putStr s
> > - if null ss
> > - then putStr "good.\n"
> > - else do modifyIORef return_val (+1)
> > - print_strings ss
> > -
> > -runQuickCheckTest :: Testable prop => (IORef Int) -> prop -> IO ()
> > -runQuickCheckTest return_val prop = do
> > - res <- quickCheckResult prop
> > - case res of
> > - Success _ -> return ()
> > - _ -> modifyIORef return_val (+1)
> > +-- | This is the big list of tests that will be run using testrunner.
> > +tests :: [(String, TestRunnerTest)]
> > +tests = [("Checking that UTF-8 packing and unpacking preserves 'hello
> world'",
> > + TestRunnerTest $
> > + unpackPSfromUTF8 (BC.pack "hello world") == "hello world"),
> > + ("Checking that hex packing and unpacking preserves 'hello
> world'",
> > + TestRunnerTest $
> > + BC.unpack (fromHex2PS $ fromPS2Hex $ BC.pack "hello world")
> > + == "hello world"),
> > + ("Checking that email can be parsed... ",
> > + TestRunnerTest $ \s ->
> > + unlines ("":s++["", ""]) ==
> > + BC.unpack (read_email (renderPS
> > + $ make_email "reponame" [] (Just (text
> "contents\n"))
> > + (text $ unlines s) (Just
> "filename")))),
> > + ("Checking email header line length... ",
> > + TestRunnerTest email_header_no_long_lines),
> > + ("Checking email for illegal characters... ",
> > + TestRunnerTest email_header_ascii_chars),
> > + ("Checking for spaces at start of folded email header lines...
> ",
> > + TestRunnerTest email_header_lines_start),
> > + ("Checking that there are no empty lines in email headers... ",
> > + TestRunnerTest email_header_no_empty_lines),
> > + ("Checking that B.concat works... ",
> > + TestRunnerTest prop_concatPS),
> > + ("Checking that hex conversion works... ",
> > + TestRunnerTest prop_hex_conversion),
> > + ("Checking that show and read work right... ",
> > + TestRunnerTest prop_read_show),
> > + ("Checking known commutes... ", TestRunnerTest commute_tests),
> > + ("Checking known merges... ", TestRunnerTest merge_tests),
> > + ("Checking known canons... ", TestRunnerTest
> canonization_tests)] ++
> > + check_subcommutes subcommutes_inverse
> > + "patch and inverse both commutex" ++
> > + check_subcommutes subcommutes_nontrivial_inverse
> > + "nontrivial commutes are correct" ++
> > + check_subcommutes subcommutes_failure "inverses fail" ++
> > + [("Checking that commuting by patch and its inverse is ok... ",
> > + TestRunnerTest prop_commute_inverse),
> > + --putStr "Checking that conflict resolution is valid... "
> > + --runQuickCheckTest returnval prop_resolve_conflicts_valid
> > + ("Checking that a patch followed by its inverse is identity...
> ",
> > + TestRunnerTest prop_patch_and_inverse_is_identity),
> > + -- The following tests are "wrong" with the Conflictor code.
> > + --putStr "Checking that a simple smart_merge is sufficient... "
> > + --runQuickCheckTest returnval
> prop_simple_smart_merge_good_enough
> > + --putStr "Checking that an elegant merge is sufficient... "
> > + --runQuickCheckTest returnval prop_elegant_merge_good_enough
> > + ("Checking that commutes are equivalent... ",
> > + TestRunnerTest prop_commute_equivalency),
> > + ("Checking that merges are valid... ",
> > + TestRunnerTest prop_merge_valid),
> > + ("Checking inverses being valid... ",
> > + TestRunnerTest prop_inverse_valid),
> > + ("Checking other inverse being valid... ",
> > + TestRunnerTest prop_other_inverse_valid),
> > + ("Checking merge swaps... ", TestRunnerTest merge_swap_tests),
> > + -- The patch generator isn't smart enough to generate correct
> test
> > + -- cases for the following: (which will be obsoleted soon,
> anyhow)
> > + --putStr "Checking the order dependence of unravel... "
> > + --runQuickCheckTest returnval prop_unravel_order_independent
> > + --putStr "Checking the unravelling of three merges... "
> > + --runQuickCheckTest returnval prop_unravel_three_merge
> > + --putStr "Checking the unravelling of a merge of a sequence...
> "
> > + --runQuickCheckTest returnval prop_unravel_seq_merge
> > + ("Checking inverse of inverse... ",
> > + TestRunnerTest prop_inverse_composition),
> > + ("Checking the order of commutes... ",
> > + TestRunnerTest prop_commute_either_order),
> > + ("Checking commutex either way... ",
> > + TestRunnerTest prop_commute_either_way),
> > + ("Checking the double commutex... ",
> > + TestRunnerTest prop_commute_twice),
> > + ("Checking that merges commutex and are well behaved... ",
> > + TestRunnerTest prop_merge_is_commutable_and_correct),
> > + ("Checking that merges can be swapped... ",
> > + TestRunnerTest prop_merge_is_swapable),
> > + ("Checking again that merges can be swapped (I'm paranoid) ...
> ",
> > + TestRunnerTest prop_merge_is_swapable),
> > + ("Checking that the patch validation works... ",
> > + TestRunnerTest test_check),
> > + ("Checking commutex/recommute... ",
> > + TestRunnerTest commute_recommute_tests),
> > + ("Checking merge properties... ",
> > + TestRunnerTest generic_merge_tests),
> > + ("Testing the lcs code... ", TestRunnerTest show_lcs_tests),
> > + ("Checking primitive patch IO functions... ",
> > + TestRunnerTest primitive_show_read_tests),
> > + ("Checking IO functions... ",
> > + TestRunnerTest show_read_tests),
> > + ("Checking primitive commutex/recommute... ",
> > + TestRunnerTest primitive_commute_recommute_tests)
> > + ]
Looks like you took a bunch of code out of a monad and put it into a list so
it could be fed to your framework. Sounds reasonable. I do wonder how you
handle the removal of the putStrs in the middle.
>
> >
> > hunk ./src/unit.lhs 189
> > -print_strings :: [String] -> IO ()
> > -print_strings [] = return ()
> > -print_strings (s:ss) = do
> > - putStr s
> > - print_strings ss
> > +-- | This instance is required for some of the tests in this module. It
> seems
> > +-- non-standard usage to me, so I don't include it in testrunner.
> > +instance RunnableTest [String] where
> > + run [] = return True
> > + run ss = do
> > + putStrLn "A test failed! Failure information: "
> > + mapM_ putStrLn ss
> > + return False
> > \end{code}
Hmm...yes I agree with the comment. This does seem a little odd. It's as
if some tests return "Maybe String" where Nothing is success. What are your
plans to deal with this in the future? Refactor the tests that do this to
be more consistent?
> >
> > \chapter{Unit Tester}
> > hunk ./src/unit.lhs 232
> > -- (excluding the carriage return and line feed)
> > email_header_no_long_lines :: String -> String -> Bool
> > email_header_no_long_lines field value =
> > - not $ any (>78) $ map B.length $ bs_lines $ formatHeader cleanField
> value
> > + not $ any (>78) $ map B.length $ bs_lines $ formatHeader cleanField
> value
> > where cleanField = clean_field_string field
I can't tell how these lines differ so I'll assume its a whitespace change
and promptly move on :)
>
> >
> > bs_lines :: B.ByteString -> [B.ByteString]
> > hunk ./src/unit.lhs 245
> > -- formatHeader doesn't escape field names, there is no such thing as
> non-ascii
> > -- field names afaik
> > email_header_ascii_chars :: String -> String -> Bool
> > -email_header_ascii_chars field value
> > +email_header_ascii_chars field value
Same as above, I don't spot a difference so moving on.
>
> > = not (any (>127) (B.unpack (formatHeader cleanField value)))
> > where cleanField = clean_field_string field
> >
> > hunk ./src/unit.lhs 276
> > show_lcs_tests :: [String]
> > show_lcs_tests = concatMap check_known_shifts known_shifts
> > check_known_shifts :: ([Int],[Int],String,String,[Int],[Int])
> > - -> [String]
> > + -> [String]
Again, I don't see so moving on.
>
> > check_known_shifts (ca, cb, sa, sb, ca', cb') = runST (
> > do ca_arr <- newListArray (0, length ca) $ toBool (0:ca)
> > cb_arr <- newListArray (0, length cb) $ toBool (0:cb)
> > hunk ./src/unit.lhs 843
> > prop_concatPS :: [String] -> Bool
> > prop_concatPS ss = concat ss == BC.unpack (B.concat $ map BC.pack ss)
> >
> > -check_subcommutes :: Testable a => IORef Int -> [(String, a)] -> String
> -> IO ()
> > -check_subcommutes _ [] _ = return ()
> > -check_subcommutes returnVal ((n,c):r) expl =
> > - do putStr $ "Checking " ++ expl ++ " for subcommute " ++ n ++ "... "
> > - runQuickCheckTest returnVal c
> > - check_subcommutes returnVal r expl
> > +-- | Groups a set of tests by giving them the same prefix in their
> description.
> > +-- When this is called as @check_subcommutes subcoms expl@, the
> prefix for a
> > +-- test becomes @"Checking " ++ expl ++ " for subcommute "@.
Yay haddocks!
>
> > +check_subcommutes :: Testable a => [(String, a)] -> String
> > + -> [(String,
> TestRunnerTest)]
> > +check_subcommutes subcoms expl = map check_subcommute subcoms
> > + where check_subcommute (name, test) = ("Checking " ++ expl
> > + ++ " for subcommute " ++ name
> > + ++ "... "
> > + ,TestRunnerTest test)
> > \end{code}
> >
> > \end{document}
I guess this is equivalent, but I don't see it immediately. Oh, I think I
get it. Before there was an explicit recursion and you realized you could
replace that with a map. Although, the previous way was threading returnVal
through the calls. Do you have a justification for why you are able to
remove that? I think I can see how it is no longer important.
>
> Make Test.Runner capable of tracking failure reasons
> ----------------------------------------------------
> > Reinier Lamers <tux_rocker at reinier.de>**20090429224425
> > Ignore-this: 58e8f597551a03fd2a314b9c49836340
> > ] hunk ./src/Test/Runner.hs 2
> > -- Copyright (C) 2009 Reinier Lamers
> > ---
> > +--
> > -- This program is free software; you can redistribute it and/or modify
> > -- it under the terms of the GNU General Public License as published by
> > -- the Free Software Foundation; either version 2, or (at your option)
> > hunk ./src/Test/Runner.hs 7
> > -- any later version.
> > ---
> > +--
> > -- This program is distributed in the hope that it will be useful,
> > -- but WITHOUT ANY WARRANTY; without even the implied warranty of
> > -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
> > hunk ./src/Test/Runner.hs 12
> > -- GNU General Public License for more details.
> > ---
> > +--
> > -- You should have received a copy of the GNU General Public License
> > -- along with this program; see the file COPYING. If not, write to
> > -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
> > hunk ./src/Test/Runner.hs 25
> >
> > import qualified Test.QuickCheck as QC ( Testable(..), quickCheckResult,
> > Result(..) )
> > +import Data.Maybe ( isJust, isNothing, fromJust )
> > import Control.Concurrent ( forkIO )
> > import Control.Concurrent.STM ( newTVar, readTVar, writeTVar,
> atomically,
> > retry, TVar )
> > hunk ./src/Test/Runner.hs 32
> >
> > -- * Classes and types for tests
> >
> > +-- | The class of all types that testrunner can treat as a test. The
> method
> > +-- 'run' should return @Nothing@ if the test succeeds, or @Just s@ if
> the test
> > +-- fails, where @s@ is a human-readable description of the failure.
> > class RunnableTest a where
> > hunk ./src/Test/Runner.hs 36
> > - run :: a -> IO Bool
> > + run :: a -> IO (Maybe String)
This refactor is an example of why I think the result type should be in a
class :)
>
> >
> > -- | Any @IO@ action that returns @True@ upon success and @False@ upon
> failure
> > -- can be treated as a test by testrunner.
> > hunk ./src/Test/Runner.hs 41
> > instance RunnableTest (IO Bool) where
> > - run = id
> > + run a = do
> > + r <- a
> > + return $ if r then Nothing else Just "Boolean test failed"
> >
> > -- | QuickCheck properties can be run by testrunner.
> > -- You do lose a lot of information on the result though; only whether
> the
> > hunk ./src/Test/Runner.hs 48
> > -- test succeeded or not is returned.
> > ---
> > +--
> > -- Note that this also provides a @RunnableTest@ instance for @Bool at .
> > instance (QC.Testable a) => RunnableTest a where
> > run t = do
> > hunk ./src/Test/Runner.hs 54
> > r <- QC.quickCheckResult t
> > return $ case r of
> > - QC.Failure _ _ _ _ -> False
> > - _ -> True
> > + QC.Failure _ _ reason _ -> Just reason
> > + _ -> Nothing
> >
> > -- | A TestRunnerTest is a data type that hides the actual type of the
> test -
> > -- QuickCheck, plain IO action, or any other RunnableTest. This is
> required to
> > hunk ./src/Test/Runner.hs 66
> > -- * Running tests
> > -- | Shows a name, runs the test, and then shows whether it failed or
> not by
> > -- printing either "OK" or "FAIL!" to standard output.
> > -run_showing_name :: (String, TestRunnerTest) -> IO Bool
> > -run_showing_name (name, TestRunnerTest t) = do
> > +run_showing_name :: (String, TestRunnerTest) -> IO (Maybe String)
> > +run_showing_name (name, TestRunnerTest t) = do
> > putStr name
> > r <- run t
> > hunk ./src/Test/Runner.hs 70
> > - putStrLn (if r then "OK" else "FAIL!")
> > + putStrLn (if isNothing r then "OK" else "FAIL!")
> > return r
> >
The above looks fine. There are lots of other things in the bundle and I
did a quick glance at them, but I'm going to stop here. In my quick glance
I didn't see anything glaring. I thought the mention of intercalate might
be a problem but I see that you hide that import and it's Data.ByteString
not Data.List so that's probably a non-issue either way.
My opinion is to accept these patches on the assumption that Reinier will
address some of my concerns in later patches. I don't see anything that
should stop the acceptance (assuming the build bots are happy), but I do
think that things like incoherent instances should be avoided so to me that
is something I would to see justified or removed.
I think these changes move in a positive direction and I appreciate the hard
work that is going into them. I hope my comments are encouraging and not
discouraging :)
I hope that helps!
Thanks,
Jason
>
> >
> > hunk ./src/Test/Runner.hs 75
> > -- | The result of the test runner mentions how many tests passed, and
> the names
> > --- and number of the tests that failed.
> > +-- and failure messages of the tests that failed.
> > data Result = Result { numPassed :: Int
> > hunk ./src/Test/Runner.hs 77
> > - , failedNames :: [String]
> > + , failures :: [(String, String)]
> > }
> >
> > -- | Run a list of named tests.
> > hunk ./src/Test/Runner.hs 85
> > runTests namedTests = do
> > results <- mapM run_showing_name namedTests
> > let namedResults = zip names results
> > - passed = length (filter (==True) results)
> > - failed = map fst $ filter (not . snd) namedResults
> > + passed = length (filter isNothing results)
> > + failed = map sndFromJust $ filter (isJust . snd) namedResults
> > return (Result passed failed)
> > where (names, _) = unzip namedTests
> > hunk ./src/Test/Runner.hs 89
> > + sndFromJust (name, result) = (name, fromJust result)
> >
> > -- * Running tests in parallel
> >
> > hunk ./src/Test/Runner.hs 93
> > -data RunnerState = RunnerState { testsToDo :: [(String, TestRunnerTest)]
> > - , passedTests :: [String]
> > - , failedTests :: [String]
> > - , numDone :: Int
> > - }
> > +data RunnerState = RunnerState
> > + { testsToDo :: [(String, TestRunnerTest)]
> > + , passedTests :: [String]
> > + , failedTests :: [(String, String)] -- ^ Names and failure messages
> > + , numDone :: Int
> > + }
> >
> > -- | Creates an initial test runner state given the list of named tests
> > initial_runner_state :: [(String, TestRunnerTest)] -> RunnerState
> > hunk ./src/Test/Runner.hs 138
> > -- state after it's done.
> > run_one_test :: TVar RunnerState -> (String, TestRunnerTest) -> IO ()
> > run_one_test stateRef (name, TestRunnerTest t) = do
> > - passed <- run t
> > - putStrLn (name ++ ": " ++ (if passed then "OK" else "FAIL!"))
> > + result <- run t
> > + putStrLn (name ++ ": " ++ (if isNothing result then "OK" else
> "FAIL!"))
> > atomically $ do
> > state <- readTVar stateRef
> > hunk ./src/Test/Runner.hs 142
> > - let state' = state { numDone = numDone state + 1 }
> > - state'' = if passed
> > - then state' { passedTests = name : passedTests
> state }
> > - else state' { failedTests = name : failedTests
> state }
> > + let ps = passedTests state
> > + fs = failedTests state
> > + state' = state { numDone = numDone state + 1 }
> > + state'' = case result of
> > + Nothing -> state' { passedTests = name : ps }
> > + Just msg -> state' { failedTests = (name, msg)
> : fs }
> > writeTVar stateRef state''
> >
> > hunk ./src/unit.lhs 50
> > module Main (main) where
> >
> > import System.IO.Unsafe ( unsafePerformIO )
> > -import ByteStringUtils
> > +import ByteStringUtils hiding ( intercalate )
> > import qualified Data.ByteString.Char8 as BC ( unpack, pack )
> > import qualified Data.ByteString as B ( empty, concat, length, unpack,
> foldr,
> > cons, ByteString, null, filter,
> head )
> > hunk ./src/unit.lhs 55
> > import Data.Char ( isPrint )
> > +import Data.List ( intercalate )
> > import Darcs.Patch
> > import Darcs.Patch.Test
> > import Darcs.Patch.Unit ( run_patch_unit_tests )
> > hunk ./src/unit.lhs 94
> > (show (length test_patches))++" patches.\n")
> > results <- runTestsParallel 2 tests
> > putStrLn (show (numPassed results) ++ " tests passed. Failing tests:")
> > - mapM_ (putStrLn . (" "++)) (failedNames results)
> > + mapM_ (putStrLn . (" "++) . fst) (failures results)
> >
> > -- | This is the big list of tests that will be run using testrunner.
> > tests :: [(String, TestRunnerTest)]
> > hunk ./src/unit.lhs 193
> > -- | This instance is required for some of the tests in this module. It
> seems
> > -- non-standard usage to me, so I don't include it in testrunner.
> > instance RunnableTest [String] where
> > - run [] = return True
> > - run ss = do
> > - putStrLn "A test failed! Failure information: "
> > - mapM_ putStrLn ss
> > - return False
> > + run [] = return Nothing
> > + run ss = return $ Just (intercalate "\n\n" ss)
> > \end{code}
> >
> > \chapter{Unit Tester}
>
> Make Darcs.Patch.Unit use Test.Runner
> -------------------------------------
> > Reinier Lamers <tux_rocker at reinier.de>**20090430185729
> > Ignore-this: db72523f63c790ce8ee20f4fbe577d4f
> >
> > This includes a semantic change: unit testing no longer stops after the
> patch
> > unit tests if one of those fails. I can't see a reason why that would be
> very
> > bad.
> > ] hunk ./src/Darcs/Patch/Unit.hs 23
> >
> > #include "gadts.h"
> >
> > -module Darcs.Patch.Unit ( run_patch_unit_tests ) where
> > +module Darcs.Patch.Unit ( patch_unit_tests ) where
> >
> > hunk ./src/Darcs/Patch/Unit.hs 25
> > -import Control.Monad ( unless )
> > import Data.Maybe ( catMaybes )
> > import qualified Data.ByteString.Char8 as BC ( pack )
> > import Darcs.Sealed
> > hunk ./src/Darcs/Patch/Unit.hs 45
> > --import Darcs.ColorPrinter ( traceDoc )
> > --import Darcs.ColorPrinter ( errorDoc )
> > import Darcs.ColorPrinter () -- for instance Show Doc
> > +import Test.Runner ( TestRunnerTest(..), RunnableTest(..) )
> >
> > -- import Debug.Trace
> > -- #include "impossible.h"
> > hunk ./src/Darcs/Patch/Unit.hs 50
> >
> > -run_patch_unit_tests :: IO Int
> > -run_patch_unit_tests =
> > - run_some_tests ""
> > - [--do putStr "Checking with quickcheck that real patches have
> consistent flattenings... "
> > - -- quickCheck (not . isBottomTimeOut (Just 10) .
> prop_consistent_tree_flattenings) >> return 0
> > - run_primitive_tests "prim join inverses"
> > - (\(a:\/:_) -> join_inverses join a) mergeables
> > - ,do putStr "Checking prim join inverses using QuickCheck... "
> > - simpleCheck (join_inverses join)
> > - ,run_primitive_tests "prim inverse doesn't commute"
> > - (\(a:\/:_) -> inverse_doesnt_commute a)
> mergeables
> > - -- The following fails because of setpref patches...
> > - --,do putStr "Checking prim inverse doesn't commute using
> QuickCheck... "
> > - -- simpleCheck (inverse_doesnt_commute :: Prim -> Maybe Doc)
> > - ,run_primitive_tests "join commute" (join_commute join)
> prim_permutables
> > - ,do putStr "Checking prim join commute using QuickCheck... "
> > - simpleCheck (unseal2 (join_commute join))
> > +-- | The unit tests defined about patches
> > +patch_unit_tests :: [(String, TestRunnerTest)]
> > +patch_unit_tests = [--do putStr "Checking with quickcheck that real
> patches have consistent flattenings... "
> > + -- quickCheck (not . isBottomTimeOut (Just 10) .
> prop_consistent_tree_flattenings) >> return 0
> > + ("prim join inverses",
> > + TestRunnerTest (run_primitive_tests (\ (a:\/:_) ->
> join_inverses join a) mergeables)),
> > + ("Checking prim join inverses using QuickCheck... ",
> > + TestRunnerTest (simpleCheck (join_inverses join))),
> > + ("prim inverse doesn't commute",
> > + TestRunnerTest (run_primitive_tests (\ (a:\/:_) ->
> inverse_doesnt_commute a) mergeables)),
> > + -- The following fails because of setpref patches...
> > + --,do putStr "Checking prim inverse doesn't commute
> using QuickCheck... "
> > + -- simpleCheck (inverse_doesnt_commute :: Prim ->
> Maybe Doc)
> > + ("join commute",
> > + TestRunnerTest (run_primitive_tests (join_commute
> join) prim_permutables)),
> > + ("Checking prim join commute using QuickCheck... ",
> > + TestRunnerTest (simpleCheck (unseal2 (join_commute
> join)))),
> > + ("prim recommute",
> > + TestRunnerTest (run_primitive_tests (recommute
> commute) $ map mergeable2commutable mergeables)),
> > + ("prim patch and inverse commute",
> > + TestRunnerTest (run_primitive_tests
> (patch_and_inverse_commute commute) $ map mergeable2commutable mergeables)),
> > + ("prim inverses commute",
> > + TestRunnerTest (run_primitive_tests
> (commute_inverses commute) $ map mergeable2commutable mergeables)),
> > + --,do putStr "Checking prim recommute using
> QuickCheck... "
> > + -- simpleCheck (recommute
> > + -- (commute :: Prim :> Prim
> > + -- -> Maybe (Prim :>
> Prim)))
> > + ("FL prim recommute",
> > + TestRunnerTest (run_primitive_tests (recommute
> commute) $ map mergeable2commutable mergeablesFL)),
> > + ("FL prim patch and inverse commute",
> > + TestRunnerTest (run_primitive_tests
> (patch_and_inverse_commute commute) $ map mergeable2commutable
> mergeablesFL)),
> > + ("FL prim inverses commute",
> > + TestRunnerTest (run_primitive_tests
> (commute_inverses commute) $ map mergeable2commutable mergeablesFL)),
> > + ("fails",
> > + TestRunnerTest (run_primitive_tests (commute_fails
> commute) ([] :: [Prim :> Prim]))),
> > + ("read and show work on Prim",
> > + TestRunnerTest (run_primitive_tests show_read
> prim_patches)),
> > + ("read and show work on RealPatch",
> > + TestRunnerTest (run_primitive_tests show_read
> real_patches)),
> > + ("Checking that readPatch and showPatch work on
> RealPatch... ",
> > + TestRunnerTest (simpleCheck (unseal $ patchFromTree
> $ (show_read :: RealPatch -> Maybe Doc)))),
> > + ("Checking that readPatch and showPatch work on FL
> RealPatch... ",
> > + TestRunnerTest (simpleCheck (unseal2 $ (show_read
> :: FL RealPatch -> Maybe Doc)))),
> > + ("example flattenings work",
> > + TestRunnerTest (run_primitive_tests (\x -> if
> prop_consistent_tree_flattenings x
> > + then
> Nothing
> > + else
> Just $ redText "oops")
> > +
> real_patch_loop_examples)),
> > + ("Checking that tree flattenings are consistent...
> ",
> > + TestRunnerTest (simpleCheck ((\b -> if b then
> Nothing else Just False) . prop_consistent_tree_flattenings))),
> > + ("Checking with quickcheck that real patches are
> consistent... ",
> > + TestRunnerTest (simpleCheck (unseal $ patchFromTree
> $ is_consistent))),
> > + ("real merge input consistent",
> > + TestRunnerTest (run_primitive_tests
> (merge_arguments_consistent is_consistent) real_mergeables)),
> > + ("real merge input is forward",
> > + TestRunnerTest (run_primitive_tests
> (merge_arguments_consistent is_forward) real_mergeables)),
> > + ("real merge output is forward",
> > + TestRunnerTest (run_primitive_tests
> (merge_consistent is_forward) real_mergeables)),
> > + ("real merge output consistent",
> > + TestRunnerTest (run_primitive_tests
> (merge_consistent is_consistent) real_mergeables)),
> > + ("real merge either way",
> > + TestRunnerTest (run_primitive_tests
> merge_either_way real_mergeables)),
> > + ("real merge and commute",
> > + TestRunnerTest (run_primitive_tests merge_commute
> real_mergeables)),
> > +
> > + ("real recommute",
> > + TestRunnerTest (run_primitive_tests (recommute
> commute) real_commutables)),
> > + ("real inverses commute",
> > + TestRunnerTest (run_primitive_tests
> (commute_inverses commute) real_commutables)),
> > + ("real permutivity",
> > + TestRunnerTest (run_primitive_tests (permutivity
> commute) $ filter (not_duplicatestriple) real_triples)),
> > + ("real partial permutivity",
> > + TestRunnerTest (run_primitive_tests
> (partial_permutivity commute) $ filter (not_duplicatestriple)
> real_triples)),
> > +
> > + ("Checking we can do merges using QuickCheck... ",
> > + TestRunnerTest (simpleCheck (prop_is_mergeable ::
> > + Sealed
> (WithStartState RepoModel (Tree Prim))
> > + -> Maybe (Tree
> RealPatch C(x))))),
> > + ("Checking again we can do merges using
> QuickCheck... ",
> > + TestRunnerTest (thoroughCheck 1000
> (prop_is_mergeable ::
> > + Sealed
> (WithStartState RepoModel (Tree Prim))
> > + ->
> Maybe (Tree RealPatch C(x))))),
> > + ("Checking recommute using QuickCheck Tree
> generator... ",
> > + TestRunnerTest (simpleCheck (unseal $
> commutePairFromTree $
> > + (recommute
> > + (commute ::
> RealPatch :> RealPatch
> > + ->
> Maybe (RealPatch :> RealPatch)))))),
> > + ("Checking recommute using QuickCheck TWFP
> generator... ",
> > + TestRunnerTest (simpleCheck (unseal $
> commutePairFromTWFP $
> > + (recommute
> > + (commute ::
> RealPatch :> RealPatch
> > + ->
> Maybe (RealPatch :> RealPatch)))))),
> > + ("Checking nontrivial recommute... ",
> > + TestRunnerTest (simpleConditionalCheck (unseal $
> commutePairFromTree $ nontrivial_reals)
> > + (unseal $
> commutePairFromTree $
> > + (recommute
> > + (commute
> :: RealPatch :> RealPatch
> > +
> -> Maybe (RealPatch :> RealPatch)))))),
> > + ("Checking nontrivial recommute using TWFP... ",
> > + TestRunnerTest (simpleConditionalCheck (unseal $
> commutePairFromTWFP $ nontrivial_reals)
> > + (unseal $
> commutePairFromTWFP $
> > + (recommute
> > + (commute
> :: RealPatch :> RealPatch
> > +
> -> Maybe (RealPatch :> RealPatch)))))),
> > +
> > + ("Checking inverses commute using QuickCheck Tree
> generator... ",
> > + TestRunnerTest (simpleCheck (unseal $
> commutePairFromTree $
> > + (commute_inverses
> > + (commute :: RealPatch
> :> RealPatch
> > + -> Maybe
> (RealPatch :> RealPatch)))))),
> > + ("Checking inverses commute using QuickCheck TWFP
> generator... ",
> > + TestRunnerTest (simpleCheck (unseal $
> commutePairFromTWFP $
> > + (commute_inverses
> > + (commute :: RealPatch
> :> RealPatch
> > + -> Maybe
> (RealPatch :> RealPatch)))))),
> > + ("Checking nontrivial inverses commute... ",
> > + TestRunnerTest (simpleConditionalCheck (unseal $
> commutePairFromTree $ nontrivial_reals)
> > + (unseal $
> commutePairFromTree $
> > +
> (commute_inverses
> > + (commute
> :: RealPatch :> RealPatch
> > +
> -> Maybe (RealPatch :> RealPatch)))))),
> > + ("Checking nontrivial inverses commute using TWFP...
> ",
> > + TestRunnerTest (simpleConditionalCheck (unseal $
> commutePairFromTWFP $ nontrivial_reals)
> > + (unseal $
> commutePairFromTWFP $
> > +
> (commute_inverses
> > + (commute
> :: RealPatch :> RealPatch
> > +
> -> Maybe (RealPatch :> RealPatch)))))),
> > +
> > + ("Checking merge either way using QuickCheck TWFP
> generator... ",
> > + TestRunnerTest (simpleCheck (unseal $
> mergePairFromTWFP $
> > + (merge_either_way ::
> RealPatch :\/: RealPatch -> Maybe Doc)))),
> > + ("Checking merge either way using QuickCheck Tree
> generator... ",
> > + TestRunnerTest (simpleCheck (unseal $
> mergePairFromTree $
> > + (merge_either_way :: RealPatch :\/:
> RealPatch -> Maybe Doc)))),
> > + ("Checking nontrivial merge either way... ",
> > + TestRunnerTest (simpleConditionalCheck (unseal $
> mergePairFromTree $ nontrivial_merge_reals)
> > + (unseal $
> mergePairFromTree $
> > +
> (merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc)))),
> > + ("Checking nontrivial merge either way using TWFP...
> ",
> > + TestRunnerTest (simpleConditionalCheck (unseal $
> mergePairFromTWFP $ nontrivial_merge_reals)
> > + (unseal $
> mergePairFromTWFP $
> > +
> (merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc)))),
> > +
> > + ("Checking permutivity... ",
> > + TestRunnerTest (simpleConditionalCheck (unseal $
> commuteTripleFromTree not_duplicatestriple)
> > + (unseal $
> commuteTripleFromTree $ permutivity
> > +
> (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch))))),
> > + ("Checking partial permutivity... ",
> > + TestRunnerTest (simpleConditionalCheck (unseal $
> commuteTripleFromTree not_duplicatestriple)
> > + (unseal $
> commuteTripleFromTree $ partial_permutivity
> > +
> (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch))))),
> > + ("Checking nontrivial permutivity... ",
> > + TestRunnerTest (simpleConditionalCheck (unseal $
> commuteTripleFromTree
> > +
> (\t -> nontrivial_triple t && not_duplicatestriple t))
> > + (unseal $
> commuteTripleFromTree $
> > +
> (permutivity
> > + (commute
> :: RealPatch :> RealPatch
> > +
> -> Maybe (RealPatch :> RealPatch))))))
> > + ]
> >
> > hunk ./src/Darcs/Patch/Unit.hs 210
> > - ,run_primitive_tests "prim recommute"
> > - (recommute commute) $ map mergeable2commutable
> mergeables
> > - ,run_primitive_tests "prim patch and inverse commute"
> > - (patch_and_inverse_commute commute) $ map
> mergeable2commutable mergeables
> > - ,run_primitive_tests "prim inverses commute"
> > - (commute_inverses commute) $ map
> mergeable2commutable mergeables
> > -
> > --- ,do putStr "Checking prim recommute using QuickCheck... "
> > --- simpleCheck (recommute
> > --- (commute :: Prim :> Prim
> > --- -> Maybe (Prim :> Prim)))
> > -
> > - ,run_primitive_tests "FL prim recommute"
> > - (recommute commute) $ map mergeable2commutable
> mergeablesFL
> > - ,run_primitive_tests "FL prim patch and inverse commute"
> > - (patch_and_inverse_commute commute) $ map
> mergeable2commutable mergeablesFL
> > - ,run_primitive_tests "FL prim inverses commute"
> > - (commute_inverses commute) $ map
> mergeable2commutable mergeablesFL
> > -
> > - ,run_primitive_tests "fails" (commute_fails commute) ([] :: [Prim :>
> Prim])
> > -
> > - ,run_primitive_tests "read and show work on Prim" show_read
> prim_patches
> > - ,run_primitive_tests "read and show work on RealPatch" show_read
> real_patches
> > - ,do putStr "Checking that readPatch and showPatch work on
> RealPatch... "
> > - simpleCheck (unseal $ patchFromTree $ (show_read :: RealPatch ->
> Maybe Doc))
> > - ,do putStr "Checking that readPatch and showPatch work on FL
> RealPatch... "
> > - simpleCheck (unseal2 $ (show_read :: FL RealPatch -> Maybe Doc))
> > -
> > - ,run_primitive_tests "example flattenings work"
> > - (\x -> if prop_consistent_tree_flattenings
> x
> > - then Nothing
> > - else Just $ redText "oops")
> > - real_patch_loop_examples
> > - ,do putStr "Checking that tree flattenings are consistent... "
> > - simpleCheck ((\b -> if b then Nothing else Just False) .
> prop_consistent_tree_flattenings)
> > -
> > - ,do putStr "Checking with quickcheck that real patches are
> consistent... "
> > - simpleCheck (unseal $ patchFromTree $ is_consistent)
> > - ,run_primitive_tests "real merge input consistent"
> > - (merge_arguments_consistent is_consistent)
> real_mergeables
> > - ,run_primitive_tests "real merge input is forward"
> > - (merge_arguments_consistent is_forward)
> real_mergeables
> > - ,run_primitive_tests "real merge output is forward"
> > - (merge_consistent is_forward)
> real_mergeables
> > - ,run_primitive_tests "real merge output consistent"
> > - (merge_consistent is_consistent)
> real_mergeables
> > - ,run_primitive_tests "real merge either way" merge_either_way
> real_mergeables
> > - ,run_primitive_tests "real merge and commute" merge_commute
> real_mergeables
> > -
> > - ,run_primitive_tests "real recommute" (recommute commute)
> real_commutables
> > - ,run_primitive_tests "real inverses commute" (commute_inverses
> commute) real_commutables
> > -
> > - ,run_primitive_tests "real permutivity" (permutivity commute) $
> > - filter (not_duplicatestriple) real_triples
> > - ,run_primitive_tests "real partial permutivity" (partial_permutivity
> commute) $
> > - filter (not_duplicatestriple) real_triples
> > -
> > - ,do putStr "Checking we can do merges using QuickCheck... "
> > - simpleCheck (prop_is_mergeable ::
> > - Sealed (WithStartState RepoModel (Tree Prim))
> > - -> Maybe (Tree RealPatch C(x)))
> > - ,do putStr "Checking again we can do merges using QuickCheck... "
> > - thoroughCheck 1000 (prop_is_mergeable ::
> > - Sealed (WithStartState RepoModel (Tree
> Prim))
> > - -> Maybe (Tree RealPatch C(x)))
> > -
> > - ,do putStr "Checking recommute using QuickCheck Tree generator... "
> > - simpleCheck (unseal $ commutePairFromTree $
> > - (recommute
> > - (commute :: RealPatch :> RealPatch
> > - -> Maybe (RealPatch :> RealPatch))))
> > - ,do putStr "Checking recommute using QuickCheck TWFP generator... "
> > - simpleCheck (unseal $ commutePairFromTWFP $
> > - (recommute
> > - (commute :: RealPatch :> RealPatch
> > - -> Maybe (RealPatch :> RealPatch))))
> > - ,do putStr "Checking nontrivial recommute... "
> > - simpleConditionalCheck (unseal $ commutePairFromTree $
> nontrivial_reals)
> > - (unseal $ commutePairFromTree $
> > - (recommute
> > - (commute :: RealPatch :> RealPatch
> > - -> Maybe (RealPatch :>
> RealPatch))))
> > - ,do putStr "Checking nontrivial recommute using TWFP... "
> > - simpleConditionalCheck (unseal $ commutePairFromTWFP $
> nontrivial_reals)
> > - (unseal $ commutePairFromTWFP $
> > - (recommute
> > - (commute :: RealPatch :> RealPatch
> > - -> Maybe (RealPatch :>
> RealPatch))))
> > -
> > - ,do putStr "Checking inverses commute using QuickCheck Tree
> generator... "
> > - simpleCheck (unseal $ commutePairFromTree $
> > - (commute_inverses
> > - (commute :: RealPatch :> RealPatch
> > - -> Maybe (RealPatch :> RealPatch))))
> > - ,do putStr "Checking inverses commute using QuickCheck TWFP
> generator... "
> > - simpleCheck (unseal $ commutePairFromTWFP $
> > - (commute_inverses
> > - (commute :: RealPatch :> RealPatch
> > - -> Maybe (RealPatch :> RealPatch))))
> > - ,do putStr "Checking nontrivial inverses commute... "
> > - simpleConditionalCheck (unseal $ commutePairFromTree $
> nontrivial_reals)
> > - (unseal $ commutePairFromTree $
> > - (commute_inverses
> > - (commute :: RealPatch :> RealPatch
> > - -> Maybe (RealPatch :>
> RealPatch))))
> > - ,do putStr "Checking nontrivial inverses commute using TWFP... "
> > - simpleConditionalCheck (unseal $ commutePairFromTWFP $
> nontrivial_reals)
> > - (unseal $ commutePairFromTWFP $
> > - (commute_inverses
> > - (commute :: RealPatch :> RealPatch
> > - -> Maybe (RealPatch :>
> RealPatch))))
> > -
> > - ,do putStr "Checking merge either way using QuickCheck TWFP
> generator... "
> > - simpleCheck (unseal $ mergePairFromTWFP $
> > - (merge_either_way :: RealPatch :\/: RealPatch ->
> Maybe Doc))
> > - ,do putStr "Checking merge either way using QuickCheck Tree
> generator... "
> > - simpleCheck (unseal $ mergePairFromTree $
> > - (merge_either_way :: RealPatch :\/: RealPatch ->
> Maybe Doc))
> > - ,do putStr "Checking nontrivial merge either way... "
> > - simpleConditionalCheck (unseal $ mergePairFromTree $
> nontrivial_merge_reals)
> > - (unseal $ mergePairFromTree $
> > - (merge_either_way :: RealPatch :\/:
> RealPatch -> Maybe Doc))
> > - ,do putStr "Checking nontrivial merge either way using TWFP... "
> > - simpleConditionalCheck (unseal $ mergePairFromTWFP $
> nontrivial_merge_reals)
> > - (unseal $ mergePairFromTWFP $
> > - (merge_either_way :: RealPatch :\/:
> RealPatch -> Maybe Doc))
> > -
> > - ,do putStr "Checking permutivity... "
> > - simpleConditionalCheck (unseal $ commuteTripleFromTree
> not_duplicatestriple)
> > - (unseal $ commuteTripleFromTree $ permutivity
> > - (commute :: RealPatch :> RealPatch -> Maybe
> (RealPatch :> RealPatch)))
> > - ,do putStr "Checking partial permutivity... "
> > - simpleConditionalCheck (unseal $ commuteTripleFromTree
> not_duplicatestriple)
> > - (unseal $ commuteTripleFromTree $ partial_permutivity
> > - (commute :: RealPatch :> RealPatch -> Maybe
> (RealPatch :> RealPatch)))
> > - ,do putStr "Checking nontrivial permutivity... "
> > - simpleConditionalCheck (unseal $ commuteTripleFromTree
> > - (\t -> nontrivial_triple t &&
> not_duplicatestriple t))
> > - (unseal $ commuteTripleFromTree $
> > - (permutivity
> > - (commute :: RealPatch :> RealPatch
> > - -> Maybe (RealPatch :> RealPatch))))
> > - ]
> > +-- | A non-standard @RunnableTest@ instance for the tests in
> > +-- @Darcs.Patch.Unit at .
> > +instance RunnableTest (IO Int) where
> > + run a = do r <- a
> > + return $ if r == 0
> > + then Nothing
> > + else Just (show r ++ " tests failed!")
> >
> > not_duplicatestriple :: RealPatch :> RealPatch :> RealPatch -> Bool
> > not_duplicatestriple (a :> b :> c) = not $ any is_duplicate [a,b,c]
> > hunk ./src/Darcs/Patch/Unit.hs 255
> > y' :/\: x' -> not (y' `unsafeCompare` y)
> ||
> > not (x' `unsafeCompare` x)
> >
> > -run_some_tests :: String -> [IO Int] -> IO Int
> > -run_some_tests name ts = do unless (null name) $ putStr $ "Testing " ++
> name ++ "... "
> > - errs <- sum `fmap` sequence ts
> > - unless (null name) $
> > - if errs < 1
> > - then putStrLn "passed."
> > - else putStrLn $ "failed " ++ name ++"
> in "++ show errs ++ " tests."
> > - return errs
> > -
> > -run_primitive_tests :: (Show a, Show b) => String -> (a -> Maybe b) ->
> [a] -> IO Int
> > -run_primitive_tests name test datas = run_some_tests name $ map test'
> datas
> > +run_primitive_tests :: (Show a, Show b) => (a -> Maybe b) -> [a] -> IO
> Int
> > +run_primitive_tests test datas = sum `fmap` (sequence (map test' datas))
> > where test' d = case test d of
> > hunk ./src/Darcs/Patch/Unit.hs 258
> > - Just e -> do putStrLn $ name ++ " failed!"
> > + Just e -> do putStrLn "failed!"
> > putStrLn $ "Input: " ++ show d
> > putStrLn $ "Output: " ++ show e
> > return 1
> > hunk ./src/unit.lhs 58
> > import Data.List ( intercalate )
> > import Darcs.Patch
> > import Darcs.Patch.Test
> > -import Darcs.Patch.Unit ( run_patch_unit_tests )
> > +import Darcs.Patch.Unit ( patch_unit_tests )
> > import Lcs ( shiftBoundaries )
> > import Test.QuickCheck hiding ( Result(..) )
> > hunk ./src/unit.lhs 61
> > -import System.Exit ( ExitCode(..), exitWith )
> > import System.IO ( hSetBuffering, stdout, BufferMode(..) )
> > import Printer ( renderPS, text )
> > import Darcs.Patch.Commute
> > hunk ./src/unit.lhs 82
> > main :: IO ()
> > main = do
> > hSetBuffering stdout NoBuffering
> > - patch_failures <- run_patch_unit_tests
> > - if patch_failures > 0
> > - then do putStrLn $ show patch_failures ++ " failures in
> Darcs.Patch.Unit."
> > - exitWith $ ExitFailure 1
> > - else putStrLn "No failures in Darcs.Patch.Unit."
> > putStr ("There are a total of "++(show (length
> primitive_test_patches))
> > ++" primitive patches.\n")
> > putStr ("There are a total of "++
> > hunk ./src/unit.lhs 92
> >
> > -- | This is the big list of tests that will be run using testrunner.
> > tests :: [(String, TestRunnerTest)]
> > -tests = [("Checking that UTF-8 packing and unpacking preserves 'hello
> world'",
> > +tests = patch_unit_tests ++
> > + [("Checking that UTF-8 packing and unpacking preserves 'hello
> world'",
> > TestRunnerTest $
> > unpackPSfromUTF8 (BC.pack "hello world") == "hello world"),
> > ("Checking that hex packing and unpacking preserves 'hello
> world'",
>
> Add command line options for unit to set no. of threads
> -------------------------------------------------------
> > Reinier Lamers <tux_rocker at reinier.de>**20090508214544
> > Ignore-this: c481215796877c12dfce297895e6ecc4
> > ] hunk ./src/unit.lhs 50
> > module Main (main) where
> >
> > import System.IO.Unsafe ( unsafePerformIO )
> > +import System.IO ( hPutStrLn, stderr )
> > import ByteStringUtils hiding ( intercalate )
> > import qualified Data.ByteString.Char8 as BC ( unpack, pack )
> > import qualified Data.ByteString as B ( empty, concat, length, unpack,
> foldr,
> > hunk ./src/unit.lhs 63
> > import Lcs ( shiftBoundaries )
> > import Test.QuickCheck hiding ( Result(..) )
> > import System.IO ( hSetBuffering, stdout, BufferMode(..) )
> > +import System.Environment ( getArgs )
> > +import System.Console.GetOpt ( OptDescr(..), ArgDescr(..), getOpt,
> usageInfo,
> > + ArgOrder(Permute) )
> > +import System.Exit ( exitWith, ExitCode(ExitSuccess) )
> > import Printer ( renderPS, text )
> > import Darcs.Patch.Commute
> > import Data.Array.Base
> > hunk ./src/unit.lhs 87
> > main :: IO ()
> > main = do
> > hSetBuffering stdout NoBuffering
> > - putStr ("There are a total of "++(show (length
> primitive_test_patches))
> > - ++" primitive patches.\n")
> > - putStr ("There are a total of "++
> > - (show (length test_patches))++" patches.\n")
> > - results <- runTestsParallel 2 tests
> > - putStrLn (show (numPassed results) ++ " tests passed. Failing tests:")
> > - mapM_ (putStrLn . (" "++) . fst) (failures results)
> > + maybeFlags <- parse_args `fmap` getArgs
> > + case maybeFlags of
> > + Nothing -> do hPutStrLn stderr "unit: Unrecognized arguments on
> command line"
> > + printUsageAndDie
> > + Just (numJobs, showHelp) ->
> > + if showHelp
> > + then printUsageAndDie
> > + else runAndShowTests numJobs
> > +
> > +printUsageAndDie :: IO ()
> > +printUsageAndDie = do
> > + putStr (usageInfo "unit - run darcs unit tests" opts)
> > + exitWith ExitSuccess
> > +
> > +runAndShowTests :: Int -> IO ()
> > +runAndShowTests numJobs = do
> > + putStr ("There are a total of "++(show (length
> primitive_test_patches))
> > + ++" primitive patches.\n")
> > + putStr ("There are a total of "++
> > + (show (length test_patches))++" patches.\n")
> > + results <- runTestsParallel numJobs tests
> > + putStrLn (show (numPassed results) ++ " tests passed. Failing
> tests:")
> > + mapM_ (putStrLn . (" "++) . fst) (failures results)
> > +
> > +-- | Data type describing command line flag
> > +data UnitFlag = ShowHelp | NumJobs Int deriving (Eq)
> > +
> > +-- | Parse a string to UnitFlag that describes the number of jobs to
> run. Exits
> > +-- in case of malformed input.
> > +parse_numjobs :: String -> UnitFlag
> > +parse_numjobs s = case reads s of
> > + [(x,"")] -> NumJobs x
> > + _ -> error "Invalid number of Haskell threads given"
> > +
> > +-- | List of possible command line options
> > +opts :: [OptDescr UnitFlag]
> > +opts = [Option ['j'] ["jobs"] (ReqArg parse_numjobs "NUM") "Number of
> Haskell threads to run unit tests"
> > + ,Option ['h'] ["help"] (NoArg ShowHelp) "Show usage
> information and exit"
> > + ]
> > +
> > +parse_args :: [String] -- ^ The list of command line args as
> from
> > + -- @getArgs@
> > + -> Maybe (Int, Bool) -- ^ Number of worker threads and
> whether to
> > + -- show help, or Nothing in case of
> invalid
> > + -- arguments
> > +parse_args args | not (null nonopts)
> > + || not (null errs) = Nothing
> > + | otherwise = Just (numJobs, showHelp)
> > + where showHelp = not (null [x | x <- vals, x == ShowHelp])
> > + numJobs | null jobsArgs = 1
> > + | otherwise = last jobsArgs
> > + jobsArgs = [j | NumJobs j <- vals]
> > + (vals, nonopts, errs) = getOpt Permute opts args
> > +
> >
> > -- | This is the big list of tests that will be run using testrunner.
> > tests :: [(String, TestRunnerTest)]
>
> Give enough information to reproduce failing Quickcheck tests
> -------------------------------------------------------------
> > Reinier Lamers <tux_rocker at reinier.de>**20090512154753
> > Ignore-this: 2cda76b9b0e09b9c27fd70e6fc45f5c1
> > ] hunk ./src/Test/Runner.hs 54
> > run t = do
> > r <- QC.quickCheckResult t
> > return $ case r of
> > - QC.Failure _ _ reason _ -> Just reason
> > - _ -> Nothing
> > + QC.Failure seed size reason _ -> Just (reason ++ "
> (seed: " ++
> > + show seed ++ ",
> size: "
> > + ++ show size)
> > + _ -> Nothing
> >
> > -- | A TestRunnerTest is a data type that hides the actual type of the
> test -
> > -- QuickCheck, plain IO action, or any other RunnableTest. This is
> required to
> > hunk ./src/unit.lhs 108
> > putStr ("There are a total of "++
> > (show (length test_patches))++" patches.\n")
> > results <- runTestsParallel numJobs tests
> > - putStrLn (show (numPassed results) ++ " tests passed. Failing
> tests:")
> > - mapM_ (putStrLn . (" "++) . fst) (failures results)
> > + putStr (show (numPassed results) ++ " tests passed.")
> > + if not (null (failures results))
> > + then do putStrLn "Failing tests:"
> > + mapM_ (putStr . formatFailure) (failures results)
> > + else putChar '\n'
> > + where formatFailure (name, output) =
> > + " " ++ name ++ ":\n" ++
> > + ((unlines . map (" "++) . lines) output)
> >
> > -- | Data type describing command line flag
> > data UnitFlag = ShowHelp | NumJobs Int deriving (Eq)
> >
>
> --
> Eric Kow <http://www.nltg.brighton.ac.uk/home/Eric.Kow>
> PGP Key ID: 08AC04F9
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.osuosl.org/pipermail/darcs-users/attachments/20090513/c9334e96/attachment-0001.htm>
More information about the darcs-users
mailing list