add test framework

.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
+

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

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

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) ++ "%"
+
+------------------------------------------------------------------------
+

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))])]

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