Permalink
Browse files

add test framework

  • Loading branch information...
1 parent 0d9b93c commit b36f6c1554a2002d5b9c563823825b06a44cb389 Patrick Perry committed Jan 20, 2009
Showing with 171 additions and 1 deletion.
  1. +10 −0 .gitignore
  2. +1 −1 configure.ac
  3. +2 −0 lapack.cabal
  4. +110 −0 tests/Driver.hs
  5. +29 −0 tests/Main.hs
  6. +19 −0 tests/Makefile.in
View
10 .gitignore
@@ -1,7 +1,17 @@
+*.hi
+*.o
cbits/config.h
aclocal.m4
+autom4te.cache
config.log
config.status
configure
dist
lapack.buildinfo
+tests/*.html
+tests/*.tix
+tests/.hpc
+tests/Makefile
+tests/test-real
+tests/test-complex
+
View
2 configure.ac
@@ -19,5 +19,5 @@ else
fi
AC_SUBST([BUILD_PACKAGE_BOOL])
-AC_CONFIG_FILES([lapack.buildinfo])
+AC_CONFIG_FILES([lapack.buildinfo tests/Makefile])
AC_OUTPUT
View
2 lapack.cabal
@@ -29,9 +29,11 @@ tested-with: GHC ==6.10.1
extra-source-files: NEWS README TODO configure.ac configure
aclocal.m4 m4/ax_lapack.m4 m4/ax_blas.m4
lapack.buildinfo.in cbits/config.h.in cbits/LAPACK.h
+ tests/Makefile.in tests/Driver.hs tests/Main.hs
extra-tmp-files: config.log config.status autom4te.cache
lapack.buildinfo cbits/config.h
+ tests/Makefile
library
hs-source-dirs: lib
View
110 tests/Driver.hs
@@ -0,0 +1,110 @@
+{-# LANGUAGE CPP #-}
+module Driver (
+ E,
+
+ AEq,
+ (===),
+ (~==),
+
+ field,
+
+ mytest,
+ mycheck,
+ mytests,
+ done,
+
+ ) where
+
+import Data.AEq( AEq )
+import qualified Data.AEq as AEq
+import Data.Complex
+import Data.List
+import Debug.Trace
+import System.IO
+import System.Random
+import Test.QuickCheck
+import Text.Printf
+import Text.Show.Functions
+
+#ifdef COMPLEX
+field = "Complex Double"
+type E = Complex Double
+#else
+field = "Double"
+type E = Double
+#endif
+
+infix 4 ===, ~==
+
+x === y | (AEq.===) x y = True
+ | otherwise = trace (printf "expected `%s', but got `%s'" (show y) (show x)) False
+
+x ~== y | (AEq.~==) x y = True
+ | otherwise = trace (printf "expected `%s', but got `%s'" (show y) (show x)) False
+
+
+------------------------------------------------------------------------
+--
+-- QC driver ( taken from xmonad-0.6 )
+--
+
+debug = False
+
+mytest :: Testable a => a -> Int -> IO (Bool, Int)
+mytest a n = mycheck defaultConfig
+ { configMaxTest=n
+ , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ] } a
+ -- , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a
+
+mycheck :: Testable a => Config -> a -> IO (Bool, Int)
+mycheck config a = do
+ rnd <- newStdGen
+ mytests config (evaluate a) rnd 0 0 []
+
+mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO (Bool, Int)
+mytests config gen rnd0 ntest nfail stamps
+ | ntest == configMaxTest config = done "OK," ntest stamps >> return (True, ntest)
+ | nfail == configMaxFail config = done "Arguments exhausted after" ntest stamps >> return (True, ntest)
+ | otherwise =
+ do putStr (configEvery config ntest (arguments result)) >> hFlush stdout
+ case ok result of
+ Nothing ->
+ mytests config gen rnd1 ntest (nfail+1) stamps
+ Just True ->
+ mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps)
+ Just False ->
+ putStr ( "Falsifiable after "
+ ++ show ntest
+ ++ " tests:\n"
+ ++ unlines (arguments result)
+ ) >> hFlush stdout >> return (False, ntest)
+ where
+ result = generate (configSize config ntest) rnd2 gen
+ (rnd1,rnd2) = split rnd0
+
+done :: String -> Int -> [[String]] -> IO ()
+done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )
+ where
+ table = display
+ . map entry
+ . reverse
+ . sort
+ . map pairLength
+ . group
+ . sort
+ . filter (not . null)
+ $ stamps
+
+ display [] = ".\n"
+ display [x] = " (" ++ x ++ ").\n"
+ display xs = ".\n" ++ unlines (map (++ ".") xs)
+
+ pairLength xss@(xs:_) = (length xss, xs)
+ entry (n, xs) = percentage n ntest
+ ++ " "
+ ++ concat (intersperse ", " xs)
+
+ percentage n m = show ((100 * n) `div` m) ++ "%"
+
+------------------------------------------------------------------------
+
View
29 tests/Main.hs
@@ -0,0 +1,29 @@
+
+import Driver
+import Control.Monad
+import System.Environment
+import Text.Printf
+
+main :: IO ()
+main = do
+ args <- getArgs
+ let n = if null args then 100 else read (head args)
+
+ printf "\nRunnings tests for field `%s'\n" field
+
+ (results, passed) <- liftM unzip $
+ foldM ( \prev (name,subtests) -> do
+ printf "\n%s\n" name
+ printf "%s\n" $ replicate (length name) '-'
+ cur <- mapM (\(s,a) -> printf "%-30s: " s >> a n) subtests
+ return (prev ++ cur)
+ )
+ []
+ tests
+
+ printf "\nPassed %d tests!\n\n" (sum passed)
+ when (not . and $ results) $ fail "\nNot all tests passed!"
+ where
+
+ tests = [
+ ] :: [(String, [(String, Int -> IO (Bool, Int))])]
View
19 tests/Makefile.in
@@ -0,0 +1,19 @@
+
+all:
+ ghc --make -package lapack-@PACKAGE_VERSION@ -fforce-recomp -DREAL Main.hs -o test-real
+ ./test-real
+
+ ghc --make -package lapack-@PACKAGE_VERSION@ -fforce-recomp -DCOMPLEX Main.hs -o test-complex
+ ./test-complex
+
+hpc:
+ ghc --make -fforce-recomp -i. -i../lib ../cbits/double.c ../cbits/zomplex.c @LDFLAGS@ @LAPACK_LIBS@ @BLAS_LIBS@ @LIBS@ -fhpc -DCOMPLEX Main.hs -o test-complex
+ ./test-complex
+ hpc markup test-complex
+
+clean:
+ find ../lib . -name '*.hi' | xargs rm -f
+ find ../lib . -name '*.o' | xargs rm -f
+ find ../cbits . -name '*.o' | xargs rm -f
+ find . -name '*.html' | xargs rm -f
+ rm -f test-real test-complex test-complex.tix

0 comments on commit b36f6c1

Please sign in to comment.