picoparsec 0.1 → 0.1.1

raw patch · 32 files changed

+927/−588 lines, 32 filesdep +case-insensitivedep +ghc-primdep +http-typesdep ~QuickCheckdep ~basedep ~bytestringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: case-insensitive, ghc-prim, http-types, quickcheck-unicode

Dependency ranges changed: QuickCheck, base, bytestring, criterion, deepseq, scientific, text

API changes (from Hackage documentation)

Files

• Data/Picoparsec.hs +26/−12
• Data/Picoparsec/Combinator.hs +14/−41
• Data/Picoparsec/Internal.hs +42/−22
• Data/Picoparsec/Internal/Types.hs +33/−45
• Data/Picoparsec/Monoid/Internal.hs +23/−55
• Data/Picoparsec/Number.hs +5/−0
• Data/Picoparsec/Text/FastSet.hs +0/−63
• benchmarks/AttoAeson.hs +2/−1
• benchmarks/Benchmarks.hs +8/−17
• benchmarks/Common.hs +47/−0
• benchmarks/HeadersByteString.hs +19/−37
• benchmarks/HeadersByteString/Atto.hs +49/−0
• benchmarks/HeadersText.hs +15/−5
• benchmarks/PicoAeson.hs +2/−1
• benchmarks/Warp.hs +17/−0
• benchmarks/picoparsec-benchmarks.cabal +11/−4
• changelog.md +38/−0
• examples/Atto_RFC2616.hs +45/−0
• examples/Makefile +6/−2
• examples/Parsec_RFC2616.hs +9/−6
• examples/RFC2616.hs +24/−49
• examples/TestRFC2616.hs +0/−37
• examples/rfc2616.c +27/−21
• picoparsec.cabal +38/−16
• tests/Makefile +0/−14
• tests/QC.hs +9/−1
• tests/QC/Combinator.hs +43/−0
• tests/QC/Common.hs +86/−0
• tests/QC/Monoid.hs +193/−114
• tests/QC/Rechunked.hs +56/−0
• tests/QC/Simple.hs +40/−0
• tests/TestFastSet.hs +0/−25

@@ -44,11 +44,9 @@     , maybeResult     , eitherResult -    -- * Combinators-    , module Data.Picoparsec.Combinator-     -- * Parsing individual tokens     , I.anyToken+    , I.notToken     , I.peekToken     , I.satisfy     , I.satisfyWith@@ -57,6 +55,7 @@     -- ** Parsing individual characters     , I.anyChar     , I.char+    , I.notChar     , I.peekChar     , I.peekChar'     , I.satisfyChar@@ -84,9 +83,32 @@      -- * Text parsing     , I.endOfLine++    -- * Combinators+    , try+    , (<?>)+    , choice+    , count+    , option+    , many'+    , many1+    , many1'+    , manyTill+    , manyTill'+    , sepBy+    , sepBy'+    , sepBy1+    , sepBy1'+    , skipMany+    , skipMany1+    , eitherP++    -- * State observation and manipulation functions+    , I.endOfInput+    , I.atEnd     ) where -import Data.Monoid (Monoid, (<>))+import Data.Monoid (Monoid)  import Data.Picoparsec.Combinator import qualified Data.Picoparsec.Monoid.Internal as I@@ -164,14 +186,6 @@ -- -- * Make active use of benchmarking and profiling tools to measure, find the problems with, and improve the performance -- of your parser.---- | If a parser has returned a 'T.Partial' result, supply it with more--- input.-feed :: Monoid t => Result t r -> t -> Result t r-feed f@(T.Fail _ _ _) _ = f-feed (T.Partial k) d    = k d-feed (T.Done t r) d    = T.Done (t <> d) r-{-# INLINE feed #-}  -- | Run a parser and print its result to standard output. parseTest :: (Monoid t, Show t, Show a) => I.Parser t a -> t -> IO ()

@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, CPP, Haskell2010 #-}+{-# LANGUAGE BangPatterns, Haskell2010 #-} -- | -- Module      :  Data.Picoparsec.Combinator -- Copyright   :  Daan Leijen 1999-2001, Bryan O'Sullivan 2009-2010, Mario Blažević <blamario@yahoo.com> 2014@@ -29,24 +29,18 @@     , skipMany     , skipMany1     , eitherP-    -- * State observation and manipulation functions+    , feed     , endOfInput     , atEnd     ) where -import Prelude hiding (null)+import Prelude hiding (succ)  import Control.Applicative (Alternative(..), Applicative(..), empty, liftA2,-                            (<|>), (*>), (<$>))+                            many, (<|>), (*>), (<$>)) import Control.Monad (MonadPlus(..))-#if !MIN_VERSION_base(4,2,0)-import Control.Applicative (many)-#endif--import Data.Monoid.Null (MonoidNull(null))-import Data.Picoparsec.Internal (demandInput, wantInput)-import Data.Picoparsec.Internal.Types (Input(..), Parser(..), addS)-import Data.Picoparsec.Internal.Types (More(..))+import Data.Picoparsec.Internal.Types (Parser(..))+import Data.Picoparsec.Internal (atEnd, endOfInput, feed) import Data.ByteString (ByteString) import Data.Text (Text) import qualified Data.Picoparsec.Zepto as Z@@ -56,17 +50,17 @@ -- -- This combinator is provided for compatibility with Parsec. -- Picoparsec parsers always backtrack on failure.-try :: Parser t a -> Parser t a+try :: Parser i a -> Parser i a try p = p {-# INLINE try #-}  -- | Name the parser, in case failure occurs.-(<?>) :: Parser t a+(<?>) :: Parser i a       -> String                 -- ^ the name to use if parsing fails-      -> Parser t a-p <?> msg0 = Parser $ \i0 a0 m0 kf ks ->-             let kf' i a m strs msg = kf i a m (msg0:strs) msg-             in runParser p i0 a0 m0 kf' ks+      -> Parser i a+p <?> msg0 = Parser $ \t pos more lose succ ->+             let lose' t' pos' more' strs msg = lose t' pos' more' (msg0:strs) msg+             in runParser p t pos more lose' succ {-# INLINE (<?>) #-} infix 0 <?> @@ -75,7 +69,8 @@ -- action. choice :: Alternative f => [f a] -> f a choice = foldr (<|>) empty-{-# SPECIALIZE choice :: [Parser ByteString a] -> Parser ByteString a #-}+{-# SPECIALIZE choice :: [Parser ByteString a]+                      -> Parser ByteString a #-} {-# SPECIALIZE choice :: [Parser Text a] -> Parser Text a #-} {-# SPECIALIZE choice :: [Z.Parser ByteString a] -> Z.Parser ByteString a #-} {-# SPECIALIZE choice :: [Z.Parser Text a] -> Z.Parser Text a #-}@@ -245,25 +240,3 @@ eitherP :: (Alternative f) => f a -> f b -> f (Either a b) eitherP a b = (Left <$> a) <|> (Right <$> b) {-# INLINE eitherP #-}---- | Match only if all input has been consumed.-endOfInput :: MonoidNull t => Parser t ()-endOfInput = Parser $ \i0 a0 m0 kf ks ->-             if null (unI i0)-             then if m0 == Complete-                  then ks i0 a0 m0 ()-                  else let kf' i1 a1 m1 _ _ = addS i0 a0 m0 i1 a1 m1 $-                                              \ i2 a2 m2 -> ks i2 a2 m2 ()-                           ks' i1 a1 m1 _   = addS i0 a0 m0 i1 a1 m1 $-                                              \ i2 a2 m2 -> kf i2 a2 m2 []-                                                            "endOfInput"-                       in  runParser demandInput i0 a0 m0 kf' ks'-             else kf i0 a0 m0 [] "endOfInput"-{-# SPECIALIZE endOfInput :: Parser ByteString () #-}-{-# SPECIALIZE endOfInput :: Parser Text () #-}---- | Return an indication of whether the end of input has been--- reached.-atEnd :: MonoidNull t => Parser t Bool-atEnd = not <$> wantInput-{-# INLINE atEnd #-}

@@ -19,26 +19,28 @@     , prompt     , demandInput     , wantInput+    , feed+    , endOfInput+    , atEnd     ) where  import Prelude hiding (null) +import Control.Applicative ((<$>)) import Data.Picoparsec.Internal.Types-import Data.ByteString (ByteString)-import Data.Monoid ((<>))+import Data.Monoid (Monoid(mappend), (<>)) import Data.Monoid.Null (MonoidNull(null))-import Data.Text (Text)  -- | Compare two 'IResult' values for equality. -- -- If both 'IResult's are 'Partial', the result will be 'Nothing', as -- they are incomplete and hence their equality cannot be known. -- (This is why there is no 'Eq' instance for 'IResult'.)-compareResults :: (Eq t, Eq r) => IResult t r -> IResult t r -> Maybe Bool-compareResults (Fail i0 ctxs0 msg0) (Fail i1 ctxs1 msg1) =-    Just (i0 == i1 && ctxs0 == ctxs1 && msg0 == msg1)-compareResults (Done i0 r0) (Done i1 r1) =-    Just (i0 == i1 && r0 == r1)+compareResults :: (Eq i, Eq r) => IResult i r -> IResult i r -> Maybe Bool+compareResults (Fail t0 ctxs0 msg0) (Fail t1 ctxs1 msg1) =+    Just (t0 == t1 && ctxs0 == ctxs1 && msg0 == msg1)+compareResults (Done t0 r0) (Done t1 r1) =+    Just (t0 == t1 && r0 == r1) compareResults (Partial _) (Partial _) = Nothing compareResults _ _ = Just False @@ -61,16 +63,7 @@     if null s     then kf i0 a0 Complete     else ks (i0 <> I s) (a0 <> A s) Incomplete-{-# SPECIALIZE prompt :: Input ByteString -> Added ByteString -> More-                      -> (Input ByteString -> Added ByteString -> More-                          -> IResult ByteString r)-                      -> (Input ByteString -> Added ByteString -> More-                          -> IResult ByteString r)-                      -> IResult ByteString r #-}-{-# SPECIALIZE prompt :: Input Text -> Added Text -> More-                      -> (Input Text -> Added Text -> More -> IResult Text r)-                      -> (Input Text -> Added Text-> More -> IResult Text r)-                      -> IResult Text r #-}+{-# INLINE prompt #-}  -- | Immediately demand more input via a 'Partial' continuation -- result.@@ -81,8 +74,7 @@     else let kf' i a m = kf i a m ["demandInput"] "not enough input"              ks' i a m = ks i a m ()          in prompt i0 a0 m0 kf' ks'-{-# SPECIALIZE demandInput :: Parser ByteString () #-}-{-# SPECIALIZE demandInput :: Parser Text () #-}+{-# INLINABLE demandInput #-}  -- | This parser always succeeds.  It returns 'True' if any input is -- available either immediately or on demand, and 'False' if the end@@ -95,5 +87,33 @@       | otherwise       -> let kf' i a m = ks i a m False                                ks' i a m = ks i a m True                            in prompt i0 a0 m0 kf' ks'-{-# SPECIALIZE wantInput :: Parser ByteString Bool #-}-{-# SPECIALIZE wantInput :: Parser Text Bool #-}+{-# INLINE wantInput #-}++-- | Match only if all input has been consumed.+endOfInput :: MonoidNull t => Parser t ()+endOfInput = Parser $ \i0 a0 m0 kf ks ->+             if null (unI i0)+             then if m0 == Complete+                  then ks i0 a0 m0 ()+                  else let kf' i1 a1 m1 _ _ = addS i0 a0 m0 i1 a1 m1 $+                                              \ i2 a2 m2 -> ks i2 a2 m2 ()+                           ks' i1 a1 m1 _   = addS i0 a0 m0 i1 a1 m1 $+                                              \ i2 a2 m2 -> kf i2 a2 m2 []+                                                            "endOfInput"+                       in  runParser demandInput i0 a0 m0 kf' ks'+             else kf i0 a0 m0 [] "endOfInput"+{-# INLINABLE endOfInput #-}++-- | Return an indication of whether the end of input has been+-- reached.+atEnd :: MonoidNull t => Parser t Bool+atEnd = not <$> wantInput+{-# INLINE atEnd #-}++-- | If a parser has returned a 'T.Partial' result, supply it with more+-- input.+feed :: Monoid i => IResult i r -> i -> IResult i r+feed f@(Fail _ _ _) _ = f+feed (Partial k) d    = k d+feed (Done t r) d     = Done (mappend t d) r+{-# INLINE feed #-}

@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, CPP, Haskell2010, Rank2Types, Safe #-}+{-# LANGUAGE BangPatterns, Haskell2010, Rank2Types, Safe #-} -- | -- Module      :  Data.Picoparsec.Internal.Types -- Copyright   :  Bryan O'Sullivan 2007-2011, Mario Blažević <blamario@yahoo.com> 2014@@ -33,42 +33,40 @@ -- -- This type is an instance of 'Functor', where 'fmap' transforms the -- value in a 'Done' result.-data IResult t r = Fail t [String] String-                 -- ^ The parse failed.  The 't' parameter is the-                 -- input that had not yet been consumed when the-                 -- failure occurred.  The @[@'String'@]@ is a list of-                 -- contexts in which the error occurred.  The-                 -- 'String' is the message describing the error, if-                 -- any.-                 | Partial (t -> IResult t r)-                 -- ^ Supply this continuation with more input so that-                 -- the parser can resume.  To indicate that no more-                 -- input is available, use an empty string.-                 | Done t r-                 -- ^ The parse succeeded.  The 't' parameter is the-                 -- input that had not yet been consumed (if any) when-                 -- the parse succeeded.+data IResult i r =+    Fail i [String] String+    -- ^ The parse failed.  The @i@ parameter is the input that had+    -- not yet been consumed when the failure occurred.  The+    -- @[@'String'@]@ is a list of contexts in which the error+    -- occurred.  The 'String' is the message describing the error, if+    -- any.+  | Partial (i -> IResult i r)+    -- ^ Supply this continuation with more input so that the parser+    -- can resume.  To indicate that no more input is available, pass+    -- an empty string to the continuation.+    --+    -- __Note__: if you get a 'Partial' result, do not call its+    -- continuation more than once.+  | Done i r+    -- ^ The parse succeeded.  The @i@ parameter is the input that had+    -- not yet been consumed (if any) when the parse succeeded. -instance (Show t, Show r) => Show (IResult t r) where+instance (Show i, Show r) => Show (IResult i r) where     show (Fail t stk msg) =-        "Fail " ++ show t ++ " " ++ show stk ++ " " ++ show msg-    show (Partial _)      = "Partial _"-    show (Done t r)       = "Done " ++ show t ++ " " ++ show r+      unwords [ "Fail", show t, show stk, show msg]+    show (Partial _)          = "Partial _"+    show (Done t r)       = unwords ["Done", show t, show r] -instance (NFData t, NFData r) => NFData (IResult t r) where+instance (NFData i, NFData r) => NFData (IResult i r) where     rnf (Fail t stk msg) = rnf t `seq` rnf stk `seq` rnf msg     rnf (Partial _)  = ()     rnf (Done t r)   = rnf t `seq` rnf r     {-# INLINE rnf #-} -fmapR :: (a -> b) -> IResult t a -> IResult t b-fmapR _ (Fail t stk msg) = Fail t stk msg-fmapR f (Partial k)       = Partial (fmapR f . k)-fmapR f (Done t r)       = Done t (f r)--instance Functor (IResult t) where-    fmap = fmapR-    {-# INLINE fmap #-}+instance Functor (IResult i) where+    fmap _ (Fail t stk msg) = Fail t stk msg+    fmap f (Partial k)      = Partial (fmap f . k)+    fmap f (Done t r)   = Done t (f r)  newtype Input t = I {unI :: t} newtype Added t = A {unA :: t}@@ -145,18 +143,12 @@     (>>=)  = bindP     fail   = failDesc -noAdds :: (Monoid t) =>-          Input t -> Added t -> More-       -> (Input t -> Added t -> More -> r) -> r-noAdds i0 _a0 m0 f = f i0 mempty m0-{-# INLINE noAdds #-}- plus :: (Monoid t) => Parser t a -> Parser t a -> Parser t a plus a b = Parser $ \i0 a0 m0 kf ks ->            let kf' i1 a1 m1 _ _ = addS i0 a0 m0 i1 a1 m1 $                                   \ i2 a2 m2 -> runParser b i2 a2 m2 kf ks                ks' i1 a1 m1 = ks i1 (a0 <> a1) m1-           in  noAdds i0 a0 m0 $ \i2 a2 m2 -> runParser a i2 a2 m2 kf' ks'+           in  runParser a i0 mempty m0 kf' ks'  instance (Monoid t) => MonadPlus (Parser t) where     mzero = failDesc "mzero"@@ -172,20 +164,19 @@     fmap = fmapP     {-# INLINE fmap #-} -apP :: Parser t (a -> b) -> Parser t a -> Parser t b+apP :: Parser i (a -> b) -> Parser i a -> Parser i b apP d e = do   b <- d   a <- e   return (b a) {-# INLINE apP #-} -instance Applicative (Parser t) where-    pure   = returnP+instance Applicative (Parser i) where+    pure   = return     {-# INLINE pure #-}     (<*>)  = apP     {-# INLINE (<*>) #-} -#if MIN_VERSION_base(4,2,0)     -- These definitions are equal to the defaults, but this     -- way the optimizer doesn't have to work so hard to figure     -- that out.@@ -193,16 +184,14 @@     {-# INLINE (*>) #-}     x <* y = x >>= \a -> y >> return a     {-# INLINE (<*) #-}-#endif -instance (Monoid t) => Alternative (Parser t) where-    empty = failDesc "empty"+instance Monoid i => Alternative (Parser i) where+    empty = fail "empty"     {-# INLINE empty #-}      (<|>) = plus     {-# INLINE (<|>) #-} -#if MIN_VERSION_base(4,2,0)     many v = many_v         where many_v = some_v <|> pure []               some_v = (:) <$> v <*> many_v@@ -213,7 +202,6 @@         many_v = some_v <|> pure []         some_v = (:) <$> v <*> many_v     {-# INLINE some #-}-#endif  failDesc :: String -> Parser t a failDesc err = Parser (\i0 a0 m0 kf _ks -> kf i0 a0 m0 [] msg)

@@ -1,4 +1,5 @@-{-# LANGUAGE BangPatterns, CPP, Rank2Types, OverloadedStrings #-}+{-# LANGUAGE BangPatterns, CPP, GADTs, Rank2Types, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module      :  Data.Picoparsec.Monoid.Internal -- Copyright   :  Bryan O'Sullivan 2007-2011, Mario Blažević <blamario@yahoo.com> 2014@@ -27,15 +28,17 @@     , module Data.Picoparsec.Combinator      -- * Parsing individual tokens+    , anyToken+    , notToken     , satisfy     , satisfyWith-    , anyToken     , skip     , peekToken          -- ** Parsing individual characters     , anyChar     , char+    , notChar     , satisfyChar     , peekChar     , peekChar'@@ -68,10 +71,13 @@     , ensureOne     ) where +import Prelude hiding (getChar, null, span, take, takeWhile)+ import Control.Applicative ((<|>), (<$>)) import Control.Monad (when) import Data.Picoparsec.Combinator import Data.Picoparsec.Internal.Types+import Data.Picoparsec.Internal (demandInput, get, prompt, put, wantInput) import Data.Monoid (Monoid(..), (<>)) import Data.Monoid.Cancellative (LeftGCDMonoid(..)) import Data.Monoid.Null (MonoidNull(null))@@ -79,66 +85,24 @@ import Data.Monoid.Factorial (FactorialMonoid) import Data.Monoid.Textual (TextualMonoid) import qualified Data.Monoid.Textual as Textual-import Prelude hiding (getChar, null, span, take, takeWhile)+import Data.String (IsString(..)) import qualified Data.Picoparsec.Internal.Types as T  type Result = IResult -ensure' :: FactorialMonoid t => Int -> T.Input t -> T.Added t -> More -> T.Failure t r -> T.Success t t r-        -> IResult t r-ensure' !n0 i0 a0 m0 kf0 ks0 =-    T.runParser (demandInput >> go n0) i0 a0 m0 kf0 ks0-  where-    go !n = T.Parser $ \i a m kf ks ->-        if Factorial.length (unI i) >= n-        then ks i a m (unI i)-        else T.runParser (demandInput >> go n) i a m kf ks+instance (IsString a, LeftGCDMonoid a, MonoidNull a, a ~ b) => IsString (Parser a b) where+    fromString = string . fromString  -- | If at least one token of input is available, return the current -- input, otherwise fail.-ensureOne :: FactorialMonoid t => Parser t t+ensureOne :: MonoidNull t => Parser t t ensureOne = T.Parser $ \i0 a0 m0 kf ks ->     if null (unI i0)-    -- The uncommon case is kept out-of-line to reduce code size:-    then ensure' 1 i0 a0 m0 kf ks+    then T.runParser (demandInput >> get) i0 a0 m0 kf ks     else ks i0 a0 m0 (unI i0)--- Non-recursive so the bounds check can be inlined: {-# INLINE ensureOne #-} --- | Ask for input.  If we receive any, pass it to a success--- continuation, otherwise to a failure continuation.-prompt :: MonoidNull t => Input t -> Added t -> More-       -> (Input t -> Added t -> More -> IResult t r)-       -> (Input t -> Added t -> More -> IResult t r)-       -> IResult t r-prompt i0 a0 _m0 kf ks = Partial $ \s ->-    if null s-    then kf i0 a0 Complete-    else ks (i0 <> I s) (a0 <> A s) Incomplete---- | Immediately demand more input via a 'Partial' continuation--- result.-demandInput :: MonoidNull t => Parser t ()-demandInput = T.Parser $ \i0 a0 m0 kf ks ->-    if m0 == Complete-    then kf i0 a0 m0 ["demandInput"] "not enough input"-    else let kf' i a m = kf i a m ["demandInput"] "not enough input"-             ks' i a m = ks i a m ()-         in prompt i0 a0 m0 kf' ks'- -- | This parser always succeeds.  It returns 'True' if any input is--- available either immediately or on demand, and 'False' if the end--- of all input has been reached.-wantInput :: MonoidNull t => Parser t Bool-wantInput = T.Parser $ \i0 a0 m0 _kf ks ->-  case () of-    _ | not (null (unI i0)) -> ks i0 a0 m0 True-      | m0 == Complete  -> ks i0 a0 m0 False-      | otherwise       -> let kf' i a m = ks i a m False-                               ks' i a m = ks i a m True-                           in prompt i0 a0 m0 kf' ks'---- | This parser always succeeds.  It returns 'True' if any input is -- available on demand, and 'False' if the end of all input has been reached. wantMoreInput :: MonoidNull t => Parser t Bool wantMoreInput = T.Parser $ \i0 a0 m0 _kf ks ->@@ -148,12 +112,6 @@            ks' i a m = ks i a m True        in prompt i0 a0 m0 kf' ks' -get :: Parser t t-get  = T.Parser $ \i0 a0 m0 _kf ks -> ks i0 a0 m0 (unI i0)--put :: t -> Parser t ()-put s = T.Parser $ \_i0 a0 m0 _kf ks -> ks (I s) a0 m0 ()- -- | The parser @satisfy p@ succeeds for any prime input token for -- which the predicate @p@ returns 'True'. Returns the token that is -- actually parsed.@@ -530,6 +488,11 @@ anyToken = satisfy $ const True {-# INLINE anyToken #-} +-- | Match any prime input token except the given one.+notToken :: (Eq t, FactorialMonoid t) => t -> Parser t t+notToken t = satisfy (/= t)+{-# INLINE notToken #-}+ -- | Match any prime input token. Returns 'mempty' if end of input -- has been reached. Does not consume any input. --@@ -555,6 +518,11 @@ char :: TextualMonoid t => Char -> Parser t Char char c = satisfyChar (== c) <?> show c {-# INLINE char #-}++-- | Match any character except the given one.+notChar :: TextualMonoid t => Char -> Parser t Char+notChar c = satisfyChar (/= c) <?> "not" ++ show c+{-# INLINE notChar #-}  -- | Match any input character, if available. Does not consume any input. --

@@ -8,6 +8,11 @@ -- Stability   :  experimental -- Portability :  unknown --+-- This module is deprecated, and both the module and 'Number' type+-- will be removed in the next major release.  Use the+-- <http://hackage.haskell.org/package/scientific scientific> package+-- and the 'Data.Scientific.Scientific' type instead.+-- -- A simple number type, useful for parsing both exact and inexact -- quantities without losing much precision. module Data.Picoparsec.Number (

@@ -1,63 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Picoparsec.FastSet--- Copyright   :  Felipe Lessa 2010, Bryan O'Sullivan 2008, Mario Blažević <blamario@yahoo.com> 2014--- License     :  BSD3------ Maintainer  :  Mario Blažević--- Stability   :  experimental--- Portability :  unknown------ Fast set membership tests for 'Char' values.  The set--- representation is unboxed for efficiency.  We test for--- membership using a binary search.----------------------------------------------------------------------------------module Data.Picoparsec.Text.FastSet-    (-    -- * Data type-      FastSet-    -- * Construction-    , fromList-    , set-    -- * Lookup-    , member-    -- * Handy interface-    , charClass-    ) where--import Data.List (sort)-import qualified Data.Array.Base as AB-import qualified Data.Array.Unboxed as A-import qualified Data.Text as T--newtype FastSet = FastSet (A.UArray Int Char)-    deriving (Eq, Ord, Show)---- | Create a set.-set :: T.Text -> FastSet-set t = mkSet (T.length t) (sort $ T.unpack t)--fromList :: [Char] -> FastSet-fromList cs = mkSet (length cs) (sort cs)--mkSet :: Int -> [Char] -> FastSet-mkSet l = FastSet . A.listArray (0,l-1)---- | Check the set for membership.-member :: Char -> FastSet -> Bool-member c (FastSet a) = uncurry search (A.bounds a)-    where search lo hi-              | hi < lo = False-              | otherwise =-                  let mid = (lo + hi) `quot` 2-                  in case compare c (AB.unsafeAt a mid) of-                       GT -> search (mid + 1) hi-                       LT -> search lo (mid - 1)-                       _ -> True--charClass :: String -> FastSet-charClass = fromList . go-    where go (a:'-':b:xs) = [a..b] ++ go xs-          go (x:xs) = x : go xs-          go _ = ""

@@ -10,6 +10,7 @@ import Data.ByteString.Builder   (Builder, byteString, toLazyByteString, charUtf8, word8) +import Common (pathTo) import Control.Applicative ((*>), (<$>), (<*), liftA2, pure) import Control.DeepSeq (NFData(..)) import Control.Monad (forM)@@ -340,7 +341,7 @@  aeson :: IO Benchmark aeson = do-  let path = "json-data"+  path <- pathTo "json-data"   names <- sort . filter (`notElem` [".", ".."]) <$> getDirectoryContents path   benches <- forM names $ \name -> do     bs <- B.readFile (path </> name)

@@ -1,8 +1,7 @@ {-# LANGUAGE BangPatterns, CPP #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} +import Common () import Control.Applicative (many)-import Control.DeepSeq (NFData(rnf)) import Criterion.Main (bench, bgroup, defaultMain, nf) import Data.Bits import Data.Char (isAlpha)@@ -10,9 +9,11 @@ import Data.Word (Word32) import Data.Word (Word8) import Numbers (numbers)+import Common (chunksOf) import Text.Parsec.Text () import Text.Parsec.Text.Lazy () import qualified AttoAeson+import qualified Warp import qualified PicoAeson import qualified Data.Attoparsec.ByteString as AB import qualified Data.Attoparsec.ByteString.Char8 as AC@@ -34,21 +35,6 @@ import qualified Data.Monoid.Instances.ByteString.UTF8 as UTF8 import Data.Monoid.Instances.ByteString.Char8 () -#if !MIN_VERSION_bytestring(0,10,0)-import Data.ByteString.Internal (ByteString(..))-instance NFData ByteString where-    rnf (PS _ _ _) = ()-#endif--instance NFData P.ParseError where-    rnf = rnf . show--chunksOf :: Int -> [a] -> [[a]]-chunksOf k = go-  where go xs = case splitAt k xs of-                  ([],_)  -> []-                  (y, ys) -> y : go ys- main :: IO () main = do   let s  = take 1024 . cycle $ ['a'..'z'] ++ ['A'..'Z']@@ -135,6 +121,10 @@        bench "attoparsec" $ nf (AB.parse word32LE) b      , bench "picoparsec" $ nf (AM.parse word32LE') b      ]+   , bgroup "takeWhile1" [+       bench "isAlpha" $ nf (ABL.parse (AC.takeWhile1 isAlpha)) bl+     , bench "isAlpha_ascii" $ nf (ABL.parse (AC.takeWhile1 AC.isAlpha_ascii)) bl+     ]    , bgroup "scan" [        bench "short" $ nf (AB.parse quotedString) (BC.pack "abcdefghijk\"")      , bench "long" $ nf (AB.parse quotedString) b@@ -145,6 +135,7 @@    , headersT    , Links.links    , numbers+   , Warp.benchmarks    ]  -- Benchmarks bind and (potential) bounds-check merging.

@@ -0,0 +1,47 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Common (+      chunksOf+    , pathTo+    , rechunkBS+    , rechunkT+    ) where++import Control.DeepSeq (NFData(rnf))+import System.Directory (doesDirectoryExist)+import System.FilePath ((</>))+import Text.Parsec (ParseError)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++#if !MIN_VERSION_bytestring(0,10,0)+import Data.ByteString.Internal (ByteString(..))++instance NFData ByteString where+    rnf (PS _ _ _) = ()+#endif++instance NFData ParseError where+    rnf = rnf . show++chunksOf :: Int -> [a] -> [[a]]+chunksOf k = go+  where go xs = case splitAt k xs of+                  ([],_)  -> []+                  (y, ys) -> y : go ys++rechunkBS :: Int -> B.ByteString -> BL.ByteString+rechunkBS n = BL.fromChunks . map B.pack . chunksOf n . B.unpack++rechunkT :: Int -> T.Text -> TL.Text+rechunkT n = TL.fromChunks . map T.pack . chunksOf n . T.unpack++pathTo :: String -> IO FilePath+pathTo wat = do+  exists <- doesDirectoryExist "benchmarks"+  return $ if exists+           then "benchmarks" </> wat+           else wat

@@ -1,46 +1,28 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures #-} module HeadersByteString (headers) where -import Control.Applicative-import Criterion.Main (bench, bgroup, nf)+import Common (pathTo, rechunkBS)+import Criterion.Main (bench, bgroup, nf, nfIO) import Criterion.Types (Benchmark)+import HeadersByteString.Atto (request, response)+import Network.Wai.Handler.Warp.RequestHeader (parseHeaderLines) import qualified Data.Attoparsec.ByteString.Char8 as B+import qualified Data.Attoparsec.ByteString.Lazy as BL import qualified Data.ByteString.Char8 as B -header = do-  name <- B.takeWhile1 (B.inClass "a-zA-Z0-9_-") <* B.char ':' <* B.skipSpace-  body <- (:) <$> bodyLine <*> many (B.takeWhile1 B.isSpace *> bodyLine)-  return (name, body)--bodyLine = B.takeTill (\c -> c == '\r' || c == '\n') <* B.endOfLine--requestLine =-    (,,) <$>-    (method <* B.skipSpace) <*>-    (B.takeTill B.isSpace <* B.skipSpace) <*>-    httpVersion-  where method = "GET" <|> "POST"--httpVersion = "HTTP/" *> ((,) <$> (int <* B.char '.') <*> int)--responseLine = (,,) <$>-               (httpVersion <* B.skipSpace) <*>-               (int <* B.skipSpace) <*>-               bodyLine--int :: B.Parser Int-int = B.decimal--request = (,) <$> (requestLine <* B.endOfLine) <*> many header--response = (,) <$> responseLine <*> many header- headers :: IO Benchmark headers = do-  req <- B.readFile "http-request.txt"-  resp <- B.readFile "http-response.txt"-  return $ bgroup "headersBS" [-      bench "request" $ nf (B.parseOnly request) req-    , bench "response" $ nf (B.parseOnly response) resp+  req <- B.readFile =<< pathTo "http-request.txt"+  resp <- B.readFile =<< pathTo "http-response.txt"+  let reql    = rechunkBS 4 req+      respl   = rechunkBS 4 resp+  return $ bgroup "headers" [+      bgroup "B" [+        bench "request" $ nf (B.parseOnly request) req+      , bench "warp" $ nfIO (parseHeaderLines [req])+      , bench "response" $ nf (B.parseOnly response) resp+      ]+    , bgroup "BL" [+        bench "request" $ nf (BL.parse request) reql+      , bench "response" $ nf (BL.parse response) respl+      ]     ]

@@ -0,0 +1,49 @@+{-# LANGUAGE BangPatterns, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-orphans #-}+module HeadersByteString.Atto+    (+      request+    , response+    ) where++import Control.Applicative+import Control.DeepSeq (NFData(..))+import Network.HTTP.Types.Version (HttpVersion, http11)+import qualified Data.Attoparsec.ByteString.Char8 as B+import qualified Data.ByteString.Char8 as B++instance NFData HttpVersion where+    rnf !_ = ()++header = do+  name <- B.takeWhile1 (B.inClass "a-zA-Z0-9_-") <* B.char ':' <* B.skipSpace+  body <- bodyLine+  return (name, body)++bodyLine = B.takeTill (\c -> c == '\r' || c == '\n') <* B.endOfLine++requestLine = do+  m <- (B.takeTill B.isSpace <* B.char ' ')+  (p,q) <- B.break (=='?') <$> (B.takeTill B.isSpace <* B.char ' ')+  v <- httpVersion+  return (m,p,q,v)++httpVersion = http11 <$ "HTTP/1.1"++responseLine = (,,) <$>+               (httpVersion <* B.skipSpace) <*>+               (int <* B.skipSpace) <*>+               bodyLine++int :: B.Parser Int+int = B.decimal++request = (,) <$> (requestLine <* B.endOfLine) <*> manyheader++response = (,) <$> responseLine <*> many header++manyheader = do+  c <- B.peekChar'+  if c == '\r' || c == '\n'+    then return []+    else (:) <$> header <*> manyheader

@@ -2,11 +2,13 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} module HeadersText (headers) where +import Common (pathTo, rechunkT) import Control.Applicative import Criterion.Main (bench, bgroup, nf) import Criterion.Types (Benchmark) import Data.Char (isSpace) import qualified Data.Attoparsec.Text as T+import qualified Data.Attoparsec.Text.Lazy as TL import qualified Data.Text.IO as T  header = do@@ -39,9 +41,17 @@  headers :: IO Benchmark headers = do-  req <- T.readFile "http-request.txt"-  resp <- T.readFile "http-response.txt"-  return $ bgroup "headersT" [-      bench "request" $ nf (T.parseOnly request) req-    , bench "response" $ nf (T.parseOnly response) resp+  req <- T.readFile =<< pathTo "http-request.txt"+  resp <- T.readFile =<< pathTo "http-response.txt"+  let reql    = rechunkT 4 req+      respl   = rechunkT 4 resp+  return $ bgroup "headers" [+      bgroup "T" [+        bench "request" $ nf (T.parseOnly request) req+      , bench "response" $ nf (T.parseOnly response) resp+      ]+    , bgroup "TL" [+        bench "request" $ nf (TL.parse request) reql+      , bench "response" $ nf (TL.parse response) respl+      ]     ]

@@ -8,6 +8,7 @@     ) where  import Control.Applicative ((*>), (<$>), (<*), (<|>), liftA2, pure)+import Common (pathTo) import Control.DeepSeq (NFData(..)) import Control.Monad (forM) import Data.Picoparsec (Parser, char, endOfInput, string)@@ -325,7 +326,7 @@  aeson :: IO Benchmark aeson = do-  let path = "json-data"+  path <- pathTo "json-data"   names <- sort . filter (`notElem` [".", ".."]) <$> getDirectoryContents path   benches1 <- forM names $ \name -> do     bs <- B.readFile (path </> name)

@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedStrings #-}++module Warp (benchmarks) where++import Criterion.Main (bench, bgroup, nf)+import Criterion.Types (Benchmark)+import Data.ByteString (ByteString)+import Network.Wai.Handler.Warp.ReadInt (readInt)+import qualified Data.Attoparsec.ByteString.Char8 as B++benchmarks :: Benchmark+benchmarks = bgroup "warp" [+    bgroup "decimal" [+      bench "warp" $ nf (readInt :: ByteString -> Int) "31337"+    , bench "atto" $ nf (B.parse (B.decimal :: B.Parser Int)) "31337"+    ]+  ]

@@ -9,23 +9,30 @@ executable picoparsec-benchmarks   main-is: Benchmarks.hs   other-modules:+    Common     HeadersByteString+    HeadersByteString.Atto     HeadersText     Links     Numbers-  hs-source-dirs: .. .-  ghc-options: -O2 -Wall+    Network.Wai.Handler.Warp.ReadInt+    Warp+  hs-source-dirs: .. . warp-3.0.1.1+  ghc-options: -O2 -Wall -rtsopts   build-depends:     array,     base == 4.*,     bytestring >= 0.10.4.0,-    criterion >= 0.5,+    case-insensitive,+    criterion >= 1.0,     deepseq >= 1.1,     directory,     filepath,     monoid-subclasses,+    ghc-prim,+    http-types,     parsec >= 3.1.2,-    scientific,+    scientific >= 0.3.1,     text >= 1.1.1.0,     unordered-containers,     vector

@@ -1,3 +1,41 @@ 0.1 +* Fixed the incorrect tracking of capacity if the initial buffer was+  empty (https://github.com/bos/attoparsec/issues/75)++0.12.1.1++* Fixed a data corruption bug that occurred under some circumstances+  if a buffer grew after prompting for more input+  (https://github.com/bos/attoparsec/issues/74)++0.12.1.0++* Now compatible with GHC 7.9++* Reintroduced the Chunk class, used by the parsers package++0.12.0.0++* A new internal representation makes almost all real-world parsers+  faster, sometimes by big margins.  For example, parsing JSON data+  with aeson is now up to 70% faster.  These performance improvements+  also come with reduced memory consumption and some new capabilities.++* The new match combinator gives both the result of a parse and the+  input that it matched.++* The test suite has doubled in size.  This made it possible to switch+  to the new internal representation with a decent degree of+  confidence that everything was more or less working.++* The benchmark suite now contains a small family of benchmarks taken+  from real-world uses of attoparsec.++* A few types that ought to have been private now are.++* A few obsolete modules and functions have been marked as deprecated.+  They will be removed from the next major release.++ * Initial commit.

@@ -0,0 +1,45 @@+{-# LANGUAGE BangPatterns #-}++module Main (main) where++import Control.Applicative+import Control.Exception (bracket)+import Control.Monad (forM_)+import Data.Attoparsec.ByteString+import RFC2616+import System.Environment+import System.IO+import qualified Data.ByteString.Char8 as B++refill :: Handle -> IO B.ByteString+refill h = B.hGet h (80*1024)++listy :: FilePath -> Handle -> IO ()+listy file h = do+  r <- parseWith (refill h) (many request) =<< refill h+  case r of+    Fail _ _ msg -> hPutStrLn stderr $ file ++ ": " ++ msg+    Done _ reqs  -> print (length reqs)++incrementy :: FilePath -> Handle -> IO ()+incrementy file h = go (0::Int) =<< refill h+ where+   go !n is = do+     r <- parseWith (refill h) request is+     case r of+       Fail _ _ msg -> hPutStrLn stderr $ file ++ ": " ++ msg+       Done bs _req+           | B.null bs -> do+              s <- refill h+              if B.null s+                then print (n+1)+                else go (n+1) s+           | otherwise -> go (n+1) bs++main :: IO ()+main = do+  args <- getArgs+  forM_ args $ \arg ->+    bracket (openFile arg ReadMode) hClose $+      -- listy arg+      incrementy arg

@@ -1,4 +1,4 @@-CC := gcc+CC := cc CFLAGS := -O3 -Wall # To make the code about 6% faster: # CFLAGS += -fwhole-program --combine@@ -12,4 +12,8 @@ clean: 	rm -f *.hi *.o c-http -vpath %.c $(HOME)/hg/http-parser+http_parser.c: http_parser.h+	curl -O https://raw.githubusercontent.com/joyent/http-parser/master/http_parser.c++http_parser.h:+	curl -O https://raw.githubusercontent.com/joyent/http-parser/master/http_parser.h

@@ -23,15 +23,16 @@ token = satisfy $ \c -> S.notMember (fromEnum c) set   where set = S.fromList . map fromEnum $ ['\0'..'\31'] ++ "()<>@,;:\\\"/[]?={} \t" ++ ['\128'..'\255'] +isHorizontalSpace :: Char -> Bool isHorizontalSpace c = c == ' ' || c == '\t'  skipHSpaces :: Stream s m Char => ParsecT s u m () skipHSpaces = skipMany1 (satisfy isHorizontalSpace)  data Request = Request {-      requestMethod   :: String-    , requestUri      :: String-    , requestProtocol :: String+      _requestMethod   :: String+    , _requestUri      :: String+    , _requestProtocol :: String     } deriving (Eq, Ord, Show)  requestLine :: Stream s m Char => ParsecT s u m Request@@ -47,8 +48,8 @@ endOfLine = (string "\r\n" *> pure ()) <|> (char '\n' *> pure ())  data Header = Header {-      headerName  :: String-    , headerValue :: [String]+      _headerName  :: String+    , _headerValue :: [String]     } deriving (Eq, Ord, Show)  messageHeader :: Stream s m Char => ParsecT s u m Header@@ -61,14 +62,16 @@ request :: Stream s m Char => ParsecT s u m (Request, [Header]) request = (,) <$> requestLine <*> many messageHeader <* endOfLine +listy :: FilePath -> IO () listy arg = do   r <- parseFromFile (many request) arg   case r of     Left err -> putStrLn $ arg ++ ": " ++ show err     Right rs -> print (length rs) +chunky :: FilePath -> IO () chunky arg = bracket (openFile arg ReadMode) hClose $ \h ->-               loop 0 =<< B.hGetContents h+               loop (0::Int) =<< B.hGetContents h  where   loop !n bs       | B.null bs = print n

@@ -5,86 +5,61 @@       Header(..)     , Request(..)     , Response(..)-    , isToken-    , messageHeader     , request-    , requestLine     , response-    , responseLine-    , lowerHeader-    , lookupHeader     ) where  import Control.Applicative-import Data.Attoparsec as P-import qualified Data.Attoparsec.Char8 as P8-import Data.Attoparsec.Char8 (char8, endOfLine, isDigit_w8)+import Data.Attoparsec.ByteString as P+import Data.Attoparsec.ByteString.Char8 (char8, endOfLine, isDigit_w8)+import Data.ByteString (ByteString) import Data.Word (Word8)-import qualified Data.ByteString.Char8 as B hiding (map)-import qualified Data.ByteString as B (map)+import Data.Attoparsec.ByteString.Char8 (isEndOfLine, isHorizontalSpace)  isToken :: Word8 -> Bool isToken w = w <= 127 && notInClass "\0-\31()<>@,;:\\\"/[]?={} \t" w  skipSpaces :: Parser ()-skipSpaces = satisfy P8.isHorizontalSpace *> skipWhile P8.isHorizontalSpace+skipSpaces = satisfy isHorizontalSpace *> skipWhile isHorizontalSpace  data Request = Request {-      requestMethod  :: !B.ByteString-    , requestUri     :: !B.ByteString-    , requestVersion :: !B.ByteString+      requestMethod  :: ByteString+    , requestUri     :: ByteString+    , requestVersion :: ByteString     } deriving (Eq, Ord, Show) -httpVersion :: Parser B.ByteString+httpVersion :: Parser ByteString httpVersion = "HTTP/" *> P.takeWhile (\c -> isDigit_w8 c || c == 46)  requestLine :: Parser Request-requestLine = do-  method <- P.takeWhile1 isToken <* char8 ' '-  uri <- P.takeWhile1 (/=32) <* char8 ' '-  version <- httpVersion <* endOfLine-  return $! Request method uri version+requestLine = Request <$> (takeWhile1 isToken <* char8 ' ')+                      <*> (takeWhile1 (/=32) <* char8 ' ')+                      <*> (httpVersion <* endOfLine)  data Header = Header {-      headerName  :: !B.ByteString-    , headerValue :: [B.ByteString]+      headerName  :: ByteString+    , headerValue :: [ByteString]     } deriving (Eq, Ord, Show)  messageHeader :: Parser Header-messageHeader = do-  header <- P.takeWhile isToken <* char8 ':' <* skipWhile P8.isHorizontalSpace-  body <- takeTill P8.isEndOfLine <* endOfLine-  bodies <- many $ skipSpaces *> takeTill P8.isEndOfLine <* endOfLine-  return $! Header header (body:bodies)+messageHeader = Header+  <$> (P.takeWhile isToken <* char8 ':' <* skipWhile isHorizontalSpace)+  <*> ((:) <$> (takeTill isEndOfLine <* endOfLine)+           <*> (many $ skipSpaces *> takeTill isEndOfLine <* endOfLine))  request :: Parser (Request, [Header]) request = (,) <$> requestLine <*> many messageHeader <* endOfLine  data Response = Response {-      responseVersion :: !B.ByteString-    , responseCode    :: !B.ByteString-    , responseMsg     :: !B.ByteString+      responseVersion :: ByteString+    , responseCode    :: ByteString+    , responseMsg     :: ByteString     } deriving (Eq, Ord, Show)  responseLine :: Parser Response-responseLine = do-  version <- httpVersion <* char8 ' '-  code <- P.takeWhile isDigit_w8 <* char8 ' '-  msg <- P.takeTill P8.isEndOfLine <* endOfLine-  return $! Response version code msg+responseLine = Response <$> (httpVersion <* char8 ' ')+                        <*> (P.takeWhile isDigit_w8 <* char8 ' ')+                        <*> (takeTill isEndOfLine <* endOfLine)  response :: Parser (Response, [Header]) response = (,) <$> responseLine <*> many messageHeader <* endOfLine--lowerHeader :: Header -> Header-lowerHeader (Header n v) = Header (B.map toLower n) (map (B.map toLower) v)-  where toLower w | w >= 65 && w <= 90 = w + 32-                  | otherwise          = w--lookupHeader :: B.ByteString -> [Header] -> [B.ByteString]-lookupHeader k = go-  where-    go (Header n v:hs)-      | k == n    = v-      | otherwise = go hs-    go _          = []

@@ -1,37 +0,0 @@-{-# LANGUAGE BangPatterns #-}-import RFC2616-import Control.Monad (forM_)-import System.IO-import Control.Exception (bracket)-import System.Environment-import qualified Data.ByteString.Char8 as B-import Data.Attoparsec--refill h = B.hGet h (4*1024)--listy file h = do-  r <- parseWith (refill h) (many request) =<< refill h-  case r of-    Fail _ _ msg -> hPutStrLn stderr $ file ++ ": " ++ msg-    Done _ reqs  -> print (length reqs)-  -incrementy file h = go 0 =<< refill h- where-   go !n is = do-     r <- parseWith (refill h) request is-     case r of-       Fail _ _ msg -> hPutStrLn stderr $ file ++ ": " ++ msg-       Done bs _req-           | B.null bs -> do-              s <- refill h-              if B.null s-                then print (n+1)-                else go (n+1) s-           | otherwise -> go (n+1) bs-  -main = do-  args <- getArgs-  forM_ args $ \arg ->-    bracket (openFile arg ReadMode) hClose $-      -- listy arg-      incrementy arg

@@ -1,21 +1,22 @@ /*- * This is a simple driver for Ryan Dahl's hand-bummed C http-parser- * package.  It is intended to read one HTTP request after another- * from a file, nothing more.+ * This is a simple driver for the http-parser package.  It is+ * intended to read one HTTP request after another from a file,+ * nothing more.  *  * For "feature parity" with the Haskell code in RFC2616.hs, we  * allocate and populate a simple structure describing each request,  * since that's the sort of thing that many real applications would  * themselves do and the library doesn't do this for us.  *- * For the http-parser source, see http://github.com/ry/http-parser/+ * For the http-parser source, see+ * https://github.com/joyent/http-parser/blob/master/http_parser.c  */  /*  * Turn off this preprocessor symbol to have the callbacks do nothing  * at all, which "improves performance" by about 50%.  */-#define LOOK_BUSY+/*#define LOOK_BUSY*/  #include <assert.h> #include <fcntl.h>@@ -27,18 +28,18 @@ #include <unistd.h>  #include "http_parser.h"-    + struct http_string {     size_t len;     char value[0]; };-    + struct http_header {     struct http_string *name;     struct http_string *value;     struct http_header *next; };-    + struct http_request {     struct http_string *method;     struct http_string *uri;@@ -49,7 +50,7 @@     size_t count;     struct http_request req; };-  + static void *xmalloc(size_t size) {     void *ptr;@@ -78,7 +79,7 @@ 	*dst = xstrdup(src, len, 0); 	return;     }-    +     p = xstrdup((*dst)->value, (*dst)->len, len);     memcpy(p->value + (*dst)->len, src, len);     p->len += len;@@ -98,7 +99,7 @@ static int url(http_parser *p, const char *at, size_t len) { #ifdef LOOK_BUSY-    struct data *data = p->data;    +    struct data *data = p->data;      xstrcat(&data->req.uri, at, len); #endif@@ -119,7 +120,7 @@ 	hdr->name = xstrdup(at, len, 0); 	hdr->value = NULL; 	hdr->next = NULL;-    + 	if (data->req.last != NULL) 	    data->req.last->next = hdr; 	data->req.last = hdr;@@ -150,7 +151,7 @@      free(data->req.method);     free(data->req.uri);-	+     for (hdr = data->req.headers; hdr != NULL; hdr = next) { 	next = hdr->next; 	free(hdr->name);@@ -164,7 +165,7 @@     data->req.headers = NULL;     data->req.last = NULL; #endif-    +     /* Bludgeon http_parser into understanding that we really want to      * keep parsing after a request that in principle ought to close      * the "connection". */@@ -180,16 +181,21 @@ static void parse(const char *path, int fd) {     struct data data;+    http_parser_settings s;     http_parser p;     ssize_t nread; -    http_parser_init(&p, HTTP_REQUEST);-    p.on_message_begin = begin;-    p.on_url = url;-    p.on_header_field = header_field;-    p.on_header_value = header_value;-    p.on_message_complete = complete;+    memset(&s, 0, sizeof(s));+    s.on_message_begin = begin;+    s.on_url = url;+    s.on_header_field = header_field;+    s.on_header_value = header_value;+    s.on_message_complete = complete;+     p.data = &data;++    http_parser_init(&p, HTTP_REQUEST);+     data.count = 0;     data.req.method = NULL;     data.req.uri = NULL;@@ -202,7 +208,7 @@  	nread = read(fd, buf, sizeof(buf)); -	np = http_parser_execute(&p, buf, nread);+	np = http_parser_execute(&p, &s, buf, nread); 	if (np != nread) { 	    fprintf(stderr, "%s: parse failed\n", path); 	    break;

@@ -1,5 +1,5 @@ name:            picoparsec-version:         0.1+version:         0.1.1 license:         BSD3 license-file:    LICENSE category:        Text, Parsing@@ -19,6 +19,7 @@  extra-source-files:     README.markdown+    benchmarks/*.cabal     benchmarks/*.hs     benchmarks/*.txt     benchmarks/Makefile@@ -29,9 +30,7 @@     examples/*.hs     examples/Makefile     tests/*.hs-    tests/Makefile     tests/QC/*.hs-    tests/TestFastSet.hs  Flag developer   Description: Whether to build the library in development mode@@ -40,17 +39,13 @@  library   build-depends: array,-                 base >= 3 && < 5,+                 base >= 4.2 && < 5,                  bytestring,                  containers,                  deepseq,                  monoid-subclasses >= 0.4 && < 0.5,-                 text >= 0.11.3.1,-                 scientific >= 0.3.1 && < 0.4-  if impl(ghc < 7.4)-    build-depends:-      bytestring < 0.10.4.0,-      text < 1.1+                 scientific >= 0.3.1 && < 0.4,+                 text >= 1.1.1.3    exposed-modules: Data.Picoparsec                    Data.Picoparsec.Combinator@@ -61,52 +56,79 @@   other-modules:   Data.Picoparsec.Monoid.Internal                    Data.Picoparsec.Internal                    Data.Picoparsec.Internal.Types-                   Data.Picoparsec.Text.FastSet   ghc-options: -O2 -Wall    if flag(developer)     ghc-prof-options: -auto-all+    ghc-options: -Werror  test-suite tests   type:           exitcode-stdio-1.0-  hs-source-dirs: tests+  hs-source-dirs: tests .   main-is:        QC.hs   other-modules:  QC.Monoid+                  QC.Combinator+                  QC.Common+                  QC.Rechunked+                  QC.Simple    ghc-options:     -Wall -threaded -rtsopts +  if flag(developer)+    ghc-options: -Werror+   build-depends:     picoparsec,+    array,     base >= 4 && < 5,     bytestring, text,     monoid-subclasses >= 0.4 && < 0.5,-    QuickCheck == 2.*, quickcheck-instances == 0.3.*, tasty >= 0.7, tasty-quickcheck >= 0.7+    quickcheck-instances == 0.3.*, tasty >= 0.7, tasty-quickcheck >= 0.7,+    deepseq >= 1.1,+    QuickCheck >= 2.7,+    quickcheck-unicode,+    scientific,+    text,+    vector  benchmark benchmarks   type: exitcode-stdio-1.0-  hs-source-dirs: benchmarks-  ghc-options: -O2 -Wall+  hs-source-dirs: benchmarks benchmarks/warp-3.0.1.1 .+  ghc-options: -O2 -Wall -rtsopts   main-is: Benchmarks.hs   other-modules:     Data.Monoid.Instances.ByteString.Char8+    Common     AttoAeson     PicoAeson     HeadersByteString+    HeadersByteString.Atto     HeadersText     Links     Numbers+    Warp+  ghc-options: -O2 -Wall++  if flag(developer)+    ghc-options: -Werror+   build-depends:     array,     attoparsec == 0.11.*,     base == 4.*,     bytestring >= 0.10.4.0,-    criterion >= 0.5,+    base == 4.*,+    bytestring >= 0.10.4.0,+    case-insensitive,+    criterion >= 1.0,     deepseq >= 1.1,     directory,     filepath,     hashable,     monoid-subclasses >= 0.4 && < 0.5,+    ghc-prim,+    http-types,     parsec >= 3.1.2,     picoparsec,     scientific >= 0.2,

@@ -1,14 +0,0 @@-all: TestFastSet.out qc.out--%.out: %.exe-	./$< | tee $<.tmp-	mv $<.tmp $@--qc.exe: QC.hs-	ghc -O -fno-warn-orphans --make -o $@ $<--%.exe: %.hs-	ghc -O -fno-warn-orphans --make -o $@ $<--clean:-	-rm -f *.hi *.o *.exe *.out

@@ -3,7 +3,15 @@  import qualified QC.Monoid as Monoid import Test.Tasty (defaultMain, testGroup)+import qualified QC.Combinator as Combinator+import qualified QC.Simple as Simple+--import qualified QC.Text as Text  main = defaultMain tests -tests = testGroup "monoid" Monoid.tests+tests = testGroup "PicoParsec" [+    testGroup "monoid" Monoid.tests+  , testGroup "combinator" Combinator.tests+  , testGroup "simple" Simple.tests+--  , testGroup "text" Text.tests+  ]

@@ -0,0 +1,43 @@+module QC.Combinator where++import Control.Applicative ((<$>), (<*>))+import Data.Monoid (mempty)+import Data.Word (Word8)+import QC.Common (Repack, parse, repackBS, toStrictBS)+import Test.Tasty (TestTree)+import Test.Tasty.QuickCheck (testProperty)+import Test.QuickCheck+import qualified Data.Picoparsec as P+import qualified Data.Picoparsec.Combinator as C+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Char8 as B8++choice :: NonEmptyList (NonEmptyList Word8) -> Gen Property+choice (NonEmpty xs) = do+  let ys = map (BL.pack . getNonEmpty) xs+  return . forAll (repackBS <$> arbitrary <*> (toStrictBS <$> elements ys)) $+    maybe False (`elem` ys) . P.maybeResult . flip P.feed mempty . P.parse (C.choice (map P.string ys))++count :: Positive (Small Int) -> Repack -> B8.ByteString -> Bool+count (Positive (Small n)) rs s =+    (length <$> parse (C.count n (P.string s)) (BL.toStrict input)) == Just n+  where input = repackBS rs (B8.concat (replicate (n+1) s))++{-+match :: Int -> NonNegative Int -> NonNegative Int -> Repack -> Bool+match n (NonNegative x) (NonNegative y) rs =+    parse (P.match parser) (repackBS rs input) == Just (input, n)+  where parser = P.skipWhile (=='x') *> P.signed P.decimal <*+                 P.skipWhile (=='y')+        input = B8.concat [+            B8.replicate x 'x', B8.pack (show n), B8.replicate y 'y'+          ]+-}++tests :: [TestTree]+tests = [+    testProperty "choice" choice+  , testProperty "count" count+--  , testProperty "match" match+  ]

@@ -0,0 +1,86 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module QC.Common+    (+      parse+    , toLazyBS+    , toStrictBS+    , Repack+    , repackBS+    , repackBS_+    , repackT+    , repackT_+    , liftOp+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<*>))+#endif+import Control.Applicative ((<$>))+import Data.Char (isAlpha)+import Data.Monoid (Monoid)+import Test.QuickCheck+import Test.QuickCheck.Unicode (shrinkChar, string)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Picoparsec as P++parse :: Monoid t => P.Parser t r -> t -> Maybe r+parse p = P.maybeResult . P.parse p++toStrictBS :: BL.ByteString -> B.ByteString+toStrictBS = B.concat . BL.toChunks++toLazyBS :: B.ByteString -> BL.ByteString+toLazyBS = BL.fromChunks . (:[])++instance Arbitrary B.ByteString where+    arbitrary = B.pack <$> arbitrary++instance Arbitrary BL.ByteString where+    arbitrary = repackBS <$> arbitrary <*> arbitrary++type Repack = NonEmptyList (Positive (Small Int))++repackBS :: Repack -> B.ByteString -> BL.ByteString+repackBS (NonEmpty bs) =+    BL.fromChunks . repackBS_ (map (getSmall . getPositive) bs)++repackBS_ :: [Int] -> B.ByteString -> [B.ByteString]+repackBS_ = go . cycle+  where go (b:bs) s+          | B.null s = []+          | otherwise = let (h,t) = B.splitAt b s+                        in h : go bs t+        go _ _ = error "unpossible"++instance Arbitrary T.Text where+    arbitrary = T.pack <$> string+    shrink    = map T.pack . shrinkList shrinkChar . T.unpack++instance Arbitrary TL.Text where+    arbitrary = TL.pack <$> string+    shrink    = map TL.pack . shrinkList shrinkChar . TL.unpack++repackT :: Repack -> T.Text -> TL.Text+repackT (NonEmpty bs) =+    TL.fromChunks . repackT_ (map (getSmall . getPositive) bs)++repackT_ :: [Int] -> T.Text -> [T.Text]+repackT_ = go . cycle+  where go (b:bs) s+          | T.null s = []+          | otherwise = let (h,t) = T.splitAt b s+                        in h : go bs t+        go _ _ = error "unpossible"++liftOp :: (Show a, Testable prop) =>+          String -> (a -> a -> prop) -> a -> a -> Property+liftOp name f x y = counterexample desc (f x y)+  where op = case name of+               (c:_) | isAlpha c -> " `" ++ name ++ "` "+                     | otherwise -> " " ++ name ++ " "+               _ -> " ??? "+        desc = "not (" ++ show x ++ op ++ show y ++ ")"

@@ -1,63 +1,72 @@-{-# LANGUAGE BangPatterns, OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-orphans #-}+{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables, GADTs #-}+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module QC.Monoid (tests) where -import Prelude hiding (null, takeWhile)+import Prelude hiding (null, take, takeWhile)  import Control.Applicative ((<$>), (<*>), (*>), many, pure) import Data.Monoid (Monoid, Sum(..), mempty, (<>))-import Data.Word (Word8)+import Data.String (fromString)+import Test.Tasty (TestTree) import Test.Tasty.QuickCheck (testProperty)+import QC.Common (liftOp, parse) import Test.QuickCheck import Test.QuickCheck.Modifiers () import qualified Data.Picoparsec as P import qualified Data.Picoparsec.State as PS import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import qualified Data.Text as T+import qualified Data.Text as T hiding (break, singleton, span)+import qualified Data.Text.Lazy as LT import qualified Data.Text.Encoding as TE-import Data.Monoid.Null (null)+import Data.Monoid.Null (MonoidNull(null))+import Data.Monoid.Cancellative (LeftGCDMonoid)+import Data.Monoid.Factorial (FactorialMonoid(primePrefix, splitPrimePrefix))+import qualified Data.Monoid.Factorial as F+import qualified Data.Monoid.Textual as T import Data.Monoid.Instances.ByteString.UTF8 (ByteStringUTF8(..), decode) -instance Arbitrary B.ByteString where-    arbitrary   = B.pack <$> arbitrary--instance Arbitrary L.ByteString where-    arbitrary   = sized $ \n -> resize (round (sqrt (toEnum n :: Double)))-                  ((L.fromChunks . map (B.pack . nonEmpty)) <$> arbitrary)-      where nonEmpty (NonEmpty a) = a--instance Arbitrary T.Text where-    arbitrary   = T.pack <$> arbitrary---- Naming.--{--label (NonEmpty s) = case parse (anyToken <?> s) B.empty of-                            (_, Left err) -> s `isInfixOf` err-                            _             -> False--}+data Witness a where+   ByteStringWitness :: Witness B.ByteString+   StringWitness :: Witness String+   TextWitness :: Witness T.Text  -- Basic byte-level combinators.  utf8 :: T.Text -> ByteStringUTF8 utf8 = ByteStringUTF8 . TE.encodeUtf8 +satisfy :: (FactorialMonoid i, Ord i, Show i) => Witness i -> i -> Property+satisfy _ s = not (null w) ==> parse (P.satisfy (<= w)) s === Just w+  where w = primePrefix s+ maybeP :: Monoid t => P.Parser t r -> t -> Maybe r maybeP p = P.maybeResult . flip P.feed mempty . P.parse p +satisfyWith :: forall i. (FactorialMonoid i, Ord i, Show i) => Witness i -> i -> i -> Property+satisfyWith _ p s = not (null p) ==> parse (P.satisfyWith id (<=c)) (c <> s) === Just c+  where c = primePrefix p++defP :: Monoid i => P.Parser i r -> i -> P.IResult i r defP p = flip P.feed mempty . P.parse p -satisfy :: Word8 -> B.ByteString -> Bool-satisfy w s = maybeP (P.satisfy (<=b)) (b <> s) == Just b-   where b = B.singleton w+char :: Char -> LT.Text -> Property+char w s = parse (P.char w) (LT.cons w s) === Just w +skip :: (FactorialMonoid i, Ord i, Show i) => Witness i -> i -> Property+skip _ ws = not (null ws) ==>+  case (parse (P.skip (<w)) s, splitPrimePrefix s) of+    (Nothing, mcs) -> maybe (property True) (expectFailure . it) mcs+    (Just _,  mcs) -> maybe (property False) it mcs+  where it cs = liftOp "<" (<) (fst cs) w+        Just (w, s) = splitPrimePrefix ws+ satisfyChar :: Char -> T.Text -> Bool satisfyChar c s = maybeP (P.satisfyChar (<=c)) (t <> s) == Just c                   && maybeP (P.satisfyChar (<=c)) (utf8 t <> utf8 s) == Just c    where t = T.singleton c -satisfyPartialChar c s (NonNegative n) = P.maybeResult p' == Just c+satisfyPartialChar :: (T.TextualMonoid i, i ~ T.Text) => Witness i -> Char -> i -> NonNegative Int -> Bool+satisfyPartialChar _ c s (NonNegative n) = P.maybeResult p' == Just c    where b = TE.encodeUtf8 (T.cons c s)          (b1, b2) = B.splitAt (n `mod` B.length b + 1) b          (u1, b1') = decode b1@@ -67,17 +76,36 @@          p2 = if null u2 then p1 else P.feed p1 u2          p' = P.feed p2 mempty -anyToken s-    | L.null s  = p == Nothing-    | otherwise = p == Just (L.take 1 s)+anyToken :: (Eq i, FactorialMonoid i, Show i) => Witness i -> i -> Bool+anyToken _ s+    | null s  = p == Nothing+    | otherwise = p == Just (F.take 1 s)   where p = maybeP P.anyToken s -anyChar s-    | T.null s  = p == Nothing-    | otherwise = p == Just (T.head s)-  where p = maybeP P.anyChar s+anyChar :: T.TextualMonoid i => Witness i -> i -> Bool+anyChar _ s = maybeP P.anyChar s == T.characterPrefix s -anyPartialChar s (NonNegative n)+notChar :: forall a. T.TextualMonoid a => Witness a -> Char -> NonEmptyList Char -> Property+notChar _ w (NonEmpty s) = parse (P.notChar w) bs === if v == Just w+                                                      then Nothing+                                                      else v+    where v = T.characterPrefix bs+          bs = fromString s :: a++peekChar :: (Eq i, T.TextualMonoid i, Show i) => Witness i -> i -> Property+peekChar _ s+    | null s  = p === Just (Nothing, s)+    | otherwise = p === Just (T.characterPrefix s, s)+  where p = maybeP ((,) <$> P.peekChar <*> P.takeRest) s++peekChar' :: T.TextualMonoid i => Witness i -> i -> Property+peekChar' _ s = parse P.peekChar' s === (fst <$> T.splitCharacterPrefix s)++string :: (Eq i, LeftGCDMonoid i, MonoidNull i, Show i) => Witness i -> i -> i -> Property+string _ s t = parse (P.string s) (s <> t) === Just s++anyPartialChar :: (Eq i, T.TextualMonoid i, Show i, i ~ T.Text) => Witness i -> i -> NonNegative Int -> Bool+anyPartialChar _ s (NonNegative n)     | T.null s  = maybeP p0 (ByteStringUTF8 b) == Nothing     | otherwise = P.maybeResult p' == Just (T.head s)    where b = TE.encodeUtf8 s@@ -89,41 +117,54 @@          p2 = if null u2 then p1 else P.feed p1 u2          p' = P.feed p2 mempty -peekToken s-    | L.null s  = p == Just (L.empty, s)-    | otherwise = p == Just (L.take 1 s, s)+peekToken :: (Eq i, FactorialMonoid i, Show i) => Witness i -> i -> Property+peekToken _ s+    | null s  = p === Just (mempty, s)+    | otherwise = p === Just (F.take 1 s, s)   where p = maybeP ((,) <$> P.peekToken <*> P.takeRest) s -string s t = maybeP (P.string s) (s `L.append` t) == Just s-+skipWhile :: Char -> LT.Text -> Property skipWhile w s =-    let t = L.dropWhile (<= w) s-    in case defP (P.skipWhile (<= L.singleton w)) s of-         P.Done t' () -> t == t'-         _            -> False+    let t = LT.dropWhile (<= w) s+    in case defP (P.skipWhile (<= LT.singleton w)) s of+         P.Done t' () -> t === t'+         _            -> property False -takeCount (Positive k) s =-    case maybeP (P.take k) s of-      Nothing -> fromIntegral k > L.length s-      Just s' -> fromIntegral k <= L.length s'+take :: (Eq i, FactorialMonoid i, Show i) => Witness i -> Int -> i -> Property+take _ n s = maybe (liftOp "<" (<) (F.length s) (fromIntegral n))+             (=== F.take n s) $+             parse (P.take n) s -takeWhile w s =-    let (h,t) = L.span (<=w) s-    in case defP (P.takeWhile (<= L.singleton w)) s of-         P.Done t' h' -> t == t' && h == h'-         _            -> False+takeRest :: (Eq i, MonoidNull i, Show i) => Witness i -> i -> Property+takeRest _ s = maybe (property False) (=== s) . maybeP P.takeRest $ s -takeCharsWhile c s =-    let (h,t) = T.span (<=c) s-    in case defP (P.takeCharsWhile (<= c)) s of-         P.Done t' h' -> t == t' && h == h'-         _            -> False+takeCount :: FactorialMonoid i => Witness i -> Positive Int -> i -> Property+takeCount _ (Positive k) s = not (null s) ==>+    case parse (P.take k) s of+      Nothing -> liftOp ">" (>) (fromIntegral k) (F.length s)+      Just _s -> liftOp "<=" (<=) (fromIntegral k) (F.length s) -takePartialCharsWhile c s (NonNegative n) = +takeWhile :: (Eq i, FactorialMonoid i, Show i) => Witness i -> i -> Property+takeWhile _ ws = not (null ws) ==>+    let (h,t) = F.span (==w) s+        Just (w,s) = splitPrimePrefix ws+    in case maybeP ((,) <$> P.takeWhile (==w) <*> P.takeRest) s of+         Just (h', t') -> t === t' .&&. h === h'+         _             -> property False++takeCharsWhile :: (Eq i, T.TextualMonoid i, Show i) => Witness i -> Char -> i -> Property+takeCharsWhile _ w s =+    let (h,t) = T.span (const False) (==w) s+    in case maybeP ((,) <$> P.takeCharsWhile (==w) <*> P.takeRest) s of+         Just (h', t') -> t === t' .&&. h === h'+         _             -> property False++takePartialCharsWhile :: (Ord i, T.TextualMonoid i, Show i, i ~ T.Text) => Witness i -> Char -> i -> NonNegative Int -> Bool+takePartialCharsWhile _ c s (NonNegative n) =     case p' of       P.Done t' h' -> utf8 t == t' && utf8 h == h'       _            -> False-   where (h,t) = T.span (<=c) s+   where (h,t) = T.span (const False) (<=c) s          b = TE.encodeUtf8 s          (b1, b2) = B.splitAt (if B.null b then 0 else n `mod` B.length b + 1) b          (u1, b1') = decode b1@@ -133,27 +174,31 @@          p2 = if null u2 then p1 else P.feed p1 u2          p' = P.feed p2 mempty -takeWhile1 w s =-    let s'    = L.cons w s-        (h,t) = L.span (<=w) s'-    in case defP (P.takeWhile1 (<= L.singleton w)) s' of+takeWhile1 :: (Ord i, FactorialMonoid i) => Witness i -> i -> Property+takeWhile1 _ ws = not (null ws) ==>+  let s'    = w <> s+      (h,t) = F.span (<=w) s'+      Just (w, s) = splitPrimePrefix ws+    in case defP (P.takeWhile1 (<= w)) s' of          P.Done t' h' -> t == t' && h == h'          _            -> False -takeCharsWhile1 c s =-    let s'    = T.cons c s-        (h,t) = T.span (<=c) s'-    in case defP (P.takeWhile1 (<= T.singleton c)) s' of+takeCharsWhile1 :: (Ord i, T.TextualMonoid i, Show i) => Witness i -> Char -> i -> Bool+takeCharsWhile1 _ c s =+    let s'    = T.singleton c <> s+        (h,t) = T.span (const False) (<=c) s'+    in case defP (P.takeCharsWhile1 (<= c)) s' of          P.Done t' h' -> t == t' && h == h'          _            -> False -takePartialCharsWhile1 c s (NonNegative n) = +takePartialCharsWhile1 :: (Eq i, T.TextualMonoid i, Show i, i ~ T.Text) => Witness i -> Char -> i -> NonNegative Int -> Bool+takePartialCharsWhile1 _ c s (NonNegative n) =     case p' of      P.Done t' h' -> utf8 t == t' && utf8 h == h'      _            -> False    where b = TE.encodeUtf8 s'          s' = T.cons c s-         (h,t) = T.span (<=c) s'+         (h,t) = T.span (const False) (<=c) s'          (b1, b2) = B.splitAt (if B.null b then 0 else n `mod` B.length b + 1) b          (u1, b1') = decode b1          u2 = ByteStringUTF8 (b1' <> b2)@@ -162,28 +207,34 @@          p2 = if null u2 then p1 else P.feed p1 u2          p' = P.feed p2 mempty -takeTill w s =-    let (h,t) = L.break (== w) s-    in case defP (P.takeTill (== L.singleton w)) s of+takeTill :: (Eq i, FactorialMonoid i) => Witness i -> i -> Property+takeTill _ ws = not (null ws) ==> +    let (h,t) = F.break (== w) s+        Just (w, s) = splitPrimePrefix ws+    in case defP (P.takeTill (== w)) s of          P.Done t' h' -> t == t' && h == h'          _            -> False -takeCharsTill c s =-    let (h,t) = T.break (== c) s+takeCharsTill :: (Eq i, T.TextualMonoid i) => Witness i -> Char -> i -> Bool+takeCharsTill _ c s =+    let (h,t) = T.break (const False) (== c) s     in case defP (P.takeCharsTill (== c)) s of          P.Done t' h' -> t == t' && h == h'          _            -> False-takeTillChar c s =-    let (h,t) = T.break (<= c) s++takeTillChar :: (Eq i, T.TextualMonoid i) => Witness i -> Char -> i -> Bool+takeTillChar _ c s =+    let (h,t) = T.break (const False) (<= c) s     in case defP (P.takeTillChar (<= c)) s of          P.Done t' h' -> t == t' && h == h'          _            -> False -takeTillPartialChar c s (NonNegative n) =+takeTillPartialChar :: (Eq i, T.TextualMonoid i, i ~ T.Text) => Witness i -> Char -> i -> NonNegative Int -> Bool+takeTillPartialChar _ c s (NonNegative n) =    case p' of       P.Done t' h' -> utf8 t == t' && utf8 h == h'       _            -> False-   where (h,t) = T.break (<= c) s+   where (h,t) = T.break (const False) (<= c) s          b = TE.encodeUtf8 s          (b1, b2) = B.splitAt (if B.null b then 0 else n `mod` B.length b + 1) b          (u1, b1') = decode b1@@ -193,19 +244,21 @@          p2 = if null u2 then p1 else P.feed p1 u2          p' = P.feed p2 mempty -takeTillChar1 c s =-    let s'    = T.cons c s-        (h,t) = T.break (< c) s'+takeTillChar1 :: (Eq i, T.TextualMonoid i) => Witness i -> Char -> i -> Bool+takeTillChar1 _ c s =+    let s'    = T.singleton c <> s+        (h,t) = T.break (const False) (< c) s'     in case defP (P.takeTillChar1 (< c)) s' of          P.Done t' h' -> t == t' && h == h'          _            -> False -takeTillPartialChar1 c s (NonNegative n) =+takeTillPartialChar1 :: (Eq i, T.TextualMonoid i, i ~ T.Text) => Witness i -> Char -> i -> NonNegative Int -> Bool+takeTillPartialChar1 _ c s (NonNegative n) =    case p' of       P.Done t' h' -> utf8 t == t' && utf8 h == h'       _            -> False-   where s'    = T.cons c s-         (h,t) = T.break (< c) s'+   where s'    = T.singleton c <> s+         (h,t) = T.break (const False) (< c) s'          b = TE.encodeUtf8 s'          (b1, b2) = B.splitAt (n `mod` B.length b + 1) b          (u1, b1') = decode b1@@ -215,40 +268,66 @@          p2 = if null u2 then p1 else P.feed p1 u2          p' = P.feed p2 mempty -takeWhile1_empty = maybeP (P.takeWhile1 undefined) L.empty == Nothing+takeWhile1_empty :: forall i. (Eq i, FactorialMonoid i) => Witness i -> Bool+takeWhile1_empty _ = maybeP (P.takeWhile1 undefined) (mempty :: i) == Nothing -endOfInput s = maybeP P.endOfInput s == if B.null s-                                        then Just ()-                                        else Nothing+endOfInput :: (Eq i, MonoidNull i) => Witness i -> i -> Property+endOfInput _ s = maybeP P.endOfInput s === if null s+                                           then Just ()+                                           else Nothing  stateful :: String -> Bool stateful s = maybeP (many (PS.modifyState (+ (Sum 1)) *> P.anyChar) *> PS.getState) (pure s)              == Just (Sum (length s)) +endOfLine :: (Eq i, T.TextualMonoid i) => Witness i -> i -> Property+endOfLine _ s =+  case (parse P.endOfLine s, T.splitCharacterPrefix s) of+    (Nothing, mcs) -> maybe (property True) (expectFailure . eol) mcs+    (Just _,  mcs) -> maybe (property False) eol mcs+  where eol (c,s') = c === '\n' .||.+                     (c, fst <$> T.splitCharacterPrefix s') === ('\r', Just '\n')++scan :: (Eq i, T.TextualMonoid i, Show i) => Witness i -> i -> Positive Int -> Property+scan _ s (Positive k) = maybeP p s === Just (F.take k s)+  where p = P.scan k $ \ n _ ->+            if n > 0 then let !n' = n - 1 in Just n' else Nothing++tests :: [TestTree] tests = [-    testProperty "satisfy" satisfy,+   testProperty "anyChar" (anyChar TextWitness)+    , testProperty "char" char+       , testProperty "notChar" (notChar TextWitness),     testProperty "satisfyChar" satisfyChar,-    testProperty "satisfyPartialChar" satisfyPartialChar,-    testProperty "anyToken" anyToken,-    testProperty "anyChar" anyChar,-    testProperty "anyPartialChar" anyPartialChar,-    testProperty "peekToken" peekToken,-    testProperty "string" string,-    testProperty "skipWhile" skipWhile,-    testProperty "takeCount" takeCount,-    testProperty "takeWhile" takeWhile,-    testProperty "takeCharsWhile" takeCharsWhile,-    testProperty "takePartialCharsWhile" takePartialCharsWhile,-    testProperty "takeWhile1" takeWhile1,-    testProperty "takeWhile1_empty" takeWhile1_empty,-    testProperty "takeCharsWhile1" takeCharsWhile1,-    testProperty "takePartialCharsWhile1" takePartialCharsWhile1,-    testProperty "takeTill" takeTill,-    testProperty "takeCharsTill" takeCharsTill,-    testProperty "takeTillChar" takeTillChar,-    testProperty "takeTillPartialChar" takeTillPartialChar,-    testProperty "takeTillChar1" takeTillChar1,-    testProperty "takeTillPartialChar1" takeTillPartialChar1,-    testProperty "endOfInput" endOfInput,+    testProperty "satisfyPartialChar" (satisfyPartialChar TextWitness),+    testProperty "anyToken" (anyToken ByteStringWitness),+    testProperty "endOfLine" (endOfLine TextWitness),+    testProperty "anyPartialChar" (anyPartialChar TextWitness),+    testProperty "peekToken" (peekToken ByteStringWitness)+    , testProperty "peekChar" (peekChar TextWitness)+    , testProperty "peekChar'" (peekChar' TextWitness)+    , testProperty "satisfy" (satisfy ByteStringWitness)+    , testProperty "satisfyWith" (satisfyWith ByteStringWitness)+    , testProperty "scan" (scan TextWitness)+    , testProperty "skip" (skip ByteStringWitness)+    , testProperty "skipWhile" skipWhile+    , testProperty "string" (string TextWitness)+    , testProperty "take" (take ByteStringWitness)+    , testProperty "takeRest" (takeRest ByteStringWitness)+    , testProperty "takeCount" (takeCount ByteStringWitness)+    , testProperty "takeTill" (takeTill ByteStringWitness),+    testProperty "takeCharsTill" (takeCharsTill TextWitness),+    testProperty "takeTillChar" (takeTillChar TextWitness),+    testProperty "takeTillPartialChar" (takeTillPartialChar TextWitness),+    testProperty "takeTillChar1" (takeTillChar1 TextWitness),+    testProperty "takeTillPartialChar1" (takeTillPartialChar1 TextWitness)+    , testProperty "takeWhile" (takeWhile ByteStringWitness)+    , testProperty "takeWhile1" (takeWhile1 ByteStringWitness)+    , testProperty "takeWhile1_empty" (takeWhile1_empty ByteStringWitness),+    testProperty "takeCharsWhile" (takeCharsWhile TextWitness),+    testProperty "takeCharsWhile1" (takeCharsWhile1 TextWitness),+    testProperty "takePartialCharsWhile" (takePartialCharsWhile TextWitness),+    testProperty "takePartialCharsWhile1" (takePartialCharsWhile1 TextWitness),+    testProperty "endOfInput" (endOfInput ByteStringWitness),     testProperty "stateful" stateful   ]

@@ -0,0 +1,56 @@+{-# LANGUAGE BangPatterns #-}++module QC.Rechunked (+      rechunkBS+    , rechunkT+    ) where++import Control.Monad (forM, forM_)+import Control.Monad.ST (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 _ [] _ = error "it's 2014, where's my Stream type?"+        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 :: [(Int,Int)] -> ST s (V.Vector Int)+        swapAll ijs = do+          mv <- G.unsafeThaw (G.enumFromTo 0 n :: V.Vector Int)+          forM_ ijs $ uncurry (M.swap mv)+          G.unsafeFreeze mv

@@ -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 (foldl')+import Data.Maybe (fromMaybe)+import Data.Monoid (Monoid)+import Data.String (IsString)+import QC.Rechunked (rechunkBS)+import Test.Tasty (TestTree)+import Test.Tasty.QuickCheck (testProperty)+import Test.QuickCheck (Property, counterexample, forAll)+import Data.Monoid.Instances.ByteString.UTF8 (ByteStringUTF8(..))+import qualified Data.Picoparsec as P++t_issue75 = expect issue75 "ab" (P.Done "" "b")++issue75 :: P.Parser ByteStringUTF8 ByteStringUTF8+issue75 = "a" >> ("b" <|> "")++expect :: (Show r, Eq r) => P.Parser ByteStringUTF8 r -> ByteString -> P.Result ByteStringUTF8 r -> Property+expect p input wanted =+  forAll (rechunkBS input) $ \in' ->+    let result = parse p (ByteStringUTF8 <$> in')+    in counterexample (show result ++ " /= " ++ show wanted) $+       fromMaybe False (P.compareResults result wanted)++parse :: (Monoid i, IsString i) => P.Parser i r -> [i] -> P.Result i r+parse p (x:xs) = foldl' P.feed (P.parse p x) xs+parse p []     = P.parse p ""++tests :: [TestTree]+tests = [+      testProperty "issue75" t_issue75+  ]

@@ -1,25 +0,0 @@-module Main (main) where--import Data.Word (Word8)-import qualified Data.Picoparsec.FastSet as F-import System.Random (Random(..), RandomGen)-import Test.QuickCheck--integralRandomR :: (Integral a, RandomGen g) => (a, a) -> g -> (a, g)-integralRandomR (a,b) g = case randomR (fromIntegral a :: Int,-                                        fromIntegral b :: Int) g-                          of (x,g') -> (fromIntegral x, g')--instance Random Word8 where-  randomR = integralRandomR-  random = randomR (minBound,maxBound)--instance Arbitrary Word8 where-    arbitrary = choose (minBound, maxBound)--prop_AllMembers s =-    let set = F.fromList s-    in all (`F.memberWord8` set) s--main = do-  quickCheck prop_AllMembers