Add a test for gh-75

attoparsec.cabal

@@ -84,6 +84,8 @@ test-suite tests
                   QC.ByteString
                   QC.Combinator
                   QC.Common
+                  QC.Rechunked
+                  QC.Simple
                   QC.Text
 
   ghc-options:
@@ -101,7 +103,8 @@ test-suite tests
     scientific,
     test-framework >= 0.8.0.2,
     test-framework-quickcheck2 >= 0.3.0.3,
-    text
+    text,
+    vector
 
 benchmark benchmarks
   type: exitcode-stdio-1.0

tests/QC.hs

@@ -4,6 +4,7 @@ module Main (main) where
 import qualified QC.Buffer as Buffer
 import qualified QC.ByteString as ByteString
 import qualified QC.Combinator as Combinator
+import qualified QC.Simple as Simple
 import qualified QC.Text as Text
 import Test.Framework (defaultMain, testGroup)
 
@@ -13,5 +14,6 @@ tests = [
     testGroup "bs" ByteString.tests
   , testGroup "buf" Buffer.tests
   , testGroup "combinator" Combinator.tests
+  , testGroup "simple" Simple.tests
   , testGroup "text" Text.tests
   ]

tests/QC/Rechunked.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE BangPatterns #-}
+
+module QC.Rechunked (
+      rechunkBS
+    , rechunkT
+    ) where
+
+import Control.Monad (forM, forM_)
+import Control.Monad.ST (runST)
+import Data.List (unfoldr)
+import Test.QuickCheck (Gen, choose)
+import qualified Data.ByteString as B
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import qualified Data.Vector.Generic as G
+import qualified Data.Vector.Generic.Mutable as M
+
+rechunkBS :: B.ByteString -> Gen [B.ByteString]
+rechunkBS = fmap (map B.copy) . rechunk_ B.splitAt B.length
+
+rechunkT :: T.Text -> Gen [T.Text]
+rechunkT = fmap (map T.copy) . rechunk_ T.splitAt T.length
+
+rechunk_ :: (Int -> a -> (a,a)) -> (a -> Int) -> a -> Gen [a]
+rechunk_ split len xs = (unfoldr go . (,) xs) `fmap` rechunkSizes (len xs)
+  where go (b,r:rs)   = Just (h, (t,rs))
+          where (h,t) = split r b
+        go (_,_)      = Nothing
+
+rechunkSizes :: Int -> Gen [Int]
+rechunkSizes n0 = shuffle =<< loop [] (0:repeat 1) n0
+  where loop acc (lb:lbs) n
+          | n <= 0 = shuffle (reverse acc)
+          | otherwise = do
+            !i <- choose (lb,n)
+            loop (i:acc) lbs (n-i)
+
+shuffle :: [Int] -> Gen [Int]
+shuffle (0:xs) = (0:) `fmap` shuffle xs
+shuffle xs = fisherYates xs
+
+fisherYates :: [a] -> Gen [a]
+fisherYates xs = (V.toList . V.backpermute v) `fmap` swapIndices (G.length v)
+  where
+    v = V.fromList xs
+    swapIndices n0 = do
+        swaps <- forM [0..n] $ \i -> ((,) i) `fmap` choose (i,n)
+        return (runST (swapAll swaps))
+      where
+        n = n0 - 1
+        swapAll ijs = do
+          mv <- G.unsafeThaw (G.enumFromTo 0 n :: V.Vector Int)
+          forM_ ijs $ uncurry (M.swap mv)
+          G.unsafeFreeze mv

tests/QC/Simple.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+
+module QC.Simple (
+      tests
+    ) where
+
+import Control.Applicative ((<|>))
+import Data.ByteString (ByteString)
+import Data.List
+import Data.Maybe
+import QC.Rechunked
+import Test.Framework (Test)
+import Test.Framework.Providers.QuickCheck2 (testProperty)
+import Test.QuickCheck
+import qualified Data.Attoparsec.ByteString.Char8 as A
+
+data Expect a b = Expect a b
+                deriving (Show)
+
+t_issue75 = expect issue75 "ab" (A.Done "" "b")
+
+issue75 :: A.Parser ByteString
+issue75 = "a" >> ("b" <|> "")
+
+expect :: (Show r, Eq r) => A.Parser r -> ByteString -> A.Result r -> Property
+expect p input wanted =
+  forAll (rechunkBS input) $ \in' ->
+    let result = parse p in'
+    in counterexample (show result ++ " /= " ++ show wanted) $
+       fromMaybe False (A.compareResults result wanted)
+
+parse :: A.Parser r -> [ByteString] -> A.Result r
+parse p (x:xs) = foldl' A.feed (A.parse p x) xs
+parse p []     = A.parse p ""
+
+tests :: [Test]
+tests = [
+      testProperty "issue75" t_issue75
+  ]