diff options
Diffstat (limited to 'testsuite/tests/lib/Data.ByteString/bytestring001.hs')
| -rw-r--r-- | testsuite/tests/lib/Data.ByteString/bytestring001.hs | 948 |
1 files changed, 948 insertions, 0 deletions
diff --git a/testsuite/tests/lib/Data.ByteString/bytestring001.hs b/testsuite/tests/lib/Data.ByteString/bytestring001.hs new file mode 100644 index 0000000000..00cfcb3763 --- /dev/null +++ b/testsuite/tests/lib/Data.ByteString/bytestring001.hs @@ -0,0 +1,948 @@ +#!/usr/bin/env runhaskell +-- +-- Uses multi-param type classes +-- + +import Test.QuickCheck.Batch +import Test.QuickCheck +import Text.Show.Functions + +import Data.Char +import Data.Int +import Data.List +import Data.Maybe +import Data.Word + +import System.IO +import System.Environment +import System.IO.Unsafe +import System.Random + +import Control.Monad ( liftM2 ) +import Control.Monad.Instances () + +import Text.Printf +import Debug.Trace + +import Foreign.Ptr + +import Data.ByteString.Lazy (ByteString(..), pack , unpack) +import qualified Data.ByteString.Lazy as L + +import Data.ByteString.Fusion +import qualified Data.ByteString as P +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Internal as L + +import qualified Data.ByteString.Char8 as PC +import qualified Data.ByteString.Lazy.Char8 as LC +import qualified Data.ByteString as P +import qualified Data.ByteString.Internal as P +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy.Char8 as D +import Data.ByteString.Fusion + +import Prelude hiding (abs) + +-- 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 let rnd = mkStdGen 99 + 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 L.ByteString where + arbitrary = arbitrary >>= return . L.fromChunks . filter (not. P.null) -- maintain the invariant. + coarbitrary s = coarbitrary (L.unpack s) + +instance Arbitrary P.ByteString where + arbitrary = P.pack `fmap` arbitrary + coarbitrary s = coarbitrary (P.unpack s) + +------------------------------------------------------------------------ +-- +-- 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 vale 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 B P where model = abstr . checkInvariant +instance Model P [W] where model = P.unpack +instance Model P [Char] where model = PC.unpack +instance Model B [W] where model = L.unpack . checkInvariant +instance Model B [Char] where model = LC.unpack . checkInvariant + +-- 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 + +-- 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 + +-- 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) + +------------------------------------------------------------------------ + +-- In a form more useful for QC testing (and it's lazy) +checkInvariant :: L.ByteString -> L.ByteString +checkInvariant cs0 = check cs0 + where check L.Empty = L.Empty + check (L.Chunk c cs) + | P.null c = error ("invariant violation: " ++ show cs0) + | otherwise = L.Chunk c (check cs) + +abstr :: L.ByteString -> P.ByteString +abstr = P.concat . L.toChunks + + +-- Some short hand. +type X = Int +type W = Word8 +type P = P.ByteString +type B = L.ByteString + +------------------------------------------------------------------------ +-- +-- 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 L.ByteString where isNull = L.null +instance IsNull P.ByteString where isNull = P.null + +------------------------------------------------------------------------ + + +-- +-- ByteString.Lazy <=> ByteString +-- + +prop_concatBP = L.concat `eq1` P.concat +prop_nullBP = L.null `eq1` P.null +prop_reverseBP = L.reverse `eq1` P.reverse +prop_transposeBP = L.transpose `eq1` P.transpose +prop_groupBP = L.group `eq1` P.group +prop_initsBP = L.inits `eq1` P.inits +prop_tailsBP = L.tails `eq1` P.tails +prop_allBP = L.all `eq2` P.all +prop_anyBP = L.any `eq2` P.any +prop_appendBP = L.append `eq2` P.append +prop_breakBP = L.break `eq2` P.break +-- prop_concatMapBP = L.concatMap `eq2` P.concatMap +prop_consBP = L.cons `eq2` P.cons +prop_countBP = L.count `eq2` P.count +prop_dropBP = L.drop `eq2` P.drop +prop_dropWhileBP = L.dropWhile `eq2` P.dropWhile +prop_filterBP = L.filter `eq2` P.filter +prop_findBP = L.find `eq2` P.find +prop_findIndexBP = L.findIndex `eq2` P.findIndex +prop_findIndicesBP = L.findIndices `eq2` P.findIndices +prop_isPrefixOfBP = L.isPrefixOf `eq2` P.isPrefixOf +prop_mapBP = L.map `eq2` P.map +prop_replicateBP = L.replicate `eq2` P.replicate +prop_snocBP = L.snoc `eq2` P.snoc +prop_spanBP = L.span `eq2` P.span +prop_splitBP = L.split `eq2` P.split +prop_splitAtBP = L.splitAt `eq2` P.splitAt +prop_takeBP = L.take `eq2` P.take +prop_takeWhileBP = L.takeWhile `eq2` P.takeWhile +prop_elemBP = L.elem `eq2` P.elem +prop_notElemBP = L.notElem `eq2` P.notElem +prop_elemIndexBP = L.elemIndex `eq2` P.elemIndex +prop_elemIndicesBP = L.elemIndices `eq2` P.elemIndices +prop_lengthBP = L.length `eq1` (fromIntegral . P.length :: P.ByteString -> Int64) +prop_readIntBP = D.readInt `eq1` C.readInt +prop_linesBP = D.lines `eq1` C.lines + +prop_headBP = L.head `eqnotnull1` P.head +prop_initBP = L.init `eqnotnull1` P.init +prop_lastBP = L.last `eqnotnull1` P.last +prop_maximumBP = L.maximum `eqnotnull1` P.maximum +prop_minimumBP = L.minimum `eqnotnull1` P.minimum +prop_tailBP = L.tail `eqnotnull1` P.tail +prop_foldl1BP = L.foldl1 `eqnotnull2` P.foldl1 +prop_foldl1BP' = L.foldl1' `eqnotnull2` P.foldl1' +prop_foldr1BP = L.foldr1 `eqnotnull2` P.foldr1 +prop_scanlBP = L.scanl `eqnotnull3` P.scanl + +prop_eqBP = eq2 + ((==) :: B -> B -> Bool) + ((==) :: P -> P -> Bool) +prop_compareBP = eq2 + ((compare) :: B -> B -> Ordering) + ((compare) :: P -> P -> Ordering) +prop_foldlBP = eq3 + (L.foldl :: (X -> W -> X) -> X -> B -> X) + (P.foldl :: (X -> W -> X) -> X -> P -> X) +prop_foldlBP' = eq3 + (L.foldl' :: (X -> W -> X) -> X -> B -> X) + (P.foldl' :: (X -> W -> X) -> X -> P -> X) +prop_foldrBP = eq3 + (L.foldr :: (W -> X -> X) -> X -> B -> X) + (P.foldr :: (W -> X -> X) -> X -> P -> X) +prop_mapAccumLBP = eq3 + (L.mapAccumL :: (X -> W -> (X,W)) -> X -> B -> (X, B)) + (P.mapAccumL :: (X -> W -> (X,W)) -> X -> P -> (X, P)) + +prop_unfoldrBP = eq3 + ((\n f a -> L.take (fromIntegral n) $ + L.unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> B) + ((\n f a -> fst $ + P.unfoldrN n f a) :: Int -> (X -> Maybe (W,X)) -> X -> P) + +-- +-- properties comparing ByteString.Lazy `eq1` List +-- + +prop_concatBL = L.concat `eq1` (concat :: [[W]] -> [W]) +prop_lengthBL = L.length `eq1` (length :: [W] -> Int) +prop_nullBL = L.null `eq1` (null :: [W] -> Bool) +prop_reverseBL = L.reverse `eq1` (reverse :: [W] -> [W]) +prop_transposeBL = L.transpose `eq1` (transpose :: [[W]] -> [[W]]) +prop_groupBL = L.group `eq1` (group :: [W] -> [[W]]) +prop_initsBL = L.inits `eq1` (inits :: [W] -> [[W]]) +prop_tailsBL = L.tails `eq1` (tails :: [W] -> [[W]]) +prop_allBL = L.all `eq2` (all :: (W -> Bool) -> [W] -> Bool) +prop_anyBL = L.any `eq2` (any :: (W -> Bool) -> [W] -> Bool) +prop_appendBL = L.append `eq2` ((++) :: [W] -> [W] -> [W]) +prop_breakBL = L.break `eq2` (break :: (W -> Bool) -> [W] -> ([W],[W])) +-- prop_concatMapBL = L.concatMap `eq2` (concatMap :: (W -> [W]) -> [W] -> [W]) +prop_consBL = L.cons `eq2` ((:) :: W -> [W] -> [W]) +prop_dropBL = L.drop `eq2` (drop :: Int -> [W] -> [W]) +prop_dropWhileBL = L.dropWhile `eq2` (dropWhile :: (W -> Bool) -> [W] -> [W]) +prop_filterBL = L.filter `eq2` (filter :: (W -> Bool ) -> [W] -> [W]) +prop_findBL = L.find `eq2` (find :: (W -> Bool) -> [W] -> Maybe W) +prop_findIndicesBL = L.findIndices `eq2` (findIndices:: (W -> Bool) -> [W] -> [Int]) +prop_findIndexBL = L.findIndex `eq2` (findIndex :: (W -> Bool) -> [W] -> Maybe Int) +prop_isPrefixOfBL = L.isPrefixOf `eq2` (isPrefixOf:: [W] -> [W] -> Bool) +prop_mapBL = L.map `eq2` (map :: (W -> W) -> [W] -> [W]) +prop_replicateBL = L.replicate `eq2` (replicate :: Int -> W -> [W]) +prop_snocBL = L.snoc `eq2` ((\xs x -> xs ++ [x]) :: [W] -> W -> [W]) +prop_spanBL = L.span `eq2` (span :: (W -> Bool) -> [W] -> ([W],[W])) +prop_splitAtBL = L.splitAt `eq2` (splitAt :: Int -> [W] -> ([W],[W])) +prop_takeBL = L.take `eq2` (take :: Int -> [W] -> [W]) +prop_takeWhileBL = L.takeWhile `eq2` (takeWhile :: (W -> Bool) -> [W] -> [W]) +prop_elemBL = L.elem `eq2` (elem :: W -> [W] -> Bool) +prop_notElemBL = L.notElem `eq2` (notElem :: W -> [W] -> Bool) +prop_elemIndexBL = L.elemIndex `eq2` (elemIndex :: W -> [W] -> Maybe Int) +prop_elemIndicesBL = L.elemIndices `eq2` (elemIndices:: W -> [W] -> [Int]) +prop_linesBL = D.lines `eq1` (lines :: String -> [String]) + +prop_foldl1BL = L.foldl1 `eqnotnull2` (foldl1 :: (W -> W -> W) -> [W] -> W) +prop_foldl1BL' = L.foldl1' `eqnotnull2` (foldl1' :: (W -> W -> W) -> [W] -> W) +prop_foldr1BL = L.foldr1 `eqnotnull2` (foldr1 :: (W -> W -> W) -> [W] -> W) +prop_headBL = L.head `eqnotnull1` (head :: [W] -> W) +prop_initBL = L.init `eqnotnull1` (init :: [W] -> [W]) +prop_lastBL = L.last `eqnotnull1` (last :: [W] -> W) +prop_maximumBL = L.maximum `eqnotnull1` (maximum :: [W] -> W) +prop_minimumBL = L.minimum `eqnotnull1` (minimum :: [W] -> W) +prop_tailBL = L.tail `eqnotnull1` (tail :: [W] -> [W]) + +prop_eqBL = eq2 + ((==) :: B -> B -> Bool) + ((==) :: [W] -> [W] -> Bool) +prop_compareBL = eq2 + ((compare) :: B -> B -> Ordering) + ((compare) :: [W] -> [W] -> Ordering) +prop_foldlBL = eq3 + (L.foldl :: (X -> W -> X) -> X -> B -> X) + ( foldl :: (X -> W -> X) -> X -> [W] -> X) +prop_foldlBL' = eq3 + (L.foldl' :: (X -> W -> X) -> X -> B -> X) + ( foldl' :: (X -> W -> X) -> X -> [W] -> X) +prop_foldrBL = eq3 + (L.foldr :: (W -> X -> X) -> X -> B -> X) + ( foldr :: (W -> X -> X) -> X -> [W] -> X) +prop_mapAccumLBL = eq3 + (L.mapAccumL :: (X -> W -> (X,W)) -> X -> B -> (X, B)) + ( mapAccumL :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W])) +prop_unfoldrBL = eq3 + ((\n f a -> L.take (fromIntegral n) $ + L.unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> B) + ((\n f a -> take n $ + unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> [W]) + +-- +-- And finally, check correspondance between Data.ByteString and List +-- + +prop_lengthPL = (fromIntegral.P.length :: P -> Int) `eq1` (length :: [W] -> Int) +prop_nullPL = P.null `eq1` (null :: [W] -> Bool) +prop_reversePL = P.reverse `eq1` (reverse :: [W] -> [W]) +prop_transposePL = P.transpose `eq1` (transpose :: [[W]] -> [[W]]) +prop_groupPL = P.group `eq1` (group :: [W] -> [[W]]) +prop_initsPL = P.inits `eq1` (inits :: [W] -> [[W]]) +prop_tailsPL = P.tails `eq1` (tails :: [W] -> [[W]]) +prop_concatPL = P.concat `eq1` (concat :: [[W]] -> [W]) +prop_allPL = P.all `eq2` (all :: (W -> Bool) -> [W] -> Bool) +prop_anyPL = P.any `eq2` (any :: (W -> Bool) -> [W] -> Bool) +prop_appendPL = P.append `eq2` ((++) :: [W] -> [W] -> [W]) +prop_breakPL = P.break `eq2` (break :: (W -> Bool) -> [W] -> ([W],[W])) +-- prop_concatMapPL = P.concatMap `eq2` (concatMap :: (W -> [W]) -> [W] -> [W]) +prop_consPL = P.cons `eq2` ((:) :: W -> [W] -> [W]) +prop_dropPL = P.drop `eq2` (drop :: Int -> [W] -> [W]) +prop_dropWhilePL = P.dropWhile `eq2` (dropWhile :: (W -> Bool) -> [W] -> [W]) +prop_filterPL = P.filter `eq2` (filter :: (W -> Bool ) -> [W] -> [W]) +prop_findPL = P.find `eq2` (find :: (W -> Bool) -> [W] -> Maybe W) +prop_findIndexPL = P.findIndex `eq2` (findIndex :: (W -> Bool) -> [W] -> Maybe Int) +prop_isPrefixOfPL = P.isPrefixOf`eq2` (isPrefixOf:: [W] -> [W] -> Bool) +prop_mapPL = P.map `eq2` (map :: (W -> W) -> [W] -> [W]) +prop_replicatePL = P.replicate `eq2` (replicate :: Int -> W -> [W]) +prop_snocPL = P.snoc `eq2` ((\xs x -> xs ++ [x]) :: [W] -> W -> [W]) +prop_spanPL = P.span `eq2` (span :: (W -> Bool) -> [W] -> ([W],[W])) +prop_splitAtPL = P.splitAt `eq2` (splitAt :: Int -> [W] -> ([W],[W])) +prop_takePL = P.take `eq2` (take :: Int -> [W] -> [W]) +prop_takeWhilePL = P.takeWhile `eq2` (takeWhile :: (W -> Bool) -> [W] -> [W]) +prop_elemPL = P.elem `eq2` (elem :: W -> [W] -> Bool) +prop_notElemPL = P.notElem `eq2` (notElem :: W -> [W] -> Bool) +prop_elemIndexPL = P.elemIndex `eq2` (elemIndex :: W -> [W] -> Maybe Int) +prop_linesPL = C.lines `eq1` (lines :: String -> [String]) +prop_findIndicesPL= P.findIndices`eq2` (findIndices:: (W -> Bool) -> [W] -> [Int]) +prop_elemIndicesPL= P.elemIndices`eq2` (elemIndices:: W -> [W] -> [Int]) + +prop_foldl1PL = P.foldl1 `eqnotnull2` (foldl1 :: (W -> W -> W) -> [W] -> W) +prop_foldl1PL' = P.foldl1' `eqnotnull2` (foldl1' :: (W -> W -> W) -> [W] -> W) +prop_foldr1PL = P.foldr1 `eqnotnull2` (foldr1 :: (W -> W -> W) -> [W] -> W) +prop_scanlPL = P.scanl `eqnotnull3` (scanl :: (W -> W -> W) -> W -> [W] -> [W]) +prop_scanl1PL = P.scanl1 `eqnotnull2` (scanl1 :: (W -> W -> W) -> [W] -> [W]) +prop_scanrPL = P.scanr `eqnotnull3` (scanr :: (W -> W -> W) -> W -> [W] -> [W]) +prop_scanr1PL = P.scanr1 `eqnotnull2` (scanr1 :: (W -> W -> W) -> [W] -> [W]) +prop_headPL = P.head `eqnotnull1` (head :: [W] -> W) +prop_initPL = P.init `eqnotnull1` (init :: [W] -> [W]) +prop_lastPL = P.last `eqnotnull1` (last :: [W] -> W) +prop_maximumPL = P.maximum `eqnotnull1` (maximum :: [W] -> W) +prop_minimumPL = P.minimum `eqnotnull1` (minimum :: [W] -> W) +prop_tailPL = P.tail `eqnotnull1` (tail :: [W] -> [W]) + +prop_eqPL = eq2 + ((==) :: P -> P -> Bool) + ((==) :: [W] -> [W] -> Bool) +prop_comparePL = eq2 + ((compare) :: P -> P -> Ordering) + ((compare) :: [W] -> [W] -> Ordering) +prop_foldlPL = eq3 + (P.foldl :: (X -> W -> X) -> X -> P -> X) + ( foldl :: (X -> W -> X) -> X -> [W] -> X) +prop_foldlPL' = eq3 + (P.foldl' :: (X -> W -> X) -> X -> P -> X) + ( foldl' :: (X -> W -> X) -> X -> [W] -> X) +prop_foldrPL = eq3 + (P.foldr :: (W -> X -> X) -> X -> P -> X) + ( foldr :: (W -> X -> X) -> X -> [W] -> X) +prop_mapAccumLPL= eq3 + (P.mapAccumL :: (X -> W -> (X,W)) -> X -> P -> (X, P)) + ( mapAccumL :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W])) +prop_mapAccumRPL= eq3 + (P.mapAccumR :: (X -> W -> (X,W)) -> X -> P -> (X, P)) + ( mapAccumR :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W])) +prop_unfoldrPL = eq3 + ((\n f a -> fst $ + P.unfoldrN n f a) :: Int -> (X -> Maybe (W,X)) -> X -> P) + ((\n f a -> take n $ + unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> [W]) + +------------------------------------------------------------------------ +-- +-- And check fusion RULES. +-- + +prop_lazylooploop em1 em2 start1 start2 arr = + loopL em2 start2 (loopArr (loopL em1 start1 arr)) == + loopSndAcc (loopL (em1 `fuseEFL` em2) (start1 :*: start2) arr) + where + _ = start1 :: Int + _ = start2 :: Int + +prop_looploop em1 em2 start1 start2 arr = + loopU em2 start2 (loopArr (loopU em1 start1 arr)) == + loopSndAcc (loopU (em1 `fuseEFL` em2) (start1 :*: start2) arr) + where + _ = start1 :: Int + _ = start2 :: Int + +------------------------------------------------------------------------ + +-- check associativity of sequence loops +prop_sequenceloops_assoc n m o x y z a1 a2 a3 xs = + + k ((f * g) * h) == k (f * (g * h)) -- associativity + + where + (*) = sequenceLoops + f = (sel n) x a1 + g = (sel m) y a2 + h = (sel o) z a3 + + _ = a1 :: Int; _ = a2 :: Int; _ = a3 :: Int + k g = loopArr (loopWrapper g xs) + +-- check wrapper elimination +prop_loop_loop_wrapper_elimination n m x y a1 a2 xs = + loopWrapper g (loopArr (loopWrapper f xs)) == + loopSndAcc (loopWrapper (sequenceLoops f g) xs) + where + f = (sel n) x a1 + g = (sel m) y a2 + _ = a1 :: Int; _ = a2 :: Int + +sel :: Bool + -> (acc -> Word8 -> PairS acc (MaybeS Word8)) + -> acc + -> Ptr Word8 + -> Ptr Word8 + -> Int + -> IO (PairS (PairS acc Int) Int) +sel False = doDownLoop +sel True = doUpLoop + +------------------------------------------------------------------------ +-- +-- Test fusion forms +-- + +prop_up_up_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doUpLoop f1 acc1) (doUpLoop f2 acc2)) == + k (doUpLoop (f1 `fuseAccAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int; k g = loopWrapper g xs + +prop_down_down_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doDownLoop f1 acc1) (doDownLoop f2 acc2)) == + k (doDownLoop (f1 `fuseAccAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int ; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_noAcc_noAcc_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doNoAccLoop f1 acc1) (doNoAccLoop f2 acc2)) == + k (doNoAccLoop (f1 `fuseNoAccNoAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int ; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_noAcc_up_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doNoAccLoop f1 acc1) (doUpLoop f2 acc2)) == + k (doUpLoop (f1 `fuseNoAccAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int; k g = loopWrapper g xs + +prop_up_noAcc_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doUpLoop f1 acc1) (doNoAccLoop f2 acc2)) == + k (doUpLoop (f1 `fuseAccNoAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int; k g = loopWrapper g xs + +prop_noAcc_down_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doNoAccLoop f1 acc1) (doDownLoop f2 acc2)) == + k (doDownLoop (f1 `fuseNoAccAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_down_noAcc_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doDownLoop f1 acc1) (doNoAccLoop f2 acc2)) == + k (doDownLoop (f1 `fuseAccNoAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int; k g = loopWrapper g xs + +prop_map_map_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doMapLoop f1 acc1) (doMapLoop f2 acc2)) == + k (doMapLoop (f1 `fuseMapMapEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_filter_filter_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doFilterLoop f1 acc1) (doFilterLoop f2 acc2)) == + k (doFilterLoop (f1 `fuseFilterFilterEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_map_filter_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doMapLoop f1 acc1) (doFilterLoop f2 acc2)) == + k (doNoAccLoop (f1 `fuseMapFilterEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_filter_map_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doFilterLoop f1 acc1) (doMapLoop f2 acc2)) == + k (doNoAccLoop (f1 `fuseFilterMapEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_map_noAcc_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doMapLoop f1 acc1) (doNoAccLoop f2 acc2)) == + k (doNoAccLoop (f1 `fuseMapNoAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_noAcc_map_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doNoAccLoop f1 acc1) (doMapLoop f2 acc2)) == + k (doNoAccLoop (f1 `fuseNoAccMapEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_map_up_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doMapLoop f1 acc1) (doUpLoop f2 acc2)) == + k (doUpLoop (f1 `fuseMapAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_up_map_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doUpLoop f1 acc1) (doMapLoop f2 acc2)) == + k (doUpLoop (f1 `fuseAccMapEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_map_down_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doMapLoop f1 acc1) (doDownLoop f2 acc2)) == + k (doDownLoop (f1 `fuseMapAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_down_map_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doDownLoop f1 acc1) (doMapLoop f2 acc2)) == + k (doDownLoop (f1 `fuseAccMapEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_filter_noAcc_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doFilterLoop f1 acc1) (doNoAccLoop f2 acc2)) == + k (doNoAccLoop (f1 `fuseFilterNoAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_noAcc_filter_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doNoAccLoop f1 acc1) (doFilterLoop f2 acc2)) == + k (doNoAccLoop (f1 `fuseNoAccFilterEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_filter_up_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doFilterLoop f1 acc1) (doUpLoop f2 acc2)) == + k (doUpLoop (f1 `fuseFilterAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_up_filter_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doUpLoop f1 acc1) (doFilterLoop f2 acc2)) == + k (doUpLoop (f1 `fuseAccFilterEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_filter_down_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doFilterLoop f1 acc1) (doDownLoop f2 acc2)) == + k (doDownLoop (f1 `fuseFilterAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_down_filter_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doDownLoop f1 acc1) (doFilterLoop f2 acc2)) == + k (doDownLoop (f1 `fuseAccFilterEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +------------------------------------------------------------------------ + +prop_length_loop_fusion_1 f1 acc1 xs = + P.length (loopArr (loopWrapper (doUpLoop f1 acc1) xs)) == + P.foldl' (const . (+1)) 0 (loopArr (loopWrapper (doUpLoop f1 acc1) xs)) + where _ = acc1 :: Int + +prop_length_loop_fusion_2 f1 acc1 xs = + P.length (loopArr (loopWrapper (doDownLoop f1 acc1) xs)) == + P.foldl' (const . (+1)) 0 (loopArr (loopWrapper (doDownLoop f1 acc1) xs)) + where _ = acc1 :: Int + +prop_length_loop_fusion_3 f1 acc1 xs = + P.length (loopArr (loopWrapper (doMapLoop f1 acc1) xs)) == + P.foldl' (const . (+1)) 0 (loopArr (loopWrapper (doMapLoop f1 acc1) xs)) + where _ = acc1 :: Int + +prop_length_loop_fusion_4 f1 acc1 xs = + P.length (loopArr (loopWrapper (doFilterLoop f1 acc1) xs)) == + P.foldl' (const . (+1)) 0 (loopArr (loopWrapper (doFilterLoop f1 acc1) xs)) + where _ = acc1 :: Int + +------------------------------------------------------------------------ +-- The entry point + +main :: IO () +main = myrun tests + +myrun :: [(String, Int -> IO ())] -> IO () +myrun tests = do + x <- getArgs + let n = if null x then 100 else read . head $ x + mapM_ (\(s,a) -> printf "%-25s: " s >> a n) tests + +-- +-- And now a list of all the properties to test. +-- + +tests = misc_tests + ++ bl_tests + ++ bp_tests + ++ pl_tests + ++ fusion_tests + +misc_tests = + [("invariant", mytest prop_invariant)] + +------------------------------------------------------------------------ +-- ByteString.Lazy <=> List + +bl_tests = + [("all", mytest prop_allBL) + ,("any", mytest prop_anyBL) + ,("append", mytest prop_appendBL) + ,("compare", mytest prop_compareBL) + ,("concat", mytest prop_concatBL) + ,("cons", mytest prop_consBL) + ,("eq", mytest prop_eqBL) + ,("filter", mytest prop_filterBL) + ,("find", mytest prop_findBL) + ,("findIndex", mytest prop_findIndexBL) + ,("findIndices", mytest prop_findIndicesBL) + ,("foldl", mytest prop_foldlBL) + ,("foldl'", mytest prop_foldlBL') + ,("foldl1", mytest prop_foldl1BL) + ,("foldl1'", mytest prop_foldl1BL') + ,("foldr", mytest prop_foldrBL) + ,("foldr1", mytest prop_foldr1BL) + ,("mapAccumL", mytest prop_mapAccumLBL) + ,("unfoldr", mytest prop_unfoldrBL) + ,("head", mytest prop_headBL) + ,("init", mytest prop_initBL) + ,("isPrefixOf", mytest prop_isPrefixOfBL) + ,("last", mytest prop_lastBL) + ,("length", mytest prop_lengthBL) + ,("map", mytest prop_mapBL) + ,("maximum", mytest prop_maximumBL) + ,("minimum", mytest prop_minimumBL) + ,("null", mytest prop_nullBL) + ,("reverse", mytest prop_reverseBL) + ,("snoc", mytest prop_snocBL) + ,("tail", mytest prop_tailBL) + ,("transpose", mytest prop_transposeBL) + ,("replicate", mytest prop_replicateBL) + ,("take", mytest prop_takeBL) + ,("drop", mytest prop_dropBL) + ,("splitAt", mytest prop_splitAtBL) + ,("takeWhile", mytest prop_takeWhileBL) + ,("dropWhile", mytest prop_dropWhileBL) + ,("break", mytest prop_breakBL) + ,("span", mytest prop_spanBL) + ,("group", mytest prop_groupBL) + ,("inits", mytest prop_initsBL) + ,("tails", mytest prop_tailsBL) + ,("elem", mytest prop_elemBL) + ,("notElem", mytest prop_notElemBL) + ,("lines", mytest prop_linesBL) + ,("elemIndex", mytest prop_elemIndexBL) + ,("elemIndices", mytest prop_elemIndicesBL) +-- ,("concatMap", mytest prop_concatMapBL) + ] + +------------------------------------------------------------------------ +-- ByteString.Lazy <=> ByteString + +bp_tests = + [("all", mytest prop_allBP) + ,("any", mytest prop_anyBP) + ,("append", mytest prop_appendBP) + ,("compare", mytest prop_compareBP) + ,("concat", mytest prop_concatBP) + ,("cons", mytest prop_consBP) + ,("eq", mytest prop_eqBP) + ,("filter", mytest prop_filterBP) + ,("find", mytest prop_findBP) + ,("findIndex", mytest prop_findIndexBP) + ,("findIndices", mytest prop_findIndicesBP) + ,("foldl", mytest prop_foldlBP) + ,("foldl'", mytest prop_foldlBP') + ,("foldl1", mytest prop_foldl1BP) + ,("foldl1'", mytest prop_foldl1BP') + ,("foldr", mytest prop_foldrBP) + ,("foldr1", mytest prop_foldr1BP) + ,("mapAccumL", mytest prop_mapAccumLBP) + ,("unfoldr", mytest prop_unfoldrBP) + ,("head", mytest prop_headBP) + ,("init", mytest prop_initBP) + ,("isPrefixOf", mytest prop_isPrefixOfBP) + ,("last", mytest prop_lastBP) + ,("length", mytest prop_lengthBP) + ,("readInt", mytest prop_readIntBP) + ,("lines", mytest prop_linesBP) + ,("map", mytest prop_mapBP) + ,("maximum ", mytest prop_maximumBP) + ,("minimum" , mytest prop_minimumBP) + ,("null", mytest prop_nullBP) + ,("reverse", mytest prop_reverseBP) + ,("snoc", mytest prop_snocBP) + ,("tail", mytest prop_tailBP) + ,("scanl", mytest prop_scanlBP) + ,("transpose", mytest prop_transposeBP) + ,("replicate", mytest prop_replicateBP) + ,("take", mytest prop_takeBP) + ,("drop", mytest prop_dropBP) + ,("splitAt", mytest prop_splitAtBP) + ,("takeWhile", mytest prop_takeWhileBP) + ,("dropWhile", mytest prop_dropWhileBP) + ,("break", mytest prop_breakBP) + ,("span", mytest prop_spanBP) + ,("split", mytest prop_splitBP) + ,("count", mytest prop_countBP) + ,("group", mytest prop_groupBP) + ,("inits", mytest prop_initsBP) + ,("tails", mytest prop_tailsBP) + ,("elem", mytest prop_elemBP) + ,("notElem", mytest prop_notElemBP) + ,("elemIndex", mytest prop_elemIndexBP) + ,("elemIndices", mytest prop_elemIndicesBP) +-- ,("concatMap", mytest prop_concatMapBP) + ] + +------------------------------------------------------------------------ +-- ByteString <=> List + +pl_tests = + [("all", mytest prop_allPL) + ,("any", mytest prop_anyPL) + ,("append", mytest prop_appendPL) + ,("compare", mytest prop_comparePL) + ,("concat", mytest prop_concatPL) + ,("cons", mytest prop_consPL) + ,("eq", mytest prop_eqPL) + ,("filter", mytest prop_filterPL) + ,("find", mytest prop_findPL) + ,("findIndex", mytest prop_findIndexPL) + ,("findIndices", mytest prop_findIndicesPL) + ,("foldl", mytest prop_foldlPL) + ,("foldl'", mytest prop_foldlPL') + ,("foldl1", mytest prop_foldl1PL) + ,("foldl1'", mytest prop_foldl1PL') + ,("foldr1", mytest prop_foldr1PL) + ,("foldr", mytest prop_foldrPL) + ,("mapAccumL", mytest prop_mapAccumLPL) + ,("mapAccumR", mytest prop_mapAccumRPL) + ,("unfoldr", mytest prop_unfoldrPL) + ,("scanl", mytest prop_scanlPL) + ,("scanl1", mytest prop_scanl1PL) + ,("scanr", mytest prop_scanrPL) + ,("scanr1", mytest prop_scanr1PL) + ,("head", mytest prop_headPL) + ,("init", mytest prop_initPL) + ,("last", mytest prop_lastPL) + ,("maximum", mytest prop_maximumPL) + ,("minimum", mytest prop_minimumPL) + ,("tail", mytest prop_tailPL) + ,("isPrefixOf", mytest prop_isPrefixOfPL) + ,("length", mytest prop_lengthPL) + ,("map", mytest prop_mapPL) + ,("null", mytest prop_nullPL) + ,("reverse", mytest prop_reversePL) + ,("snoc", mytest prop_snocPL) + ,("transpose", mytest prop_transposePL) + ,("replicate", mytest prop_replicatePL) + ,("take", mytest prop_takePL) + ,("drop", mytest prop_dropPL) + ,("splitAt", mytest prop_splitAtPL) + ,("takeWhile", mytest prop_takeWhilePL) + ,("dropWhile", mytest prop_dropWhilePL) + ,("break", mytest prop_breakPL) + ,("span", mytest prop_spanPL) + ,("group", mytest prop_groupPL) + ,("inits", mytest prop_initsPL) + ,("tails", mytest prop_tailsPL) + ,("elem", mytest prop_elemPL) + ,("notElem", mytest prop_notElemPL) + ,("lines", mytest prop_linesBL) + ,("elemIndex", mytest prop_elemIndexPL) + ,("elemIndices", mytest prop_elemIndicesPL) +-- ,("concatMap", mytest prop_concatMapPL) + ] + +------------------------------------------------------------------------ +-- Fusion rules + +fusion_tests = +-- v1 fusion + [ ("lazy loop/loop fusion", mytest prop_lazylooploop) + , ("loop/loop fusion", mytest prop_looploop) + +-- v2 fusion + ,("loop/loop wrapper elim", mytest prop_loop_loop_wrapper_elimination) + ,("sequence association", mytest prop_sequenceloops_assoc) + + ,("up/up loop fusion", mytest prop_up_up_loop_fusion) + ,("down/down loop fusion", mytest prop_down_down_loop_fusion) + ,("noAcc/noAcc loop fusion", mytest prop_noAcc_noAcc_loop_fusion) + ,("noAcc/up loop fusion", mytest prop_noAcc_up_loop_fusion) + ,("up/noAcc loop fusion", mytest prop_up_noAcc_loop_fusion) + ,("noAcc/down loop fusion", mytest prop_noAcc_down_loop_fusion) + ,("down/noAcc loop fusion", mytest prop_down_noAcc_loop_fusion) + ,("map/map loop fusion", mytest prop_map_map_loop_fusion) + ,("filter/filter loop fusion", mytest prop_filter_filter_loop_fusion) + ,("map/filter loop fusion", mytest prop_map_filter_loop_fusion) + ,("filter/map loop fusion", mytest prop_filter_map_loop_fusion) + ,("map/noAcc loop fusion", mytest prop_map_noAcc_loop_fusion) + ,("noAcc/map loop fusion", mytest prop_noAcc_map_loop_fusion) + ,("map/up loop fusion", mytest prop_map_up_loop_fusion) + ,("up/map loop fusion", mytest prop_up_map_loop_fusion) + ,("map/down loop fusion", mytest prop_map_down_fusion) + ,("down/map loop fusion", mytest prop_down_map_loop_fusion) + ,("filter/noAcc loop fusion", mytest prop_filter_noAcc_loop_fusion) + ,("noAcc/filter loop fusion", mytest prop_noAcc_filter_loop_fusion) + ,("filter/up loop fusion", mytest prop_filter_up_loop_fusion) + ,("up/filter loop fusion", mytest prop_up_filter_loop_fusion) + ,("filter/down loop fusion", mytest prop_filter_down_fusion) + ,("down/filter loop fusion", mytest prop_down_filter_loop_fusion) + + ,("length/loop fusion", mytest prop_length_loop_fusion_1) + ,("length/loop fusion", mytest prop_length_loop_fusion_2) + ,("length/loop fusion", mytest prop_length_loop_fusion_3) + ,("length/loop fusion", mytest prop_length_loop_fusion_4) + ] + + +------------------------------------------------------------------------ +-- +-- These are miscellaneous tests left over. Or else they test some +-- property internal to a type (i.e. head . sort == minimum), without +-- reference to a model type. +-- + +invariant :: L.ByteString -> Bool +invariant L.Empty = True +invariant (L.Chunk c cs) = not (P.null c) && invariant cs + +prop_invariant = invariant + |