storablevector 0.1 → 0.1.0
raw patch · 2 files changed
+247/−1 lines, 2 files
Files
- storablevector.cabal +2/−1
- tests/QuickCheckUtils.hs +245/−0
storablevector.cabal view
@@ -1,5 +1,5 @@ Name: storablevector-Version: 0.1+Version: 0.1.0 Category: Data Synopsis: Fast, packed, strict storable arrays with a list interface like ByteString Description:@@ -27,5 +27,6 @@ CPP-Options: -DSLOW_FOREIGN_PTR Hs-Source-Dirs: ., tests Main-Is: tests.hs+Other-Modules: QuickCheckUtils Extensions: CPP, ForeignFunctionInterface Build-Depends: base, haskell98, bytestring, QuickCheck
+ tests/QuickCheckUtils.hs view
@@ -0,0 +1,245 @@+{-# OPTIONS_GHC -O -fglasgow-exts #-}+--+-- Uses multi-param type classes+--+module QuickCheckUtils where++import Test.QuickCheck.Batch+import Test.QuickCheck+import Text.Show.Functions++import Control.Monad ( liftM2 )+import Data.Char+import Data.List+import Data.Word+import Data.Int+import System.Random+import System.IO++import Data.ByteString.Fusion+import qualified Data.ByteString as P+import qualified Data.StorableVector as V++import qualified Data.ByteString.Char8 as PC++-- Enable this to get verbose test output. Including the actual tests.+debug = False++mytest :: Testable a => a -> Int -> IO ()+mytest a n = mycheck defaultConfig+ { configMaxTest=n+ , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a++mycheck :: Testable a => Config -> a -> IO ()+mycheck config a =+ do rnd <- newStdGen+ mytests config (evaluate a) rnd 0 0 []++mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO ()+mytests config gen rnd0 ntest nfail stamps+ | ntest == configMaxTest config = do done "OK," ntest stamps+ | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps+ | 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+ where+ result = generate (configSize config ntest) rnd2 gen+ (rnd1,rnd2) = split rnd0++done :: String -> Int -> [[String]] -> IO ()+done mesg ntest stamps =+ do 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) ++ "%"++------------------------------------------------------------------------++instance Arbitrary Char where+ arbitrary = choose ('a', 'i')+ coarbitrary c = variant (ord c `rem` 4)++instance (Arbitrary a, Arbitrary b) => Arbitrary (PairS a b) where+ arbitrary = liftM2 (:*:) arbitrary arbitrary+ coarbitrary (a :*: b) = coarbitrary a . coarbitrary b++instance Arbitrary Word8 where+ arbitrary = choose (97, 105)+ coarbitrary c = variant (fromIntegral ((fromIntegral c) `rem` 4))++instance Arbitrary Int64 where+ arbitrary = sized $ \n -> choose (-fromIntegral n,fromIntegral n)+ coarbitrary n = variant (fromIntegral (if n >= 0 then 2*n else 2*(-n) + 1))++instance Arbitrary a => Arbitrary (MaybeS a) where+ arbitrary = do a <- arbitrary ; elements [NothingS, JustS a]+ coarbitrary NothingS = variant 0+ coarbitrary _ = variant 1 -- ok?++{-+instance Arbitrary Char where+ arbitrary = choose ('\0', '\255') -- since we have to test words, unlines too+ coarbitrary c = variant (ord c `rem` 16)++instance Arbitrary Word8 where+ arbitrary = choose (minBound, maxBound)+ coarbitrary c = variant (fromIntegral ((fromIntegral c) `rem` 16))+-}++instance Random Word8 where+ randomR = integralRandomR+ random = randomR (minBound,maxBound)++instance Random Int64 where+ randomR = integralRandomR+ random = randomR (minBound,maxBound)++integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)+integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,+ fromIntegral b :: Integer) g of+ (x,g) -> (fromIntegral x, g)++instance Arbitrary V where+ arbitrary = V.pack `fmap` arbitrary+ coarbitrary s = coarbitrary (V.unpack s)++instance Arbitrary P.ByteString where+ arbitrary = P.pack `fmap` arbitrary+ coarbitrary s = coarbitrary (P.unpack s)++instance Functor ((->) r) where+ fmap = (.)++instance Monad ((->) r) where+ return = const+ f >>= k = \ r -> k (f r) r++instance Functor ((,) a) where+ fmap f (x,y) = (x, f y)++------------------------------------------------------------------------+--+-- We're doing two forms of testing here. Firstly, model based testing.+-- For our Lazy and strict bytestring types, we have model types:+--+-- i.e. Lazy == Byte+-- \\ //+-- List +--+-- That is, the Lazy type can be modeled by functions in both the Byte+-- and List type. For each of the 3 models, we have a set of tests that+-- check those types match.+--+-- The Model class connects a type and its model type, via a conversion+-- function. +--+--+class Model a b where+ model :: a -> b -- get the abstract value from a concrete value++--+-- Connecting our Lazy and Strict types to their models. We also check+-- the data invariant on Lazy types.+--+-- These instances represent the arrows in the above diagram+--+instance Model P [W] where model = P.unpack+instance Model P [Char] where model = PC.unpack+instance Model V [W] where model = V.unpack+instance Model V P where model = P.pack . V.unpack++-- Types are trivially modeled by themselves+instance Model Bool Bool where model = id+instance Model Int Int where model = id+instance Model Int64 Int64 where model = id+instance Model Int64 Int where model = fromIntegral+instance Model Word8 Word8 where model = id+instance Model Ordering Ordering where model = id+instance Model Char Char where model = id++-- More structured types are modeled recursively, using the NatTrans class from Gofer.+class (Functor f, Functor g) => NatTrans f g where+ eta :: f a -> g a++-- The transformation of the same type is identity+instance NatTrans [] [] where eta = id+instance NatTrans Maybe Maybe where eta = id+instance NatTrans ((->) X) ((->) X) where eta = id+instance NatTrans ((->) W) ((->) W) where eta = id+instance NatTrans ((->) Char) ((->) Char) where eta = id++-- We have a transformation of pairs, if the pairs are in Model+instance Model f g => NatTrans ((,) f) ((,) g) where eta (f,a) = (model f, a)++-- And finally, we can take any (m a) to (n b), if we can Model m n, and a b+instance (NatTrans m n, Model a b) => Model (m a) (n b) where model x = fmap model (eta x)++------------------------------------------------------------------------++-- Some short hand.+type X = Int+type W = Word8+type P = P.ByteString+type V = V.Vector Word8++------------------------------------------------------------------------+--+-- These comparison functions handle wrapping and equality.+--+-- A single class for these would be nice, but note that they differe in+-- the number of arguments, and those argument types, so we'd need HList+-- tricks. See here: http://okmij.org/ftp/Haskell/vararg-fn.lhs+--++eq1 f g = \a ->+ model (f a) == g (model a)+eq2 f g = \a b ->+ model (f a b) == g (model a) (model b)+eq3 f g = \a b c ->+ model (f a b c) == g (model a) (model b) (model c)+eq4 f g = \a b c d ->+ model (f a b c d) == g (model a) (model b) (model c) (model d)+eq5 f g = \a b c d e ->+ model (f a b c d e) == g (model a) (model b) (model c) (model d) (model e)++--+-- And for functions that take non-null input+--+eqnotnull1 f g = \x -> (not (isNull x)) ==> eq1 f g x+eqnotnull2 f g = \x y -> (not (isNull y)) ==> eq2 f g x y+eqnotnull3 f g = \x y z -> (not (isNull z)) ==> eq3 f g x y z++class IsNull t where isNull :: t -> Bool+instance IsNull P.ByteString where isNull = P.null+instance IsNull V where isNull = V.null++instance Show V where+ show = show . V.unpack