blas-0.6: tests/Driver.hs

{-# LANGUAGE CPP #-}
module Driver (
    E,
    
    Natural(..),
    Index(..),
    Assocs(..),
    
    Natural2(..),
    Index2(..),
    Assocs2(..),
    
    module Control.Arrow,
    module Control.Monad,
    module Control.Monad.ST,
    
    module Data.AEq,
    module Data.Function,
    module Data.Ix,
    module Data.List,
    module Data.Ord,
    
    module Debug.Trace,
    
    module Test.QuickCheck,
    
    module Text.Printf,

    field,

    mytest,
    mycheck,
    mytests,
    done,

    ) where

import Control.Arrow
import Control.Monad
import Control.Monad.ST

import Data.AEq
import Data.Complex
import Data.Ix
import Data.Function
import Data.List
import Data.Ord

import Debug.Trace

import System.IO
import System.Random

import Test.QuickCheck hiding ( vector )

import Text.Printf
import Text.Show.Functions

import Generators.Matrix

#ifdef COMPLEX
field = "Complex Double"
type E = Complex Double 
#else
field = "Double"
type E = Double
#endif

instance (Arbitrary e, RealFloat e) => Arbitrary (Complex e) where
    arbitrary = liftM2 (:+) arbitrary arbitrary
    coarbitrary (x:+y) = coarbitrary (x,y)

newtype Natural = Nat Int deriving (Eq,Show)
instance Arbitrary Natural where
    arbitrary = do
        n <- arbitrary
        return $ Nat (abs n)
        
    coarbitrary = undefined

newtype Natural2 = Nat2 (Int,Int) deriving (Eq,Show)
instance Arbitrary Natural2 where
    arbitrary = matrixSized $ \s -> do
        (Nat m) <- resize s arbitrary
        (Nat n) <- resize s arbitrary
        return $ Nat2 (m,n)
        
    coarbitrary = undefined

data Index = Index Int Int deriving (Eq,Show)
instance Arbitrary Index where
    arbitrary = do
        n <- arbitrary
        i <- choose (0, abs n)
        return $ Index i (abs n + 1)
        
    coarbitrary = undefined

data Index2 = Index2 (Int,Int) (Int,Int) deriving (Eq,Show)
instance Arbitrary Index2 where
    arbitrary = matrixSized $ \s -> do
        (Index i m) <- resize s arbitrary
        (Index j n) <- resize s arbitrary
        return $ Index2 (i,j) (m,n)
    
    coarbitrary = undefined

data Assocs = Assocs Int [(Int,E)] deriving (Eq,Show)
instance Arbitrary Assocs where
    arbitrary = do
        (Nat n) <- arbitrary
        (Nat s) <- if n == 0 then return (Nat 0) else arbitrary
        ies <- replicateM s $ liftM2 (,) (choose (0,n-1)) arbitrary
        return $ Assocs n ies
        
    coarbitrary = undefined

data Assocs2 = Assocs2 (Int,Int) [((Int,Int),E)] deriving (Eq,Show)
instance Arbitrary Assocs2 where
    arbitrary = do
        (Nat2 (m,n)) <- arbitrary
        (Nat s) <- if m == 0 || n == 0 then return (Nat 0) else arbitrary
        ijes <- replicateM s $ liftM2 (,) (liftM2 (,) (choose (0,m-1)) 
                                                      (choose (0,n-1)))
                                          arbitrary
        return $ Assocs2 (m,n) ijes
        
    coarbitrary = undefined


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

------------------------------------------------------------------------