05fc26c...master · typeable/attoparsec

git.iko.soy/typeable/attoparsec

67 files changed+3657−889

since splitsnapshots

unifiedsplit

.gitignore+1 .hgignore+5−1 .hgtags+11 .travis.yml+161 Data/Attoparsec.hs+1−1 Data/Attoparsec/ByteString.hs+34−19 Data/Attoparsec/ByteString/Buffer.hs+156 Data/Attoparsec/ByteString/Char8.hs+40−54 Data/Attoparsec/ByteString/FastSet.hs+1−1 Data/Attoparsec/ByteString/Internal.hs+148−140 Data/Attoparsec/ByteString/Lazy.hs+10−3 Data/Attoparsec/Char8.hs+1−1 Data/Attoparsec/Combinator.hs+59−42 Data/Attoparsec/Internal.hs+143−5 Data/Attoparsec/ByteString/Fhthagn.hs → Data/Attoparsec/Internal/Fhthagn.hs+1−1 Data/Attoparsec/Internal/Types.hs+137−57 Data/Attoparsec/Lazy.hs+1−1 Data/Attoparsec/Number.hs+15−2 Data/Attoparsec/Text.hs+61−50 Data/Attoparsec/Text/Buffer.hs+172 Data/Attoparsec/Text/FastSet.hs+85−27 Data/Attoparsec/Text/Internal.hs+132−125 Data/Attoparsec/Text/Lazy.hs+13−10 Data/Attoparsec/Types.hs+3−2 Data/Attoparsec/Zepto.hs+88−46 README.markdown−6 attoparsec.cabal+83−27 benchmarks/Aeson.hs+8−3 benchmarks/Benchmarks.hs+10 benchmarks/Common.hs+10 benchmarks/Genome.hs+75 benchmarks/HeadersByteString.hs+15−34 benchmarks/HeadersByteString/Atto.hs+57 benchmarks/HeadersText.hs+3−3 benchmarks/Links.hs+2−2 benchmarks/Numbers.hs+1 benchmarks/Sets.hs+21 benchmarks/TextFastSet.hs+121 benchmarks/Warp.hs+17 benchmarks/attoparsec-benchmarks.cabal+13−3 benchmarks/http-request.txt+3−8 benchmarks/http-response.txt+2−4 benchmarks/warp-3.0.1.1/LICENSE+20 benchmarks/warp-3.0.1.1/Network/Wai/Handler/Warp/ReadInt.hs+67 benchmarks/warp-3.0.1.1/Network/Wai/Handler/Warp/RequestHeader.hs+172 changelog.md+71 examples/TestRFC2616.hs → examples/Atto_RFC2616.hs+16−8 examples/Makefile+6−2 examples/Parsec_RFC2616.hs+9−6 examples/RFC2616.hs+24−49 examples/attoparsec-examples.cabal+31 examples/http-requests.txt+494 examples/rfc2616.c+27−21 tests/Makefile−14 tests/QC.hs+6−2 tests/QC/Buffer.hs+96 tests/QC/ByteString.hs+39−9 tests/QC/Combinator.hs+18−5 tests/QC/Common.hs+34−4 tests/QC/IPv6/Internal.hs+316 tests/QC/IPv6/Types.hs+29 tests/QC/Rechunked.hs+56 tests/QC/Simple.hs+37 tests/QC/Text.hs+100−66 tests/QC/Text/FastSet.hs+15 tests/QC/Text/Regressions.hs+54 tests/TestFastSet.hs−25

.gitignore+1

@@ -3,3 +3,4 @@

33/dist/

44.cabal-sandbox

55cabal.sandbox.config

6+*.sw[op]

.hgignore+5−1

@@ -1,11 +1,15 @@

1−^(?:\.cabal-sandbox|benchmarks/\.cabal-sandbox|cabal-dev|dist)$

21\.(?:aux|eventlog|h[ip]|hs.html|log|[mt]ix|[oa]|orig|prof|ps|rej|swp)$

32~$

3+^(?:.+/|)\.cabal-sandbox/

4+^(?:.+/|)dist/

45benchmarks/Arse

56benchmarks/dist

67benchmarks/med.txt

78benchmarks/tiny

9+benchmarks/warp-[0-9]*

810cabal.sandbox.config

11+examples/c-http

12+examples/http_parser.[ch]

913hpc.*\.html$

1014

1115syntax: glob

.hgtags+11

@@ -50,3 +50,14 @@ ec23283e88c00af34c3144a8775ca4358daea3f7 0.10.4.0

5050a3c7a521fd58595d6a470ab890cc54a80dd45bd7 0.11.3.1

515138326ce07aca6c8c3a014b0d454d2a5bfdbd6a52 0.11.3.2

5252694039f4fc157a8ca5dce37959391615b6c3f535 0.11.3.3

53+1fe92d1838fb1b1afcee1ca18d4970cf7e01956e 0.11.3.4

54+68203a4cb847da905fa44b5aa1942b99d5867ab4 0.12.0.0

55+c9c2b05707b2fffcd749d5817e3e0d04e6ad6d0d 0.12.1.0

56+9157c2b4c35aa5f683b4ac51e6ff52c696bc22e2 0.12.1.1

57+682ba515f7ba62500ad79371b37b90932e0c0e3d 0.12.1.2

58+2066a72b79b478f59a9c7f1839c522fc59ba9af7 0.12.1.3

59+ef875ad3bebef2b6fb1bd7063de6a46a06d0d4b4 0.12.1.4

60+dc1fcff28d13a508f677c7b06af6420877842493 0.12.1.5

61+013e04e4526bfd5e9e4a611b42e6f03c413bea91 0.12.1.6

62+0ddbce995b77b8db391b4d6519f13feddf4b5bf3 0.13.0.0

63+46c16463ec20ad46c9cd0bfb1050c4268f34b749 0.13.0.1

.travis.ymlnew file+161

@@ -0,0 +1,161 @@

1+# This Travis job script has been generated by a script via

2+#

3+# haskell-ci '--tests-jobs=>=7.4' '--no-benchmarks' 'attoparsec.cabal'

4+#

5+# For more information, see https://github.com/haskell-CI/haskell-ci

6+#

7+# version: 0.3.20190815

8+#

9+language: c

10+dist: xenial

11+git:

12+ # whether to recursively clone submodules

13+ submodules: false

14+cache:

15+ directories:

16+ - $HOME/.cabal/packages

17+ - $HOME/.cabal/store

18+before_cache:

19+ - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log

20+ # remove files that are regenerated by 'cabal update'

21+ - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*

22+ - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json

23+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache

24+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar

25+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx

26+ - rm -rfv $CABALHOME/packages/head.hackage

27+matrix:

28+ include:

29+ - compiler: ghc-8.8.1

30+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}

31+ - compiler: ghc-8.6.5

32+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}}

33+ - compiler: ghc-8.4.4

34+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-2.4"]}}

35+ - compiler: ghc-8.2.2

36+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-2.4"]}}

37+ - compiler: ghc-8.0.2

38+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4"]}}

39+ - compiler: ghc-7.10.3

40+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.10.3","cabal-install-2.4"]}}

41+ - compiler: ghc-7.8.4

42+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.8.4","cabal-install-2.4"]}}

43+ - compiler: ghc-7.6.3

44+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.6.3","cabal-install-2.4"]}}

45+ - compiler: ghc-7.4.2

46+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.4.2","cabal-install-2.4"]}}

47+ - compiler: ghc-7.2.2

48+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.2.2","cabal-install-2.4"]}}

49+ - compiler: ghc-7.0.4

50+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.0.4","cabal-install-2.4"]}}

51+before_install:

52+ - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')

53+ - WITHCOMPILER="-w $HC"

54+ - HCPKG="$HC-pkg"

55+ - unset CC

56+ - CABAL=/opt/ghc/bin/cabal

57+ - CABALHOME=$HOME/.cabal

58+ - export PATH="$CABALHOME/bin:$PATH"

59+ - TOP=$(pwd)

60+ - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"

61+ - echo $HCNUMVER

62+ - CABAL="$CABAL -vnormal+nowrap+markoutput"

63+ - set -o pipefail

64+ - |

65+ echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk

66+ echo 'BEGIN { state = "output"; }' >> .colorful.awk

67+ echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk

68+ echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk

69+ echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk

70+ echo ' if (state == "cabal") {' >> .colorful.awk

71+ echo ' print blue($0)' >> .colorful.awk

72+ echo ' } else {' >> .colorful.awk

73+ echo ' print $0' >> .colorful.awk

74+ echo ' }' >> .colorful.awk

75+ echo '}' >> .colorful.awk

76+ - cat .colorful.awk

77+ - |

78+ color_cabal_output () {

79+ awk -f $TOP/.colorful.awk

80+ }

81+ - echo text | color_cabal_output

82+install:

83+ - ${CABAL} --version

84+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"

85+ - TEST=--enable-tests

86+ - if [ $HCNUMVER -lt 70400 ] ; then TEST=--disable-tests ; fi

87+ - BENCH=--enable-benchmarks

88+ - BENCH=--disable-benchmarks

89+ - HEADHACKAGE=false

90+ - rm -f $CABALHOME/config

91+ - |

92+ echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config

93+ echo "remote-build-reporting: anonymous" >> $CABALHOME/config

94+ echo "write-ghc-environment-files: always" >> $CABALHOME/config

95+ echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config

96+ echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config

97+ echo "world-file: $CABALHOME/world" >> $CABALHOME/config

98+ echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config

99+ echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config

100+ echo "installdir: $CABALHOME/bin" >> $CABALHOME/config

101+ echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config

102+ echo "store-dir: $CABALHOME/store" >> $CABALHOME/config

103+ echo "install-dirs user" >> $CABALHOME/config

104+ echo " prefix: $CABALHOME" >> $CABALHOME/config

105+ echo "repository hackage.haskell.org" >> $CABALHOME/config

106+ echo " url: http://hackage.haskell.org/" >> $CABALHOME/config

107+ - cat $CABALHOME/config

108+ - rm -fv cabal.project cabal.project.local cabal.project.freeze

109+ - travis_retry ${CABAL} v2-update -v

110+ # Generate cabal.project

111+ - rm -rf cabal.project cabal.project.local cabal.project.freeze

112+ - touch cabal.project

113+ - |

114+ echo "packages: ." >> cabal.project

115+ - |

116+ - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(attoparsec)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"

117+ - cat cabal.project || true

118+ - cat cabal.project.local || true

119+ - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi

120+ - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output

121+ - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"

122+ - rm cabal.project.freeze

123+ - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output

124+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output

125+script:

126+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)

127+ # Packaging...

128+ - ${CABAL} v2-sdist all | color_cabal_output

129+ # Unpacking...

130+ - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/

131+ - cd ${DISTDIR} || false

132+ - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;

133+ - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;

134+ - PKGDIR_attoparsec="$(find . -maxdepth 1 -type d -regex '.*/attoparsec-[0-9.]*')"

135+ # Generate cabal.project

136+ - rm -rf cabal.project cabal.project.local cabal.project.freeze

137+ - touch cabal.project

138+ - |

139+ echo "packages: ${PKGDIR_attoparsec}" >> cabal.project

140+ - |

141+ - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(attoparsec)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"

142+ - cat cabal.project || true

143+ - cat cabal.project.local || true

144+ # Building...

145+ # this builds all libraries and executables (without tests/benchmarks)

146+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output

147+ # Building with tests and benchmarks...

148+ # build & run tests, build benchmarks

149+ - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output

150+ # Testing...

151+ - if [ $HCNUMVER -ge 70400 ] ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi

152+ # cabal check...

153+ - (cd ${PKGDIR_attoparsec} && ${CABAL} -vnormal check)

154+ # haddock...

155+ - ${CABAL} v2-haddock $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output

156+ # Building without installed constraints for packages in global-db...

157+ - rm -f cabal.project.local

158+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output

159+

160+# REGENDATA ["--tests-jobs=>=7.4","--no-benchmarks","attoparsec.cabal"]

161+# EOF

Data/Attoparsec.hs+1−1

@@ -1,6 +1,6 @@

11-- |

22-- Module : Data.Attoparsec

3−-- Copyright : Bryan O'Sullivan 2007-2014

3+-- Copyright : Bryan O'Sullivan 2007-2015

44-- License : BSD3

55--

66-- Maintainer : bos@serpentine.com

Data/Attoparsec/ByteString.hs+34−19

@@ -1,6 +1,10 @@

1+{-# LANGUAGE CPP #-}

2+#if __GLASGOW_HASKELL__ >= 702

3+{-# LANGUAGE Trustworthy #-}

4+#endif

15-- |

26-- Module : Data.Attoparsec.ByteString

3−-- Copyright : Bryan O'Sullivan 2007-2014

7+-- Copyright : Bryan O'Sullivan 2007-2015

48-- License : BSD3

59--

610-- Maintainer : bos@serpentine.com

@@ -59,6 +63,7 @@ module Data.Attoparsec.ByteString

5963 , I.skipWhile

6064 , I.take

6165 , I.scan

66+ , I.runScanner

6267 , I.takeWhile

6368 , I.takeWhile1

6469 , I.takeTill

@@ -92,6 +97,7 @@ module Data.Attoparsec.ByteString

9297 ) where

9398

9499import Data.Attoparsec.Combinator

100+import Data.List (intercalate)

95101import qualified Data.Attoparsec.ByteString.Internal as I

96102import qualified Data.Attoparsec.Internal as I

97103import qualified Data.ByteString as B

@@ -100,50 +106,51 @@ import qualified Data.Attoparsec.Internal.Types as T

100106

101107-- $parsec

102108--

103−-- Compared to Parsec 3, Attoparsec makes several tradeoffs. It is

109+-- Compared to Parsec 3, attoparsec makes several tradeoffs. It is

104110-- not intended for, or ideal for, all possible uses.

105111--

106−-- * While Attoparsec can consume input incrementally, Parsec cannot.

112+-- * While attoparsec can consume input incrementally, Parsec cannot.

107113-- Incremental input is a huge deal for efficient and secure network

108114-- and system programming, since it gives much more control to users

109115-- of the library over matters such as resource usage and the I/O

110116-- model to use.

111117--

112−-- * Much of the performance advantage of Attoparsec is gained via

118+-- * Much of the performance advantage of attoparsec is gained via

113119-- high-performance parsers such as 'I.takeWhile' and 'I.string'.

114120-- If you use complicated combinators that return lists of bytes or

115121-- characters, there is less performance difference between the two

116122-- libraries.

117123--

118−-- * Unlike Parsec 3, Attoparsec does not support being used as a

124+-- * Unlike Parsec 3, attoparsec does not support being used as a

119125-- monad transformer.

120126--

121−-- * Attoparsec is specialised to deal only with strict 'B.ByteString'

127+-- * attoparsec is specialised to deal only with strict 'B.ByteString'

122128-- input. Efficiency concerns rule out both lists and lazy

123129-- bytestrings. The usual use for lazy bytestrings would be to

124130-- allow consumption of very large input without a large footprint.

125−-- For this need, Attoparsec's incremental input provides an

131+-- For this need, attoparsec's incremental input provides an

126132-- excellent substitute, with much more control over when input

127133-- takes place. If you must use lazy bytestrings, see the

128134-- "Data.Attoparsec.ByteString.Lazy" module, which feeds lazy chunks

129135-- to a regular parser.

130136--

131137-- * Parsec parsers can produce more helpful error messages than

132−-- Attoparsec parsers. This is a matter of focus: Attoparsec avoids

138+-- attoparsec parsers. This is a matter of focus: attoparsec avoids

133139-- the extra book-keeping in favour of higher performance.

134140

135141-- $incremental

136142--

137−-- Attoparsec supports incremental input, meaning that you can feed it

143+-- attoparsec supports incremental input, meaning that you can feed it

138144-- a bytestring that represents only part of the expected total amount

139145-- of data to parse. If your parser reaches the end of a fragment of

140146-- input and could consume more input, it will suspend parsing and

141147-- return a 'T.Partial' continuation.

142148--

143−-- Supplying the 'T.Partial' continuation with another bytestring will

144−-- resume parsing at the point where it was suspended. You must be

145−-- prepared for the result of the resumed parse to be another

146−-- 'T.Partial' continuation.

149+-- Supplying the 'T.Partial' continuation with a bytestring will

150+-- resume parsing at the point where it was suspended, with the

151+-- bytestring you supplied used as new input at the end of the

152+-- existing input. You must be prepared for the result of the resumed

153+-- parse to be another 'T.Partial' continuation.

147154--

148155-- To indicate that you have no more input, supply the 'T.Partial'

149156-- continuation with an empty bytestring.

@@ -155,12 +162,19 @@ import qualified Data.Attoparsec.Internal.Types as T

155162-- If you do not need support for incremental input, consider using

156163-- the 'I.parseOnly' function to run your parser. It will never

157164-- prompt for more input.

165+--

166+-- /Note/: incremental input does /not/ imply that attoparsec will

167+-- release portions of its internal state for garbage collection as it

168+-- proceeds. Its internal representation is equivalent to a single

169+-- 'ByteString': if you feed incremental input to a parser, it will

170+-- require memory proportional to the amount of input you supply.

171+-- (This is necessary to support arbitrary backtracking.)

158172

159173-- $performance

160174--

161−-- If you write an Attoparsec-based parser carefully, it can be

162−-- realistic to expect it to perform within a factor of 2 of a

163−-- hand-rolled C parser (measuring megabytes parsed per second).

175+-- If you write an attoparsec-based parser carefully, it can be

176+-- realistic to expect it to perform similarly to a hand-rolled C

177+-- parser (measuring megabytes parsed per second).

164178--

165179-- To actually achieve high performance, there are a few guidelines

166180-- that it is useful to follow.

@@ -210,6 +224,7 @@ maybeResult _ = Nothing

210224-- | Convert a 'Result' value to an 'Either' value. A 'T.Partial'

211225-- result is treated as failure.

212226eitherResult :: Result r -> Either String r

213−eitherResult (T.Done _ r) = Right r

214−eitherResult (T.Fail _ _ msg) = Left msg

215−eitherResult _ = Left "Result: incomplete input"

227+eitherResult (T.Done _ r) = Right r

228+eitherResult (T.Fail _ [] msg) = Left msg

229+eitherResult (T.Fail _ ctxs msg) = Left (intercalate " > " ctxs ++ ": " ++ msg)

230+eitherResult _ = Left "Result: incomplete input"

Data/Attoparsec/ByteString/Buffer.hsnew file+156

@@ -0,0 +1,156 @@

1+{-# LANGUAGE BangPatterns #-}

2+-- |

3+-- Module : Data.Attoparsec.ByteString.Buffer

4+-- Copyright : Bryan O'Sullivan 2007-2015

5+-- License : BSD3

6+--

7+-- Maintainer : bos@serpentine.com

8+-- Stability : experimental

9+-- Portability : GHC

10+--

11+-- An "immutable" buffer that supports cheap appends.

12+--

13+-- A Buffer is divided into an immutable read-only zone, followed by a

14+-- mutable area that we've preallocated, but not yet written to.

15+--

16+-- We overallocate at the end of a Buffer so that we can cheaply

17+-- append. Since a user of an existing Buffer cannot see past the end

18+-- of its immutable zone into the data that will change during an

19+-- append, this is safe.

20+--

21+-- Once we run out of space at the end of a Buffer, we do the usual

22+-- doubling of the buffer size.

23+--

24+-- The fact of having a mutable buffer really helps with performance,

25+-- but it does have a consequence: if someone misuses the Partial API

26+-- that attoparsec uses by calling the same continuation repeatedly

27+-- (which never makes sense in practice), they could overwrite data.

28+--

29+-- Since the API *looks* pure, it should *act* pure, too, so we use

30+-- two generation counters (one mutable, one immutable) to track the

31+-- number of appends to a mutable buffer. If the counters ever get out

32+-- of sync, someone is appending twice to a mutable buffer, so we

33+-- duplicate the entire buffer in order to preserve the immutability

34+-- of its older self.

35+--

36+-- While we could go a step further and gain protection against API

37+-- abuse on a multicore system, by use of an atomic increment

38+-- instruction to bump the mutable generation counter, that would be

39+-- very expensive, and feels like it would also be in the realm of the

40+-- ridiculous. Clients should never call a continuation more than

41+-- once; we lack a linear type system that could enforce this; and

42+-- there's only so far we should go to accommodate broken uses.

43+

44+module Data.Attoparsec.ByteString.Buffer

45+ (

46+ Buffer

47+ , buffer

48+ , unbuffer

49+ , pappend

50+ , length

51+ , unsafeIndex

52+ , substring

53+ , unsafeDrop

54+ ) where

55+

56+import Control.Exception (assert)

57+import Data.ByteString.Internal (ByteString(..), memcpy, nullForeignPtr)

58+import Data.Attoparsec.Internal.Fhthagn (inlinePerformIO)

59+import Data.List (foldl1')

60+import Data.Monoid as Mon (Monoid(..))

61+import Data.Semigroup (Semigroup(..))

62+import Data.Word (Word8)

63+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)

64+import Foreign.Ptr (castPtr, plusPtr)

65+import Foreign.Storable (peek, peekByteOff, poke, sizeOf)

66+import GHC.ForeignPtr (mallocPlainForeignPtrBytes)

67+import Prelude hiding (length)

68+

69+-- If _cap is zero, this buffer is empty.

70+data Buffer = Buf {

71+ _fp :: {-# UNPACK #-} !(ForeignPtr Word8)

72+ , _off :: {-# UNPACK #-} !Int

73+ , _len :: {-# UNPACK #-} !Int

74+ , _cap :: {-# UNPACK #-} !Int

75+ , _gen :: {-# UNPACK #-} !Int

76+ }

77+

78+instance Show Buffer where

79+ showsPrec p = showsPrec p . unbuffer

80+

81+-- | The initial 'Buffer' has no mutable zone, so we can avoid all

82+-- copies in the (hopefully) common case of no further input being fed

83+-- to us.

84+buffer :: ByteString -> Buffer

85+buffer (PS fp off len) = Buf fp off len len 0

86+

87+unbuffer :: Buffer -> ByteString

88+unbuffer (Buf fp off len _ _) = PS fp off len

89+

90+instance Semigroup Buffer where

91+ (Buf _ _ _ 0 _) <> b = b

92+ a <> (Buf _ _ _ 0 _) = a

93+ buf <> (Buf fp off len _ _) = append buf fp off len

94+

95+instance Monoid Buffer where

96+ mempty = Buf nullForeignPtr 0 0 0 0

97+

98+ mappend = (<>)

99+

100+ mconcat [] = Mon.mempty

101+ mconcat xs = foldl1' mappend xs

102+

103+pappend :: Buffer -> ByteString -> Buffer

104+pappend (Buf _ _ _ 0 _) bs = buffer bs

105+pappend buf (PS fp off len) = append buf fp off len

106+

107+append :: Buffer -> ForeignPtr a -> Int -> Int -> Buffer

108+append (Buf fp0 off0 len0 cap0 gen0) !fp1 !off1 !len1 =

109+ inlinePerformIO . withForeignPtr fp0 $ \ptr0 ->

110+ withForeignPtr fp1 $ \ptr1 -> do

111+ let genSize = sizeOf (0::Int)

112+ newlen = len0 + len1

113+ gen <- if gen0 == 0

114+ then return 0

115+ else peek (castPtr ptr0)

116+ if gen == gen0 && newlen <= cap0

117+ then do

118+ let newgen = gen + 1

119+ poke (castPtr ptr0) newgen

120+ memcpy (ptr0 `plusPtr` (off0+len0))

121+ (ptr1 `plusPtr` off1)

122+ (fromIntegral len1)

123+ return (Buf fp0 off0 newlen cap0 newgen)

124+ else do

125+ let newcap = newlen * 2

126+ fp <- mallocPlainForeignPtrBytes (newcap + genSize)

127+ withForeignPtr fp $ \ptr_ -> do

128+ let ptr = ptr_ `plusPtr` genSize

129+ newgen = 1

130+ poke (castPtr ptr_) newgen

131+ memcpy ptr (ptr0 `plusPtr` off0) (fromIntegral len0)

132+ memcpy (ptr `plusPtr` len0) (ptr1 `plusPtr` off1)

133+ (fromIntegral len1)

134+ return (Buf fp genSize newlen newcap newgen)

135+

136+length :: Buffer -> Int

137+length (Buf _ _ len _ _) = len

138+{-# INLINE length #-}

139+

140+unsafeIndex :: Buffer -> Int -> Word8

141+unsafeIndex (Buf fp off len _ _) i = assert (i >= 0 && i < len) .

142+ inlinePerformIO . withForeignPtr fp $ flip peekByteOff (off+i)

143+{-# INLINE unsafeIndex #-}

144+

145+substring :: Int -> Int -> Buffer -> ByteString

146+substring s l (Buf fp off len _ _) =

147+ assert (s >= 0 && s <= len) .

148+ assert (l >= 0 && l <= len-s) $

149+ PS fp (off+s) l

150+{-# INLINE substring #-}

151+

152+unsafeDrop :: Int -> Buffer -> ByteString

153+unsafeDrop s (Buf fp off len _ _) =

154+ assert (s >= 0 && s <= len) $

155+ PS fp (off+s) (len-s)

156+{-# INLINE unsafeDrop #-}

Data/Attoparsec/ByteString/Char8.hs+40−54

@@ -1,10 +1,13 @@

1−{-# LANGUAGE BangPatterns, FlexibleInstances, TypeFamilies,

1+{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, TypeFamilies,

22 TypeSynonymInstances, GADTs #-}

3−{-# OPTIONS_GHC -fno-warn-orphans #-}

3+#if __GLASGOW_HASKELL__ >= 702

4+{-# LANGUAGE Trustworthy #-} -- Imports internal modules

5+#endif

6+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-warnings-deprecations #-}

58-- |

69-- Module : Data.Attoparsec.ByteString.Char8

7−-- Copyright : Bryan O'Sullivan 2007-2014

10+-- Copyright : Bryan O'Sullivan 2007-2015

811-- License : BSD3

912--

1013-- Maintainer : bos@serpentine.com

@@ -27,9 +30,10 @@ module Data.Attoparsec.ByteString.Char8

2730

2831 -- * Running parsers

2932 , A.parse

33+ , A.feed

3034 , A.parseOnly

31− , A.parseTest

3235 , A.parseWith

36+ , A.parseTest

3337

3438 -- ** Result conversion

3539 , A.maybeResult

@@ -66,7 +70,7 @@ module Data.Attoparsec.ByteString.Char8

6670

6771 -- * Efficient string handling

6872 , I.string

69− , stringCI

73+ , I.stringCI

7074 , skipSpace

7175 , skipWhile

7276 , I.take

@@ -123,7 +127,11 @@ module Data.Attoparsec.ByteString.Char8

123127 , I.atEnd

124128 ) where

125129

126−import Control.Applicative (pure, (*>), (<*), (<$>), (<|>))

130+#if !MIN_VERSION_base(4,8,0)

131+import Control.Applicative (pure, (*>), (<*), (<$>))

132+import Data.Word (Word)

133+#endif

134+import Control.Applicative ((<|>))

127135import Control.Monad (void, when)

128136import Data.Attoparsec.ByteString.FastSet (charClass, memberChar)

129137import Data.Attoparsec.ByteString.Internal (Parser)

@@ -135,7 +143,7 @@ import Data.Int (Int8, Int16, Int32, Int64)

135143import Data.String (IsString(..))

136144import Data.Scientific (Scientific)

137145import qualified Data.Scientific as Sci

138−import Data.Word (Word8, Word16, Word32, Word64, Word)

146+import Data.Word (Word8, Word16, Word32, Word64)

139147import Prelude hiding (takeWhile)

140148import qualified Data.Attoparsec.ByteString as A

141149import qualified Data.Attoparsec.ByteString.Internal as I

@@ -161,16 +169,6 @@ instance (a ~ B.ByteString) => IsString (Parser a) where

161169-- currency sign in ISO-8859-1). Haskell 'Char' values above U+00FF

162170-- are truncated, so e.g. U+1D6B7 is truncated to the byte @0xB7@.

163171

164−-- ASCII-specific but fast, oh yes.

165−toLower :: Word8 -> Word8

166−toLower w | w >= 65 && w <= 90 = w + 32

167− | otherwise = w

168−

169−-- | Satisfy a literal string, ignoring case.

170−stringCI :: B.ByteString -> Parser B.ByteString

171−stringCI = I.stringTransform (B8.map toLower)

172−{-# INLINE stringCI #-}

173−

174172-- | Consume input as long as the predicate returns 'True', and return

175173-- the consumed input.

176174--

@@ -234,7 +232,7 @@ isDigit c = c >= '0' && c <= '9'

234232

235233-- | A fast digit predicate.

236234isDigit_w8 :: Word8 -> Bool

237−isDigit_w8 w = w >= 48 && w <= 57

235+isDigit_w8 w = w - 48 <= 9

238236{-# INLINE isDigit_w8 #-}

239237

240238-- | Match any character.

@@ -271,7 +269,7 @@ isSpace c = (c == ' ') || ('\t' <= c && c <= '\r')

271269

272270-- | Fast 'Word8' predicate for matching ASCII space characters.

273271isSpace_w8 :: Word8 -> Bool

274−isSpace_w8 w = (w == 32) || (9 <= w && w <= 13)

272+isSpace_w8 w = w == 32 || w - 9 <= 4

275273{-# INLINE isSpace_w8 #-}

276274

277275

@@ -446,9 +444,8 @@ hexadecimal = B8.foldl' step 0 `fmap` I.takeWhile1 isHexDigit

446444

447445-- | Parse and decode an unsigned decimal number.

448446decimal :: Integral a => Parser a

449−decimal = B8.foldl' step 0 `fmap` I.takeWhile1 isDig

450− where isDig w = w >= 48 && w <= 57

451− step a w = a * 10 + fromIntegral (w - 48)

447+decimal = B8.foldl' step 0 `fmap` I.takeWhile1 isDigit_w8

448+ where step a w = a * 10 + fromIntegral (w - 48)

452449{-# SPECIALISE decimal :: Parser Int #-}

453450{-# SPECIALISE decimal :: Parser Int8 #-}

454451{-# SPECIALISE decimal :: Parser Int16 #-}

@@ -474,6 +471,24 @@ signed p = (negate <$> (char8 '-' *> p))

474471 <|> (char8 '+' *> p)

475472 <|> p

476473

474+-- | Parse a rational number.

475+--

476+-- The syntax accepted by this parser is the same as for 'double'.

477+--

478+-- /Note/: this parser is not safe for use with inputs from untrusted

479+-- sources. An input with a suitably large exponent such as

480+-- @"1e1000000000"@ will cause a huge 'Integer' to be allocated,

481+-- resulting in what is effectively a denial-of-service attack.

482+--

483+-- In most cases, it is better to use 'double' or 'scientific'

484+-- instead.

485+rational :: Fractional a => Parser a

486+{-# SPECIALIZE rational :: Parser Double #-}

487+{-# SPECIALIZE rational :: Parser Float #-}

488+{-# SPECIALIZE rational :: Parser Rational #-}

489+{-# SPECIALIZE rational :: Parser Scientific #-}

490+rational = scientifically realToFrac

491+

477492-- | Parse a rational number.

478493--

479494-- This parser accepts an optional leading sign character, followed by

@@ -501,42 +516,12 @@ signed p = (negate <$> (char8 '-' *> p))

501516--

502517-- This function does not accept string representations of \"NaN\" or

503518-- \"Infinity\".

504−rational :: Fractional a => Parser a

505−{-# SPECIALIZE rational :: Parser Double #-}

506−{-# SPECIALIZE rational :: Parser Float #-}

507−{-# SPECIALIZE rational :: Parser Rational #-}

508−{-# SPECIALIZE rational :: Parser Scientific #-}

509−rational = scientifically realToFrac

510−

511−-- | Parse a rational number.

512−--

513−-- The syntax accepted by this parser is the same as for 'rational'.

514−--

515−-- /Note/: This function is almost ten times faster than 'rational',

516−-- but is slightly less accurate.

517−--

518−-- The 'Double' type supports about 16 decimal places of accuracy.

519−-- For 94.2% of numbers, this function and 'rational' give identical

520−-- results, but for the remaining 5.8%, this function loses precision

521−-- around the 15th decimal place. For 0.001% of numbers, this

522−-- function will lose precision at the 13th or 14th decimal place.

523−--

524−-- This function does not accept string representations of \"NaN\" or

525−-- \"Infinity\".

526519double :: Parser Double

527520double = scientifically Sci.toRealFloat

528521

529522-- | Parse a number, attempting to preserve both speed and precision.

530523--

531−-- The syntax accepted by this parser is the same as for 'rational'.

532−--

533−-- /Note/: This function is almost ten times faster than 'rational'.

534−-- On integral inputs, it gives perfectly accurate answers, and on

535−-- floating point inputs, it is slightly less accurate than

536−-- 'rational'.

537−--

538−-- This function does not accept string representations of \"NaN\" or

539−-- \"

524+-- The syntax accepted by this parser is the same as for 'double'.

540525number :: Parser Number

541526number = scientifically $ \s ->

542527 let e = Sci.base10Exponent s

@@ -544,10 +529,11 @@ number = scientifically $ \s ->

544529 in if e >= 0

545530 then I (c * 10 ^ e)

546531 else D (Sci.toRealFloat s)

532+{-# DEPRECATED number "Use 'scientific' instead." #-}

547533

548534-- | Parse a scientific number.

549535--

550−-- The syntax accepted by this parser is the same as for 'rational'.

536+-- The syntax accepted by this parser is the same as for 'double'.

551537scientific :: Parser Scientific

552538scientific = scientifically id

553539

Data/Attoparsec/ByteString/FastSet.hs+1−1

@@ -3,7 +3,7 @@

33-----------------------------------------------------------------------------

44-- |

55-- Module : Data.Attoparsec.ByteString.FastSet

6−-- Copyright : Bryan O'Sullivan 2007-2014

6+-- Copyright : Bryan O'Sullivan 2007-2015

77-- License : BSD3

88--

99-- Maintainer : bos@serpentine.com

Data/Attoparsec/ByteString/Internal.hs+148−140

@@ -1,14 +1,15 @@

1−{-# LANGUAGE BangPatterns, OverloadedStrings, RecordWildCards #-}

1+{-# LANGUAGE BangPatterns, CPP, GADTs, OverloadedStrings, RankNTypes,

2+ RecordWildCards #-}

23-- |

34-- Module : Data.Attoparsec.ByteString.Internal

4−-- Copyright : Bryan O'Sullivan 2007-2014

5+-- Copyright : Bryan O'Sullivan 2007-2015

56-- License : BSD3

67--

78-- Maintainer : bos@serpentine.com

89-- Stability : experimental

910-- Portability : unknown

1011--

11−-- Simple, efficient parser combinators for 'B.ByteString' strings,

12+-- Simple, efficient parser combinators for 'ByteString' strings,

1213-- loosely based on the Parsec library.

1314

1415module Data.Attoparsec.ByteString.Internal

@@ -46,7 +47,7 @@ module Data.Attoparsec.ByteString.Internal

4647 -- * Efficient string handling

4748 , skipWhile

4849 , string

49− , stringTransform

50+ , stringCI

5051 , take

5152 , scan

5253 , runScanner

@@ -65,18 +66,25 @@ module Data.Attoparsec.ByteString.Internal

6566 , atEnd

6667 ) where

6768

68−import Control.Applicative ((<|>), (<$>))

69+#if !MIN_VERSION_base(4,8,0)

70+import Control.Applicative ((<$>))

71+#endif

72+import Control.Applicative ((<|>))

6973import Control.Monad (when)

74+import Data.Attoparsec.ByteString.Buffer (Buffer, buffer)

7075import Data.Attoparsec.ByteString.FastSet (charClass, memberWord8)

71−import Data.Attoparsec.ByteString.Fhthagn (inlinePerformIO)

7276import Data.Attoparsec.Combinator ((<?>))

77+import Data.Attoparsec.Internal

78+import Data.Attoparsec.Internal.Fhthagn (inlinePerformIO)

7379import Data.Attoparsec.Internal.Types hiding (Parser, Failure, Success)

80+import Data.ByteString (ByteString)

81+import Data.List (intercalate)

7482import Data.Word (Word8)

7583import Foreign.ForeignPtr (withForeignPtr)

7684import Foreign.Ptr (castPtr, minusPtr, plusPtr)

7785import Foreign.Storable (Storable(peek, sizeOf))

7886import Prelude hiding (getChar, succ, take, takeWhile)

79−import Data.ByteString (ByteString)

87+import qualified Data.Attoparsec.ByteString.Buffer as Buf

8088import qualified Data.Attoparsec.Internal.Types as T

8189import qualified Data.ByteString as B8

8290import qualified Data.ByteString.Char8 as B

@@ -84,10 +92,10 @@ import qualified Data.ByteString.Internal as B

8492import qualified Data.ByteString.Lazy as L

8593import qualified Data.ByteString.Unsafe as B

8694

87−type Parser = T.Parser B.ByteString B.ByteString

88−type Result = IResult B.ByteString B.ByteString

89−type Failure r = T.Failure B.ByteString B.ByteString r

90−type Success a r = T.Success B.ByteString B.ByteString a r

95+type Parser = T.Parser ByteString

96+type Result = IResult ByteString

97+type Failure r = T.Failure ByteString Buffer r

98+type Success a r = T.Success ByteString Buffer a r

9199

92100-- | The parser @satisfy p@ succeeds for any byte for which the

93101-- predicate @p@ returns 'True'. Returns the byte that is actually

@@ -133,22 +141,15 @@ storable = hack undefined

133141 hack :: Storable b => b -> Parser b

134142 hack dummy = do

135143 (fp,o,_) <- B.toForeignPtr `fmap` take (sizeOf dummy)

136− return . B.inlinePerformIO . withForeignPtr fp $ \p ->

144+ return . inlinePerformIO . withForeignPtr fp $ \p ->

137145 peek (castPtr $ p `plusPtr` o)

138146

139−-- | Consume @n@ bytes of input, but succeed only if the predicate

140−-- returns 'True'.

141−takeWith :: Int -> (B.ByteString -> Bool) -> Parser B.ByteString

142−takeWith n0 p = do

147+-- | Consume exactly @n@ bytes of input.

148+take :: Int -> Parser ByteString

149+take n0 = do

143150 let n = max n0 0

144151 s <- ensure n

145− if p s

146− then advance n >> return s

147− else fail "takeWith"

148−

149−-- | Consume exactly @n@ bytes of input.

150−take :: Int -> Parser B.ByteString

151−take n = takeWith n (const True)

152+ advance n >> return s

152153{-# INLINE take #-}

153154

154155-- | @string s@ parses a sequence of bytes that identically match

@@ -164,16 +165,62 @@ take n = takeWith n (const True)

164165--

165166-- The reason for its failure is that the first branch is a

166167-- partial match, and will consume the letters @\'f\'@ and @\'o\'@

167−-- before failing. In Attoparsec, the above parser will /succeed/ on

168+-- before failing. In attoparsec, the above parser will /succeed/ on

168169-- that input, because the failed first branch will consume nothing.

169−string :: B.ByteString -> Parser B.ByteString

170−string s = takeWith (B.length s) (==s)

170+string :: ByteString -> Parser ByteString

171+string s = string_ (stringSuspended id) id s

171172{-# INLINE string #-}

172173

173−stringTransform :: (B.ByteString -> B.ByteString) -> B.ByteString

174− -> Parser B.ByteString

175−stringTransform f s = takeWith (B.length s) ((==f s) . f)

176−{-# INLINE stringTransform #-}

174+-- ASCII-specific but fast, oh yes.

175+toLower :: Word8 -> Word8

176+toLower w | w >= 65 && w <= 90 = w + 32

177+ | otherwise = w

178+

179+-- | Satisfy a literal string, ignoring case.

180+stringCI :: ByteString -> Parser ByteString

181+stringCI s = string_ (stringSuspended lower) lower s

182+ where lower = B8.map toLower

183+{-# INLINE stringCI #-}

184+

185+string_ :: (forall r. ByteString -> ByteString -> Buffer -> Pos -> More

186+ -> Failure r -> Success ByteString r -> Result r)

187+ -> (ByteString -> ByteString)

188+ -> ByteString -> Parser ByteString

189+string_ suspended f s0 = T.Parser $ \t pos more lose succ ->

190+ let n = B.length s

191+ s = f s0

192+ in if lengthAtLeast pos n t

193+ then let t' = substring pos (Pos n) t

194+ in if s == f t'

195+ then succ t (pos + Pos n) more t'

196+ else lose t pos more [] "string"

197+ else let t' = Buf.unsafeDrop (fromPos pos) t

198+ in if f t' `B.isPrefixOf` s

199+ then suspended s (B.drop (B.length t') s) t pos more lose succ

200+ else lose t pos more [] "string"

201+{-# INLINE string_ #-}

202+

203+stringSuspended :: (ByteString -> ByteString)

204+ -> ByteString -> ByteString -> Buffer -> Pos -> More

205+ -> Failure r

206+ -> Success ByteString r

207+ -> Result r

208+stringSuspended f s0 s t pos more lose succ =

209+ runParser (demandInput_ >>= go) t pos more lose succ

210+ where go s'0 = T.Parser $ \t' pos' more' lose' succ' ->

211+ let m = B.length s

212+ s' = f s'0

213+ n = B.length s'

214+ in if n >= m

215+ then if B.unsafeTake m s' == s

216+ then let o = Pos (B.length s0)

217+ in succ' t' (pos' + o) more'

218+ (substring pos' o t')

219+ else lose' t' pos' more' [] "string"

220+ else if s' == B.unsafeTake n s

221+ then stringSuspended f s0 (B.unsafeDrop n s)

222+ t' pos' more' lose' succ'

223+ else lose' t' pos' more' [] "string"

177224

178225-- | Skip past input for as long as the predicate returns 'True'.

179226skipWhile :: (Word8 -> Bool) -> Parser ()

@@ -181,11 +228,8 @@ skipWhile p = go

181228 where

182229 go = do

183230 t <- B8.takeWhile p <$> get

184− advance (B.length t)

185− eoc <- endOfChunk

186− when eoc $ do

187− input <- wantInput

188− when input go

231+ continue <- inputSpansChunks (B.length t)

232+ when continue go

189233{-# INLINE skipWhile #-}

190234

191235-- | Consume input as long as the predicate returns 'False'

@@ -198,7 +242,7 @@ skipWhile p = go

198242-- combinators such as 'Control.Applicative.many', because such

199243-- parsers loop until a failure occurs. Careless use will thus result

200244-- in an infinite loop.

201−takeTill :: (Word8 -> Bool) -> Parser B.ByteString

245+takeTill :: (Word8 -> Bool) -> Parser ByteString

202246takeTill p = takeWhile (not . p)

203247{-# INLINE takeTill #-}

204248

@@ -212,23 +256,27 @@ takeTill p = takeWhile (not . p)

212256-- combinators such as 'Control.Applicative.many', because such

213257-- parsers loop until a failure occurs. Careless use will thus result

214258-- in an infinite loop.

215−takeWhile :: (Word8 -> Bool) -> Parser B.ByteString

216−takeWhile p = (B.concat . reverse) `fmap` go []

259+takeWhile :: (Word8 -> Bool) -> Parser ByteString

260+takeWhile p = do

261+ s <- B8.takeWhile p <$> get

262+ continue <- inputSpansChunks (B.length s)

263+ if continue

264+ then takeWhileAcc p [s]

265+ else return s

266+{-# INLINE takeWhile #-}

267+

268+takeWhileAcc :: (Word8 -> Bool) -> [ByteString] -> Parser ByteString

269+takeWhileAcc p = go

217270 where

218271 go acc = do

219272 s <- B8.takeWhile p <$> get

220− advance (B.length s)

221− eoc <- endOfChunk

222− if eoc

223− then do

224− input <- wantInput

225− if input

226− then go (s:acc)

227− else return (s:acc)

228− else return (s:acc)

229−{-# INLINE takeWhile #-}

273+ continue <- inputSpansChunks (B.length s)

274+ if continue

275+ then go (s:acc)

276+ else return $ concatReverse (s:acc)

277+{-# INLINE takeWhileAcc #-}

230278

231−takeRest :: Parser [B.ByteString]

279+takeRest :: Parser [ByteString]

232280takeRest = go []

233281 where

234282 go acc = do

@@ -241,7 +289,7 @@ takeRest = go []

241289 else return (reverse acc)

242290

243291-- | Consume all remaining input and return it as a single string.

244−takeByteString :: Parser B.ByteString

292+takeByteString :: Parser ByteString

245293takeByteString = B.concat `fmap` takeRest

246294

247295-- | Consume all remaining input and return it as a single string.

@@ -250,7 +298,7 @@ takeLazyByteString = L.fromChunks `fmap` takeRest

250298

251299data T s = T {-# UNPACK #-} !Int s

252300

253−scan_ :: (s -> [B.ByteString] -> Parser r) -> s -> (s -> Word8 -> Maybe s)

301+scan_ :: (s -> [ByteString] -> Parser r) -> s -> (s -> Word8 -> Maybe s)

254302 -> Parser r

255303scan_ f s0 p = go [] s0

256304 where

@@ -271,14 +319,9 @@ scan_ f s0 p = go [] s0

271319 bs <- get

272320 let T i s' = inlinePerformIO $ scanner bs

273321 !h = B.unsafeTake i bs

274− advance i

275− eoc <- endOfChunk

276− if eoc

277− then do

278− input <- wantInput

279− if input

280− then go (h:acc) s'

281− else f s' (h:acc)

322+ continue <- inputSpansChunks i

323+ if continue

324+ then go (h:acc) s'

282325 else f s' (h:acc)

283326{-# INLINE scan_ #-}

284327

@@ -294,17 +337,14 @@ scan_ f s0 p = go [] s0

294337-- combinators such as 'Control.Applicative.many', because such

295338-- parsers loop until a failure occurs. Careless use will thus result

296339-- in an infinite loop.

297−scan :: s -> (s -> Word8 -> Maybe s) -> Parser B.ByteString

298−scan = scan_ $ \_ chunks ->

299− case chunks of

300− [x] -> return x

301− xs -> return $! B.concat $ reverse xs

340+scan :: s -> (s -> Word8 -> Maybe s) -> Parser ByteString

341+scan = scan_ $ \_ chunks -> return $! concatReverse chunks

302342{-# INLINE scan #-}

303343

304344-- | Like 'scan', but generalized to return the final state of the

305345-- scanner.

306−runScanner :: s -> (s -> Word8 -> Maybe s) -> Parser (B.ByteString, s)

307−runScanner = scan_ $ \s xs -> return (B.concat (reverse xs), s)

346+runScanner :: s -> (s -> Word8 -> Maybe s) -> Parser (ByteString, s)

347+runScanner = scan_ $ \s xs -> let !sx = concatReverse xs in return (sx, s)

308348{-# INLINE runScanner #-}

309349

310350-- | Consume input as long as the predicate returns 'True', and return

@@ -313,7 +353,7 @@ runScanner = scan_ $ \s xs -> return (B.concat (reverse xs), s)

313353-- This parser requires the predicate to succeed on at least one byte

314354-- of input: it will fail if the predicate never returns 'True' or if

315355-- there is no input left.

316−takeWhile1 :: (Word8 -> Bool) -> Parser B.ByteString

356+takeWhile1 :: (Word8 -> Bool) -> Parser ByteString

317357takeWhile1 p = do

318358 (`when` demandInput) =<< endOfChunk

319359 s <- B8.takeWhile p <$> get

@@ -324,8 +364,9 @@ takeWhile1 p = do

324364 advance len

325365 eoc <- endOfChunk

326366 if eoc

327− then (s<>) `fmap` takeWhile p

367+ then takeWhileAcc p [s]

328368 else return s

369+{-# INLINE takeWhile1 #-}

329370

330371-- | Match any byte in a set.

331372--

@@ -373,13 +414,13 @@ notWord8 c = satisfy (/= c) <?> "not " ++ show c

373414peekWord8 :: Parser (Maybe Word8)

374415peekWord8 = T.Parser $ \t pos@(Pos pos_) more _lose succ ->

375416 case () of

376− _| pos_ < B.length t ->

377− let !w = B.unsafeIndex t pos_

417+ _| pos_ < Buf.length t ->

418+ let !w = Buf.unsafeIndex t pos_

378419 in succ t pos more (Just w)

379420 | more == Complete ->

380421 succ t pos more Nothing

381422 | otherwise ->

382− let succ' t' pos' more' = let !w = B.unsafeIndex t pos_

423+ let succ' t' pos' more' = let !w = Buf.unsafeIndex t' pos_

383424 in succ t' pos' more' (Just w)

384425 lose' t' pos' more' = succ t' pos' more' Nothing

385426 in prompt t pos more lose' succ'

@@ -390,7 +431,7 @@ peekWord8 = T.Parser $ \t pos@(Pos pos_) more _lose succ ->

390431peekWord8' :: Parser Word8

391432peekWord8' = T.Parser $ \t pos more lose succ ->

392433 if lengthAtLeast pos 1 t

393− then succ t pos more (B.unsafeIndex t (fromPos pos))

434+ then succ t pos more (Buf.unsafeIndex t (fromPos pos))

394435 else let succ' t' pos' more' bs' = succ t' pos' more' $! B.unsafeHead bs'

395436 in ensureSuspended 1 t pos more lose succ'

396437{-# INLINE peekWord8' #-}

@@ -402,43 +443,62 @@ endOfLine = (word8 10 >> return ()) <|> (string "\r\n" >> return ())

402443

403444-- | Terminal failure continuation.

404445failK :: Failure a

405−failK t (Pos pos) _more stack msg = Fail (B.unsafeDrop pos t) stack msg

446+failK t (Pos pos) _more stack msg = Fail (Buf.unsafeDrop pos t) stack msg

406447{-# INLINE failK #-}

407448

408449-- | Terminal success continuation.

409450successK :: Success a a

410−successK t (Pos pos) _more a = Done (B.unsafeDrop pos t) a

451+successK t (Pos pos) _more a = Done (Buf.unsafeDrop pos t) a

411452{-# INLINE successK #-}

412453

413454-- | Run a parser.

414−parse :: Parser a -> B.ByteString -> Result a

415−parse m s = T.runParser m s (Pos 0) Incomplete failK successK

455+parse :: Parser a -> ByteString -> Result a

456+parse m s = T.runParser m (buffer s) (Pos 0) Incomplete failK successK

416457{-# INLINE parse #-}

417458

418459-- | Run a parser that cannot be resupplied via a 'Partial' result.

419−parseOnly :: Parser a -> B.ByteString -> Either String a

420−parseOnly m s = case T.runParser m s (Pos 0) Complete failK successK of

421− Fail _ _ err -> Left err

422− Done _ a -> Right a

423− _ -> error "parseOnly: impossible error!"

460+--

461+-- This function does not force a parser to consume all of its input.

462+-- Instead, any residual input will be discarded. To force a parser

463+-- to consume all of its input, use something like this:

464+--

465+-- @

466+--'parseOnly' (myParser 'Control.Applicative.<*' 'endOfInput')

467+-- @

468+parseOnly :: Parser a -> ByteString -> Either String a

469+parseOnly m s = case T.runParser m (buffer s) (Pos 0) Complete failK successK of

470+ Fail _ [] err -> Left err

471+ Fail _ ctxs err -> Left (intercalate " > " ctxs ++ ": " ++ err)

472+ Done _ a -> Right a

473+ _ -> error "parseOnly: impossible error!"

424474{-# INLINE parseOnly #-}

425475

426476get :: Parser ByteString

427477get = T.Parser $ \t pos more _lose succ ->

428− succ t pos more (B.unsafeDrop (fromPos pos) t)

478+ succ t pos more (Buf.unsafeDrop (fromPos pos) t)

429479{-# INLINE get #-}

430480

431481endOfChunk :: Parser Bool

432482endOfChunk = T.Parser $ \t pos more _lose succ ->

433− succ t pos more (fromPos pos == B.length t)

483+ succ t pos more (fromPos pos == Buf.length t)

434484{-# INLINE endOfChunk #-}

435485

486+inputSpansChunks :: Int -> Parser Bool

487+inputSpansChunks i = T.Parser $ \t pos_ more _lose succ ->

488+ let pos = pos_ + Pos i

489+ in if fromPos pos < Buf.length t || more == Complete

490+ then succ t pos more False

491+ else let lose' t' pos' more' = succ t' pos' more' False

492+ succ' t' pos' more' = succ t' pos' more' True

493+ in prompt t pos more lose' succ'

494+{-# INLINE inputSpansChunks #-}

495+

436496advance :: Int -> Parser ()

437497advance n = T.Parser $ \t pos more _lose succ ->

438498 succ t (pos + Pos n) more ()

439499{-# INLINE advance #-}

440500

441−ensureSuspended :: Int -> ByteString -> Pos -> More

501+ensureSuspended :: Int -> Buffer -> Pos -> More

442502 -> Failure r

443503 -> Success ByteString r

444504 -> Result r

@@ -457,54 +517,8 @@ ensure n = T.Parser $ \t pos more lose succ ->

457517 then succ t pos more (substring pos (Pos n) t)

458518 -- The uncommon case is kept out-of-line to reduce code size:

459519 else ensureSuspended n t pos more lose succ

460−-- Non-recursive so the bounds check can be inlined:

461520{-# INLINE ensure #-}

462521

463−-- | Ask for input. If we receive any, pass it to a success

464−-- continuation, otherwise to a failure continuation.

465−prompt :: ByteString -> Pos -> More

466− -> (ByteString -> Pos -> More -> IResult ByteString ByteString r)

467− -> (ByteString -> Pos -> More -> IResult ByteString ByteString r)

468− -> IResult ByteString ByteString r

469−prompt t pos _more lose succ = Partial $ \s ->

470− if B.null s

471− then lose t pos Complete

472− else succ (t <> s) pos Incomplete

473−

474−-- | Immediately demand more input via a 'Partial' continuation

475−-- result.

476−demandInput :: Parser ()

477−demandInput = T.Parser $ \t pos more lose succ ->

478− case more of

479− Complete -> lose t pos more [] "not enough input"

480− _ -> let lose' t' pos' more' = lose t' pos' more' [] "not enough input"

481− succ' t' pos' more' = succ t' pos' more' ()

482− in prompt t pos more lose' succ'

483−

484−-- | This parser always succeeds. It returns 'True' if any input is

485−-- available either immediately or on demand, and 'False' if the end

486−-- of all input has been reached.

487−wantInput :: Parser Bool

488−wantInput = T.Parser $ \t pos more _lose succ ->

489− case () of

490− _ | lengthAtLeast pos 1 t -> succ t pos more True

491− | more == Complete -> succ t pos more False

492− | otherwise -> let lose' t' pos' more' = succ t' pos' more' False

493− succ' t' pos' more' = succ t' pos' more' True

494− in prompt t pos more lose' succ'

495−{-# INLINE wantInput #-}

496−

497−-- | Match only if all input has been consumed.

498−endOfInput :: Parser ()

499−endOfInput = T.Parser $ \t pos more lose succ ->

500− case () of

501− _| lengthAtLeast pos 1 t -> lose t pos more [] "endOfInput"

502− | more == Complete -> succ t pos more ()

503− | otherwise ->

504− let lose' t' pos' more' _ctx _msg = succ t' pos' more' ()

505− succ' t' pos' more' _a = lose t' pos' more' [] "endOfInput"

506− in runParser demandInput t pos more lose' succ'

507−

508522-- | Return both the result of a parse and the portion of the input

509523-- that was consumed while it was being parsed.

510524match :: Parser a -> Parser (ByteString, a)

@@ -513,16 +527,10 @@ match p = T.Parser $ \t pos more lose succ ->

513527 succ t' pos' more' (substring pos (pos'-pos) t', a)

514528 in runParser p t pos more lose succ'

515529

516−-- | Return an indication of whether the end of input has been

517−-- reached.

518−atEnd :: Parser Bool

519−atEnd = not <$> wantInput

520−{-# INLINE atEnd #-}

521−

522−lengthAtLeast :: Pos -> Int -> ByteString -> Bool

523−lengthAtLeast (Pos pos) n bs = B.length bs >= pos + n

530+lengthAtLeast :: Pos -> Int -> Buffer -> Bool

531+lengthAtLeast (Pos pos) n bs = Buf.length bs >= pos + n

524532{-# INLINE lengthAtLeast #-}

525533

526−substring :: Pos -> Pos -> ByteString -> ByteString

527−substring (Pos pos) (Pos n) bs = B.unsafeTake n (B.unsafeDrop pos bs)

534+substring :: Pos -> Pos -> Buffer -> ByteString

535+substring (Pos pos) (Pos n) = Buf.substring pos n

528536{-# INLINE substring #-}

Data/Attoparsec/ByteString/Lazy.hs+10−3

@@ -1,6 +1,11 @@

1+{-# LANGUAGE CPP #-}

2+#if __GLASGOW_HASKELL__ >= 702

3+{-# LANGUAGE Trustworthy #-} -- Imports internal modules

4+#endif

16-- |

27-- Module : Data.Attoparsec.ByteString.Lazy

3−-- Copyright : Bryan O'Sullivan 2007-2014

8+-- Copyright : Bryan O'Sullivan 2007-2015

49-- License : BSD3

510--

611-- Maintainer : bos@serpentine.com

@@ -36,6 +41,7 @@ module Data.Attoparsec.ByteString.Lazy

3641

3742import Control.DeepSeq (NFData(rnf))

3843import Data.ByteString.Lazy.Internal (ByteString(..), chunk)

44+import Data.List (intercalate)

3945import qualified Data.ByteString as B

4046import qualified Data.Attoparsec.ByteString as A

4147import qualified Data.Attoparsec.Internal.Types as T

@@ -99,5 +105,6 @@ maybeResult _ = Nothing

99105

100106-- | Convert a 'Result' value to an 'Either' value.

101107eitherResult :: Result r -> Either String r

102−eitherResult (Done _ r) = Right r

103−eitherResult (Fail _ _ msg) = Left msg

108+eitherResult (Done _ r) = Right r

109+eitherResult (Fail _ [] msg) = Left msg

110+eitherResult (Fail _ ctxs msg) = Left (intercalate " > " ctxs ++ ": " ++ msg)

Data/Attoparsec/Char8.hs+1−1

@@ -1,6 +1,6 @@

11-- |

22-- Module : Data.Attoparsec.Char8

3−-- Copyright : Bryan O'Sullivan 2007-2014

3+-- Copyright : Bryan O'Sullivan 2007-2015

44-- License : BSD3

55--

66-- Maintainer : bos@serpentine.com

Data/Attoparsec/Combinator.hs+59−42

@@ -1,7 +1,10 @@

1−{-# LANGUAGE BangPatterns #-}

1+{-# LANGUAGE BangPatterns, CPP #-}

2+#if __GLASGOW_HASKELL__ >= 702

3+{-# LANGUAGE Trustworthy #-} -- Imports internal modules

4+#endif

25-- |

36-- Module : Data.Attoparsec.Combinator

4−-- Copyright : Daan Leijen 1999-2001, Bryan O'Sullivan 2007-2014

7+-- Copyright : Daan Leijen 1999-2001, Bryan O'Sullivan 2007-2015

58-- License : BSD3

69--

710-- Maintainer : bos@serpentine.com

@@ -30,14 +33,21 @@ module Data.Attoparsec.Combinator

3033 , skipMany1

3134 , eitherP

3235 , feed

36+ , satisfyElem

37+ , endOfInput

38+ , atEnd

39+ , lookAhead

3340 ) where

3441

35−import Control.Applicative (Alternative(..), Applicative(..), empty, liftA2,

36− many, (<|>), (*>), (<$>))

42+#if !MIN_VERSION_base(4,8,0)

43+import Control.Applicative (Applicative(..), (<$>))

44+import Data.Monoid (Monoid(mappend))

45+#endif

46+import Control.Applicative (Alternative(..), empty, liftA2, many, (<|>))

3747import Control.Monad (MonadPlus(..))

3848import Data.Attoparsec.Internal.Types (Parser(..), IResult(..))

49+import Data.Attoparsec.Internal (endOfInput, atEnd, satisfyElem)

3950import Data.ByteString (ByteString)

40−import Data.Monoid (Monoid(mappend))

4151import Data.Text (Text)

4252import qualified Data.Attoparsec.Zepto as Z

4353import Prelude hiding (succ)

@@ -46,15 +56,15 @@ import Prelude hiding (succ)

4656-- input appears to have been consumed.

4757--

4858-- This combinator is provided for compatibility with Parsec.

49−-- Attoparsec parsers always backtrack on failure.

50−try :: Parser i t a -> Parser i t a

59+-- attoparsec parsers always backtrack on failure.

60+try :: Parser i a -> Parser i a

5161try p = p

5262{-# INLINE try #-}

5363

5464-- | Name the parser, in case failure occurs.

55−(<?>) :: Parser i t a

65+(<?>) :: Parser i a

5666 -> String -- ^ the name to use if parsing fails

57− -> Parser i t a

67+ -> Parser i a

5868p <?> msg0 = Parser $ \t pos more lose succ ->

5969 let lose' t' pos' more' strs msg = lose t' pos' more' (msg0:strs) msg

6070 in runParser p t pos more lose' succ

@@ -66,9 +76,9 @@ infix 0 <?>

6676-- action.

6777choice :: Alternative f => [f a] -> f a

6878choice = foldr (<|>) empty

69−{-# SPECIALIZE choice :: [Parser ByteString ByteString a]

70− -> Parser ByteString ByteString a #-}

71−{-# SPECIALIZE choice :: [Parser Text Text a] -> Parser Text Text a #-}

79+{-# SPECIALIZE choice :: [Parser ByteString a]

80+ -> Parser ByteString a #-}

81+{-# SPECIALIZE choice :: [Parser Text a] -> Parser Text a #-}

7282{-# SPECIALIZE choice :: [Z.Parser a] -> Z.Parser a #-}

7383

7484-- | @option x p@ tries to apply action @p@. If @p@ fails without

@@ -78,8 +88,8 @@ choice = foldr (<|>) empty

7888-- > priority = option 0 (digitToInt <$> digit)

7989option :: Alternative f => a -> f a -> f a

8090option x p = p <|> pure x

81−{-# SPECIALIZE option :: a -> Parser ByteString ByteString a -> Parser ByteString ByteString a #-}

82−{-# SPECIALIZE option :: a -> Parser Text Text a -> Parser Text Text a #-}

91+{-# SPECIALIZE option :: a -> Parser ByteString a -> Parser ByteString a #-}

92+{-# SPECIALIZE option :: a -> Parser Text a -> Parser Text a #-}

8393{-# SPECIALIZE option :: a -> Z.Parser a -> Z.Parser a #-}

8494

8595-- | A version of 'liftM2' that is strict in the result of its first

@@ -122,50 +132,50 @@ many1' p = liftM2' (:) p (many' p)

122132-- | @sepBy p sep@ applies /zero/ or more occurrences of @p@, separated

123133-- by @sep@. Returns a list of the values returned by @p@.

124134--

125−-- > commaSep p = p `sepBy` (symbol ",")

135+-- > commaSep p = p `sepBy` (char ',')

126136sepBy :: Alternative f => f a -> f s -> f [a]

127137sepBy p s = liftA2 (:) p ((s *> sepBy1 p s) <|> pure []) <|> pure []

128−{-# SPECIALIZE sepBy :: Parser ByteString ByteString a -> Parser ByteString ByteString s

129− -> Parser ByteString ByteString [a] #-}

130−{-# SPECIALIZE sepBy :: Parser Text Text a -> Parser Text Text s -> Parser Text Text [a] #-}

138+{-# SPECIALIZE sepBy :: Parser ByteString a -> Parser ByteString s

139+ -> Parser ByteString [a] #-}

140+{-# SPECIALIZE sepBy :: Parser Text a -> Parser Text s -> Parser Text [a] #-}

131141{-# SPECIALIZE sepBy :: Z.Parser a -> Z.Parser s -> Z.Parser [a] #-}

132142

133143-- | @sepBy' p sep@ applies /zero/ or more occurrences of @p@, separated

134144-- by @sep@. Returns a list of the values returned by @p@. The value

135145-- returned by @p@ is forced to WHNF.

136146--

137−-- > commaSep p = p `sepBy'` (symbol ",")

147+-- > commaSep p = p `sepBy'` (char ',')

138148sepBy' :: (MonadPlus m) => m a -> m s -> m [a]

139149sepBy' p s = scan `mplus` return []

140150 where scan = liftM2' (:) p ((s >> sepBy1' p s) `mplus` return [])

141−{-# SPECIALIZE sepBy' :: Parser ByteString ByteString a -> Parser ByteString ByteString s

142− -> Parser ByteString ByteString [a] #-}

143−{-# SPECIALIZE sepBy' :: Parser Text Text a -> Parser Text Text s -> Parser Text Text [a] #-}

151+{-# SPECIALIZE sepBy' :: Parser ByteString a -> Parser ByteString s

152+ -> Parser ByteString [a] #-}

153+{-# SPECIALIZE sepBy' :: Parser Text a -> Parser Text s -> Parser Text [a] #-}

144154{-# SPECIALIZE sepBy' :: Z.Parser a -> Z.Parser s -> Z.Parser [a] #-}

145155

146156-- | @sepBy1 p sep@ applies /one/ or more occurrences of @p@, separated

147157-- by @sep@. Returns a list of the values returned by @p@.

148158--

149−-- > commaSep p = p `sepBy1` (symbol ",")

159+-- > commaSep p = p `sepBy1` (char ',')

150160sepBy1 :: Alternative f => f a -> f s -> f [a]

151161sepBy1 p s = scan

152162 where scan = liftA2 (:) p ((s *> scan) <|> pure [])

153−{-# SPECIALIZE sepBy1 :: Parser ByteString ByteString a -> Parser ByteString ByteString s

154− -> Parser ByteString ByteString [a] #-}

155−{-# SPECIALIZE sepBy1 :: Parser Text Text a -> Parser Text Text s -> Parser Text Text [a] #-}

163+{-# SPECIALIZE sepBy1 :: Parser ByteString a -> Parser ByteString s

164+ -> Parser ByteString [a] #-}

165+{-# SPECIALIZE sepBy1 :: Parser Text a -> Parser Text s -> Parser Text [a] #-}

156166{-# SPECIALIZE sepBy1 :: Z.Parser a -> Z.Parser s -> Z.Parser [a] #-}

157167

158168-- | @sepBy1' p sep@ applies /one/ or more occurrences of @p@, separated

159169-- by @sep@. Returns a list of the values returned by @p@. The value

160170-- returned by @p@ is forced to WHNF.

161171--

162−-- > commaSep p = p `sepBy1'` (symbol ",")

172+-- > commaSep p = p `sepBy1'` (char ',')

163173sepBy1' :: (MonadPlus m) => m a -> m s -> m [a]

164174sepBy1' p s = scan

165175 where scan = liftM2' (:) p ((s >> scan) `mplus` return [])

166−{-# SPECIALIZE sepBy1' :: Parser ByteString ByteString a -> Parser ByteString ByteString s

167− -> Parser ByteString ByteString [a] #-}

168−{-# SPECIALIZE sepBy1' :: Parser Text Text a -> Parser Text Text s -> Parser Text Text [a] #-}

176+{-# SPECIALIZE sepBy1' :: Parser ByteString a -> Parser ByteString s

177+ -> Parser ByteString [a] #-}

178+{-# SPECIALIZE sepBy1' :: Parser Text a -> Parser Text s -> Parser Text [a] #-}

169179{-# SPECIALIZE sepBy1' :: Z.Parser a -> Z.Parser s -> Z.Parser [a] #-}

170180

171181-- | @manyTill p end@ applies action @p@ /zero/ or more times until

@@ -180,9 +190,9 @@ sepBy1' p s = scan

180190manyTill :: Alternative f => f a -> f b -> f [a]

181191manyTill p end = scan

182192 where scan = (end *> pure []) <|> liftA2 (:) p scan

183−{-# SPECIALIZE manyTill :: Parser ByteString ByteString a -> Parser ByteString ByteString b

184− -> Parser ByteString ByteString [a] #-}

185−{-# SPECIALIZE manyTill :: Parser Text Text a -> Parser Text Text b -> Parser Text Text [a] #-}

193+{-# SPECIALIZE manyTill :: Parser ByteString a -> Parser ByteString b

194+ -> Parser ByteString [a] #-}

195+{-# SPECIALIZE manyTill :: Parser Text a -> Parser Text b -> Parser Text [a] #-}

186196{-# SPECIALIZE manyTill :: Z.Parser a -> Z.Parser b -> Z.Parser [a] #-}

187197

188198-- | @manyTill' p end@ applies action @p@ /zero/ or more times until

@@ -199,24 +209,24 @@ manyTill p end = scan

199209manyTill' :: (MonadPlus m) => m a -> m b -> m [a]

200210manyTill' p end = scan

201211 where scan = (end >> return []) `mplus` liftM2' (:) p scan

202−{-# SPECIALIZE manyTill' :: Parser ByteString ByteString a -> Parser ByteString ByteString b

203− -> Parser ByteString ByteString [a] #-}

204−{-# SPECIALIZE manyTill' :: Parser Text Text a -> Parser Text Text b -> Parser Text Text [a] #-}

212+{-# SPECIALIZE manyTill' :: Parser ByteString a -> Parser ByteString b

213+ -> Parser ByteString [a] #-}

214+{-# SPECIALIZE manyTill' :: Parser Text a -> Parser Text b -> Parser Text [a] #-}

205215{-# SPECIALIZE manyTill' :: Z.Parser a -> Z.Parser b -> Z.Parser [a] #-}

206216

207217-- | Skip zero or more instances of an action.

208218skipMany :: Alternative f => f a -> f ()

209219skipMany p = scan

210220 where scan = (p *> scan) <|> pure ()

211−{-# SPECIALIZE skipMany :: Parser ByteString ByteString a -> Parser ByteString ByteString () #-}

212−{-# SPECIALIZE skipMany :: Parser Text Text a -> Parser Text Text () #-}

221+{-# SPECIALIZE skipMany :: Parser ByteString a -> Parser ByteString () #-}

222+{-# SPECIALIZE skipMany :: Parser Text a -> Parser Text () #-}

213223{-# SPECIALIZE skipMany :: Z.Parser a -> Z.Parser () #-}

214224

215225-- | Skip one or more instances of an action.

216226skipMany1 :: Alternative f => f a -> f ()

217227skipMany1 p = p *> skipMany p

218−{-# SPECIALIZE skipMany1 :: Parser ByteString ByteString a -> Parser ByteString ByteString () #-}

219−{-# SPECIALIZE skipMany1 :: Parser Text Text a -> Parser Text Text () #-}

228+{-# SPECIALIZE skipMany1 :: Parser ByteString a -> Parser ByteString () #-}

229+{-# SPECIALIZE skipMany1 :: Parser Text a -> Parser Text () #-}

220230{-# SPECIALIZE skipMany1 :: Z.Parser a -> Z.Parser () #-}

221231

222232-- | Apply the given action repeatedly, returning every result.

@@ -231,8 +241,15 @@ eitherP a b = (Left <$> a) <|> (Right <$> b)

231241

232242-- | If a parser has returned a 'T.Partial' result, supply it with more

233243-- input.

234−feed :: Monoid t => IResult t t r -> t -> IResult t t r

235−feed f@(Fail _ _ _) _ = f

244+feed :: Monoid i => IResult i r -> i -> IResult i r

245+feed (Fail t ctxs msg) d = Fail (mappend t d) ctxs msg

236246feed (Partial k) d = k d

237247feed (Done t r) d = Done (mappend t d) r

238248{-# INLINE feed #-}

249+

250+-- | Apply a parser without consuming any input.

251+lookAhead :: Parser i a -> Parser i a

252+lookAhead p = Parser $ \t pos more lose succ ->

253+ let succ' t' _pos' more' = succ t' pos more'

254+ in runParser p t pos more lose succ'

255+{-# INLINE lookAhead #-}

Data/Attoparsec/Internal.hs+143−5

@@ -1,7 +1,7 @@

1−{-# LANGUAGE BangPatterns #-}

1+{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}

22-- |

33-- Module : Data.Attoparsec.Internal

4−-- Copyright : Bryan O'Sullivan 2007-2014

4+-- Copyright : Bryan O'Sullivan 2007-2015

55-- License : BSD3

66--

77-- Maintainer : bos@serpentine.com

@@ -12,11 +12,24 @@

1212-- library.

1313

1414module Data.Attoparsec.Internal

15− (

16− compareResults

15+ ( compareResults

16+ , prompt

17+ , demandInput

18+ , demandInput_

19+ , wantInput

20+ , endOfInput

21+ , atEnd

22+ , satisfyElem

23+ , concatReverse

1724 ) where

1825

26+#if !MIN_VERSION_base(4,8,0)

27+import Control.Applicative ((<$>))

28+import Data.Monoid (Monoid, mconcat)

29+#endif

1930import Data.Attoparsec.Internal.Types

31+import Data.ByteString (ByteString)

32+import Data.Text (Text)

2033import Prelude hiding (succ)

2134

2235-- | Compare two 'IResult' values for equality.

@@ -24,10 +37,135 @@ import Prelude hiding (succ)

2437-- If both 'IResult's are 'Partial', the result will be 'Nothing', as

2538-- they are incomplete and hence their equality cannot be known.

2639-- (This is why there is no 'Eq' instance for 'IResult'.)

27−compareResults :: (Eq i, Eq r) => IResult i t r -> IResult i t r -> Maybe Bool

40+compareResults :: (Eq i, Eq r) => IResult i r -> IResult i r -> Maybe Bool

2841compareResults (Fail t0 ctxs0 msg0) (Fail t1 ctxs1 msg1) =

2942 Just (t0 == t1 && ctxs0 == ctxs1 && msg0 == msg1)

3043compareResults (Done t0 r0) (Done t1 r1) =

3144 Just (t0 == t1 && r0 == r1)

3245compareResults (Partial _) (Partial _) = Nothing

3346compareResults _ _ = Just False

47+

48+-- | Ask for input. If we receive any, pass the augmented input to a

49+-- success continuation, otherwise to a failure continuation.

50+prompt :: Chunk t

51+ => State t -> Pos -> More

52+ -> (State t -> Pos -> More -> IResult t r)

53+ -> (State t -> Pos -> More -> IResult t r)

54+ -> IResult t r

55+prompt t pos _more lose succ = Partial $ \s ->

56+ if nullChunk s

57+ then lose t pos Complete

58+ else succ (pappendChunk t s) pos Incomplete

59+{-# SPECIALIZE prompt :: State ByteString -> Pos -> More

60+ -> (State ByteString -> Pos -> More

61+ -> IResult ByteString r)

62+ -> (State ByteString -> Pos -> More

63+ -> IResult ByteString r)

64+ -> IResult ByteString r #-}

65+{-# SPECIALIZE prompt :: State Text -> Pos -> More

66+ -> (State Text -> Pos -> More -> IResult Text r)

67+ -> (State Text -> Pos -> More -> IResult Text r)

68+ -> IResult Text r #-}

69+

70+-- | Immediately demand more input via a 'Partial' continuation

71+-- result.

72+demandInput :: Chunk t => Parser t ()

73+demandInput = Parser $ \t pos more lose succ ->

74+ case more of

75+ Complete -> lose t pos more [] "not enough input"

76+ _ -> let lose' _ pos' more' = lose t pos' more' [] "not enough input"

77+ succ' t' pos' more' = succ t' pos' more' ()

78+ in prompt t pos more lose' succ'

79+{-# SPECIALIZE demandInput :: Parser ByteString () #-}

80+{-# SPECIALIZE demandInput :: Parser Text () #-}

81+

82+-- | Immediately demand more input via a 'Partial' continuation

83+-- result. Return the new input.

84+demandInput_ :: Chunk t => Parser t t

85+demandInput_ = Parser $ \t pos more lose succ ->

86+ case more of

87+ Complete -> lose t pos more [] "not enough input"

88+ _ -> Partial $ \s ->

89+ if nullChunk s

90+ then lose t pos Complete [] "not enough input"

91+ else succ (pappendChunk t s) pos more s

92+{-# SPECIALIZE demandInput_ :: Parser ByteString ByteString #-}

93+{-# SPECIALIZE demandInput_ :: Parser Text Text #-}

94+

95+-- | This parser always succeeds. It returns 'True' if any input is

96+-- available either immediately or on demand, and 'False' if the end

97+-- of all input has been reached.

98+wantInput :: forall t . Chunk t => Parser t Bool

99+wantInput = Parser $ \t pos more _lose succ ->

100+ case () of

101+ _ | pos < atBufferEnd (undefined :: t) t -> succ t pos more True

102+ | more == Complete -> succ t pos more False

103+ | otherwise -> let lose' t' pos' more' = succ t' pos' more' False

104+ succ' t' pos' more' = succ t' pos' more' True

105+ in prompt t pos more lose' succ'

106+{-# INLINE wantInput #-}

107+

108+-- | Match only if all input has been consumed.

109+endOfInput :: forall t . Chunk t => Parser t ()

110+endOfInput = Parser $ \t pos more lose succ ->

111+ case () of

112+ _| pos < atBufferEnd (undefined :: t) t -> lose t pos more [] "endOfInput"

113+ | more == Complete -> succ t pos more ()

114+ | otherwise ->

115+ let lose' t' pos' more' _ctx _msg = succ t' pos' more' ()

116+ succ' t' pos' more' _a = lose t' pos' more' [] "endOfInput"

117+ in runParser demandInput t pos more lose' succ'

118+{-# SPECIALIZE endOfInput :: Parser ByteString () #-}

119+{-# SPECIALIZE endOfInput :: Parser Text () #-}

120+

121+-- | Return an indication of whether the end of input has been

122+-- reached.

123+atEnd :: Chunk t => Parser t Bool

124+atEnd = not <$> wantInput

125+{-# INLINE atEnd #-}

126+

127+satisfySuspended :: forall t r . Chunk t

128+ => (ChunkElem t -> Bool)

129+ -> State t -> Pos -> More

130+ -> Failure t (State t) r

131+ -> Success t (State t) (ChunkElem t) r

132+ -> IResult t r

133+satisfySuspended p t pos more lose succ =

134+ runParser (demandInput >> go) t pos more lose succ

135+ where go = Parser $ \t' pos' more' lose' succ' ->

136+ case bufferElemAt (undefined :: t) pos' t' of

137+ Just (e, l) | p e -> succ' t' (pos' + Pos l) more' e

138+ | otherwise -> lose' t' pos' more' [] "satisfyElem"

139+ Nothing -> runParser (demandInput >> go) t' pos' more' lose' succ'

140+{-# SPECIALIZE satisfySuspended :: (ChunkElem ByteString -> Bool)

141+ -> State ByteString -> Pos -> More

142+ -> Failure ByteString (State ByteString) r

143+ -> Success ByteString (State ByteString)

144+ (ChunkElem ByteString) r

145+ -> IResult ByteString r #-}

146+{-# SPECIALIZE satisfySuspended :: (ChunkElem Text -> Bool)

147+ -> State Text -> Pos -> More

148+ -> Failure Text (State Text) r

149+ -> Success Text (State Text)

150+ (ChunkElem Text) r

151+ -> IResult Text r #-}

152+

153+-- | The parser @satisfyElem p@ succeeds for any chunk element for which the

154+-- predicate @p@ returns 'True'. Returns the element that is

155+-- actually parsed.

156+satisfyElem :: forall t . Chunk t

157+ => (ChunkElem t -> Bool) -> Parser t (ChunkElem t)

158+satisfyElem p = Parser $ \t pos more lose succ ->

159+ case bufferElemAt (undefined :: t) pos t of

160+ Just (e, l) | p e -> succ t (pos + Pos l) more e

161+ | otherwise -> lose t pos more [] "satisfyElem"

162+ Nothing -> satisfySuspended p t pos more lose succ

163+{-# INLINE satisfyElem #-}

164+

165+-- | Concatenate a monoid after reversing its elements. Used to

166+-- glue together a series of textual chunks that have been accumulated

167+-- \"backwards\".

168+concatReverse :: Monoid m => [m] -> m

169+concatReverse [x] = x

170+concatReverse xs = mconcat (reverse xs)

171+{-# INLINE concatReverse #-}

Data/Attoparsec/ByteString/Fhthagn.hs → Data/Attoparsec/Internal/Fhthagn.hsrenamed+1−1

@@ -1,7 +1,7 @@

11{-# LANGUAGE BangPatterns, Rank2Types, OverloadedStrings,

22 RecordWildCards, MagicHash, UnboxedTuples #-}

4−module Data.Attoparsec.ByteString.Fhthagn

4+module Data.Attoparsec.Internal.Fhthagn

55 (

66 inlinePerformIO

77 ) where

Data/Attoparsec/Internal/Types.hs+137−57

@@ -1,8 +1,8 @@

1−{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, OverloadedStrings,

1+{-# LANGUAGE CPP, BangPatterns, GeneralizedNewtypeDeriving, OverloadedStrings,

22 Rank2Types, RecordWildCards, TypeFamilies #-}

33-- |

44-- Module : Data.Attoparsec.Internal.Types

5−-- Copyright : Bryan O'Sullivan 2007-2014

5+-- Copyright : Bryan O'Sullivan 2007-2015

66-- License : BSD3

77--

88-- Maintainer : bos@serpentine.com

@@ -15,62 +15,82 @@

1515module Data.Attoparsec.Internal.Types

1616 (

1717 Parser(..)

18+ , State

1819 , Failure

1920 , Success

2021 , Pos(..)

2122 , IResult(..)

2223 , More(..)

2324 , (<>)

25+ , Chunk(..)

2426 ) where

2527

26−import Control.Applicative (Alternative(..), Applicative(..), (<$>))

28+import Control.Applicative as App (Applicative(..), (<$>))

29+import Control.Applicative (Alternative(..))

2730import Control.DeepSeq (NFData(rnf))

2831import Control.Monad (MonadPlus(..))

29−import Data.Monoid (Monoid(..))

30−import Prelude hiding (getChar, succ)

32+import qualified Control.Monad.Fail as Fail (MonadFail(..))

33+import Data.Monoid as Mon (Monoid(..))

34+import Data.Semigroup (Semigroup(..))

35+import Data.Word (Word8)

36+import Data.ByteString (ByteString)

37+import qualified Data.ByteString as BS

38+import Data.ByteString.Internal (w2c)

39+import Data.Text (Text)

40+import qualified Data.Text as Text

41+import Data.Text.Unsafe (Iter(..))

42+import Prelude hiding (succ)

43+import qualified Data.Attoparsec.ByteString.Buffer as B

44+import qualified Data.Attoparsec.Text.Buffer as T

3145

3246newtype Pos = Pos { fromPos :: Int }

3347 deriving (Eq, Ord, Show, Num)

3448

35−-- | The result of a parse. This is parameterised over the type @t@

49+-- | The result of a parse. This is parameterised over the type @i@

3650-- of string that was processed.

3751--

3852-- This type is an instance of 'Functor', where 'fmap' transforms the

3953-- value in a 'Done' result.

40−data IResult i t r =

54+data IResult i r =

4155 Fail i [String] String

42− -- ^ The parse failed. The 'i' parameter is the input that had

56+ -- ^ The parse failed. The @i@ parameter is the input that had

4357 -- not yet been consumed when the failure occurred. The

4458 -- @[@'String'@]@ is a list of contexts in which the error

4559 -- occurred. The 'String' is the message describing the error, if

4660 -- any.

47− | Partial (i -> IResult i t r)

61+ | Partial (i -> IResult i r)

4862 -- ^ Supply this continuation with more input so that the parser

49− -- can resume. To indicate that no more input is available, use

50− -- an empty string.

63+ -- can resume. To indicate that no more input is available, pass

64+ -- an empty string to the continuation.

65+ --

66+ -- __Note__: if you get a 'Partial' result, do not call its

67+ -- continuation more than once.

5168 | Done i r

52− -- ^ The parse succeeded. The 'i' parameter is the input that had

69+ -- ^ The parse succeeded. The @i@ parameter is the input that had

5370 -- not yet been consumed (if any) when the parse succeeded.

5471

55−instance (Show i, Show r) => Show (IResult i t r) where

56− show (Fail t stk msg) =

57− unwords [ "Fail", show t, show stk, show msg]

58− show (Partial _) = "Partial _"

59− show (Done t r) = unwords ["Done", show t, show r]

72+instance (Show i, Show r) => Show (IResult i r) where

73+ showsPrec d ir = showParen (d > 10) $

74+ case ir of

75+ (Fail t stk msg) -> showString "Fail" . f t . f stk . f msg

76+ (Partial _) -> showString "Partial _"

77+ (Done t r) -> showString "Done" . f t . f r

78+ where f :: Show a => a -> ShowS

79+ f x = showChar ' ' . showsPrec 11 x

6080

61−instance (NFData i, NFData r) => NFData (IResult i t r) where

81+instance (NFData i, NFData r) => NFData (IResult i r) where

6282 rnf (Fail t stk msg) = rnf t `seq` rnf stk `seq` rnf msg

6383 rnf (Partial _) = ()

6484 rnf (Done t r) = rnf t `seq` rnf r

6585 {-# INLINE rnf #-}

6686

67−instance Functor (IResult i t) where

87+instance Functor (IResult i) where

6888 fmap _ (Fail t stk msg) = Fail t stk msg

6989 fmap f (Partial k) = Partial (fmap f . k)

7090 fmap f (Done t r) = Done t (f r)

7191

72−-- | The core parser type. This is parameterised over the type @t@ of

73−-- string being processed.

92+-- | The core parser type. This is parameterised over the type @i@

93+-- of string being processed.

7494--

7595-- This type is an instance of the following classes:

7696--

@@ -83,36 +103,45 @@ instance Functor (IResult i t) where

83103-- 'mplus' executes the right-hand parser if the left-hand one

84104-- fails. When the parser on the right executes, the input is reset

85105-- to the same state as the parser on the left started with. (In

86−-- other words, Attoparsec is a backtracking parser that supports

106+-- other words, attoparsec is a backtracking parser that supports

87107-- arbitrary lookahead.)

88108--

89109-- * 'Alternative', which follows 'MonadPlus'.

90−newtype Parser i t a = Parser {

91− runParser :: forall r. t -> Pos -> More

92− -> Failure i t r

93− -> Success i t a r

94− -> IResult i t r

110+newtype Parser i a = Parser {

111+ runParser :: forall r.

112+ State i -> Pos -> More

113+ -> Failure i (State i) r

114+ -> Success i (State i) a r

115+ -> IResult i r

95116 }

96117

118+type family State i

119+type instance State ByteString = B.Buffer

120+type instance State Text = T.Buffer

121+

97122type Failure i t r = t -> Pos -> More -> [String] -> String

98− -> IResult i t r

99−type Success i t a r = t -> Pos -> More -> a -> IResult i t r

123+ -> IResult i r

124+type Success i t a r = t -> Pos -> More -> a -> IResult i r

100125

101126-- | Have we read all available input?

102127data More = Complete | Incomplete

103128 deriving (Eq, Show)

104129

105−instance Monoid More where

106− mappend c@Complete _ = c

107− mappend _ m = m

108− mempty = Incomplete

130+instance Semigroup More where

131+ c@Complete <> _ = c

132+ _ <> m = m

109133

110−instance Monad (Parser i t) where

111− fail err = Parser $ \t pos more lose _succ -> lose t pos more [] msg

112− where msg = "Failed reading: " ++ err

134+instance Mon.Monoid More where

135+ mappend = (<>)

136+ mempty = Incomplete

137+

138+instance Monad (Parser i) where

139+#if !(MIN_VERSION_base(4,13,0))

140+ fail = Fail.fail

113141 {-# INLINE fail #-}

142+#endif

114143

115− return v = Parser $ \t pos more _lose succ -> succ t pos more v

144+ return = App.pure

116145 {-# INLINE return #-}

117146

118147 m >>= k = Parser $ \t !pos more lose succ ->

@@ -120,50 +149,59 @@ instance Monad (Parser i t) where

120149 in runParser m t pos more lose succ'

121150 {-# INLINE (>>=) #-}

122151

123−plus :: (Monoid t) => Parser i t a -> Parser i t a -> Parser i t a

152+ (>>) = (*>)

153+ {-# INLINE (>>) #-}

154+

155+

156+instance Fail.MonadFail (Parser i) where

157+ fail err = Parser $ \t pos more lose _succ -> lose t pos more [] msg

158+ where msg = "Failed reading: " ++ err

159+ {-# INLINE fail #-}

160+

161+plus :: Parser i a -> Parser i a -> Parser i a

124162plus f g = Parser $ \t pos more lose succ ->

125163 let lose' t' _pos' more' _ctx _msg = runParser g t' pos more' lose succ

126164 in runParser f t pos more lose' succ

127165

128−instance (Monoid t) => MonadPlus (Parser i t) where

166+instance MonadPlus (Parser i) where

129167 mzero = fail "mzero"

130168 {-# INLINE mzero #-}

131169 mplus = plus

132170

133−instance Functor (Parser i t) where

171+instance Functor (Parser i) where

134172 fmap f p = Parser $ \t pos more lose succ ->

135173 let succ' t' pos' more' a = succ t' pos' more' (f a)

136174 in runParser p t pos more lose succ'

137175 {-# INLINE fmap #-}

138176

139−apP :: Parser i t (a -> b) -> Parser i t a -> Parser i t b

177+apP :: Parser i (a -> b) -> Parser i a -> Parser i b

140178apP d e = do

141179 b <- d

142180 a <- e

143181 return (b a)

144182{-# INLINE apP #-}

145183

146−instance Applicative (Parser i t) where

147− pure = return

184+instance Applicative (Parser i) where

185+ pure v = Parser $ \t !pos more _lose succ -> succ t pos more v

148186 {-# INLINE pure #-}

149187 (<*>) = apP

150188 {-# INLINE (<*>) #-}

151−

152− -- These definitions are equal to the defaults, but this

153− -- way the optimizer doesn't have to work so hard to figure

154− -- that out.

155− (*>) = (>>)

189+ m *> k = m >>= \_ -> k

156190 {-# INLINE (*>) #-}

157− x <* y = x >>= \a -> y >> return a

191+ x <* y = x >>= \a -> y >> pure a

158192 {-# INLINE (<*) #-}

159193

160−instance (Monoid t) => Monoid (Parser i t a) where

194+instance Semigroup (Parser i a) where

195+ (<>) = plus

196+ {-# INLINE (<>) #-}

197+

198+instance Monoid (Parser i a) where

161199 mempty = fail "mempty"

162200 {-# INLINE mempty #-}

163− mappend = plus

201+ mappend = (<>)

164202 {-# INLINE mappend #-}

165203

166−instance (Monoid t) => Alternative (Parser i t) where

204+instance Alternative (Parser i) where

167205 empty = fail "empty"

168206 {-# INLINE empty #-}

169207

@@ -171,8 +209,9 @@ instance (Monoid t) => Alternative (Parser i t) where

171209 {-# INLINE (<|>) #-}

172210

173211 many v = many_v

174− where many_v = some_v <|> pure []

175− some_v = (:) <$> v <*> many_v

212+ where

213+ many_v = some_v <|> pure []

214+ some_v = (:) <$> v <*> many_v

176215 {-# INLINE many #-}

177216

178217 some v = some_v

@@ -181,6 +220,47 @@ instance (Monoid t) => Alternative (Parser i t) where

181220 some_v = (:) <$> v <*> many_v

182221 {-# INLINE some #-}

183222

184−(<>) :: (Monoid m) => m -> m -> m

185−(<>) = mappend

186−{-# INLINE (<>) #-}

223+-- | A common interface for input chunks.

224+class Monoid c => Chunk c where

225+ type ChunkElem c

226+ -- | Test if the chunk is empty.

227+ nullChunk :: c -> Bool

228+ -- | Append chunk to a buffer.

229+ pappendChunk :: State c -> c -> State c

230+ -- | Position at the end of a buffer. The first argument is ignored.

231+ atBufferEnd :: c -> State c -> Pos

232+ -- | Return the buffer element at the given position along with its length.

233+ bufferElemAt :: c -> Pos -> State c -> Maybe (ChunkElem c, Int)

234+ -- | Map an element to the corresponding character.

235+ -- The first argument is ignored.

236+ chunkElemToChar :: c -> ChunkElem c -> Char

237+

238+instance Chunk ByteString where

239+ type ChunkElem ByteString = Word8

240+ nullChunk = BS.null

241+ {-# INLINE nullChunk #-}

242+ pappendChunk = B.pappend

243+ {-# INLINE pappendChunk #-}

244+ atBufferEnd _ = Pos . B.length

245+ {-# INLINE atBufferEnd #-}

246+ bufferElemAt _ (Pos i) buf

247+ | i < B.length buf = Just (B.unsafeIndex buf i, 1)

248+ | otherwise = Nothing

249+ {-# INLINE bufferElemAt #-}

250+ chunkElemToChar _ = w2c

251+ {-# INLINE chunkElemToChar #-}

252+

253+instance Chunk Text where

254+ type ChunkElem Text = Char

255+ nullChunk = Text.null

256+ {-# INLINE nullChunk #-}

257+ pappendChunk = T.pappend

258+ {-# INLINE pappendChunk #-}

259+ atBufferEnd _ = Pos . T.length

260+ {-# INLINE atBufferEnd #-}

261+ bufferElemAt _ (Pos i) buf

262+ | i < T.length buf = let Iter c l = T.iter buf i in Just (c, l)

263+ | otherwise = Nothing

264+ {-# INLINE bufferElemAt #-}

265+ chunkElemToChar _ = id

266+ {-# INLINE chunkElemToChar #-}

Data/Attoparsec/Lazy.hs+1−1

@@ -1,6 +1,6 @@

11-- |

22-- Module : Data.Attoparsec.Lazy

3−-- Copyright : Bryan O'Sullivan 2007-2014

3+-- Copyright : Bryan O'Sullivan 2007-2015

44-- License : BSD3

55--

66-- Maintainer : bos@serpentine.com

Data/Attoparsec/Number.hs+15−2

@@ -1,16 +1,25 @@

11{-# LANGUAGE DeriveDataTypeable #-}

22-- |

33-- Module : Data.Attoparsec.Number

4−-- Copyright : Bryan O'Sullivan 2007-2014

4+-- Copyright : Bryan O'Sullivan 2007-2015

55-- License : BSD3

66--

77-- Maintainer : bos@serpentine.com

88-- Stability : experimental

99-- Portability : unknown

1010--

11+-- This module is deprecated, and both the module and 'Number' type

12+-- will be removed in the next major release. Use the

13+-- <http://hackage.haskell.org/package/scientific scientific> package

14+-- and the 'Data.Scientific.Scientific' type instead.

15+--

1116-- A simple number type, useful for parsing both exact and inexact

1217-- quantities without losing much precision.

13−module Data.Attoparsec.Number ( Number(..) ) where

18+module Data.Attoparsec.Number

19+ {-# DEPRECATED "This module will be removed in the next major release." #-}

20+ (

21+ Number(..)

22+ ) where

1423

1524import Control.DeepSeq (NFData(rnf))

1625import Data.Data (Data)

@@ -19,9 +28,13 @@ import Data.Typeable (Typeable)

1928

2029-- | A numeric type that can represent integers accurately, and

2130-- floating point numbers to the precision of a 'Double'.

31+--

32+-- /Note/: this type is deprecated, and will be removed in the next

33+-- major release. Use the 'Data.Scientific.Scientific' type instead.

2234data Number = I !Integer

2335 | D {-# UNPACK #-} !Double

2436 deriving (Typeable, Data)

37+{-# DEPRECATED Number "Use Scientific instead." #-}

2538

2639instance Show Number where

2740 show (I a) = show a

Data/Attoparsec/Text.hs+61−50

@@ -1,8 +1,12 @@

1−{-# LANGUAGE BangPatterns, FlexibleInstances, TypeSynonymInstances #-}

1+{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, TypeSynonymInstances #-}

2+#if __GLASGOW_HASKELL__ >= 702

3+{-# LANGUAGE Trustworthy #-} -- Imports internal modules

4+#endif

5+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}

37-- |

48-- Module : Data.Attoparsec.Text

5−-- Copyright : Bryan O'Sullivan 2007-2014

9+-- Copyright : Bryan O'Sullivan 2007-2015

610-- License : BSD3

711--

812-- Maintainer : bos@serpentine.com

@@ -68,6 +72,7 @@ module Data.Attoparsec.Text

6872 , skipSpace

6973 , I.skipWhile

7074 , I.scan

75+ , I.runScanner

7176 , I.take

7277 , I.takeWhile

7378 , I.takeWhile1

@@ -121,7 +126,11 @@ module Data.Attoparsec.Text

121126 , I.atEnd

122127 ) where

123128

124−import Control.Applicative (pure, (<$>), (*>), (<*), (<|>))

129+#if !MIN_VERSION_base(4,8,0)

130+import Control.Applicative (pure, (*>), (<*), (<$>))

131+import Data.Word (Word)

132+#endif

133+import Control.Applicative ((<|>))

125134import Data.Attoparsec.Combinator

126135import Data.Attoparsec.Number (Number(..))

127136import Data.Scientific (Scientific)

@@ -130,8 +139,9 @@ import Data.Attoparsec.Text.Internal (Parser, Result, parse, takeWhile1)

130139import Data.Bits (Bits, (.|.), shiftL)

131140import Data.Char (isAlpha, isDigit, isSpace, ord)

132141import Data.Int (Int8, Int16, Int32, Int64)

142+import Data.List (intercalate)

133143import Data.Text (Text)

134−import Data.Word (Word8, Word16, Word32, Word64, Word)

144+import Data.Word (Word8, Word16, Word32, Word64)

135145import qualified Data.Attoparsec.Internal as I

136146import qualified Data.Attoparsec.Internal.Types as T

137147import qualified Data.Attoparsec.Text.Internal as I

@@ -139,49 +149,50 @@ import qualified Data.Text as T

139149

140150-- $parsec

141151--

142−-- Compared to Parsec 3, Attoparsec makes several tradeoffs. It is

152+-- Compared to Parsec 3, attoparsec makes several tradeoffs. It is

143153-- not intended for, or ideal for, all possible uses.

144154--

145−-- * While Attoparsec can consume input incrementally, Parsec cannot.

155+-- * While attoparsec can consume input incrementally, Parsec cannot.

146156-- Incremental input is a huge deal for efficient and secure network

147157-- and system programming, since it gives much more control to users

148158-- of the library over matters such as resource usage and the I/O

149159-- model to use.

150160--

151−-- * Much of the performance advantage of Attoparsec is gained via

161+-- * Much of the performance advantage of attoparsec is gained via

152162-- high-performance parsers such as 'I.takeWhile' and 'I.string'.

153163-- If you use complicated combinators that return lists of

154164-- characters, there is less performance difference between the two

155165-- libraries.

156166--

157−-- * Unlike Parsec 3, Attoparsec does not support being used as a

167+-- * Unlike Parsec 3, attoparsec does not support being used as a

158168-- monad transformer.

159169--

160−-- * Attoparsec is specialised to deal only with strict 'Text'

170+-- * attoparsec is specialised to deal only with strict 'Text'

161171-- input. Efficiency concerns rule out both lists and lazy text.

162172-- The usual use for lazy text would be to allow consumption of very

163173-- large input without a large footprint. For this need,

164−-- Attoparsec's incremental input provides an excellent substitute,

174+-- attoparsec's incremental input provides an excellent substitute,

165175-- with much more control over when input takes place. If you must

166176-- use lazy text, see the 'Lazy' module, which feeds lazy chunks to

167177-- a regular parser.

168178--

169179-- * Parsec parsers can produce more helpful error messages than

170−-- Attoparsec parsers. This is a matter of focus: Attoparsec avoids

180+-- attoparsec parsers. This is a matter of focus: attoparsec avoids

171181-- the extra book-keeping in favour of higher performance.

172182

173183-- $incremental

174184--

175−-- Attoparsec supports incremental input, meaning that you can feed it

185+-- attoparsec supports incremental input, meaning that you can feed it

176186-- a 'Text' that represents only part of the expected total amount

177187-- of data to parse. If your parser reaches the end of a fragment of

178188-- input and could consume more input, it will suspend parsing and

179189-- return a 'T.Partial' continuation.

180190--

181191-- Supplying the 'T.Partial' continuation with another string will

182−-- resume parsing at the point where it was suspended. You must be

183−-- prepared for the result of the resumed parse to be another

184−-- 'Partial' continuation.

192+-- resume parsing at the point where it was suspended, with the string

193+-- you supplied used as new input at the end of the existing

194+-- input. You must be prepared for the result of the resumed parse to

195+-- be another 'Partial' continuation.

185196--

186197-- To indicate that you have no more input, supply the 'Partial'

187198-- continuation with an 'T.empty' 'Text'.

@@ -193,12 +204,19 @@ import qualified Data.Text as T

193204-- If you do not need support for incremental input, consider using

194205-- the 'I.parseOnly' function to run your parser. It will never

195206-- prompt for more input.

207+--

208+-- /Note/: incremental input does /not/ imply that attoparsec will

209+-- release portions of its internal state for garbage collection as it

210+-- proceeds. Its internal representation is equivalent to a single

211+-- 'Text': if you feed incremental input to an a parser, it will

212+-- require memory proportional to the amount of input you supply.

213+-- (This is necessary to support arbitrary backtracking.)

196214

197215-- $performance

198216--

199−-- If you write an Attoparsec-based parser carefully, it can be

200−-- realistic to expect it to perform within a factor of 2 of a

201−-- hand-rolled C parser (measuring megabytes parsed per second).

217+-- If you write an attoparsec-based parser carefully, it can be

218+-- realistic to expect it to perform similarly to a hand-rolled C

219+-- parser (measuring megabytes parsed per second).

202220--

203221-- To actually achieve high performance, there are a few guidelines

204222-- that it is useful to follow.

@@ -248,9 +266,10 @@ maybeResult _ = Nothing

248266-- | Convert a 'Result' value to an 'Either' value. A 'Partial' result

249267-- is treated as failure.

250268eitherResult :: Result r -> Either String r

251−eitherResult (T.Done _ r) = Right r

252−eitherResult (T.Fail _ _ msg) = Left msg

253−eitherResult _ = Left "Result: incomplete input"

269+eitherResult (T.Done _ r) = Right r

270+eitherResult (T.Fail _ [] msg) = Left msg

271+eitherResult (T.Fail _ ctxs msg) = Left (intercalate " > " ctxs ++ ": " ++ msg)

272+eitherResult _ = Left "Result: incomplete input"

254273

255274-- | A predicate that matches either a carriage return @\'\\r\'@ or

256275-- newline @\'\\n\'@ character.

@@ -323,6 +342,24 @@ signed p = (negate <$> (I.char '-' *> p))

323342 <|> (I.char '+' *> p)

324343 <|> p

325344

345+-- | Parse a rational number.

346+--

347+-- The syntax accepted by this parser is the same as for 'double'.

348+--

349+-- /Note/: this parser is not safe for use with inputs from untrusted

350+-- sources. An input with a suitably large exponent such as

351+-- @"1e1000000000"@ will cause a huge 'Integer' to be allocated,

352+-- resulting in what is effectively a denial-of-service attack.

353+--

354+-- In most cases, it is better to use 'double' or 'scientific'

355+-- instead.

356+rational :: Fractional a => Parser a

357+{-# SPECIALIZE rational :: Parser Double #-}

358+{-# SPECIALIZE rational :: Parser Float #-}

359+{-# SPECIALIZE rational :: Parser Rational #-}

360+{-# SPECIALIZE rational :: Parser Scientific #-}

361+rational = scientifically realToFrac

362+

326363-- | Parse a rational number.

327364--

328365-- This parser accepts an optional leading sign character, followed by

@@ -350,39 +387,12 @@ signed p = (negate <$> (I.char '-' *> p))

350387--

351388-- This function does not accept string representations of \"NaN\" or

352389-- \"Infinity\".

353−rational :: Fractional a => Parser a

354−{-# SPECIALIZE rational :: Parser Double #-}

355−{-# SPECIALIZE rational :: Parser Float #-}

356−{-# SPECIALIZE rational :: Parser Rational #-}

357−{-# SPECIALIZE rational :: Parser Scientific #-}

358−rational = scientifically realToFrac

359−

360−-- | Parse a rational number.

361−--

362−-- The syntax accepted by this parser is the same as for 'rational'.

363−--

364−-- /Note/: This function is almost ten times faster than 'rational',

365−-- but is slightly less accurate.

366−--

367−-- The 'Double' type supports about 16 decimal places of accuracy.

368−-- For 94.2% of numbers, this function and 'rational' give identical

369−-- results, but for the remaining 5.8%, this function loses precision

370−-- around the 15th decimal place. For 0.001% of numbers, this

371−-- function will lose precision at the 13th or 14th decimal place.

372−--

373−-- This function does not accept string representations of \"NaN\" or

374−-- \"Infinity\".

375390double :: Parser Double

376391double = scientifically Sci.toRealFloat

377392

378393-- | Parse a number, attempting to preserve both speed and precision.

379394--

380−-- The syntax accepted by this parser is the same as for 'rational'.

381−--

382−-- /Note/: This function is almost ten times faster than 'rational'.

383−-- On integral inputs, it gives perfectly accurate answers, and on

384−-- floating point inputs, it is slightly less accurate than

385−-- 'rational'.

395+-- The syntax accepted by this parser is the same as for 'double'.

386396--

387397-- This function does not accept string representations of \"NaN\" or

388398-- \"Infinity\".

@@ -393,10 +403,11 @@ number = scientifically $ \s ->

393403 in if e >= 0

394404 then I (c * 10 ^ e)

395405 else D (Sci.toRealFloat s)

406+{-# DEPRECATED number "Use 'scientific' instead." #-}

396407

397408-- | Parse a scientific number.

398409--

399−-- The syntax accepted by this parser is the same as for 'rational'.

410+-- The syntax accepted by this parser is the same as for 'double'.

400411scientific :: Parser Scientific

401412scientific = scientifically id

402413

Data/Attoparsec/Text/Buffer.hsnew file+172

@@ -0,0 +1,172 @@

1+{-# LANGUAGE BangPatterns, CPP, MagicHash, RankNTypes, RecordWildCards,

2+ UnboxedTuples #-}

4+-- |

5+-- Module : Data.Attoparsec.Text.Buffer

6+-- Copyright : Bryan O'Sullivan 2007-2015

7+-- License : BSD3

8+--

9+-- Maintainer : bos@serpentine.com

10+-- Stability : experimental

11+-- Portability : GHC

12+--

13+-- An immutable buffer that supports cheap appends.

14+

15+-- A Buffer is divided into an immutable read-only zone, followed by a

16+-- mutable area that we've preallocated, but not yet written to.

17+--

18+-- We overallocate at the end of a Buffer so that we can cheaply

19+-- append. Since a user of an existing Buffer cannot see past the end

20+-- of its immutable zone into the data that will change during an

21+-- append, this is safe.

22+--

23+-- Once we run out of space at the end of a Buffer, we do the usual

24+-- doubling of the buffer size.

25+

26+module Data.Attoparsec.Text.Buffer

27+ (

28+ Buffer

29+ , buffer

30+ , unbuffer

31+ , unbufferAt

32+ , length

33+ , pappend

34+ , iter

35+ , iter_

36+ , substring

37+ , dropWord16

38+ ) where

39+

40+import Control.Exception (assert)

41+import Data.Bits (shiftR)

42+import Data.List (foldl1')

43+import Data.Monoid as Mon (Monoid(..))

44+import Data.Semigroup (Semigroup(..))

45+import Data.Text ()

46+import Data.Text.Internal (Text(..))

47+import Data.Text.Internal.Encoding.Utf16 (chr2)

48+import Data.Text.Internal.Unsafe.Char (unsafeChr)

49+import Data.Text.Unsafe (Iter(..))

50+import Foreign.Storable (sizeOf)

51+import GHC.Base (Int(..), indexIntArray#, unsafeCoerce#, writeIntArray#)

52+import GHC.ST (ST(..), runST)

53+import Prelude hiding (length)

54+import qualified Data.Text.Array as A

55+

56+-- If _cap is zero, this buffer is empty.

57+data Buffer = Buf {

58+ _arr :: {-# UNPACK #-} !A.Array

59+ , _off :: {-# UNPACK #-} !Int

60+ , _len :: {-# UNPACK #-} !Int

61+ , _cap :: {-# UNPACK #-} !Int

62+ , _gen :: {-# UNPACK #-} !Int

63+ }

64+

65+instance Show Buffer where

66+ showsPrec p = showsPrec p . unbuffer

67+

68+-- | The initial 'Buffer' has no mutable zone, so we can avoid all

69+-- copies in the (hopefully) common case of no further input being fed

70+-- to us.

71+buffer :: Text -> Buffer

72+buffer (Text arr off len) = Buf arr off len len 0

73+

74+unbuffer :: Buffer -> Text

75+unbuffer (Buf arr off len _ _) = Text arr off len

76+

77+unbufferAt :: Int -> Buffer -> Text

78+unbufferAt s (Buf arr off len _ _) =

79+ assert (s >= 0 && s <= len) $

80+ Text arr (off+s) (len-s)

81+

82+instance Semigroup Buffer where

83+ (Buf _ _ _ 0 _) <> b = b

84+ a <> (Buf _ _ _ 0 _) = a

85+ buf <> (Buf arr off len _ _) = append buf arr off len

86+ {-# INLINE (<>) #-}

87+

88+instance Monoid Buffer where

89+ mempty = Buf A.empty 0 0 0 0

90+ {-# INLINE mempty #-}

91+

92+ mappend = (<>)

93+

94+ mconcat [] = Mon.mempty

95+ mconcat xs = foldl1' (<>) xs

96+

97+pappend :: Buffer -> Text -> Buffer

98+pappend (Buf _ _ _ 0 _) t = buffer t

99+pappend buf (Text arr off len) = append buf arr off len

100+

101+append :: Buffer -> A.Array -> Int -> Int -> Buffer

102+append (Buf arr0 off0 len0 cap0 gen0) !arr1 !off1 !len1 = runST $ do

103+ let woff = sizeOf (0::Int) `shiftR` 1

104+ newlen = len0 + len1

105+ !gen = if gen0 == 0 then 0 else readGen arr0

106+ if gen == gen0 && newlen <= cap0

107+ then do

108+ let newgen = gen + 1

109+ marr <- unsafeThaw arr0

110+ writeGen marr newgen

111+ A.copyI marr (off0+len0) arr1 off1 (off0+newlen)

112+ arr2 <- A.unsafeFreeze marr

113+ return (Buf arr2 off0 newlen cap0 newgen)

114+ else do

115+ let newcap = newlen * 2

116+ newgen = 1

117+ marr <- A.new (newcap + woff)

118+ writeGen marr newgen

119+ A.copyI marr woff arr0 off0 (woff+len0)

120+ A.copyI marr (woff+len0) arr1 off1 (woff+newlen)

121+ arr2 <- A.unsafeFreeze marr

122+ return (Buf arr2 woff newlen newcap newgen)

123+

124+length :: Buffer -> Int

125+length (Buf _ _ len _ _) = len

126+{-# INLINE length #-}

127+

128+substring :: Int -> Int -> Buffer -> Text

129+substring s l (Buf arr off len _ _) =

130+ assert (s >= 0 && s <= len) .

131+ assert (l >= 0 && l <= len-s) $

132+ Text arr (off+s) l

133+{-# INLINE substring #-}

134+

135+dropWord16 :: Int -> Buffer -> Text

136+dropWord16 s (Buf arr off len _ _) =

137+ assert (s >= 0 && s <= len) $

138+ Text arr (off+s) (len-s)

139+{-# INLINE dropWord16 #-}

140+

141+-- | /O(1)/ Iterate (unsafely) one step forwards through a UTF-16

142+-- array, returning the current character and the delta to add to give

143+-- the next offset to iterate at.

144+iter :: Buffer -> Int -> Iter

145+iter (Buf arr off _ _ _) i

146+ | m < 0xD800 || m > 0xDBFF = Iter (unsafeChr m) 1

147+ | otherwise = Iter (chr2 m n) 2

148+ where m = A.unsafeIndex arr j

149+ n = A.unsafeIndex arr k

150+ j = off + i

151+ k = j + 1

152+{-# INLINE iter #-}

153+

154+-- | /O(1)/ Iterate one step through a UTF-16 array, returning the

155+-- delta to add to give the next offset to iterate at.

156+iter_ :: Buffer -> Int -> Int

157+iter_ (Buf arr off _ _ _) i | m < 0xD800 || m > 0xDBFF = 1

158+ | otherwise = 2

159+ where m = A.unsafeIndex arr (off+i)

160+{-# INLINE iter_ #-}

161+

162+unsafeThaw :: A.Array -> ST s (A.MArray s)

163+unsafeThaw A.Array{..} = ST $ \s# ->

164+ (# s#, A.MArray (unsafeCoerce# aBA) #)

165+

166+readGen :: A.Array -> Int

167+readGen a = case indexIntArray# (A.aBA a) 0# of r# -> I# r#

168+

169+writeGen :: A.MArray s -> Int -> ST s ()

170+writeGen a (I# gen#) = ST $ \s0# ->

171+ case writeIntArray# (A.maBA a) 0# gen# s0# of

172+ s1# -> (# s1#, () #)

Data/Attoparsec/Text/FastSet.hs+85−27

@@ -1,16 +1,20 @@

1−-----------------------------------------------------------------------------

1+{-# LANGUAGE BangPatterns #-}

3+------------------------------------------------------------------------------

24-- |

35-- Module : Data.Attoparsec.FastSet

4−-- Copyright : Felipe Lessa 2010, Bryan O'Sullivan 2007-2014

6+-- Copyright : Felipe Lessa 2010, Bryan O'Sullivan 2007-2015

57-- License : BSD3

68--

79-- Maintainer : felipe.lessa@gmail.com

810-- Stability : experimental

911-- Portability : unknown

1012--

11−-- Fast set membership tests for 'Char' values. The set

12−-- representation is unboxed for efficiency. We test for

13−-- membership using a binary search.

13+-- Fast set membership tests for 'Char' values. We test for

14+-- membership using a hashtable implemented with Robin Hood

15+-- collision resolution. The set representation is unboxed,

16+-- and the characters and hashes interleaved, for efficiency.

17+--

1418--

1519-----------------------------------------------------------------------------

1620module Data.Attoparsec.Text.FastSet

@@ -26,38 +30,92 @@ module Data.Attoparsec.Text.FastSet

2630 , charClass

2731 ) where

2832

29−import Data.List (sort)

33+import Data.Bits ((.|.), (.&.), shiftR)

34+import Data.Function (on)

35+import Data.List (sort, sortBy)

3036import qualified Data.Array.Base as AB

3137import qualified Data.Array.Unboxed as A

3238import qualified Data.Text as T

3339

34−newtype FastSet = FastSet (A.UArray Int Char)

35− deriving (Eq, Ord, Show)

40+data FastSet = FastSet {

41+ table :: {-# UNPACK #-} !(A.UArray Int Int)

42+ , mask :: {-# UNPACK #-} !Int

43+ }

3644

37−-- | Create a set.

38−set :: T.Text -> FastSet

39−set t = mkSet (T.length t) (sort $ T.unpack t)

45+data Entry = Entry {

46+ key :: {-# UNPACK #-} !Char

47+ , initialIndex :: {-# UNPACK #-} !Int

48+ , index :: {-# UNPACK #-} !Int

49+ }

50+

51+offset :: Entry -> Int

52+offset e = index e - initialIndex e

53+

54+resolveCollisions :: [Entry] -> [Entry]

55+resolveCollisions [] = []

56+resolveCollisions [e] = [e]

57+resolveCollisions (a:b:entries) = a' : resolveCollisions (b' : entries)

58+ where (a', b')

59+ | index a < index b = (a, b)

60+ | offset a < offset b = (b { index=index a }, a { index=index a + 1 })

61+ | otherwise = (a, b { index=index a + 1 })

4062

41−fromList :: [Char] -> FastSet

42−fromList cs = mkSet (length cs) (sort cs)

63+pad :: Int -> [Entry] -> [Entry]

64+pad = go 0

65+ where -- ensure that we pad enough so that lookups beyond the

66+ -- last hash in the table fall within the array

67+ go !_ !m [] = replicate (max 1 m + 1) empty

68+ go k m (e:entries) = map (const empty) [k..i - 1] ++ e :

69+ go (i + 1) (m + i - k - 1) entries

70+ where i = index e

71+ empty = Entry '\0' maxBound 0

4372

44−mkSet :: Int -> [Char] -> FastSet

45−mkSet l = FastSet . A.listArray (0,l-1)

73+nextPowerOf2 :: Int -> Int

74+nextPowerOf2 0 = 1

75+nextPowerOf2 x = go (x - 1) 1

76+ where go y 32 = y + 1

77+ go y k = go (y .|. (y `shiftR` k)) $ k * 2

78+

79+fastHash :: Char -> Int

80+fastHash = fromEnum

81+

82+fromList :: String -> FastSet

83+fromList s = FastSet (AB.listArray (0, length interleaved - 1) interleaved)

84+ mask'

85+ where s' = ordNub (sort s)

86+ l = length s'

87+ mask' = nextPowerOf2 ((5 * l) `div` 4) - 1

88+ entries = pad mask' .

89+ resolveCollisions .

90+ sortBy (compare `on` initialIndex) .

91+ zipWith (\c i -> Entry c i i) s' .

92+ map ((.&. mask') . fastHash) $ s'

93+ interleaved = concatMap (\e -> [fromEnum $ key e, initialIndex e])

94+ entries

95+

96+ordNub :: Eq a => [a] -> [a]

97+ordNub [] = []

98+ordNub (y:ys) = go y ys

99+ where go x (z:zs)

100+ | x == z = go x zs

101+ | otherwise = x : go z zs

102+ go x [] = [x]

103+

104+set :: T.Text -> FastSet

105+set = fromList . T.unpack

46106

47107-- | Check the set for membership.

48108member :: Char -> FastSet -> Bool

49−member c (FastSet a) = uncurry search (A.bounds a)

50− where search lo hi

51− | hi < lo = False

52− | otherwise =

53− let mid = (lo + hi) `quot` 2

54− in case compare c (AB.unsafeAt a mid) of

55− GT -> search (mid + 1) hi

56− LT -> search lo (mid - 1)

57− _ -> True

109+member c a = go (2 * i)

110+ where i = fastHash c .&. mask a

111+ lookupAt j b = (i' <= i) && (c == c' || b)

112+ where c' = toEnum $ AB.unsafeAt (table a) j

113+ i' = AB.unsafeAt (table a) $ j + 1

114+ go j = lookupAt j . lookupAt (j + 2) . lookupAt (j + 4) .

115+ lookupAt (j + 6) . go $ j + 8

58116

59117charClass :: String -> FastSet

60118charClass = fromList . go

61− where go (a:'-':b:xs) = [a..b] ++ go xs

62− go (x:xs) = x : go xs

63− go _ = ""

119+ where go (a:'-':b:xs) = [a..b] ++ go xs

120+ go (x:xs) = x : go xs

121+ go _ = ""

Data/Attoparsec/Text/Internal.hs+132−125

@@ -3,14 +3,14 @@

33{-# OPTIONS_GHC -fno-warn-orphans #-}

44-- |

55-- Module : Data.Attoparsec.Text.Internal

6−-- Copyright : Bryan O'Sullivan 2007-2014

6+-- Copyright : Bryan O'Sullivan 2007-2015

77-- License : BSD3

88--

99-- Maintainer : bos@serpentine.com

1010-- Stability : experimental

1111-- Portability : unknown

1212--

13−-- Simple, efficient parser combinators for 'T.Text' strings, loosely

13+-- Simple, efficient parser combinators for 'Text' strings, loosely

1414-- based on the Parsec library.

1515

1616module Data.Attoparsec.Text.Internal

@@ -65,11 +65,15 @@ module Data.Attoparsec.Text.Internal

6565 , atEnd

6666 ) where

6767

68−import Control.Applicative ((<|>), (<$>))

68+import Control.Applicative ((<|>), (<$>), pure, (*>))

6969import Control.Monad (when)

7070import Data.Attoparsec.Combinator ((<?>))

71+import Data.Attoparsec.Internal

7172import Data.Attoparsec.Internal.Types hiding (Parser, Failure, Success)

72−import Data.Char (chr, ord)

73+import qualified Data.Attoparsec.Text.Buffer as Buf

74+import Data.Attoparsec.Text.Buffer (Buffer, buffer)

75+import Data.Char (isAsciiUpper, isAsciiLower, toUpper, toLower)

76+import Data.List (intercalate)

7377import Data.String (IsString(..))

7478import Data.Text.Internal (Text(..))

7579import Prelude hiding (getChar, succ, take, takeWhile)

@@ -79,10 +83,10 @@ import qualified Data.Text as T

7983import qualified Data.Text.Lazy as L

8084import qualified Data.Text.Unsafe as T

8185

82−type Parser = T.Parser Text Text

83−type Result = IResult Text Text

84−type Failure r = T.Failure Text Text r

85−type Success a r = T.Success Text Text a r

86+type Parser = T.Parser Text

87+type Result = IResult Text

88+type Failure r = T.Failure Text Buffer r

89+type Success a r = T.Success Text Buffer a r

8690

8791instance (a ~ Text) => IsString (Parser a) where

8892 fromString = string . T.pack

@@ -153,12 +157,49 @@ take n = takeWith (max n 0) (const True)

153157--

154158-- The reason for its failure is that the first branch is a

155159-- partial match, and will consume the letters @\'f\'@ and @\'o\'@

156−-- before failing. In Attoparsec, the above parser will /succeed/ on

160+-- before failing. In attoparsec, the above parser will /succeed/ on

157161-- that input, because the failed first branch will consume nothing.

158162string :: Text -> Parser Text

159−string s = takeWith (T.length s) (==s)

163+string s = string_ (stringSuspended id) id s

160164{-# INLINE string #-}

161165

166+string_ :: (forall r. Text -> Text -> Buffer -> Pos -> More

167+ -> Failure r -> Success Text r -> Result r)

168+ -> (Text -> Text)

169+ -> Text -> Parser Text

170+string_ suspended f s0 = T.Parser $ \t pos more lose succ ->

171+ let s = f s0

172+ ft = f (Buf.unbufferAt (fromPos pos) t)

173+ in case T.commonPrefixes s ft of

174+ Nothing

175+ | T.null s -> succ t pos more T.empty

176+ | T.null ft -> suspended s s t pos more lose succ

177+ | otherwise -> lose t pos more [] "string"

178+ Just (pfx,ssfx,tsfx)

179+ | T.null ssfx -> let l = Pos (T.lengthWord16 pfx)

180+ in succ t (pos + l) more (substring pos l t)

181+ | not (T.null tsfx) -> lose t pos more [] "string"

182+ | otherwise -> suspended s ssfx t pos more lose succ

183+{-# INLINE string_ #-}

184+

185+stringSuspended :: (Text -> Text)

186+ -> Text -> Text -> Buffer -> Pos -> More

187+ -> Failure r

188+ -> Success Text r

189+ -> Result r

190+stringSuspended f s000 s0 t0 pos0 more0 lose0 succ0 =

191+ runParser (demandInput_ >>= go) t0 pos0 more0 lose0 succ0

192+ where

193+ go s' = T.Parser $ \t pos more lose succ ->

194+ let s = f s'

195+ in case T.commonPrefixes s0 s of

196+ Nothing -> lose t pos more [] "string"

197+ Just (_pfx,ssfx,tsfx)

198+ | T.null ssfx -> let l = Pos (T.lengthWord16 s000)

199+ in succ t (pos + l) more (substring pos l t)

200+ | T.null tsfx -> stringSuspended f s000 ssfx t pos more lose succ

201+ | otherwise -> lose t pos more [] "string"

202+

162203-- | Satisfy a literal string, ignoring case.

163204--

164205-- Note: this function is currently quite inefficient. Unicode case

@@ -181,34 +222,24 @@ stringCI s = go 0

181222

182223-- | Satisfy a literal string, ignoring case for characters in the ASCII range.

183224asciiCI :: Text -> Parser Text

184−asciiCI input = do

185− (k,t) <- ensure n

186− if asciiToLower t == s

187− then advance k >> return t

188− else fail "asciiCI"

189− where

190− n = T.length input

191− s = asciiToLower input

192−

193− -- convert letters in the ASCII range to lower-case

194− asciiToLower = T.map f

195− where

196− offset = ord 'a' - ord 'A'

197− f c | 'A' <= c && c <= 'Z' = chr (ord c + offset)

198− | otherwise = c

225+asciiCI s = fmap fst $ match $ T.foldr ((*>) . asciiCharCI) (pure ()) s

199226{-# INLINE asciiCI #-}

200227

228+asciiCharCI :: Char -> Parser Char

229+asciiCharCI c

230+ | isAsciiUpper c = char c <|> char (toLower c)

231+ | isAsciiLower c = char c <|> char (toUpper c)

232+ | otherwise = char c

233+{-# INLINE asciiCharCI #-}

234+

201235-- | Skip past input for as long as the predicate returns 'True'.

202236skipWhile :: (Char -> Bool) -> Parser ()

203237skipWhile p = go

204238 where

205239 go = do

206240 t <- T.takeWhile p <$> get

207− advance (lengthOf t)

208− eoc <- endOfChunk

209− when eoc $ do

210− input <- wantInput

211− when input go

241+ continue <- inputSpansChunks (size t)

242+ when continue go

212243{-# INLINE skipWhile #-}

213244

214245-- | Consume input as long as the predicate returns 'False'

@@ -236,19 +267,25 @@ takeTill p = takeWhile (not . p)

236267-- parsers loop until a failure occurs. Careless use will thus result

237268-- in an infinite loop.

238269takeWhile :: (Char -> Bool) -> Parser Text

239−takeWhile p = (T.concat . reverse) `fmap` go []

270+takeWhile p = do

271+ h <- T.takeWhile p <$> get

272+ continue <- inputSpansChunks (size h)

273+ -- only use slow concat path if necessary

274+ if continue

275+ then takeWhileAcc p [h]

276+ else return h

277+{-# INLINE takeWhile #-}

278+

279+takeWhileAcc :: (Char -> Bool) -> [Text] -> Parser Text

280+takeWhileAcc p = go

240281 where

241282 go acc = do

242283 h <- T.takeWhile p <$> get

243− advance (lengthOf h)

244− eoc <- endOfChunk

245− if eoc

246− then do

247− input <- wantInput

248− if input

249− then go (h:acc)

250− else return (h:acc)

251− else return (h:acc)

284+ continue <- inputSpansChunks (size h)

285+ if continue

286+ then go (h:acc)

287+ else return $ concatReverse (h:acc)

288+{-# INLINE takeWhileAcc #-}

252289

253290takeRest :: Parser [Text]

254291takeRest = go []

@@ -258,7 +295,7 @@ takeRest = go []

258295 if input

259296 then do

260297 s <- get

261− advance (lengthOf s)

298+ advance (size s)

262299 go (s:acc)

263300 else return (reverse acc)

264301

@@ -271,7 +308,7 @@ takeLazyText :: Parser L.Text

271308takeLazyText = L.fromChunks `fmap` takeRest

272309

273310data Scan s = Continue s

274− | Finished {-# UNPACK #-} !Int T.Text

311+ | Finished s {-# UNPACK #-} !Int Text

275312

276313scan_ :: (s -> [Text] -> Parser r) -> s -> (s -> Char -> Maybe s) -> Parser r

277314scan_ f s0 p = go [] s0

@@ -280,18 +317,17 @@ scan_ f s0 p = go [] s0

280317 case T.uncons t of

281318 Just (c,t') -> case p s c of

282319 Just s' -> scanner s' (n+1) t'

283− Nothing -> Finished n t

320+ Nothing -> Finished s n t

284321 Nothing -> Continue s

285322 go acc s = do

286323 input <- get

287324 case scanner s 0 input of

288− Continue s' -> do advance (lengthOf input)

289− more <- wantInput

290− if more

325+ Continue s' -> do continue <- inputSpansChunks (size input)

326+ if continue

291327 then go (input : acc) s'

292328 else f s' (input : acc)

293− Finished n t -> do advance (lengthOf input - lengthOf t)

294− f s (T.take n input : acc)

329+ Finished s' n t -> do advance (size input - size t)

330+ f s' (T.take n input : acc)

295331{-# INLINE scan_ #-}

296332

297333-- | A stateful scanner. The predicate consumes and transforms a

@@ -307,16 +343,13 @@ scan_ f s0 p = go [] s0

307343-- parsers loop until a failure occurs. Careless use will thus result

308344-- in an infinite loop.

309345scan :: s -> (s -> Char -> Maybe s) -> Parser Text

310−scan = scan_ $ \_ chunks ->

311− case chunks of

312− [x] -> return x

313− xs -> return . T.concat . reverse $ xs

346+scan = scan_ $ \_ chunks -> return $! concatReverse chunks

314347{-# INLINE scan #-}

315348

316349-- | Like 'scan', but generalized to return the final state of the

317350-- scanner.

318351runScanner :: s -> (s -> Char -> Maybe s) -> Parser (Text, s)

319−runScanner = scan_ $ \s xs -> return (T.concat (reverse xs), s)

352+runScanner = scan_ $ \s xs -> let !sx = concatReverse xs in return (sx, s)

320353{-# INLINE runScanner #-}

321354

322355-- | Consume input as long as the predicate returns 'True', and return

@@ -329,13 +362,14 @@ takeWhile1 :: (Char -> Bool) -> Parser Text

329362takeWhile1 p = do

330363 (`when` demandInput) =<< endOfChunk

331364 h <- T.takeWhile p <$> get

332− let len = lengthOf h

333− when (len == 0) $ fail "takeWhile1"

334− advance len

365+ let size' = size h

366+ when (size' == 0) $ fail "takeWhile1"

367+ advance size'

335368 eoc <- endOfChunk

336369 if eoc

337− then (h<>) `fmap` takeWhile p

370+ then takeWhileAcc p [h]

338371 else return h

372+{-# INLINE takeWhile1 #-}

339373

340374-- | Match any character in a set.

341375--

@@ -384,13 +418,13 @@ peekChar :: Parser (Maybe Char)

384418peekChar = T.Parser $ \t pos more _lose succ ->

385419 case () of

386420 _| pos < lengthOf t ->

387− let T.Iter !c _ = T.iter t (fromPos pos)

421+ let T.Iter !c _ = Buf.iter t (fromPos pos)

388422 in succ t pos more (Just c)

389423 | more == Complete ->

390424 succ t pos more Nothing

391425 | otherwise ->

392426 let succ' t' pos' more' =

393− let T.Iter !c _ = T.iter t' (fromPos pos')

427+ let T.Iter !c _ = Buf.iter t' (fromPos pos')

394428 in succ t' pos' more' (Just c)

395429 lose' t' pos' more' = succ t' pos' more' Nothing

396430 in prompt t pos more lose' succ'

@@ -411,30 +445,39 @@ endOfLine = (char '\n' >> return ()) <|> (string "\r\n" >> return ())

411445

412446-- | Terminal failure continuation.

413447failK :: Failure a

414−failK t (Pos pos) _more stack msg = Fail (T.dropWord16 pos t) stack msg

448+failK t (Pos pos) _more stack msg = Fail (Buf.dropWord16 pos t) stack msg

415449{-# INLINE failK #-}

416450

417451-- | Terminal success continuation.

418452successK :: Success a a

419−successK t (Pos pos) _more a = Done (T.dropWord16 pos t) a

453+successK t (Pos pos) _more a = Done (Buf.dropWord16 pos t) a

420454{-# INLINE successK #-}

421455

422456-- | Run a parser.

423457parse :: Parser a -> Text -> Result a

424−parse m s = runParser m s 0 Incomplete failK successK

458+parse m s = runParser m (buffer s) 0 Incomplete failK successK

425459{-# INLINE parse #-}

426460

427461-- | Run a parser that cannot be resupplied via a 'Partial' result.

462+--

463+-- This function does not force a parser to consume all of its input.

464+-- Instead, any residual input will be discarded. To force a parser

465+-- to consume all of its input, use something like this:

466+--

467+-- @

468+--'parseOnly' (myParser 'Control.Applicative.<*' 'endOfInput')

469+-- @

428470parseOnly :: Parser a -> Text -> Either String a

429−parseOnly m s = case runParser m s 0 Complete failK successK of

430− Fail _ _ err -> Left err

431− Done _ a -> Right a

432− _ -> error "parseOnly: impossible error!"

471+parseOnly m s = case runParser m (buffer s) 0 Complete failK successK of

472+ Fail _ [] err -> Left err

473+ Fail _ ctxs err -> Left (intercalate " > " ctxs ++ ": " ++ err)

474+ Done _ a -> Right a

475+ _ -> error "parseOnly: impossible error!"

433476{-# INLINE parseOnly #-}

434477

435478get :: Parser Text

436479get = T.Parser $ \t pos more _lose succ ->

437− succ t pos more (T.dropWord16 (fromPos pos) t)

480+ succ t pos more (Buf.dropWord16 (fromPos pos) t)

438481{-# INLINE get #-}

439482

440483endOfChunk :: Parser Bool

@@ -442,11 +485,21 @@ endOfChunk = T.Parser $ \t pos more _lose succ ->

442485 succ t pos more (pos == lengthOf t)

443486{-# INLINE endOfChunk #-}

444487

488+inputSpansChunks :: Pos -> Parser Bool

489+inputSpansChunks i = T.Parser $ \t pos_ more _lose succ ->

490+ let pos = pos_ + i

491+ in if pos < lengthOf t || more == Complete

492+ then succ t pos more False

493+ else let lose' t' pos' more' = succ t' pos' more' False

494+ succ' t' pos' more' = succ t' pos' more' True

495+ in prompt t pos more lose' succ'

496+{-# INLINE inputSpansChunks #-}

497+

445498advance :: Pos -> Parser ()

446499advance n = T.Parser $ \t pos more _lose succ -> succ t (pos+n) more ()

447500{-# INLINE advance #-}

448501

449−ensureSuspended :: Int -> Text -> Pos -> More

502+ensureSuspended :: Int -> Buffer -> Pos -> More

450503 -> Failure r -> Success (Pos, Text) r

451504 -> Result r

452505ensureSuspended n t pos more lose succ =

@@ -464,53 +517,8 @@ ensure n = T.Parser $ \t pos more lose succ ->

464517 Just n' -> succ t pos more (n', substring pos n' t)

465518 -- The uncommon case is kept out-of-line to reduce code size:

466519 Nothing -> ensureSuspended n t pos more lose succ

467−-- Non-recursive so the bounds check can be inlined:

468520{-# INLINE ensure #-}

469521

470−-- | Ask for input. If we receive any, pass it to a success

471−-- continuation, otherwise to a failure continuation.

472−prompt :: Text -> Pos -> More

473− -> (Text -> Pos -> More -> IResult Text Text r)

474− -> (Text -> Pos -> More -> IResult Text Text r)

475− -> Result r

476−prompt t pos _more lose succ = Partial $ \s ->

477− if T.null s

478− then lose t pos Complete

479− else succ (t <> s) pos Incomplete

480−

481−-- | Immediately demand more input via a 'Partial' continuation

482−-- result.

483−demandInput :: Parser ()

484−demandInput = T.Parser $ \t pos more lose succ ->

485− case more of

486− Complete -> lose t pos more [] "not enough input"

487− _ -> let lose' t' pos' more' = lose t' pos' more' [] "not enough input"

488− succ' t' pos' more' = succ t' pos' more' ()

489− in prompt t pos more lose' succ'

490−

491−-- | This parser always succeeds. It returns 'True' if any input is

492−-- available either immediately or on demand, and 'False' if the end

493−-- of all input has been reached.

494−wantInput :: Parser Bool

495−wantInput = T.Parser $ \t pos more _lose succ ->

496− case () of

497− _ | pos < lengthOf t -> succ t pos more True

498− | more == Complete -> succ t pos more False

499− | otherwise -> let lose' t' pos' more' = succ t' pos' more' False

500− succ' t' pos' more' = succ t' pos' more' True

501− in prompt t pos more lose' succ'

502−

503−-- | Match only if all input has been consumed.

504−endOfInput :: Parser ()

505−endOfInput = T.Parser $ \t pos more lose succ ->

506− case () of

507− _| pos < lengthOf t -> lose t pos more [] "endOfInput"

508− | more == Complete -> succ t pos more ()

509− | otherwise ->

510− let lose' t' pos' more' _ctx _msg = succ t' pos' more' ()

511− succ' t' pos' more' _a = lose t' pos' more' [] "endOfInput"

512− in runParser demandInput t pos more lose' succ'

513−

514522-- | Return both the result of a parse and the portion of the input

515523-- that was consumed while it was being parsed.

516524match :: Parser a -> Parser (Text, a)

@@ -519,24 +527,23 @@ match p = T.Parser $ \t pos more lose succ ->

519527 (substring pos (pos'-pos) t', a)

520528 in runParser p t pos more lose succ'

521529

522−-- | Return an indication of whether the end of input has been

523−-- reached.

524−atEnd :: Parser Bool

525−atEnd = not <$> wantInput

526−{-# INLINE atEnd #-}

527−

528−lengthAtLeast :: Pos -> Int -> Text -> Maybe Pos

530+-- | Ensure that at least @n@ code points of input are available.

531+-- Returns the number of words consumed while traversing.

532+lengthAtLeast :: Pos -> Int -> Buffer -> Maybe Pos

529533lengthAtLeast pos n t = go 0 (fromPos pos)

530534 where go i !p

531535 | i == n = Just (Pos p - pos)

532536 | p == len = Nothing

533− | otherwise = go (i+1) (p + T.iter_ t p)

537+ | otherwise = go (i+1) (p + Buf.iter_ t p)

534538 Pos len = lengthOf t

535539{-# INLINE lengthAtLeast #-}

536540

537−substring :: Pos -> Pos -> Text -> Text

538−substring (Pos pos) (Pos n) t = T.takeWord16 n (T.dropWord16 pos t)

541+substring :: Pos -> Pos -> Buffer -> Text

542+substring (Pos pos) (Pos n) = Buf.substring pos n

539543{-# INLINE substring #-}

540544

541−lengthOf :: Text -> Pos

542−lengthOf (Text _arr _off len) = Pos len

545+lengthOf :: Buffer -> Pos

546+lengthOf = Pos . Buf.length

547+

548+size :: Text -> Pos

549+size (Text _ _ l) = Pos l

Data/Attoparsec/Text/Lazy.hs+13−10

@@ -1,7 +1,12 @@

1+{-# LANGUAGE CPP #-}

2+#if __GLASGOW_HASKELL__ >= 702

3+{-# LANGUAGE Trustworthy #-} -- Imports internal modules

4+#endif

16{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}

27-- |

38-- Module : Data.Attoparsec.Text.Lazy

4−-- Copyright : Bryan O'Sullivan 2007-2014

9+-- Copyright : Bryan O'Sullivan 2007-2015

510-- License : BSD3

611--

712-- Maintainer : bos@serpentine.com

@@ -36,6 +41,7 @@ module Data.Attoparsec.Text.Lazy

3641 ) where

3742

3843import Control.DeepSeq (NFData(rnf))

44+import Data.List (intercalate)

3945import Data.Text.Lazy.Internal (Text(..), chunk)

4046import qualified Data.Attoparsec.Internal.Types as T

4147import qualified Data.Attoparsec.Text as A

@@ -45,20 +51,16 @@ import Data.Attoparsec.Text hiding (IResult(..), Result, eitherResult,

4551

4652-- | The result of a parse.

4753data Result r = Fail Text [String] String

48− -- ^ The parse failed. The 'ByteString' is the input

54+ -- ^ The parse failed. The 'Text' is the input

4955 -- that had not yet been consumed when the failure

5056 -- occurred. The @[@'String'@]@ is a list of contexts

5157 -- in which the error occurred. The 'String' is the

5258 -- message describing the error, if any.

5359 | Done Text r

54− -- ^ The parse succeeded. The 'ByteString' is the

60+ -- ^ The parse succeeded. The 'Text' is the

5561 -- input that had not yet been consumed (if any) when

5662 -- the parse succeeded.

57−

58−instance Show r => Show (Result r) where

59− show (Fail bs stk msg) =

60− "Fail " ++ show bs ++ " " ++ show stk ++ " " ++ show msg

61− show (Done bs r) = "Done " ++ show bs ++ " " ++ show r

63+ deriving (Show)

6264

6365instance NFData r => NFData (Result r) where

6466 rnf (Fail bs ctxs msg) = rnf bs `seq` rnf ctxs `seq` rnf msg

@@ -94,5 +96,6 @@ maybeResult _ = Nothing

9496

9597-- | Convert a 'Result' value to an 'Either' value.

9698eitherResult :: Result r -> Either String r

97−eitherResult (Done _ r) = Right r

98−eitherResult (Fail _ _ msg) = Left msg

99+eitherResult (Done _ r) = Right r

100+eitherResult (Fail _ [] msg) = Left msg

101+eitherResult (Fail _ ctxs msg) = Left (intercalate " > " ctxs ++ ": " ++ msg)

Data/Attoparsec/Types.hs+3−2

@@ -1,6 +1,6 @@

11-- |

22-- Module : Data.Attoparsec.Types

3−-- Copyright : Bryan O'Sullivan 2007-2014

3+-- Copyright : Bryan O'Sullivan 2007-2015

44-- License : BSD3

55--

66-- Maintainer : bos@serpentine.com

@@ -14,6 +14,7 @@ module Data.Attoparsec.Types

1414 (

1515 Parser

1616 , IResult(..)

17+ , Chunk(chunkElemToChar)

1718 ) where

1819

19−import Data.Attoparsec.Internal.Types (Parser(..), IResult(..))

20+import Data.Attoparsec.Internal.Types (Parser(..), IResult(..), Chunk(..))

Data/Attoparsec/Zepto.hs+88−46

@@ -1,8 +1,12 @@

1−{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}

1+{-# LANGUAGE CPP #-}

2+#if __GLASGOW_HASKELL__ >= 702

3+{-# LANGUAGE Trustworthy #-} -- Data.ByteString.Unsafe

4+#endif

5+{-# LANGUAGE BangPatterns #-}

37-- |

48-- Module : Data.Attoparsec.Zepto

5−-- Copyright : Bryan O'Sullivan 2007-2014

9+-- Copyright : Bryan O'Sullivan 2007-2015

610-- License : BSD3

711--

812-- Maintainer : bos@serpentine.com

@@ -12,112 +16,150 @@

1216-- A tiny, highly specialized combinator parser for 'B.ByteString'

1317-- strings.

1418--

15−-- While the main Attoparsec module generally performs well, this

19+-- While the main attoparsec module generally performs well, this

1620-- module is particularly fast for simple non-recursive loops that

1721-- should not normally result in failed parses.

1822--

1923-- /Warning/: on more complex inputs involving recursion or failure,

2024-- parsers based on this module may be as much as /ten times slower/

21−-- than regular Attoparsec! You should /only/ use this module when you

25+-- than regular attoparsec! You should /only/ use this module when you

2226-- have benchmarks that prove that its use speeds your code up.

2327module Data.Attoparsec.Zepto

2428 (

2529 Parser

30+ , ZeptoT

2631 , parse

32+ , parseT

2733 , atEnd

2834 , string

2935 , take

3036 , takeWhile

3137 ) where

3238

33−import Data.Word (Word8)

3439import Control.Applicative

35−import Control.Monad

36−import Data.Monoid

37−import qualified Data.ByteString as B

38−import qualified Data.ByteString.Unsafe as B

40+import Control.Monad (MonadPlus(..), ap)

41+import qualified Control.Monad.Fail as Fail

42+import Control.Monad.IO.Class (MonadIO(..))

3943import Data.ByteString (ByteString)

44+import Data.Functor.Identity (Identity(runIdentity))

45+import Data.Monoid as Mon (Monoid(..))

46+import Data.Semigroup (Semigroup(..))

47+import Data.Word (Word8)

4048import Prelude hiding (take, takeWhile)

49+import qualified Data.ByteString as B

50+import qualified Data.ByteString.Unsafe as B

4151

4252newtype S = S {

4353 input :: ByteString

4454 }

4555

4656data Result a = Fail String

47− | OK !a

57+ | OK !a S

4858

4959-- | A simple parser.

5060--

5161-- This monad is strict in its state, and the monadic bind operator

5262-- ('>>=') evaluates each result to weak head normal form before

5363-- passing it along.

54−newtype Parser a = Parser {

55− runParser :: S -> (# Result a, S #)

64+newtype ZeptoT m a = Parser {

65+ runParser :: S -> m (Result a)

5666 }

5767

58−instance Functor Parser where

59− fmap f m = Parser $ \s -> case runParser m s of

60− (# OK a, s' #) -> (# OK (f a), s' #)

61− (# Fail err, s' #) -> (# Fail err, s' #)

68+type Parser a = ZeptoT Identity a

69+

70+instance Monad m => Functor (ZeptoT m) where

71+ fmap f m = Parser $ \s -> do

72+ result <- runParser m s

73+ case result of

74+ OK a s' -> return (OK (f a) s')

75+ Fail err -> return (Fail err)

6276 {-# INLINE fmap #-}

6377

64−instance Monad Parser where

65− return a = Parser $ \s -> (# OK a, s #)

78+instance MonadIO m => MonadIO (ZeptoT m) where

79+ liftIO act = Parser $ \s -> do

80+ result <- liftIO act

81+ return (OK result s)

82+ {-# INLINE liftIO #-}

83+

84+instance Monad m => Monad (ZeptoT m) where

85+ return = pure

6686 {-# INLINE return #-}

6787

68− m >>= k = Parser $ \s -> case runParser m s of

69− (# OK a, s' #) -> runParser (k a) s'

70− (# Fail err, s' #) -> (# Fail err, s' #)

88+ m >>= k = Parser $ \s -> do

89+ result <- runParser m s

90+ case result of

91+ OK a s' -> runParser (k a) s'

92+ Fail err -> return (Fail err)

7193 {-# INLINE (>>=) #-}

7294

73− fail msg = Parser $ \s -> (# Fail msg, s #)

95+#if !(MIN_VERSION_base(4,13,0))

96+ fail = Fail.fail

97+ {-# INLINE fail #-}

98+#endif

7499

75−instance MonadPlus Parser where

100+instance Monad m => Fail.MonadFail (ZeptoT m) where

101+ fail msg = Parser $ \_ -> return (Fail msg)

102+ {-# INLINE fail #-}

103+

104+instance Monad m => MonadPlus (ZeptoT m) where

76105 mzero = fail "mzero"

77106 {-# INLINE mzero #-}

78107

79− mplus a b = Parser $ \s ->

80− case runParser a s of

81− (# ok@(OK _), s' #) -> (# ok, s' #)

82− (# _, _ #) -> case runParser b s of

83− (# ok@(OK _), s'' #) -> (# ok, s'' #)

84− (# err, s'' #) -> (# err, s'' #)

108+ mplus a b = Parser $ \s -> do

109+ result <- runParser a s

110+ case result of

111+ ok@(OK _ _) -> return ok

112+ _ -> runParser b s

85113 {-# INLINE mplus #-}

86114

87−instance Applicative Parser where

88− pure = return

115+instance (Monad m) => Applicative (ZeptoT m) where

116+ pure a = Parser $ \s -> return (OK a s)

89117 {-# INLINE pure #-}

90118 (<*>) = ap

91119 {-# INLINE (<*>) #-}

92120

93−gets :: (S -> a) -> Parser a

94−gets f = Parser $ \s -> (# OK (f s), s #)

121+gets :: Monad m => (S -> a) -> ZeptoT m a

122+gets f = Parser $ \s -> return (OK (f s) s)

95123{-# INLINE gets #-}

96124

97−put :: S -> Parser ()

98−put s = Parser $ \_ -> (# OK (), s #)

125+put :: Monad m => S -> ZeptoT m ()

126+put s = Parser $ \_ -> return (OK () s)

99127{-# INLINE put #-}

100128

101129-- | Run a parser.

102130parse :: Parser a -> ByteString -> Either String a

103−parse p bs = case runParser p (S bs) of

104− (# OK a, _ #) -> Right a

105− (# Fail err, _ #) -> Left err

106−

107−instance Monoid (Parser a) where

131+parse p bs = case runIdentity (runParser p (S bs)) of

132+ (OK a _) -> Right a

133+ (Fail err) -> Left err

134+{-# INLINE parse #-}

135+

136+-- | Run a parser on top of the given base monad.

137+parseT :: Monad m => ZeptoT m a -> ByteString -> m (Either String a)

138+parseT p bs = do

139+ result <- runParser p (S bs)

140+ case result of

141+ OK a _ -> return (Right a)

142+ Fail err -> return (Left err)

143+{-# INLINE parseT #-}

144+

145+instance Monad m => Semigroup (ZeptoT m a) where

146+ (<>) = mplus

147+ {-# INLINE (<>) #-}

148+

149+instance Monad m => Mon.Monoid (ZeptoT m a) where

108150 mempty = fail "mempty"

109151 {-# INLINE mempty #-}

110− mappend = mplus

152+ mappend = (<>)

111153 {-# INLINE mappend #-}

112154

113−instance Alternative Parser where

155+instance Monad m => Alternative (ZeptoT m) where

114156 empty = fail "empty"

115157 {-# INLINE empty #-}

116158 (<|>) = mplus

117159 {-# INLINE (<|>) #-}

118160

119161-- | Consume input while the predicate returns 'True'.

120−takeWhile :: (Word8 -> Bool) -> Parser ByteString

162+takeWhile :: Monad m => (Word8 -> Bool) -> ZeptoT m ByteString

121163takeWhile p = do

122164 (h,t) <- gets (B.span p . input)

123165 put (S t)

@@ -125,7 +167,7 @@ takeWhile p = do

125167{-# INLINE takeWhile #-}

126168

127169-- | Consume @n@ bytes of input.

128−take :: Int -> Parser ByteString

170+take :: Monad m => Int -> ZeptoT m ByteString

129171take !n = do

130172 s <- gets input

131173 if B.length s >= n

@@ -134,7 +176,7 @@ take !n = do

134176{-# INLINE take #-}

135177

136178-- | Match a string exactly.

137−string :: ByteString -> Parser ()

179+string :: Monad m => ByteString -> ZeptoT m ()

138180string s = do

139181 i <- gets input

140182 if s `B.isPrefixOf` i

@@ -143,7 +185,7 @@ string s = do

143185{-# INLINE string #-}

144186

145187-- | Indicate whether the end of the input has been reached.

146−atEnd :: Parser Bool

188+atEnd :: Monad m => ZeptoT m Bool

147189atEnd = do

148190 i <- gets input

149191 return $! B.null i

README.markdown−6

@@ -16,12 +16,6 @@ Master [git repository](https://github.com/bos/attoparsec):

1616

1717* `git clone git://github.com/bos/attoparsec.git`

1818

19−There's also a [Mercurial mirror](https://bitbucket.org/bos/attoparsec):

20−

21−* `hg clone https://bitbucket.org/bos/attoparsec`

22−

23−(You can create and contribute changes using either Mercurial or git.)

24−

2519Authors

2620-------

2721

attoparsec.cabal+83−27

@@ -1,12 +1,13 @@

11name: attoparsec

2−version: 0.12.0.0

2+version: 0.13.2.2

3+x-revision: 3

34license: BSD3

45license-file: LICENSE

56category: Text, Parsing

67author: Bryan O'Sullivan <bos@serpentine.com>

7−maintainer: Bryan O'Sullivan <bos@serpentine.com>

8+maintainer: Bryan O'Sullivan <bos@serpentine.com>, Ben Gamari <ben@smart-cactus.org>

89stability: experimental

9−tested-with: GHC == 7.0, GHC == 7.2, GHC == 7.4, GHC == 7.6, GHC == 7.8

10+tested-with: GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.2, GHC ==7.6.3, GHC ==7.8.4, GHC ==7.10.3, GHC ==8.0.2, GHC ==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.1

1011synopsis: Fast combinator parsing for bytestrings and text

1112cabal-version: >= 1.8

1213homepage: https://github.com/bos/attoparsec

@@ -21,6 +22,7 @@ extra-source-files:

2122 benchmarks/*.cabal

2223 benchmarks/*.hs

2324 benchmarks/*.txt

25+ benchmarks/json-data/*.json

2426 benchmarks/Makefile

2527 benchmarks/med.txt.bz2

2628 changelog.md

@@ -28,9 +30,8 @@ extra-source-files:

2830 examples/*.hs

2931 examples/Makefile

3032 tests/*.hs

31− tests/Makefile

3233 tests/QC/*.hs

33− tests/TestFastSet.hs

34+ tests/QC/IPv6/*.hs

3435

3536Flag developer

3637 Description: Whether to build the library in development mode

@@ -39,16 +40,21 @@ Flag developer

3940

4041library

4142 build-depends: array,

42− base >= 4.2 && < 5,

43+ base >= 4.3 && < 5,

4344 bytestring,

4445 containers,

4546 deepseq,

4647 scientific >= 0.3.1 && < 0.4,

47− text >= 0.11.3.1

48+ transformers >= 0.2 && (< 0.4 || >= 0.4.1.0) && < 0.6,

49+ text >= 1.1.1.3

4850 if impl(ghc < 7.4)

4951 build-depends:

50− bytestring < 0.10.4.0,

51− text < 1.1

52+ bytestring < 0.10.4.0

53+

54+ if !impl(ghc >= 8.0)

55+ -- Data.Semigroup && Control.Monad.Fail are available in base-4.9+

56+ build-depends: fail == 4.9.*,

57+ semigroups >=0.16.1 && <0.20

5258

5359 exposed-modules: Data.Attoparsec

5460 Data.Attoparsec.ByteString

@@ -56,17 +62,19 @@ library

5662 Data.Attoparsec.ByteString.Lazy

5763 Data.Attoparsec.Char8

5864 Data.Attoparsec.Combinator

65+ Data.Attoparsec.Internal

66+ Data.Attoparsec.Internal.Types

5967 Data.Attoparsec.Lazy

6068 Data.Attoparsec.Number

6169 Data.Attoparsec.Text

6270 Data.Attoparsec.Text.Lazy

6371 Data.Attoparsec.Types

6472 Data.Attoparsec.Zepto

65− other-modules: Data.Attoparsec.ByteString.FastSet

66− Data.Attoparsec.ByteString.Fhthagn

73+ other-modules: Data.Attoparsec.ByteString.Buffer

74+ Data.Attoparsec.ByteString.FastSet

6775 Data.Attoparsec.ByteString.Internal

68− Data.Attoparsec.Internal

69− Data.Attoparsec.Internal.Types

76+ Data.Attoparsec.Internal.Fhthagn

77+ Data.Attoparsec.Text.Buffer

7078 Data.Attoparsec.Text.FastSet

7179 Data.Attoparsec.Text.Internal

7280 ghc-options: -O2 -Wall

@@ -77,12 +85,37 @@ library

7785

7886test-suite tests

7987 type: exitcode-stdio-1.0

80− hs-source-dirs: tests

88+ hs-source-dirs: tests .

8189 main-is: QC.hs

82− other-modules: QC.ByteString

90+ other-modules: QC.Buffer

91+ QC.ByteString

8392 QC.Combinator

8493 QC.Common

94+ QC.IPv6.Internal

95+ QC.IPv6.Types

96+ QC.Rechunked

97+ QC.Simple

8598 QC.Text

99+ QC.Text.FastSet

100+ QC.Text.Regressions

101+

102+ other-modules: Data.Attoparsec.ByteString

103+ Data.Attoparsec.ByteString.Buffer

104+ Data.Attoparsec.ByteString.Char8

105+ Data.Attoparsec.ByteString.FastSet

106+ Data.Attoparsec.ByteString.Internal

107+ Data.Attoparsec.ByteString.Lazy

108+ Data.Attoparsec.Combinator

109+ Data.Attoparsec.Internal

110+ Data.Attoparsec.Internal.Fhthagn

111+ Data.Attoparsec.Internal.Types

112+ Data.Attoparsec.Number

113+ Data.Attoparsec.Text

114+ Data.Attoparsec.Text.Buffer

115+ Data.Attoparsec.Text.FastSet

116+ Data.Attoparsec.Text.Internal

117+ Data.Attoparsec.Text.Lazy

118+ Data.Attoparsec.Zepto

86119

87120 ghc-options:

88121 -Wall -threaded -rtsopts

@@ -91,25 +124,41 @@ test-suite tests

91124 ghc-options: -Werror

92125

93126 build-depends:

94− attoparsec,

95− base >= 4 && < 5,

127+ array,

128+ base,

96129 bytestring,

97− QuickCheck >= 2.7,

98− test-framework >= 0.8.0.2,

99− test-framework-quickcheck2 >= 0.3.0.3,

100− text

130+ deepseq >= 1.1,

131+ QuickCheck >= 2.13.2 && < 2.14,

132+ quickcheck-unicode,

133+ scientific,

134+ tasty >= 0.11,

135+ tasty-quickcheck >= 0.8,

136+ text,

137+ transformers >= 0.2 && (< 0.4 || >= 0.4.1.0) && < 0.6,

138+ vector

139+

140+ if !impl(ghc >= 8.0)

141+ -- Data.Semigroup && Control.Monad.Fail are available in base-4.9+

142+ build-depends: fail == 4.9.*,

143+ semigroups >=0.16.1 && <0.20

101144

102145benchmark benchmarks

103146 type: exitcode-stdio-1.0

104− hs-source-dirs: benchmarks, .

105− ghc-options: -O2 -Wall

147+ hs-source-dirs: benchmarks benchmarks/warp-3.0.1.1 .

148+ ghc-options: -O2 -Wall -rtsopts

106149 main-is: Benchmarks.hs

107150 other-modules:

108151 Common

109152 HeadersByteString

153+ HeadersByteString.Atto

110154 HeadersText

111155 Links

156+ Network.Wai.Handler.Warp.ReadInt

157+ Network.Wai.Handler.Warp.RequestHeader

112158 Numbers

159+ Sets

160+ TextFastSet

161+ Warp

113162 ghc-options: -O2 -Wall

114163

115164 if flag(developer)

@@ -119,20 +168,27 @@ benchmark benchmarks

119168 array,

120169 base == 4.*,

121170 bytestring >= 0.10.4.0,

122− criterion >= 0.8.1.0,

171+ case-insensitive,

172+ containers,

173+ criterion >= 1.0,

123174 deepseq >= 1.1,

124175 directory,

125176 filepath,

177+ ghc-prim,

178+ http-types,

126179 parsec >= 3.1.2,

127180 scientific,

128181 text >= 1.1.1.0,

182+ transformers >= 0.2 && (< 0.4 || >= 0.4.1.0) && < 0.6,

129183 unordered-containers,

130184 vector

131185

186+ if !impl(ghc >= 8.0)

187+ -- Data.Semigroup && Control.Monad.Fail are available in base-4.9+

188+ build-depends: fail == 4.9.*,

189+ semigroups >=0.16.1 && <0.19

190+

132191source-repository head

133192 type: git

134193 location: https://github.com/bos/attoparsec

135194

136−source-repository head

137− type: mercurial

138− location: https://bitbucket.org/bos/attoparsec

benchmarks/Aeson.hs+8−3

@@ -10,7 +10,13 @@ module Aeson

1010import Data.ByteString.Builder

1111 (Builder, byteString, toLazyByteString, charUtf8, word8)

1212

13−import Control.Applicative ((*>), (<$>), (<*), liftA2, pure)

13+#if !MIN_VERSION_base(4,8,0)

14+import Control.Applicative ((*>), (<$>), (<*), pure)

15+import Data.Monoid (mappend, mempty)

16+#endif

17+

18+import Common (pathTo)

19+import Control.Applicative (liftA2)

1420import Control.DeepSeq (NFData(..))

1521import Control.Monad (forM)

1622import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific,

@@ -19,7 +25,6 @@ import Data.Bits ((.|.), shiftL)

1925import Data.ByteString (ByteString)

2026import Data.Char (chr)

2127import Data.List (sort)

22−import Data.Monoid (mappend, mempty)

2328import Data.Scientific (Scientific)

2429import Data.Text (Text)

2530import Data.Text.Encoding (decodeUtf8')

@@ -340,7 +345,7 @@ toByteString = L.toStrict . toLazyByteString

340345

341346aeson :: IO Benchmark

342347aeson = do

343− let path = "json-data"

348+ path <- pathTo "json-data"

344349 names <- sort . filter (`notElem` [".", ".."]) <$> getDirectoryContents path

345350 benches <- forM names $ \name -> do

346351 bs <- B.readFile (path </> name)

benchmarks/Benchmarks.hs+10

@@ -11,7 +11,9 @@ import Numbers (numbers)

1111import Common (chunksOf)

1212import Text.Parsec.Text ()

1313import Text.Parsec.Text.Lazy ()

14+import qualified Warp

1415import qualified Aeson

16+import qualified Genome

1517import qualified Data.Attoparsec.ByteString as AB

1618import qualified Data.Attoparsec.ByteString.Char8 as AC

1719import qualified Data.Attoparsec.ByteString.Lazy as ABL

@@ -26,6 +28,7 @@ import qualified HeadersByteString

2628import qualified HeadersText

2729import qualified Links

2830import qualified Text.Parsec as P

31+import qualified Sets

2932

3033main :: IO ()

3134main = do

@@ -68,10 +71,14 @@ main = do

6871 , bench "isAlpha_ascii" $ nf (ABL.parse (AC.takeWhile AC.isAlpha_ascii)) bl

6972 , bench "isAlpha_iso8859_15" $

7073 nf (ABL.parse (AC.takeWhile AC.isAlpha_iso8859_15)) bl

74+ , bench "T isAlpha" $ nf (AT.parse (AT.takeWhile isAlpha)) t

75+ , bench "TL isAlpha" $ nf (ATL.parse (AT.takeWhile isAlpha)) tl

7176 ]

7277 , bgroup "takeWhile1" [

7378 bench "isAlpha" $ nf (ABL.parse (AC.takeWhile1 isAlpha)) bl

7479 , bench "isAlpha_ascii" $ nf (ABL.parse (AC.takeWhile1 AC.isAlpha_ascii)) bl

80+ , bench "T isAlpha" $ nf (AT.parse (AT.takeWhile1 isAlpha)) t

81+ , bench "TL isAlpha" $ nf (ATL.parse (AT.takeWhile1 isAlpha)) tl

7582 ]

7683 , bench "word32LE" $ nf (AB.parse word32LE) b

7784 , bgroup "scan" [

@@ -79,10 +86,13 @@ main = do

7986 , bench "long" $ nf (AB.parse quotedString) b

8087 ]

8188 , aeson

89+ , Genome.genome

8290 , headersBS

8391 , headersT

8492 , Links.links

8593 , numbers

94+ , Sets.benchmarks

95+ , Warp.benchmarks

8696 ]

8797

8898-- Benchmarks bind and (potential) bounds-check merging.

benchmarks/Common.hs+10

@@ -3,11 +3,14 @@

44module Common (

55 chunksOf

6+ , pathTo

67 , rechunkBS

78 , rechunkT

89 ) where

910

1011import Control.DeepSeq (NFData(rnf))

12+import System.Directory (doesDirectoryExist)

13+import System.FilePath ((</>))

1114import Text.Parsec (ParseError)

1215import qualified Data.ByteString as B

1316import qualified Data.ByteString.Lazy as BL

@@ -35,3 +38,10 @@ rechunkBS n = BL.fromChunks . map B.pack . chunksOf n . B.unpack

3538

3639rechunkT :: Int -> T.Text -> TL.Text

3740rechunkT n = TL.fromChunks . map T.pack . chunksOf n . T.unpack

41+

42+pathTo :: String -> IO FilePath

43+pathTo wat = do

44+ exists <- doesDirectoryExist "benchmarks"

45+ return $ if exists

46+ then "benchmarks" </> wat

47+ else wat

benchmarks/Genome.hsnew file+75

@@ -0,0 +1,75 @@

1+{-# LANGUAGE OverloadedStrings #-}

3+module Genome

4+ (

5+ genome

6+ ) where

8+import Control.Applicative

9+import Criterion.Main

10+import Data.ByteString (ByteString)

11+import qualified Data.ByteString.Char8 as B8

12+import qualified Data.ByteString.Lazy.Char8 as L8

13+import Data.Attoparsec.ByteString.Char8 as B

14+import qualified Data.Attoparsec.ByteString.Lazy as BL

15+import Data.Text (Text)

16+import qualified Data.Text as T

17+import qualified Data.Text.Lazy as TL

18+import Data.Attoparsec.Text as T

19+import qualified Data.Attoparsec.Text.Lazy as TL

20+import Common (rechunkBS, rechunkT)

21+

22+genome :: Benchmark

23+genome = bgroup "genome" [

24+ bgroup "bytestring" [

25+ bench "s" $ nf (map (B.parse searchBS)) (B8.tails geneB)

26+ , bench "l" $ nf (map (BL.parse searchBS)) (L8.tails geneBL)

27+ , bgroup "CI" [

28+ bench "s" $ nf (map (B.parse searchBSCI)) (B8.tails geneB)

29+ , bench "l" $ nf (map (BL.parse searchBSCI)) (L8.tails geneBL)

30+ ]

31+ ]

32+ , bgroup "text" [

33+ bench "s" $ nf (map (T.parse searchT)) (T.tails geneT)

34+ , bench "l" $ nf (map (TL.parse searchT)) (TL.tails geneTL)

35+ , bgroup "CI" [

36+ bench "s" $ nf (map (T.parse searchTCI)) (T.tails geneT)

37+ , bench "l" $ nf (map (TL.parse searchTCI)) (TL.tails geneTL)

38+ ]

39+ ]

40+ ]

41+ where geneB = B8.pack gene

42+ geneBL = rechunkBS 4 geneB

43+ geneT = T.pack gene

44+ geneTL = rechunkT 4 geneT

45+

46+searchBS :: B.Parser ByteString

47+searchBS = "caac" *> ("aaca" <|> "aact")

48+

49+searchBSCI :: B.Parser ByteString

50+searchBSCI = B.stringCI "CAAC" *> (B.stringCI "AACA" <|> B.stringCI "AACT")

51+

52+searchT :: T.Parser Text

53+searchT = "caac" *> ("aaca" <|> "aact")

54+

55+searchTCI :: T.Parser Text

56+searchTCI = T.asciiCI "CAAC" *> (T.asciiCI "AACA" <|> T.asciiCI "AACT")

57+

58+-- Dictyostelium discoideum developmental protein DG1094 (gacT) gene,

59+-- partial cds. http://www.ncbi.nlm.nih.gov/nuccore/AF081586.1

60+

61+gene :: String

62+gene = "atcgatttagaaagatacaaagatagaaccatcaataataaacaagagaagagagcaagt\

63+ \agagatattaataaagagattgaaagagagattgaaaagaagagattatcaccaagagaa\

64+ \agattaaatttatttggtctttcttcctcatcttcatcagtgaattcaacattaacaaga\

65+ \tctacagcaaatattatctctacaatagacggtagtggaggtagtaatcgtaatagtaaa\

66+ \aattatggtaatggctcatcctcctcctcaaatagaagatatagtaatactattaatcaa\

67+ \caattacaaatgcaattacaacaacttcaaatccaacaacaacaatatcaacaaactcaa\

68+ \caatctcaaataccattacaatatcaacaacaacaacagcaacaacaacaacaaaccact\

69+ \acaactacaactacatcaagtggtagtaatagattctcttcaaatagatataaaccagtt\

70+ \gatcttacacaatcatcttcaaactttcgttattcacgtgaaatttatgatgatgattat\

71+ \tattcaaataataatttaatgatgtttggtaatgagcaaccaaatcaaacaccaatttct\

72+ \gtatcatcttcatctgcattcacacgtcaaagatctcaaagttgctttgaaccagagaat\

73+ \cttgtattgctacaacaacaatatcaacaatatcaacaacaacaacaacaacaacaacaa\

74+ \attccattccaagcaaatccacaatatagtaatgctgttattgaacaaaaattggatcaa\

75+ \attagagataccattaataatttacatagagataaccgagtctctaga"

benchmarks/HeadersByteString.hs+15−34

@@ -1,52 +1,33 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

31module HeadersByteString (headers) where

5−import Common (rechunkBS)

6−import Control.Applicative

7−import Criterion.Main (bench, bgroup, nf)

3+import Common (pathTo, rechunkBS)

4+import Criterion.Main (bench, bgroup, nf, nfIO)

85import Criterion.Types (Benchmark)

6+import HeadersByteString.Atto (request, response)

7+import Network.Wai.Handler.Warp.RequestHeader (parseHeaderLines)

98import qualified Data.Attoparsec.ByteString.Char8 as B

109import qualified Data.Attoparsec.ByteString.Lazy as BL

1110import qualified Data.ByteString.Char8 as B

1211

13−header = do

14− name <- B.takeWhile1 (B.inClass "a-zA-Z0-9_-") <* B.char ':' <* B.skipSpace

15− body <- (:) <$> bodyLine <*> many (B.takeWhile1 B.isSpace *> bodyLine)

16− return (name, body)

17−

18−bodyLine = B.takeTill (\c -> c == '\r' || c == '\n') <* B.endOfLine

19−

20−requestLine =

21− (,,) <$>

22− (method <* B.skipSpace) <*>

23− (B.takeTill B.isSpace <* B.skipSpace) <*>

24− httpVersion

25− where method = "GET" <|> "POST"

26−

27−httpVersion = "HTTP/" *> ((,) <$> (int <* B.char '.') <*> int)

28−

29−responseLine = (,,) <$>

30− (httpVersion <* B.skipSpace) <*>

31− (int <* B.skipSpace) <*>

32− bodyLine

33−

34−int :: B.Parser Int

35−int = B.decimal

36−

37−request = (,) <$> (requestLine <* B.endOfLine) <*> many header

38−

39−response = (,) <$> responseLine <*> many header

12+-- Note: In the benchmarks for parsing an http request

13+-- from a strict bytestring, we consider warp's implementation,

14+-- which has highly optimized code for handling the first

15+-- line in particular. It's treatment of the headers

16+-- is more relaxed from the treatment they are given by the

17+-- attoparsec parser benchmarked here. Consequently, it

18+-- is should not be possible to match its performance since

19+-- it accepts header names with disallowed characters.

4020

4121headers :: IO Benchmark

4222headers = do

43− req <- B.readFile "http-request.txt"

44− resp <- B.readFile "http-response.txt"

23+ req <- B.readFile =<< pathTo "http-request.txt"

24+ resp <- B.readFile =<< pathTo "http-response.txt"

4525 let reql = rechunkBS 4 req

4626 respl = rechunkBS 4 resp

4727 return $ bgroup "headers" [

4828 bgroup "B" [

4929 bench "request" $ nf (B.parseOnly request) req

30+ , bench "warp" $ nfIO (parseHeaderLines (B.split '\n' req))

5031 , bench "response" $ nf (B.parseOnly response) resp

5132 ]

5233 , bgroup "BL" [

benchmarks/HeadersByteString/Atto.hsnew file+57

@@ -0,0 +1,57 @@

1+{-# LANGUAGE BangPatterns, OverloadedStrings #-}

2+{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-orphans #-}

3+module HeadersByteString.Atto

4+ (

5+ request

6+ , response

7+ ) where

9+import Control.Applicative

10+import Control.DeepSeq (NFData(..))

11+import Network.HTTP.Types.Version (HttpVersion, http11)

12+import qualified Data.Attoparsec.ByteString.Char8 as B

13+import qualified Data.ByteString.Char8 as B

14+

15+instance NFData HttpVersion where

16+ rnf !_ = ()

17+

18+isHeaderChar :: Char -> Bool

19+isHeaderChar c =

20+ (c >= 'a' && c <= 'z') ||

21+ (c >= 'A' && c <= 'Z') ||

22+ (c >= '0' && c <= '9') ||

23+ (c == '_') ||

24+ (c == '-')

25+

26+header = do

27+ name <- B.takeWhile1 isHeaderChar <* B.char ':' <* B.skipSpace

28+ body <- bodyLine

29+ return (name, body)

30+

31+bodyLine = B.takeTill (\c -> c == '\r' || c == '\n') <* B.endOfLine

32+

33+requestLine = do

34+ m <- (B.takeTill B.isSpace <* B.char ' ')

35+ (p,q) <- B.break (=='?') <$> (B.takeTill B.isSpace <* B.char ' ')

36+ v <- httpVersion

37+ return (m,p,q,v)

38+

39+httpVersion = http11 <$ "HTTP/1.1"

40+

41+responseLine = (,,) <$>

42+ (httpVersion <* B.skipSpace) <*>

43+ (int <* B.skipSpace) <*>

44+ bodyLine

45+

46+int :: B.Parser Int

47+int = B.decimal

48+

49+request = (,) <$> (requestLine <* B.endOfLine) <*> manyheader

50+

51+response = (,) <$> responseLine <*> many header

52+

53+manyheader = do

54+ c <- B.peekChar'

55+ if c == '\r' || c == '\n'

56+ then return []

57+ else (:) <$> header <*> manyheader

benchmarks/HeadersText.hs+3−3

@@ -2,7 +2,7 @@

22{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

33module HeadersText (headers) where

5−import Common (rechunkT)

5+import Common (pathTo, rechunkT)

66import Control.Applicative

77import Criterion.Main (bench, bgroup, nf)

88import Criterion.Types (Benchmark)

@@ -41,8 +41,8 @@ response = (,) <$> responseLine <*> many header

4141

4242headers :: IO Benchmark

4343headers = do

44− req <- T.readFile "http-request.txt"

45− resp <- T.readFile "http-response.txt"

44+ req <- T.readFile =<< pathTo "http-request.txt"

45+ resp <- T.readFile =<< pathTo "http-response.txt"

4646 let reql = rechunkT 4 req

4747 respl = rechunkT 4 resp

4848 return $ bgroup "headers" [

benchmarks/Links.hs+2−2

@@ -5,8 +5,8 @@ module Links (links) where

55import Control.Applicative

66import Control.DeepSeq (NFData(..))

77import Criterion.Main (Benchmark, bench, nf)

8−import Data.Attoparsec as A

9−import Data.Attoparsec.Char8 as A8

8+import Data.Attoparsec.ByteString as A

9+import Data.Attoparsec.ByteString.Char8 as A8

1010import Data.ByteString.Char8 as B8

1111

1212data Link = Link {

benchmarks/Numbers.hs+1

@@ -1,4 +1,5 @@

11{-# LANGUAGE BangPatterns #-}

2+{-# OPTIONS_GHC -fno-warn-deprecations #-}

34module Numbers (numbers) where

benchmarks/Sets.hsnew file+21

@@ -0,0 +1,21 @@

1+module Sets (benchmarks) where

3+import Criterion

4+import Data.Char (ord)

5+import qualified Data.Attoparsec.Text.FastSet as FastSet

6+import qualified TextFastSet

7+import qualified Data.HashSet as HashSet

8+import qualified Data.IntSet as IntSet

10+smallSet :: String

11+smallSet = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']

12+

13+benchmarks :: Benchmark

14+benchmarks = bgroup "sets" [

15+ bench "Fast" $ whnf (FastSet.member '*') (FastSet.fromList smallSet)

16+ , bench "Hash" $ whnf (HashSet.member '*') (HashSet.fromList smallSet)

17+ , bench "Int" $ whnf (IntSet.member (ord '*'))

18+ (IntSet.fromList (map ord smallSet))

19+ , bench "TextFast" $ whnf (TextFastSet.member '*')

20+ (TextFastSet.fromList smallSet)

21+ ]

benchmarks/TextFastSet.hsnew file+121

@@ -0,0 +1,121 @@

1+{-# LANGUAGE BangPatterns #-}

3+------------------------------------------------------------------------------

4+-- |

5+-- Module : Data.Attoparsec.FastSet

6+-- Copyright : Felipe Lessa 2010, Bryan O'Sullivan 2007-2015

7+-- License : BSD3

8+--

9+-- Maintainer : felipe.lessa@gmail.com

10+-- Stability : experimental

11+-- Portability : unknown

12+--

13+-- Fast set membership tests for 'Char' values. We test for

14+-- membership using a hashtable implemented with Robin Hood

15+-- collision resolution. The set representation is unboxed,

16+-- and the characters and hashes interleaved, for efficiency.

17+--

18+--

19+-----------------------------------------------------------------------------

20+module TextFastSet

21+ (

22+ -- * Data type

23+ FastSet

24+ -- * Construction

25+ , fromList

26+ , set

27+ -- * Lookup

28+ , member

29+ -- * Handy interface

30+ , charClass

31+ ) where

32+

33+import Data.Bits ((.|.), (.&.), shiftR)

34+import Data.Function (on)

35+import Data.List (sort, sortBy)

36+import qualified Data.Array.Base as AB

37+import qualified Data.Array.Unboxed as A

38+import qualified Data.Text as T

39+

40+data FastSet = FastSet {

41+ table :: {-# UNPACK #-} !(A.UArray Int Int)

42+ , mask :: {-# UNPACK #-} !Int

43+ }

44+

45+data Entry = Entry {

46+ key :: {-# UNPACK #-} !Char

47+ , initialIndex :: {-# UNPACK #-} !Int

48+ , index :: {-# UNPACK #-} !Int

49+ }

50+

51+offset :: Entry -> Int

52+offset e = index e - initialIndex e

53+

54+resolveCollisions :: [Entry] -> [Entry]

55+resolveCollisions [] = []

56+resolveCollisions [e] = [e]

57+resolveCollisions (a:b:entries) = a' : resolveCollisions (b' : entries)

58+ where (a', b')

59+ | index a < index b = (a, b)

60+ | offset a < offset b = (b { index=index a }, a { index=index a + 1 })

61+ | otherwise = (a, b { index=index a + 1 })

62+

63+pad :: Int -> [Entry] -> [Entry]

64+pad = go 0

65+ where -- ensure that we pad enough so that lookups beyond the

66+ -- last hash in the table fall within the array

67+ go !_ !m [] = replicate (max 1 m + 1) empty

68+ go k m (e:entries) = map (const empty) [k..i - 1] ++ e :

69+ go (i + 1) (m + i - k - 1) entries

70+ where i = index e

71+ empty = Entry '\0' maxBound 0

72+

73+nextPowerOf2 :: Int -> Int

74+nextPowerOf2 0 = 1

75+nextPowerOf2 x = go (x - 1) 1

76+ where go y 32 = y + 1

77+ go y k = go (y .|. (y `shiftR` k)) $ k * 2

78+

79+fastHash :: Char -> Int

80+fastHash = fromEnum

81+

82+fromList :: String -> FastSet

83+fromList s = FastSet (AB.listArray (0, length interleaved - 1) interleaved)

84+ mask'

85+ where s' = ordNub (sort s)

86+ l = length s'

87+ mask' = nextPowerOf2 ((5 * l) `div` 4) - 1

88+ entries = pad mask' .

89+ resolveCollisions .

90+ sortBy (compare `on` initialIndex) .

91+ zipWith (\c i -> Entry c i i) s' .

92+ map ((.&. mask') . fastHash) $ s'

93+ interleaved = concatMap (\e -> [fromEnum $ key e, initialIndex e])

94+ entries

95+

96+ordNub :: Eq a => [a] -> [a]

97+ordNub [] = []

98+ordNub (y:ys) = go y ys

99+ where go x (z:zs)

100+ | x == z = go x zs

101+ | otherwise = x : go z zs

102+ go x [] = [x]

103+

104+set :: T.Text -> FastSet

105+set = fromList . T.unpack

106+

107+-- | Check the set for membership.

108+member :: Char -> FastSet -> Bool

109+member c a = go (2 * i)

110+ where i = fastHash c .&. mask a

111+ lookupAt j b = (i' <= i) && (c == c' || b)

112+ where c' = toEnum $ AB.unsafeAt (table a) j

113+ i' = AB.unsafeAt (table a) $ j + 1

114+ go j = lookupAt j . lookupAt (j + 2) . lookupAt (j + 4) .

115+ lookupAt (j + 6) . go $ j + 8

116+

117+charClass :: String -> FastSet

118+charClass = fromList . go

119+ where go (a:'-':b:xs) = [a..b] ++ go xs

120+ go (x:xs) = x : go xs

121+ go _ = ""

benchmarks/Warp.hsnew file+17

@@ -0,0 +1,17 @@

1+{-# LANGUAGE OverloadedStrings #-}

3+module Warp (benchmarks) where

5+import Criterion.Main (bench, bgroup, nf)

6+import Criterion.Types (Benchmark)

7+import Data.ByteString (ByteString)

8+import Network.Wai.Handler.Warp.ReadInt (readInt)

9+import qualified Data.Attoparsec.ByteString.Char8 as B

10+

11+benchmarks :: Benchmark

12+benchmarks = bgroup "warp" [

13+ bgroup "decimal" [

14+ bench "warp" $ nf (readInt :: ByteString -> Int) "31337"

15+ , bench "atto" $ nf (B.parse (B.decimal :: B.Parser Int)) "31337"

16+ ]

17+ ]

benchmarks/attoparsec-benchmarks.cabal+13−3

@@ -11,21 +11,31 @@ executable attoparsec-benchmarks

1111 other-modules:

1212 Common

1313 HeadersByteString

14+ HeadersByteString.Atto

1415 HeadersText

1516 Links

1617 Numbers

17− hs-source-dirs: .. .

18− ghc-options: -O2 -Wall

18+ Network.Wai.Handler.Warp.ReadInt

19+ Sets

20+ TextFastSet

21+ Warp

22+ hs-source-dirs: .. . warp-3.0.1.1

23+ ghc-options: -O2 -Wall -rtsopts

1924 build-depends:

2025 array,

2126 base == 4.*,

2227 bytestring >= 0.10.4.0,

23− criterion >= 0.8.1.0,

28+ case-insensitive,

29+ containers,

30+ criterion >= 1.0,

2431 deepseq >= 1.1,

2532 directory,

2633 filepath,

34+ ghc-prim,

35+ http-types,

2736 parsec >= 3.1.2,

2837 scientific >= 0.3.1,

2938 text >= 1.1.1.0,

39+ transformers,

3040 unordered-containers,

3141 vector

benchmarks/http-request.txt+3−8

@@ -1,14 +1,9 @@

11GET / HTTP/1.1

22Host: twitter.com

3−Accept: text/html, application/xhtml+xml, application/xml; q=0.9,

4− image/webp, */*; q=0.8

3+Accept: text/html, application/xhtml+xml, application/xml; q=0.9, image/webp, */*; q=0.8

54Accept-Encoding: gzip,deflate,sdch

65Accept-Language: en-GB,en-US;q=0.8,en;q=0.6

76Cache-Control: max-age=0

8−Cookie: guest_id=v1%3A139; _twitter_sess=BAh7CSIKZmxhc2hJQz-e1e1;

9− __utma=43838368.452555194.1399611824.1; __utmb=43838368;

10− __utmc=43838368; __utmz=1399611824.1.1.utmcsr=(direct)|utmcmd=(none)

11−User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10_8_5)

12− AppleWebKit/537.36 (KHTML, like Gecko) Chrome/35.0.1916.86

13− Safari/537.36

7+Cookie: guest_id=v1%3A139; _twitter_sess=BAh7CSIKZmxhc2hJQz-e1e1; __utma=43838368.452555194.1399611824.1; __utmb=43838368; __utmc=43838368; __utmz=1399611824.1.1.utmcsr=(direct)|utmcmd=(none)

8+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10_8_5) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/35.0.1916.86 Safari/537.36

149

benchmarks/http-response.txt+2−4

@@ -3,10 +3,8 @@ Date: Fri, 09 May 2014 04:24:57 GMT

33Expires: -1

44Cache-Control: private, max-age=0

55Content-Type: text/html; charset=ISO-8859-1

6−Set-Cookie: PREF=ID=1a871afc4240db5e:FF:LM=1399609497:S=e5MZ0itEekjVwNcU;

7− expires=Sun, 08-May-2016 04:24:57 GMT; path=/; domain=.google.com

8−Set-Cookie: NID=67=-WlfaDG6VSEPk7abAjrK98HBSoCD2ID6JKkUR95tEumzDmg7Fc8pSQ8;

9− expires=Sat, 08-Nov-2014 04:24:57 GMT; path=/; domain=.google.com; HttpOnly

6+Set-Cookie: PREF=ID=1a871afc4240db5e:FF:LM=1399609497:S=e5MZ0itEekjVwNcU; expires=Sun, 08-May-2016 04:24:57 GMT; path=/; domain=.google.com

7+Set-Cookie: NID=67=-WlfaDG6VSEPk7abAjrK98HBSoCD2ID6JKkUR95tEumzDmg7Fc8pSQ8; expires=Sat, 08-Nov-2014 04:24:57 GMT; path=/; domain=.google.com; HttpOnly

108P3P: CP="This is not a P3P policy! See http://www.google.com/support/accounts/bin/answer.py?hl=en&answer=151657 for more info."

119Server: gws

1210X-XSS-Protection: 1; mode=block

benchmarks/warp-3.0.1.1/LICENSEnew file+20

@@ -0,0 +1,20 @@

3+Permission is hereby granted, free of charge, to any person obtaining

4+a copy of this software and associated documentation files (the

5+"Software"), to deal in the Software without restriction, including

6+without limitation the rights to use, copy, modify, merge, publish,

7+distribute, sublicense, and/or sell copies of the Software, and to

8+permit persons to whom the Software is furnished to do so, subject to

9+the following conditions:

10+

11+The above copyright notice and this permission notice shall be

12+included in all copies or substantial portions of the Software.

13+

14+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,

15+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF

16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND

17+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE

18+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION

19+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION

20+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

benchmarks/warp-3.0.1.1/Network/Wai/Handler/Warp/ReadInt.hsnew file+67

@@ -0,0 +1,67 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE MagicHash #-}

3+{-# LANGUAGE BangPatterns #-}

5+-- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>

6+-- License : BSD3

8+module Network.Wai.Handler.Warp.ReadInt (

9+ readInt

10+ , readInt64

11+ ) where

12+

13+-- This function lives in its own file because the MagicHash pragma interacts

14+-- poorly with the CPP pragma.

15+

16+import Data.ByteString (ByteString)

17+import qualified Data.ByteString as S

18+import Data.Int (Int64)

19+import GHC.Prim

20+import GHC.Types

21+import GHC.Word

22+

23+{-# INLINE readInt #-}

24+readInt :: Integral a => ByteString -> a

25+readInt bs = fromIntegral $ readInt64 bs

26+

27+-- This function is used to parse the Content-Length field of HTTP headers and

28+-- is a performance hot spot. It should only be replaced with something

29+-- significantly and provably faster.

30+--

31+-- It needs to be able work correctly on 32 bit CPUs for file sizes > 2G so we

32+-- use Int64 here and then make a generic 'readInt' that allows conversion to

33+-- Int and Integer.

34+

35+{-# NOINLINE readInt64 #-}

36+readInt64 :: ByteString -> Int64

37+readInt64 bs = S.foldl' (\ !i !c -> i * 10 + fromIntegral (mhDigitToInt c)) 0

38+ $ S.takeWhile isDigit bs

39+

40+data Table = Table !Addr#

41+

42+{-# NOINLINE mhDigitToInt #-}

43+mhDigitToInt :: Word8 -> Int

44+mhDigitToInt (W8# i) = I# (word2Int# (indexWord8OffAddr# addr (word2Int# i)))

45+ where

46+ !(Table addr) = table

47+ table :: Table

48+ table = Table

49+ "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\

50+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\

51+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\

52+ \\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x00\x00\x00\x00\x00\x00\

53+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\

54+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\

55+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\

56+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\

57+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\

58+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\

59+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\

60+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\

61+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\

62+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\

63+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\

64+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#

65+

66+isDigit :: Word8 -> Bool

67+isDigit w = w >= 48 && w <= 57

benchmarks/warp-3.0.1.1/Network/Wai/Handler/Warp/RequestHeader.hsnew file+172

@@ -0,0 +1,172 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE BangPatterns #-}

5+module Network.Wai.Handler.Warp.RequestHeader (

6+ parseHeaderLines

7+ , parseByteRanges

8+ ) where

10+import Control.Exception (Exception, throwIO)

11+import Control.Monad (when)

12+import Data.Typeable (Typeable)

13+import qualified Data.ByteString as S

14+import qualified Data.ByteString.Char8 as B (unpack, readInteger)

15+import Data.ByteString.Internal (ByteString(..), memchr)

16+import qualified Data.CaseInsensitive as CI

17+import Data.Word (Word8)

18+import Foreign.ForeignPtr (withForeignPtr)

19+import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)

20+import Foreign.Storable (peek)

21+import qualified Network.HTTP.Types as H

22+-- import Network.Wai.Handler.Warp.Types

23+import qualified Network.HTTP.Types.Header as HH

24+-- $setup

25+-- >>> :set -XOverloadedStrings

26+

27+data InvalidRequest = NotEnoughLines [String]

28+ | BadFirstLine String

29+ | NonHttp

30+ | IncompleteHeaders

31+ | ConnectionClosedByPeer

32+ | OverLargeHeader

33+ deriving (Eq, Typeable, Show)

34+

35+instance Exception InvalidRequest

36+

37+----------------------------------------------------------------

38+

39+parseHeaderLines :: [ByteString]

40+ -> IO (H.Method

41+ ,ByteString -- Path

42+ ,ByteString -- Path, parsed

43+ ,ByteString -- Query

44+ ,H.HttpVersion

45+ ,H.RequestHeaders

46+ )

47+parseHeaderLines [] = throwIO $ NotEnoughLines []

48+parseHeaderLines (firstLine:otherLines) = do

49+ (method, path', query, httpversion) <- parseRequestLine firstLine

50+ let path = H.extractPath path'

51+ hdr = map parseHeader otherLines

52+ return (method, path', path, query, httpversion, hdr)

53+

54+----------------------------------------------------------------

55+

56+-- |

57+--

58+-- >>> parseRequestLine "GET / HTTP/1.1"

59+-- ("GET","/","",HTTP/1.1)

60+-- >>> parseRequestLine "POST /cgi/search.cgi?key=foo HTTP/1.0"

61+-- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0)

62+-- >>> parseRequestLine "GET "

63+-- *** Exception: Warp: Invalid first line of request: "GET "

64+-- >>> parseRequestLine "GET /NotHTTP UNKNOWN/1.1"

65+-- *** Exception: Warp: Request line specified a non-HTTP request

66+parseRequestLine :: ByteString

67+ -> IO (H.Method

68+ ,ByteString -- Path

69+ ,ByteString -- Query

70+ ,H.HttpVersion)

71+parseRequestLine requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do

72+ when (len < 14) $ throwIO baderr

73+ let methodptr = ptr `plusPtr` off

74+ limptr = methodptr `plusPtr` len

75+ lim0 = fromIntegral len

76+

77+ pathptr0 <- memchr methodptr 32 lim0 -- ' '

78+ when (pathptr0 == nullPtr || (limptr `minusPtr` pathptr0) < 11) $

79+ throwIO baderr

80+ let pathptr = pathptr0 `plusPtr` 1

81+ lim1 = fromIntegral (limptr `minusPtr` pathptr0)

82+

83+ httpptr0 <- memchr pathptr 32 lim1 -- ' '

84+ when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $

85+ throwIO baderr

86+ let httpptr = httpptr0 `plusPtr` 1

87+ lim2 = fromIntegral (httpptr0 `minusPtr` pathptr)

88+

89+ checkHTTP httpptr

90+ !hv <- httpVersion httpptr

91+ queryptr <- memchr pathptr 63 lim2 -- '?'

92+

93+ let !method = bs ptr methodptr pathptr0

94+ !path

95+ | queryptr == nullPtr = bs ptr pathptr httpptr0

96+ | otherwise = bs ptr pathptr queryptr

97+ !query

98+ | queryptr == nullPtr = S.empty

99+ | otherwise = bs ptr queryptr httpptr0

100+

101+ return (method,path,query,hv)

102+ where

103+ baderr = BadFirstLine $ B.unpack requestLine

104+ check :: Ptr Word8 -> Int -> Word8 -> IO ()

105+ check p n w = do

106+ w0 <- peek $ p `plusPtr` n

107+ when (w0 /= w) $ throwIO NonHttp

108+ checkHTTP httpptr = do

109+ check httpptr 0 72 -- 'H'

110+ check httpptr 1 84 -- 'T'

111+ check httpptr 2 84 -- 'T'

112+ check httpptr 3 80 -- 'P'

113+ check httpptr 4 47 -- '/'

114+ check httpptr 6 46 -- '.'

115+ httpVersion httpptr = do

116+ major <- peek $ httpptr `plusPtr` 5

117+ minor <- peek $ httpptr `plusPtr` 7

118+ return $ if major == (49 :: Word8) && minor == (49 :: Word8) then

119+ H.http11

120+ else

121+ H.http10

122+ bs ptr p0 p1 = PS fptr o l

123+ where

124+ o = p0 `minusPtr` ptr

125+ l = p1 `minusPtr` p0

126+

127+----------------------------------------------------------------

128+

129+-- |

130+--

131+-- >>> parseHeader "Content-Length:47"

132+-- ("Content-Length","47")

133+-- >>> parseHeader "Accept-Ranges: bytes"

134+-- ("Accept-Ranges","bytes")

135+-- >>> parseHeader "Host: example.com:8080"

136+-- ("Host","example.com:8080")

137+-- >>> parseHeader "NoSemiColon"

138+-- ("NoSemiColon","")

139+

140+parseHeader :: ByteString -> H.Header

141+parseHeader s =

142+ let (k, rest) = S.break (== 58) s -- ':'

143+ rest' = S.dropWhile (\c -> c == 32 || c == 9) $ S.drop 1 rest

144+ in (CI.mk k, rest')

145+

146+parseByteRanges :: S.ByteString -> Maybe HH.ByteRanges

147+parseByteRanges bs1 = do

148+ bs2 <- stripPrefix "bytes=" bs1

149+ (r, bs3) <- range bs2

150+ ranges (r:) bs3

151+ where

152+ range bs2 =

153+ case stripPrefix "-" bs2 of

154+ Just bs3 -> do

155+ (i, bs4) <- B.readInteger bs3

156+ Just (HH.ByteRangeSuffix i, bs4)

157+ Nothing -> do

158+ (i, bs3) <- B.readInteger bs2

159+ bs4 <- stripPrefix "-" bs3

160+ case B.readInteger bs4 of

161+ Nothing -> Just (HH.ByteRangeFrom i, bs4)

162+ Just (j, bs5) -> Just (HH.ByteRangeFromTo i j, bs5)

163+ ranges front bs3 =

164+ case stripPrefix "," bs3 of

165+ Nothing -> Just (front [])

166+ Just bs4 -> do

167+ (r, bs5) <- range bs4

168+ ranges (front . (r:)) bs5

169+

170+ stripPrefix x y

171+ | x `S.isPrefixOf` y = Just (S.drop (S.length x) y)

172+ | otherwise = Nothing

changelog.md+71

@@ -1,3 +1,74 @@

1+0.13.2.1

3+* Improved performance of `Data.Attoparsec.Text.asciiCI`

5+0.13.2.0

7+* `pure` is now strict in `Position`

9+0.13.1.0

10+

11+* `runScanner` now correctly returns the final state

12+ (https://github.com/bos/attoparsec/issues/105).

13+* `Parser`, `ZeptoT`, `Buffer`, and `More` now expose `Semigroup` instances.

14+* `Parser`, and `ZeptoT` now expose `MonadFail` instances.

15+

16+0.13.0.2

17+

18+* Restore the fast specialised character set implementation for Text

19+* Move testsuite from test-framework to tasty

20+* Performance optimization of takeWhile and takeWhile1

21+

22+0.13.0.1

23+

24+* Fixed a bug in the implementations of inClass and notInClass for

25+ Text (https://github.com/bos/attoparsec/issues/103)

26+

27+0.13.0.0

28+

29+* Made the parser type in the Zepto module a monad transformer

30+ (needed by aeson's string unescaping parser).

31+

32+0.12.1.6

33+

34+* Fixed a case folding bug in the ByteString version of stringCI.

35+

36+0.12.1.5

37+

38+* Fixed an indexing bug in the new Text implementation of string,

39+ reported by Michel Boucey.

40+

41+0.12.1.4

42+

43+* Fixed a case where the string parser would consume an unnecessary

44+ amount of input before failing a match, when it could bail much

45+ earlier (https://github.com/bos/attoparsec/issues/97)

46+

47+* Added more context to error messages

48+ (https://github.com/bos/attoparsec/pull/79)

49+

50+0.12.1.3

51+

52+* Fixed incorrect tracking of Text lengths

53+ (https://github.com/bos/attoparsec/issues/80)

54+

55+0.12.1.2

56+

57+* Fixed the incorrect tracking of capacity if the initial buffer was

58+ empty (https://github.com/bos/attoparsec/issues/75)

59+

60+0.12.1.1

61+

62+* Fixed a data corruption bug that occurred under some circumstances

63+ if a buffer grew after prompting for more input

64+ (https://github.com/bos/attoparsec/issues/74)

65+

66+0.12.1.0

67+

68+* Now compatible with GHC 7.9

69+

70+* Reintroduced the Chunk class, used by the parsers package

71+

1720.12.0.0

273

374* A new internal representation makes almost all real-world parsers

examples/TestRFC2616.hs → examples/Atto_RFC2616.hsrenamed+16−8

@@ -1,21 +1,28 @@

11{-# LANGUAGE BangPatterns #-}

2−import RFC2616

3−import Control.Monad (forM_)

4−import System.IO

3+module Main (main) where

5+import Control.Applicative

56import Control.Exception (bracket)

7+import Control.Monad (forM_)

8+import Data.Attoparsec.ByteString

9+import RFC2616

610import System.Environment

11+import System.IO

712import qualified Data.ByteString.Char8 as B

8−import Data.Attoparsec

913

10−refill h = B.hGet h (4*1024)

14+refill :: Handle -> IO B.ByteString

15+refill h = B.hGet h (80*1024)

1116

17+listy :: FilePath -> Handle -> IO ()

1218listy file h = do

1319 r <- parseWith (refill h) (many request) =<< refill h

1420 case r of

1521 Fail _ _ msg -> hPutStrLn stderr $ file ++ ": " ++ msg

1622 Done _ reqs -> print (length reqs)

17−

18−incrementy file h = go 0 =<< refill h

23+

24+incrementy :: FilePath -> Handle -> IO ()

25+incrementy file h = go (0::Int) =<< refill h

1926 where

2027 go !n is = do

2128 r <- parseWith (refill h) request is

@@ -28,7 +35,8 @@ incrementy file h = go 0 =<< refill h

2835 then print (n+1)

2936 else go (n+1) s

3037 | otherwise -> go (n+1) bs

31−

38+

39+main :: IO ()

3240main = do

3341 args <- getArgs

3442 forM_ args $ \arg ->

examples/Makefile+6−2

@@ -1,4 +1,4 @@

1−CC := gcc

1+CC := cc

22CFLAGS := -O3 -Wall

33# To make the code about 6% faster:

44# CFLAGS += -fwhole-program --combine

@@ -12,4 +12,8 @@ c-http: rfc2616.c http_parser.c

1212clean:

1313 rm -f *.hi *.o c-http

1414

15−vpath %.c $(HOME)/hg/http-parser

15+http_parser.c: http_parser.h

16+ curl -O https://raw.githubusercontent.com/joyent/http-parser/master/http_parser.c

17+

18+http_parser.h:

19+ curl -O https://raw.githubusercontent.com/joyent/http-parser/master/http_parser.h

examples/Parsec_RFC2616.hs+9−6

@@ -23,15 +23,16 @@ token :: Stream s m Char => ParsecT s u m Char

2323token = satisfy $ \c -> S.notMember (fromEnum c) set

2424 where set = S.fromList . map fromEnum $ ['\0'..'\31'] ++ "()<>@,;:\\\"/[]?={} \t" ++ ['\128'..'\255']

2525

26+isHorizontalSpace :: Char -> Bool

2627isHorizontalSpace c = c == ' ' || c == '\t'

2728

2829skipHSpaces :: Stream s m Char => ParsecT s u m ()

2930skipHSpaces = skipMany1 (satisfy isHorizontalSpace)

3031

3132data Request = Request {

32− requestMethod :: String

33− , requestUri :: String

34− , requestProtocol :: String

33+ _requestMethod :: String

34+ , _requestUri :: String

35+ , _requestProtocol :: String

3536 } deriving (Eq, Ord, Show)

3637

3738requestLine :: Stream s m Char => ParsecT s u m Request

@@ -47,8 +48,8 @@ endOfLine :: Stream s m Char => ParsecT s u m ()

4748endOfLine = (string "\r\n" *> pure ()) <|> (char '\n' *> pure ())

4849

4950data Header = Header {

50− headerName :: String

51− , headerValue :: [String]

51+ _headerName :: String

52+ , _headerValue :: [String]

5253 } deriving (Eq, Ord, Show)

5354

5455messageHeader :: Stream s m Char => ParsecT s u m Header

@@ -61,14 +62,16 @@ messageHeader = do

6162request :: Stream s m Char => ParsecT s u m (Request, [Header])

6263request = (,) <$> requestLine <*> many messageHeader <* endOfLine

6364

65+listy :: FilePath -> IO ()

6466listy arg = do

6567 r <- parseFromFile (many request) arg

6668 case r of

6769 Left err -> putStrLn $ arg ++ ": " ++ show err

6870 Right rs -> print (length rs)

6971

72+chunky :: FilePath -> IO ()

7073chunky arg = bracket (openFile arg ReadMode) hClose $ \h ->

71− loop 0 =<< B.hGetContents h

74+ loop (0::Int) =<< B.hGetContents h

7275 where

7376 loop !n bs

7477 | B.null bs = print n

examples/RFC2616.hs+24−49

@@ -5,86 +5,61 @@ module RFC2616

55 Header(..)

66 , Request(..)

77 , Response(..)

8− , isToken

9− , messageHeader

108 , request

11− , requestLine

129 , response

13− , responseLine

14− , lowerHeader

15− , lookupHeader

1610 ) where

1711

1812import Control.Applicative

19−import Data.Attoparsec as P

20−import qualified Data.Attoparsec.Char8 as P8

21−import Data.Attoparsec.Char8 (char8, endOfLine, isDigit_w8)

13+import Data.Attoparsec.ByteString as P

14+import Data.Attoparsec.ByteString.Char8 (char8, endOfLine, isDigit_w8)

15+import Data.ByteString (ByteString)

2216import Data.Word (Word8)

23−import qualified Data.ByteString.Char8 as B hiding (map)

24−import qualified Data.ByteString as B (map)

17+import Data.Attoparsec.ByteString.Char8 (isEndOfLine, isHorizontalSpace)

2518

2619isToken :: Word8 -> Bool

2720isToken w = w <= 127 && notInClass "\0-\31()<>@,;:\\\"/[]?={} \t" w

2821

2922skipSpaces :: Parser ()

30−skipSpaces = satisfy P8.isHorizontalSpace *> skipWhile P8.isHorizontalSpace

23+skipSpaces = satisfy isHorizontalSpace *> skipWhile isHorizontalSpace

3124

3225data Request = Request {

33− requestMethod :: !B.ByteString

34− , requestUri :: !B.ByteString

35− , requestVersion :: !B.ByteString

26+ requestMethod :: ByteString

27+ , requestUri :: ByteString

28+ , requestVersion :: ByteString

3629 } deriving (Eq, Ord, Show)

3730

38−httpVersion :: Parser B.ByteString

31+httpVersion :: Parser ByteString

3932httpVersion = "HTTP/" *> P.takeWhile (\c -> isDigit_w8 c || c == 46)

4033

4134requestLine :: Parser Request

42−requestLine = do

43− method <- P.takeWhile1 isToken <* char8 ' '

44− uri <- P.takeWhile1 (/=32) <* char8 ' '

45− version <- httpVersion <* endOfLine

46− return $! Request method uri version

35+requestLine = Request <$> (takeWhile1 isToken <* char8 ' ')

36+ <*> (takeWhile1 (/=32) <* char8 ' ')

37+ <*> (httpVersion <* endOfLine)

4738

4839data Header = Header {

49− headerName :: !B.ByteString

50− , headerValue :: [B.ByteString]

40+ headerName :: ByteString

41+ , headerValue :: [ByteString]

5142 } deriving (Eq, Ord, Show)

5243

5344messageHeader :: Parser Header

54−messageHeader = do

55− header <- P.takeWhile isToken <* char8 ':' <* skipWhile P8.isHorizontalSpace

56− body <- takeTill P8.isEndOfLine <* endOfLine

57− bodies <- many $ skipSpaces *> takeTill P8.isEndOfLine <* endOfLine

58− return $! Header header (body:bodies)

45+messageHeader = Header

46+ <$> (P.takeWhile isToken <* char8 ':' <* skipWhile isHorizontalSpace)

47+ <*> ((:) <$> (takeTill isEndOfLine <* endOfLine)

48+ <*> (many $ skipSpaces *> takeTill isEndOfLine <* endOfLine))

5949

6050request :: Parser (Request, [Header])

6151request = (,) <$> requestLine <*> many messageHeader <* endOfLine

6252

6353data Response = Response {

64− responseVersion :: !B.ByteString

65− , responseCode :: !B.ByteString

66− , responseMsg :: !B.ByteString

54+ responseVersion :: ByteString

55+ , responseCode :: ByteString

56+ , responseMsg :: ByteString

6757 } deriving (Eq, Ord, Show)

6858

6959responseLine :: Parser Response

70−responseLine = do

71− version <- httpVersion <* char8 ' '

72− code <- P.takeWhile isDigit_w8 <* char8 ' '

73− msg <- P.takeTill P8.isEndOfLine <* endOfLine

74− return $! Response version code msg

60+responseLine = Response <$> (httpVersion <* char8 ' ')

61+ <*> (P.takeWhile isDigit_w8 <* char8 ' ')

62+ <*> (takeTill isEndOfLine <* endOfLine)

7563

7664response :: Parser (Response, [Header])

7765response = (,) <$> responseLine <*> many messageHeader <* endOfLine

78−

79−lowerHeader :: Header -> Header

80−lowerHeader (Header n v) = Header (B.map toLower n) (map (B.map toLower) v)

81− where toLower w | w >= 65 && w <= 90 = w + 32

82− | otherwise = w

83−

84−lookupHeader :: B.ByteString -> [Header] -> [B.ByteString]

85−lookupHeader k = go

86− where

87− go (Header n v:hs)

88− | k == n = v

89− | otherwise = go hs

90− go _ = []

examples/attoparsec-examples.cabalnew file+31

@@ -0,0 +1,31 @@

1+-- These examples are not intended to be installed.

2+-- So don't install 'em.

4+name: attoparsec-examples

5+version: 0

6+cabal-version: >=1.6

7+build-type: Simple

9+executable atto-rfc2616

10+ main-is: Atto_RFC2616.hs

11+ hs-source-dirs: .. .

12+ ghc-options: -O2 -Wall -rtsopts

13+ build-depends:

14+ array,

15+ base == 4.*,

16+ bytestring >= 0.10.4.0,

17+ deepseq >= 1.1,

18+ scientific >= 0.3.1,

19+ text >= 1.1.1.0

20+

21+executable parsec-rfc2616

22+ main-is: Parsec_RFC2616.hs

23+ hs-source-dirs: .

24+ ghc-options: -O2 -Wall -rtsopts

25+ build-depends:

26+ array,

27+ base == 4.*,

28+ containers,

29+ bytestring >= 0.10.4.0,

30+ parsec,

31+ text >= 1.1.1.0

examples/http-requests.txtnew file+494

@@ -0,0 +1,494 @@

1+GET / HTTP/1.1

2+Host: www.reddit.com

3+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

4+Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8

5+Accept-Language: en-us,en;q=0.5

6+Accept-Encoding: gzip, deflate

7+Connection: keep-alive

9+GET /reddit.v_EZwRzV-Ns.css HTTP/1.1

10+Host: www.redditstatic.com

11+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

12+Accept: text/css,*/*;q=0.1

13+Accept-Language: en-us,en;q=0.5

14+Accept-Encoding: gzip, deflate

15+Connection: keep-alive

16+Referer: http://www.reddit.com/

17+

18+GET /reddit-init.en-us.O1zuMqOOQvY.js HTTP/1.1

19+Host: www.redditstatic.com

20+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

21+Accept: */*

22+Accept-Language: en-us,en;q=0.5

23+Accept-Encoding: gzip, deflate

24+Connection: keep-alive

25+Referer: http://www.reddit.com/

26+

27+GET /reddit.en-us.31yAfSoTsfo.js HTTP/1.1

28+Host: www.redditstatic.com

29+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

30+Accept: */*

31+Accept-Language: en-us,en;q=0.5

32+Accept-Encoding: gzip, deflate

33+Connection: keep-alive

34+Referer: http://www.reddit.com/

35+

36+GET /kill.png HTTP/1.1

37+Host: www.redditstatic.com

38+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

39+Accept: image/png,image/*;q=0.8,*/*;q=0.5

40+Accept-Language: en-us,en;q=0.5

41+Accept-Encoding: gzip, deflate

42+Connection: keep-alive

43+Referer: http://www.reddit.com/

44+

45+GET /icon.png HTTP/1.1

46+Host: www.redditstatic.com

47+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

48+Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8

49+Accept-Language: en-us,en;q=0.5

50+Accept-Encoding: gzip, deflate

51+Connection: keep-alive

52+

53+GET /favicon.ico HTTP/1.1

54+Host: www.redditstatic.com

55+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

56+Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8

57+Accept-Language: en-us,en;q=0.5

58+Accept-Encoding: gzip, deflate

59+Connection: keep-alive

60+

61+GET /AMZM4CWd6zstSC8y.jpg HTTP/1.1

62+Host: b.thumbs.redditmedia.com

63+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

64+Accept: image/png,image/*;q=0.8,*/*;q=0.5

65+Accept-Language: en-us,en;q=0.5

66+Accept-Encoding: gzip, deflate

67+Connection: keep-alive

68+Referer: http://www.reddit.com/

69+

70+GET /jz1d5Nm0w97-YyNm.jpg HTTP/1.1

71+Host: b.thumbs.redditmedia.com

72+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

73+Accept: image/png,image/*;q=0.8,*/*;q=0.5

74+Accept-Language: en-us,en;q=0.5

75+Accept-Encoding: gzip, deflate

76+Connection: keep-alive

77+Referer: http://www.reddit.com/

78+

79+GET /aWGO99I6yOcNUKXB.jpg HTTP/1.1

80+Host: a.thumbs.redditmedia.com

81+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

82+Accept: image/png,image/*;q=0.8,*/*;q=0.5

83+Accept-Language: en-us,en;q=0.5

84+Accept-Encoding: gzip, deflate

85+Connection: keep-alive

86+Referer: http://www.reddit.com/

87+

88+GET /rZ_rD5TjrJM0E9Aj.css HTTP/1.1

89+Host: e.thumbs.redditmedia.com

90+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

91+Accept: text/css,*/*;q=0.1

92+Accept-Language: en-us,en;q=0.5

93+Accept-Encoding: gzip, deflate

94+Connection: keep-alive

95+Referer: http://www.reddit.com/

96+

97+GET /tmsPwagFzyTvrGRx.jpg HTTP/1.1

98+Host: a.thumbs.redditmedia.com

99+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

100+Accept: image/png,image/*;q=0.8,*/*;q=0.5

101+Accept-Language: en-us,en;q=0.5

102+Accept-Encoding: gzip, deflate

103+Connection: keep-alive

104+Referer: http://www.reddit.com/

105+

106+GET /KYgUaLvXCK3TCEJx.jpg HTTP/1.1

107+Host: a.thumbs.redditmedia.com

108+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

109+Accept: image/png,image/*;q=0.8,*/*;q=0.5

110+Accept-Language: en-us,en;q=0.5

111+Accept-Encoding: gzip, deflate

112+Connection: keep-alive

113+Referer: http://www.reddit.com/

114+

115+GET /81pzxT5x2ozuEaxX.jpg HTTP/1.1

116+Host: e.thumbs.redditmedia.com

117+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

118+Accept: image/png,image/*;q=0.8,*/*;q=0.5

119+Accept-Language: en-us,en;q=0.5

120+Accept-Encoding: gzip, deflate

121+Connection: keep-alive

122+Referer: http://www.reddit.com/

123+

124+GET /MFqCUiUVPO5V8t6x.jpg HTTP/1.1

125+Host: a.thumbs.redditmedia.com

126+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

127+Accept: image/png,image/*;q=0.8,*/*;q=0.5

128+Accept-Language: en-us,en;q=0.5

129+Accept-Encoding: gzip, deflate

130+Connection: keep-alive

131+Referer: http://www.reddit.com/

132+

133+GET /TFpYTiAO5aEowokv.jpg HTTP/1.1

134+Host: e.thumbs.redditmedia.com

135+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

136+Accept: image/png,image/*;q=0.8,*/*;q=0.5

137+Accept-Language: en-us,en;q=0.5

138+Accept-Encoding: gzip, deflate

139+Connection: keep-alive

140+Referer: http://www.reddit.com/

141+

142+GET /eMWMpmm9APNeNqcF.jpg HTTP/1.1

143+Host: e.thumbs.redditmedia.com

144+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

145+Accept: image/png,image/*;q=0.8,*/*;q=0.5

146+Accept-Language: en-us,en;q=0.5

147+Accept-Encoding: gzip, deflate

148+Connection: keep-alive

149+Referer: http://www.reddit.com/

150+

151+GET /S-IpsJrOKuaK9GZ8.jpg HTTP/1.1

152+Host: c.thumbs.redditmedia.com

153+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

154+Accept: image/png,image/*;q=0.8,*/*;q=0.5

155+Accept-Language: en-us,en;q=0.5

156+Accept-Encoding: gzip, deflate

157+Connection: keep-alive

158+Referer: http://www.reddit.com/

159+

160+GET /3V6dj9PDsNnheDXn.jpg HTTP/1.1

161+Host: c.thumbs.redditmedia.com

162+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

163+Accept: image/png,image/*;q=0.8,*/*;q=0.5

164+Accept-Language: en-us,en;q=0.5

165+Accept-Encoding: gzip, deflate

166+Connection: keep-alive

167+Referer: http://www.reddit.com/

168+

169+GET /wQ3-VmNXhv8sg4SJ.jpg HTTP/1.1

170+Host: c.thumbs.redditmedia.com

171+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

172+Accept: image/png,image/*;q=0.8,*/*;q=0.5

173+Accept-Language: en-us,en;q=0.5

174+Accept-Encoding: gzip, deflate

175+Connection: keep-alive

176+Referer: http://www.reddit.com/

177+

178+GET /ixd1C1njpczEWC22.jpg HTTP/1.1

179+Host: c.thumbs.redditmedia.com

180+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

181+Accept: image/png,image/*;q=0.8,*/*;q=0.5

182+Accept-Language: en-us,en;q=0.5

183+Accept-Encoding: gzip, deflate

184+Connection: keep-alive

185+Referer: http://www.reddit.com/

186+

187+GET /nGsQj15VyOHMwmq8.jpg HTTP/1.1

188+Host: c.thumbs.redditmedia.com

189+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

190+Accept: image/png,image/*;q=0.8,*/*;q=0.5

191+Accept-Language: en-us,en;q=0.5

192+Accept-Encoding: gzip, deflate

193+Connection: keep-alive

194+Referer: http://www.reddit.com/

195+

196+GET /zT4yQmDxQLbIxK1b.jpg HTTP/1.1

197+Host: c.thumbs.redditmedia.com

198+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

199+Accept: image/png,image/*;q=0.8,*/*;q=0.5

200+Accept-Language: en-us,en;q=0.5

201+Accept-Encoding: gzip, deflate

202+Connection: keep-alive

203+Referer: http://www.reddit.com/

204+

205+GET /L5e1HcZLv1iu4nrG.jpg HTTP/1.1

206+Host: f.thumbs.redditmedia.com

207+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

208+Accept: image/png,image/*;q=0.8,*/*;q=0.5

209+Accept-Language: en-us,en;q=0.5

210+Accept-Encoding: gzip, deflate

211+Connection: keep-alive

212+Referer: http://www.reddit.com/

213+

214+GET /WJFFPxD8X4JO_lIG.jpg HTTP/1.1

215+Host: f.thumbs.redditmedia.com

216+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

217+Accept: image/png,image/*;q=0.8,*/*;q=0.5

218+Accept-Language: en-us,en;q=0.5

219+Accept-Encoding: gzip, deflate

220+Connection: keep-alive

221+Referer: http://www.reddit.com/

222+

223+GET /hVMVTDdjuY3bQox5.jpg HTTP/1.1

224+Host: f.thumbs.redditmedia.com

225+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

226+Accept: image/png,image/*;q=0.8,*/*;q=0.5

227+Accept-Language: en-us,en;q=0.5

228+Accept-Encoding: gzip, deflate

229+Connection: keep-alive

230+Referer: http://www.reddit.com/

231+

232+GET /rnWf8CjBcyPQs5y_.jpg HTTP/1.1

233+Host: f.thumbs.redditmedia.com

234+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

235+Accept: image/png,image/*;q=0.8,*/*;q=0.5

236+Accept-Language: en-us,en;q=0.5

237+Accept-Encoding: gzip, deflate

238+Connection: keep-alive

239+Referer: http://www.reddit.com/

240+

241+GET /gZJL1jNylKbGV4d-.jpg HTTP/1.1

242+Host: d.thumbs.redditmedia.com

243+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

244+Accept: image/png,image/*;q=0.8,*/*;q=0.5

245+Accept-Language: en-us,en;q=0.5

246+Accept-Encoding: gzip, deflate

247+Connection: keep-alive

248+Referer: http://www.reddit.com/

249+

250+GET /aNd2zNRLXiMnKUFh.jpg HTTP/1.1

251+Host: c.thumbs.redditmedia.com

252+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

253+Accept: image/png,image/*;q=0.8,*/*;q=0.5

254+Accept-Language: en-us,en;q=0.5

255+Accept-Encoding: gzip, deflate

256+Connection: keep-alive

257+Referer: http://www.reddit.com/

258+

259+GET /droparrowgray.gif HTTP/1.1

260+Host: www.redditstatic.com

261+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

262+Accept: image/png,image/*;q=0.8,*/*;q=0.5

263+Accept-Language: en-us,en;q=0.5

264+Accept-Encoding: gzip, deflate

265+Connection: keep-alive

266+Referer: http://www.redditstatic.com/reddit.v_EZwRzV-Ns.css

267+

268+GET /sprite-reddit.an0Lnf61Ap4.png HTTP/1.1

269+Host: www.redditstatic.com

270+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

271+Accept: image/png,image/*;q=0.8,*/*;q=0.5

272+Accept-Language: en-us,en;q=0.5

273+Accept-Encoding: gzip, deflate

274+Connection: keep-alive

275+Referer: http://www.redditstatic.com/reddit.v_EZwRzV-Ns.css

276+

277+GET /ga.js HTTP/1.1

278+Host: www.google-analytics.com

279+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

280+Accept: */*

281+Accept-Language: en-us,en;q=0.5

282+Accept-Encoding: gzip, deflate

283+Connection: keep-alive

284+Referer: http://www.reddit.com/

285+If-Modified-Since: Tue, 29 Oct 2013 19:33:51 GMT

286+

287+GET /reddit/ads.html?sr=-reddit.com&bust2 HTTP/1.1

288+Host: static.adzerk.net

289+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

290+Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8

291+Accept-Language: en-us,en;q=0.5

292+Accept-Encoding: gzip, deflate

293+Connection: keep-alive

294+Referer: http://www.reddit.com/

295+

296+GET /pixel/of_destiny.png?v=hOlmDALJCWWdjzfBV4ZxJPmrdCLWB%2Ftq7Z%2Ffp4Q%2FxXbVPPREuMJMVGzKraTuhhNWxCCwi6yFEZg%3D&r=783333388 HTTP/1.1

297+Host: pixel.redditmedia.com

298+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

299+Accept: image/png,image/*;q=0.8,*/*;q=0.5

300+Accept-Language: en-us,en;q=0.5

301+Accept-Encoding: gzip, deflate

302+Connection: keep-alive

303+Referer: http://www.reddit.com/

304+

305+GET /UNcO-h_QcS9PD-Gn.jpg HTTP/1.1

306+Host: c.thumbs.redditmedia.com

307+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

308+Accept: image/png,image/*;q=0.8,*/*;q=0.5

309+Accept-Language: en-us,en;q=0.5

310+Accept-Encoding: gzip, deflate

311+Connection: keep-alive

312+Referer: http://e.thumbs.redditmedia.com/rZ_rD5TjrJM0E9Aj.css

313+

314+GET /welcome-lines.png HTTP/1.1

315+Host: www.redditstatic.com

316+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

317+Accept: image/png,image/*;q=0.8,*/*;q=0.5

318+Accept-Language: en-us,en;q=0.5

319+Accept-Encoding: gzip, deflate

320+Connection: keep-alive

321+Referer: http://www.redditstatic.com/reddit.v_EZwRzV-Ns.css

322+

323+GET /welcome-upvote.png HTTP/1.1

324+Host: www.redditstatic.com

325+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

326+Accept: image/png,image/*;q=0.8,*/*;q=0.5

327+Accept-Language: en-us,en;q=0.5

328+Accept-Encoding: gzip, deflate

329+Connection: keep-alive

330+Referer: http://www.redditstatic.com/reddit.v_EZwRzV-Ns.css

331+

332+GET /__utm.gif?utmwv=5.5.1&utms=1&utmn=720496082&utmhn=www.reddit.com&utme=8(site*srpath*usertype*uitype)9(%20reddit.com*%20reddit.com-GET_listing*guest*web)11(3!2)&utmcs=UTF-8&utmsr=2560x1600&utmvp=1288x792&utmsc=24-bit&utmul=en-us&utmje=1&utmfl=13.0%20r0&utmdt=reddit%3A%20the%20front%20page%20of%20the%20internet&utmhid=2129416330&utmr=-&utmp=%2F&utmht=1400862512705&utmac=UA-12131688-1&utmcc=__utma%3D55650728.585571751.1400862513.1400862513.1400862513.1%3B%2B__utmz%3D55650728.1400862513.1.1.utmcsr%3D(direct)%7Cutmccn%3D(direct)%7Cutmcmd%3D(none)%3B&utmu=qR~ HTTP/1.1

333+Host: www.google-analytics.com

334+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

335+Accept: image/png,image/*;q=0.8,*/*;q=0.5

336+Accept-Language: en-us,en;q=0.5

337+Accept-Encoding: gzip, deflate

338+Connection: keep-alive

339+Referer: http://www.reddit.com/

340+

341+GET /ImnpOQhbXUPkwceN.png HTTP/1.1

342+Host: a.thumbs.redditmedia.com

343+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

344+Accept: image/png,image/*;q=0.8,*/*;q=0.5

345+Accept-Language: en-us,en;q=0.5

346+Accept-Encoding: gzip, deflate

347+Connection: keep-alive

348+Referer: http://www.reddit.com/

349+

350+GET /ajax/libs/jquery/1.7.1/jquery.min.js HTTP/1.1

351+Host: ajax.googleapis.com

352+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

353+Accept: */*

354+Accept-Language: en-us,en;q=0.5

355+Accept-Encoding: gzip, deflate

356+Connection: keep-alive

357+Referer: http://static.adzerk.net/reddit/ads.html?sr=-reddit.com&bust2

358+

359+GET /__utm.gif?utmwv=5.5.1&utms=2&utmn=1493472678&utmhn=www.reddit.com&utmt=event&utme=5(AdBlock*enabled*false)(0)8(site*srpath*usertype*uitype)9(%20reddit.com*%20reddit.com-GET_listing*guest*web)11(3!2)&utmcs=UTF-8&utmsr=2560x1600&utmvp=1288x792&utmsc=24-bit&utmul=en-us&utmje=1&utmfl=13.0%20r0&utmdt=reddit%3A%20the%20front%20page%20of%20the%20internet&utmhid=2129416330&utmr=-&utmp=%2F&utmht=1400862512708&utmac=UA-12131688-1&utmni=1&utmcc=__utma%3D55650728.585571751.1400862513.1400862513.1400862513.1%3B%2B__utmz%3D55650728.1400862513.1.1.utmcsr%3D(direct)%7Cutmccn%3D(direct)%7Cutmcmd%3D(none)%3B&utmu=6R~ HTTP/1.1

360+Host: www.google-analytics.com

361+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

362+Accept: image/png,image/*;q=0.8,*/*;q=0.5

363+Accept-Language: en-us,en;q=0.5

364+Accept-Encoding: gzip, deflate

365+Connection: keep-alive

366+Referer: http://www.reddit.com/

367+

368+GET /ados.js?q=43 HTTP/1.1

369+Host: secure.adzerk.net

370+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

371+Accept: */*

372+Accept-Language: en-us,en;q=0.5

373+Accept-Encoding: gzip, deflate

374+Connection: keep-alive

375+Referer: http://static.adzerk.net/reddit/ads.html?sr=-reddit.com&bust2

376+

377+GET /fetch-trackers?callback=jQuery111005268222517967478_1400862512407&ids%5B%5D=t3_25jzeq-t8_k2ii&_=1400862512408 HTTP/1.1

378+Host: tracker.redditmedia.com

379+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

380+Accept: */*

381+Accept-Language: en-us,en;q=0.5

382+Accept-Encoding: gzip, deflate

383+Connection: keep-alive

384+Referer: http://www.reddit.com/

385+

386+GET /ados?t=1400862512892&request={%22Placements%22:[{%22A%22:5146,%22S%22:24950,%22D%22:%22main%22,%22AT%22:5},{%22A%22:5146,%22S%22:24950,%22D%22:%22sponsorship%22,%22AT%22:8}],%22Keywords%22:%22-reddit.com%22,%22Referrer%22:%22http%3A%2F%2Fwww.reddit.com%2F%22,%22IsAsync%22:true,%22WriteResults%22:true} HTTP/1.1

387+Host: engine.adzerk.net

388+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

389+Accept: */*

390+Accept-Language: en-us,en;q=0.5

391+Accept-Encoding: gzip, deflate

392+Connection: keep-alive

393+Referer: http://static.adzerk.net/reddit/ads.html?sr=-reddit.com&bust2

394+

395+GET /pixel/of_doom.png?id=t3_25jzeq-t8_k2ii&hash=da31d967485cdbd459ce1e9a5dde279fef7fc381&r=1738649500 HTTP/1.1

396+Host: pixel.redditmedia.com

397+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

398+Accept: image/png,image/*;q=0.8,*/*;q=0.5

399+Accept-Language: en-us,en;q=0.5

400+Accept-Encoding: gzip, deflate

401+Connection: keep-alive

402+Referer: http://www.reddit.com/

403+

404+GET /Extensions/adFeedback.js HTTP/1.1

405+Host: static.adzrk.net

406+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

407+Accept: */*

408+Accept-Language: en-us,en;q=0.5

409+Accept-Encoding: gzip, deflate

410+Connection: keep-alive

411+Referer: http://static.adzerk.net/reddit/ads.html?sr=-reddit.com&bust2

412+

413+GET /Extensions/adFeedback.css HTTP/1.1

414+Host: static.adzrk.net

415+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

416+Accept: text/css,*/*;q=0.1

417+Accept-Language: en-us,en;q=0.5

418+Accept-Encoding: gzip, deflate

419+Connection: keep-alive

420+Referer: http://static.adzerk.net/reddit/ads.html?sr=-reddit.com&bust2

421+

422+GET /reddit/ads-load.html?bust2 HTTP/1.1

423+Host: static.adzerk.net

424+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

425+Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8

426+Accept-Language: en-us,en;q=0.5

427+Accept-Encoding: gzip, deflate

428+Connection: keep-alive

429+Referer: http://www.reddit.com/

430+

431+GET /Advertisers/a774d7d6148046efa89403a8db635a81.jpg HTTP/1.1

432+Host: static.adzerk.net

433+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

434+Accept: image/png,image/*;q=0.8,*/*;q=0.5

435+Accept-Language: en-us,en;q=0.5

436+Accept-Encoding: gzip, deflate

437+Connection: keep-alive

438+Referer: http://static.adzerk.net/reddit/ads.html?sr=-reddit.com&bust2

439+

440+GET /i.gif?e=eyJhdiI6NjIzNTcsImF0Ijo1LCJjbSI6MTE2MzUxLCJjaCI6Nzk4NCwiY3IiOjMzNzAxNSwiZGkiOiI4NmI2Y2UzYWM5NDM0MjhkOTk2ZTg4MjYwZDE5ZTE1YyIsImRtIjoxLCJmYyI6NDE2MTI4LCJmbCI6MjEwNDY0LCJrdyI6Ii1yZWRkaXQuY29tIiwibWsiOiItcmVkZGl0LmNvbSIsIm53Ijo1MTQ2LCJwYyI6MCwicHIiOjIwMzYyLCJydCI6MSwicmYiOiJodHRwOi8vd3d3LnJlZGRpdC5jb20vIiwic3QiOjI0OTUwLCJ1ayI6InVlMS01ZWIwOGFlZWQ5YTc0MDFjOTE5NWNiOTMzZWI3Yzk2NiIsInRzIjoxNDAwODYyNTkzNjQ1fQ&s=lwlbFf2Uywt7zVBFRj_qXXu7msY HTTP/1.1

441+Host: engine.adzerk.net

442+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

443+Accept: image/png,image/*;q=0.8,*/*;q=0.5

444+Accept-Language: en-us,en;q=0.5

445+Accept-Encoding: gzip, deflate

446+Connection: keep-alive

447+Referer: http://static.adzerk.net/reddit/ads.html?sr=-reddit.com&bust2

448+Cookie: azk=ue1-5eb08aeed9a7401c9195cb933eb7c966

449+

450+GET /BurstingPipe/adServer.bs?cn=tf&c=19&mc=imp&pli=9994987&PluID=0&ord=1400862593644&rtu=-1 HTTP/1.1

451+Host: bs.serving-sys.com

452+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

453+Accept: image/png,image/*;q=0.8,*/*;q=0.5

454+Accept-Language: en-us,en;q=0.5

455+Accept-Encoding: gzip, deflate

456+Connection: keep-alive

457+Referer: http://static.adzerk.net/reddit/ads.html?sr=-reddit.com&bust2

458+

459+GET /Advertisers/63cfd0044ffd49c0a71a6626f7a1d8f0.jpg HTTP/1.1

460+Host: static.adzerk.net

461+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

462+Accept: image/png,image/*;q=0.8,*/*;q=0.5

463+Accept-Language: en-us,en;q=0.5

464+Accept-Encoding: gzip, deflate

465+Connection: keep-alive

466+Referer: http://static.adzerk.net/reddit/ads-load.html?bust2

467+

468+GET /BurstingPipe/adServer.bs?cn=tf&c=19&mc=imp&pli=9962555&PluID=0&ord=1400862593645&rtu=-1 HTTP/1.1

469+Host: bs.serving-sys.com

470+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

471+Accept: image/png,image/*;q=0.8,*/*;q=0.5

472+Accept-Language: en-us,en;q=0.5

473+Accept-Encoding: gzip, deflate

474+Connection: keep-alive

475+Referer: http://static.adzerk.net/reddit/ads-load.html?bust2

476+Cookie: S_9994987=6754579095859875029; A4=01fmFvgRnI09SF00000; u2=d1263d39-874b-4a89-86cd-a2ab0860ed4e3Zl040

477+

478+GET /i.gif?e=eyJhdiI6NjIzNTcsImF0Ijo4LCJjbSI6MTE2MzUxLCJjaCI6Nzk4NCwiY3IiOjMzNzAxOCwiZGkiOiI3OTdlZjU3OWQ5NjE0ODdiODYyMGMyMGJkOTE4YzNiMSIsImRtIjoxLCJmYyI6NDE2MTMxLCJmbCI6MjEwNDY0LCJrdyI6Ii1yZWRkaXQuY29tIiwibWsiOiItcmVkZGl0LmNvbSIsIm53Ijo1MTQ2LCJwYyI6MCwicHIiOjIwMzYyLCJydCI6MSwicmYiOiJodHRwOi8vd3d3LnJlZGRpdC5jb20vIiwic3QiOjI0OTUwLCJ1ayI6InVlMS01ZWIwOGFlZWQ5YTc0MDFjOTE5NWNiOTMzZWI3Yzk2NiIsInRzIjoxNDAwODYyNTkzNjQ2fQ&s=OjzxzXAgQksbdQOHNm-bjZcnZPA HTTP/1.1

479+Host: engine.adzerk.net

480+User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1

481+Accept: image/png,image/*;q=0.8,*/*;q=0.5

482+Accept-Language: en-us,en;q=0.5

483+Accept-Encoding: gzip, deflate

484+Connection: keep-alive

485+Referer: http://static.adzerk.net/reddit/ads-load.html?bust2

486+Cookie: azk=ue1-5eb08aeed9a7401c9195cb933eb7c966

487+

488+GET /subscribe?host_int=1042356184&ns_map=571794054_374233948806,464381511_13349283399&user_id=245722467&nid=1399334269710011966&ts=1400862514 HTTP/1.1

489+Host: notify8.dropbox.com

490+Accept-Encoding: identity

491+Connection: keep-alive

492+X-Dropbox-Locale: en_US

493+User-Agent: DropboxDesktopClient/2.7.54 (Macintosh; 10.8; ('i32',); en_US)

494+

examples/rfc2616.c+27−21

@@ -1,21 +1,22 @@

11/*

2− * This is a simple driver for Ryan Dahl's hand-bummed C http-parser

3− * package. It is intended to read one HTTP request after another

4− * from a file, nothing more.

2+ * This is a simple driver for the http-parser package. It is

3+ * intended to read one HTTP request after another from a file,

4+ * nothing more.

55 *

66 * For "feature parity" with the Haskell code in RFC2616.hs, we

77 * allocate and populate a simple structure describing each request,

88 * since that's the sort of thing that many real applications would

99 * themselves do and the library doesn't do this for us.

1010 *

11− * For the http-parser source, see http://github.com/ry/http-parser/

11+ * For the http-parser source, see

12+ * https://github.com/joyent/http-parser/blob/master/http_parser.c

1213 */

1314

1415/*

1516 * Turn off this preprocessor symbol to have the callbacks do nothing

1617 * at all, which "improves performance" by about 50%.

1718 */

18−#define LOOK_BUSY

19+/*#define LOOK_BUSY*/

1920

2021#include <assert.h>

2122#include <fcntl.h>

@@ -27,18 +28,18 @@

2728#include <unistd.h>

2829

2930#include "http_parser.h"

30−

31+

3132struct http_string {

3233 size_t len;

3334 char value[0];

3435};

35−

36+

3637struct http_header {

3738 struct http_string *name;

3839 struct http_string *value;

3940 struct http_header *next;

4041};

41−

42+

4243struct http_request {

4344 struct http_string *method;

4445 struct http_string *uri;

@@ -49,7 +50,7 @@ struct data {

4950 size_t count;

5051 struct http_request req;

5152};

52−

53+

5354static void *xmalloc(size_t size)

5455{

5556 void *ptr;

@@ -78,7 +79,7 @@ static void xstrcat(struct http_string **dst, const char *src, size_t len)

7879 *dst = xstrdup(src, len, 0);

7980 return;

8081 }

81−

82+

8283 p = xstrdup((*dst)->value, (*dst)->len, len);

8384 memcpy(p->value + (*dst)->len, src, len);

8485 p->len += len;

@@ -98,7 +99,7 @@ static int begin(http_parser *p)

9899static int url(http_parser *p, const char *at, size_t len)

99100{

100101#ifdef LOOK_BUSY

101− struct data *data = p->data;

102+ struct data *data = p->data;

102103

103104 xstrcat(&data->req.uri, at, len);

104105#endif

@@ -119,7 +120,7 @@ static int header_field(http_parser *p, const char *at, size_t len)

119120 hdr->name = xstrdup(at, len, 0);

120121 hdr->value = NULL;

121122 hdr->next = NULL;

122−

123+

123124 if (data->req.last != NULL)

124125 data->req.last->next = hdr;

125126 data->req.last = hdr;

@@ -150,7 +151,7 @@ static int complete(http_parser *p)

150151

151152 free(data->req.method);

152153 free(data->req.uri);

153−

154+

154155 for (hdr = data->req.headers; hdr != NULL; hdr = next) {

155156 next = hdr->next;

156157 free(hdr->name);

@@ -164,7 +165,7 @@ static int complete(http_parser *p)

164165 data->req.headers = NULL;

165166 data->req.last = NULL;

166167#endif

167−

168+

168169 /* Bludgeon http_parser into understanding that we really want to

169170 * keep parsing after a request that in principle ought to close

170171 * the "connection". */

@@ -180,16 +181,21 @@ static int complete(http_parser *p)

180181static void parse(const char *path, int fd)

181182{

182183 struct data data;

184+ http_parser_settings s;

183185 http_parser p;

184186 ssize_t nread;

185187

186− http_parser_init(&p, HTTP_REQUEST);

187− p.on_message_begin = begin;

188− p.on_url = url;

189− p.on_header_field = header_field;

190− p.on_header_value = header_value;

191− p.on_message_complete = complete;

188+ memset(&s, 0, sizeof(s));

189+ s.on_message_begin = begin;

190+ s.on_url = url;

191+ s.on_header_field = header_field;

192+ s.on_header_value = header_value;

193+ s.on_message_complete = complete;

194+

192195 p.data = &data;

196+

197+ http_parser_init(&p, HTTP_REQUEST);

198+

193199 data.count = 0;

194200 data.req.method = NULL;

195201 data.req.uri = NULL;

@@ -202,7 +208,7 @@ static void parse(const char *path, int fd)

202208

203209 nread = read(fd, buf, sizeof(buf));

204210

205− np = http_parser_execute(&p, buf, nread);

211+ np = http_parser_execute(&p, &s, buf, nread);

206212 if (np != nread) {

207213 fprintf(stderr, "%s: parse failed\n", path);

208214 break;

tests/Makefiledeleted−14

@@ -1,14 +0,0 @@

1−all: TestFastSet.out qc.out

2−

3−%.out: %.exe

4− ./$< | tee $<.tmp

5− mv $<.tmp $@

6−

7−qc.exe: QC.hs

8− ghc -O -fno-warn-orphans --make -o $@ $<

9−

10−%.exe: %.hs

11− ghc -O -fno-warn-orphans --make -o $@ $<

12−

13−clean:

14− -rm -f *.hi *.o *.exe *.out

tests/QC.hs+6−2

@@ -1,15 +1,19 @@

11{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

22module Main (main) where

4+import qualified QC.Buffer as Buffer

45import qualified QC.ByteString as ByteString

56import qualified QC.Combinator as Combinator

7+import qualified QC.Simple as Simple

68import qualified QC.Text as Text

7−import Test.Framework (defaultMain, testGroup)

9+import Test.Tasty (defaultMain, testGroup)

810

911main = defaultMain tests

1012

11−tests = [

13+tests = testGroup "tests" [

1214 testGroup "bs" ByteString.tests

15+ , testGroup "buf" Buffer.tests

1316 , testGroup "combinator" Combinator.tests

17+ , testGroup "simple" Simple.tests

1418 , testGroup "text" Text.tests

1519 ]

tests/QC/Buffer.hsnew file+96

@@ -0,0 +1,96 @@

1+{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, OverloadedStrings,

2+ TypeSynonymInstances #-}

4+module QC.Buffer (tests) where

6+#if !MIN_VERSION_base(4,8,0)

7+import Control.Applicative ((<$>))

8+import Data.Monoid (Monoid(mconcat))

9+#endif

10+import QC.Common ()

11+import Test.Tasty (TestTree)

12+import Test.Tasty.QuickCheck (testProperty)

13+import Test.QuickCheck

14+import qualified Data.Attoparsec.ByteString.Buffer as BB

15+import qualified Data.Attoparsec.Text.Buffer as BT

16+import qualified Data.ByteString as B

17+import qualified Data.ByteString.Unsafe as B

18+import qualified Data.Text as T

19+import qualified Data.Text.Unsafe as T

20+

21+data BP t b = BP [t] !t !b

22+ deriving (Eq, Show)

23+

24+type BPB = BP B.ByteString BB.Buffer

25+type BPT = BP T.Text BT.Buffer

26+

27+instance Arbitrary BPB where

28+ arbitrary = do

29+ bss <- arbitrary

30+ return $! toBP BB.buffer bss

31+

32+ shrink (BP bss _ _) = toBP BB.buffer <$> shrink bss

33+

34+instance Arbitrary BPT where

35+ arbitrary = do

36+ bss <- arbitrary

37+ return $! toBP BT.buffer bss

38+

39+ shrink (BP bss _ _) = toBP BT.buffer <$> shrink bss

40+

41+toBP :: (Monoid a, Monoid b) => (a -> b) -> [a] -> BP a b

42+toBP buf bss = BP bss (mconcat bss) (mconcat (map buf bss))

43+

44+b_unbuffer :: BPB -> Property

45+b_unbuffer (BP _ts t buf) = t === BB.unbuffer buf

46+

47+t_unbuffer :: BPT -> Property

48+t_unbuffer (BP _ts t buf) = t === BT.unbuffer buf

49+

50+b_length :: BPB -> Property

51+b_length (BP _ts t buf) = B.length t === BB.length buf

52+

53+t_length :: BPT -> Property

54+t_length (BP _ts t buf) = T.lengthWord16 t === BT.length buf

55+

56+b_unsafeIndex :: BPB -> Gen Property

57+b_unsafeIndex (BP _ts t buf) = do

58+ let l = B.length t

59+ i <- choose (0,l-1)

60+ return $ l === 0 .||. B.unsafeIndex t i === BB.unsafeIndex buf i

61+

62+t_iter :: BPT -> Gen Property

63+t_iter (BP _ts t buf) = do

64+ let l = T.lengthWord16 t

65+ i <- choose (0,l-1)

66+ let it (T.Iter c q) = (c,q)

67+ return $ l === 0 .||. it (T.iter t i) === it (BT.iter buf i)

68+

69+t_iter_ :: BPT -> Gen Property

70+t_iter_ (BP _ts t buf) = do

71+ let l = T.lengthWord16 t

72+ i <- choose (0,l-1)

73+ return $ l === 0 .||. T.iter_ t i === BT.iter_ buf i

74+

75+b_unsafeDrop :: BPB -> Gen Property

76+b_unsafeDrop (BP _ts t buf) = do

77+ i <- choose (0, B.length t)

78+ return $ B.unsafeDrop i t === BB.unsafeDrop i buf

79+

80+t_dropWord16 :: BPT -> Gen Property

81+t_dropWord16 (BP _ts t buf) = do

82+ i <- choose (0, T.lengthWord16 t)

83+ return $ T.dropWord16 i t === BT.dropWord16 i buf

84+

85+tests :: [TestTree]

86+tests = [

87+ testProperty "b_unbuffer" b_unbuffer

88+ , testProperty "t_unbuffer" t_unbuffer

89+ , testProperty "b_length" b_length

90+ , testProperty "t_length" t_length

91+ , testProperty "b_unsafeIndex" b_unsafeIndex

92+ , testProperty "t_iter" t_iter

93+ , testProperty "t_iter_" t_iter_

94+ , testProperty "b_unsafeDrop" b_unsafeDrop

95+ , testProperty "t_dropWord16" t_dropWord16

96+ ]

tests/QC/ByteString.hs+39−9

@@ -1,19 +1,23 @@

1−{-# LANGUAGE BangPatterns, OverloadedStrings #-}

1+{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-}

22module QC.ByteString (tests) where

4−import Control.Applicative ((<$>), (<*>))

5−import Data.Char (chr, ord)

4+#if !MIN_VERSION_base(4,8,0)

5+import Control.Applicative ((<*>), (<$>))

6+#endif

7+import Data.Char (chr, ord, toUpper)

68import Data.Int (Int64)

79import Data.Word (Word8)

810import Prelude hiding (take, takeWhile)

9−import QC.Common (liftOp, parseBS, toStrictBS)

10−import Test.Framework (Test)

11−import Test.Framework.Providers.QuickCheck2 (testProperty)

11+import QC.Common (ASCII(..), liftOp, parseBS, toStrictBS)

12+import Test.Tasty (TestTree)

13+import Test.Tasty.QuickCheck (testProperty)

1214import Test.QuickCheck

1315import qualified Data.Attoparsec.ByteString as P

1416import qualified Data.Attoparsec.ByteString.Char8 as P8

17+import qualified Data.Attoparsec.ByteString.FastSet as S

1518import qualified Data.Attoparsec.ByteString.Lazy as PL

1619import qualified Data.ByteString as B

20+import qualified Data.ByteString.Char8 as B8

1721import qualified Data.ByteString.Lazy as L

1822import qualified Data.ByteString.Lazy.Char8 as L8

1923

@@ -22,9 +26,11 @@ import qualified Data.ByteString.Lazy.Char8 as L8

2226satisfy :: Word8 -> L.ByteString -> Property

2327satisfy w s = parseBS (P.satisfy (<=w)) (L.cons w s) === Just w

2428

25−satisfyWith :: Char -> L.ByteString -> Property

26−satisfyWith c s = parseBS (P.satisfyWith (chr . fromIntegral) (<=c))

29+satisfyWith :: Word8 -> L.ByteString -> Property

30+satisfyWith w s = parseBS (P.satisfyWith (chr . fromIntegral) (<=c))

2731 (L.cons (fromIntegral (ord c)) s) === Just c

32+ where

33+ c = chr (fromIntegral w)

2834

2935word8 :: Word8 -> L.ByteString -> Property

3036word8 w s = parseBS (P.word8 w) (L.cons w s) === Just w

@@ -62,6 +68,18 @@ string :: L.ByteString -> L.ByteString -> Property

6268string s t = parseBS (P.string s') (s `L.append` t) === Just s'

6369 where s' = toStrictBS s

6470

71+stringCI :: ASCII L.ByteString -> ASCII L.ByteString -> Property

72+stringCI (ASCII s) (ASCII t) =

73+ parseBS (P8.stringCI up) (s `L.append` t) === Just s'

74+ where s' = toStrictBS s

75+ up = B8.map toUpper s'

76+

77+strings :: L.ByteString -> L.ByteString -> L.ByteString -> Property

78+strings s t u =

79+ parseBS (P.string (toStrictBS s) >> P.string t') (L.concat [s,t,u])

80+ === Just t'

81+ where t' = toStrictBS t

82+

6583skipWhile :: Word8 -> L.ByteString -> Property

6684skipWhile w s =

6785 let t = L.dropWhile (<=w) s

@@ -131,7 +149,15 @@ scan s (Positive k) = parseBS p s === Just (toStrictBS $ L.take k s)

131149 where p = P.scan k $ \ n _ ->

132150 if n > 0 then let !n' = n - 1 in Just n' else Nothing

133151

134−tests :: [Test]

152+members :: [Word8] -> Property

153+members s = property $ all (`S.memberWord8` set) s

154+ where set = S.fromList s

155+

156+nonmembers :: [Word8] -> [Word8] -> Property

157+nonmembers s s' = property . not . any (`S.memberWord8` set) $ filter (not . (`elem` s)) s'

158+ where set = S.fromList s

159+

160+tests :: [TestTree]

135161tests = [

136162 testProperty "anyWord8" anyWord8

137163 , testProperty "endOfInput" endOfInput

@@ -145,6 +171,8 @@ tests = [

145171 , testProperty "skip" skip

146172 , testProperty "skipWhile" skipWhile

147173 , testProperty "string" string

174+ , testProperty "stringCI" stringCI

175+ , testProperty "strings" strings

148176 , testProperty "take" take

149177 , testProperty "takeByteString" takeByteString

150178 , testProperty "takeCount" takeCount

@@ -154,4 +182,6 @@ tests = [

154182 , testProperty "takeWhile1" takeWhile1

155183 , testProperty "takeWhile1_empty" takeWhile1_empty

156184 , testProperty "word8" word8

185+ , testProperty "members" members

186+ , testProperty "nonmembers" nonmembers

157187 ]

tests/QC/Combinator.hs+18−5

@@ -1,10 +1,15 @@

1+{-# LANGUAGE CPP, OverloadedStrings #-}

13module QC.Combinator where

3−import Control.Applicative

5+#if !MIN_VERSION_base(4,8,0)

6+import Control.Applicative ((<*>), (<$>), (<*), (*>))

7+#endif

8+import Data.Maybe (fromJust, isJust)

49import Data.Word (Word8)

5−import QC.Common (Repack, parseBS, repackBS)

6−import Test.Framework (Test)

7−import Test.Framework.Providers.QuickCheck2 (testProperty)

10+import QC.Common (Repack, parseBS, repackBS, toLazyBS)

11+import Test.Tasty (TestTree)

12+import Test.Tasty.QuickCheck (testProperty)

813import Test.QuickCheck

914import qualified Data.Attoparsec.ByteString.Char8 as P

1015import qualified Data.Attoparsec.Combinator as C

@@ -22,6 +27,13 @@ count (Positive (Small n)) rs s =

2227 (length <$> parseBS (C.count n (P.string s)) input) == Just n

2328 where input = repackBS rs (B.concat (replicate (n+1) s))

2429

30+lookAhead :: NonEmptyList Word8 -> Bool

31+lookAhead (NonEmpty xs) =

32+ let ys = B.pack xs

33+ withLookAheadThenConsume = (\x y -> (x, y)) <$> C.lookAhead (P.string ys) <*> P.string ys

34+ mr = parseBS withLookAheadThenConsume $ toLazyBS ys

35+ in isJust mr && fst (fromJust mr) == snd (fromJust mr)

36+

2537match :: Int -> NonNegative Int -> NonNegative Int -> Repack -> Bool

2638match n (NonNegative x) (NonNegative y) rs =

2739 parseBS (P.match parser) (repackBS rs input) == Just (input, n)

@@ -31,9 +43,10 @@ match n (NonNegative x) (NonNegative y) rs =

3143 B8.replicate x 'x', B8.pack (show n), B8.replicate y 'y'

3244 ]

3345

34−tests :: [Test]

46+tests :: [TestTree]

3547tests = [

3648 testProperty "choice" choice

3749 , testProperty "count" count

50+ , testProperty "lookAhead" lookAhead

3851 , testProperty "match" match

3952 ]

tests/QC/Common.hs+34−4

@@ -1,7 +1,9 @@

1+{-# LANGUAGE CPP, FlexibleInstances #-}

12{-# OPTIONS_GHC -fno-warn-orphans #-}

23module QC.Common

34 (

4− parseBS

5+ ASCII(..)

6+ , parseBS

57 , parseT

68 , toLazyBS

79 , toStrictBS

@@ -13,9 +15,12 @@ module QC.Common

1315 , liftOp

1416 ) where

1517

16−import Control.Applicative ((<$>), (<*>))

18+#if !MIN_VERSION_base(4,8,0)

19+import Control.Applicative ((<*>), (<$>))

20+#endif

1721import Data.Char (isAlpha)

1822import Test.QuickCheck

23+import Test.QuickCheck.Unicode (shrinkChar, string)

1924import qualified Data.ByteString as B

2025import qualified Data.ByteString.Lazy as BL

2126import qualified Data.Text as T

@@ -23,6 +28,16 @@ import qualified Data.Text.Lazy as TL

2328import qualified Data.Attoparsec.ByteString.Lazy as BL

2429import qualified Data.Attoparsec.Text.Lazy as TL

2530

31+#if !MIN_VERSION_base(4,4,0)

32+-- This should really be a dependency on the random package :-(

33+instance Random Word8 where

34+ randomR = integralRandomR

35+ random = randomR (minBound,maxBound)

36+

37+instance Arbitrary Word8 where

38+ arbitrary = choose (minBound, maxBound)

39+#endif

40+

2641parseBS :: BL.Parser r -> BL.ByteString -> Maybe r

2742parseBS p = BL.maybeResult . BL.parse p

2843

@@ -37,9 +52,22 @@ toLazyBS = BL.fromChunks . (:[])

3752

3853instance Arbitrary B.ByteString where

3954 arbitrary = B.pack <$> arbitrary

55+ shrink = map B.pack . shrink . B.unpack

4056

4157instance Arbitrary BL.ByteString where

4258 arbitrary = repackBS <$> arbitrary <*> arbitrary

59+ shrink = map BL.pack . shrink . BL.unpack

60+

61+newtype ASCII a = ASCII { fromASCII :: a }

62+ deriving (Eq, Ord, Show)

63+

64+instance Arbitrary (ASCII B.ByteString) where

65+ arbitrary = (ASCII . B.pack) <$> listOf (choose (0,127))

66+ shrink = map (ASCII . B.pack) . shrink . B.unpack . fromASCII

67+

68+instance Arbitrary (ASCII BL.ByteString) where

69+ arbitrary = ASCII <$> (repackBS <$> arbitrary <*> (fromASCII <$> arbitrary))

70+ shrink = map (ASCII . BL.pack) . shrink . BL.unpack . fromASCII

4371

4472type Repack = NonEmptyList (Positive (Small Int))

4573

@@ -56,10 +84,12 @@ repackBS_ = go . cycle

5684 go _ _ = error "unpossible"

5785

5886instance Arbitrary T.Text where

59− arbitrary = T.pack <$> arbitrary

87+ arbitrary = T.pack <$> string

88+ shrink = map T.pack . shrinkList shrinkChar . T.unpack

6089

6190instance Arbitrary TL.Text where

62− arbitrary = repackT <$> arbitrary <*> arbitrary

91+ arbitrary = TL.pack <$> string

92+ shrink = map TL.pack . shrinkList shrinkChar . TL.unpack

6393

6494repackT :: Repack -> T.Text -> TL.Text

6595repackT (NonEmpty bs) =

tests/QC/IPv6/Internal.hsnew file+316

@@ -0,0 +1,316 @@

1+-- -----------------------------------------------------------------------------

3+-- |

4+-- Module : Text.IPv6Addr

6+-- License : BSD-Style

7+-- Maintainer : michel.boucey@gmail.com

8+--

9+-- Dealing with IPv6 address text representations, canonization and manipulations.

10+--

11+

12+-- -----------------------------------------------------------------------------

13+

14+{-# LANGUAGE OverloadedStrings #-}

15+

16+module QC.IPv6.Internal where {-

17+ ( expandTokens

18+ , macAddr

19+ , maybeIPv6AddrTokens

20+ , ipv4AddrToIPv6AddrTokens

21+ , ipv6TokensToText

22+ , ipv6TokensToIPv6Addr

23+ , isIPv6Addr

24+ , maybeTokIPv6Addr

25+ , maybeTokPureIPv6Addr

26+ , fromDoubleColon

27+ , fromIPv6Addr

28+ , toDoubleColon

29+ ) where -}

30+

31+import Debug.Trace

32+import Control.Monad (replicateM)

33+import Data.Attoparsec.Text

34+import Data.Char (isDigit,isHexDigit,toLower)

35+import Data.Monoid ((<>))

36+import Control.Applicative ((<|>),(<*))

37+import Data.List (group,isSuffixOf,elemIndex,elemIndices,intersperse)

38+import Data.Word (Word32)

39+import Numeric (showHex)

40+import qualified Data.Text as T

41+import qualified Data.Text.Read as R (decimal)

42+import Data.Maybe (fromJust)

43+

44+import QC.IPv6.Types

45+

46+tok0 = "0"

47+

48+-- | Returns the 'T.Text' of an IPv6 address.

49+fromIPv6Addr :: IPv6Addr -> T.Text

50+fromIPv6Addr (IPv6Addr t) = t

51+

52+-- | Given an arbitrary list of 'IPv6AddrToken', returns the corresponding 'T.Text'.

53+ipv6TokensToText :: [IPv6AddrToken] -> T.Text

54+ipv6TokensToText l = T.concat $ map ipv6TokenToText l

55+

56+-- | Returns the corresponding 'T.Text' of an IPv6 address token.

57+ipv6TokenToText :: IPv6AddrToken -> T.Text

58+ipv6TokenToText (SixteenBit s) = s

59+ipv6TokenToText Colon = ":"

60+ipv6TokenToText DoubleColon = "::"

61+ipv6TokenToText AllZeros = tok0 -- "A single 16-bit 0000 field MUST be represented as 0" (RFC 5952, 4.1)

62+ipv6TokenToText (IPv4Addr a) = a

63+

64+-- | Returns 'True' if a list of 'IPv6AddrToken' constitutes a valid IPv6 Address.

65+isIPv6Addr :: [IPv6AddrToken] -> Bool

66+isIPv6Addr [] = False

67+isIPv6Addr [DoubleColon] = True

68+isIPv6Addr [DoubleColon,SixteenBit tok1] = True

69+isIPv6Addr tks =

70+ diffNext tks && (do

71+ let cdctks = countDoubleColon tks

72+ let lentks = length tks

73+ let lasttk = last tks

74+ let lenconst = (lentks == 15 && cdctks == 0) || (lentks < 15 && cdctks == 1)

75+ firstValidToken tks &&

76+ (case countIPv4Addr tks of

77+ 0 -> case lasttk of

78+ SixteenBit _ -> lenconst

79+ DoubleColon -> lenconst

80+ AllZeros -> lenconst

81+ _ -> False

82+ 1 -> case lasttk of

83+ IPv4Addr _ -> (lentks == 13 && cdctks == 0) || (lentks < 12 && cdctks == 1)

84+ _ -> False

85+ otherwise -> False))

86+ where diffNext [] = False

87+ diffNext [_] = True

88+ diffNext (t:ts) = do

89+ let h = head ts

90+ case t of

91+ SixteenBit _ -> case h of

92+ SixteenBit _ -> False

93+ AllZeros -> False

94+ _ -> diffNext ts

95+ AllZeros -> case h of

96+ SixteenBit _ -> False

97+ AllZeros -> False

98+ _ -> diffNext ts

99+ _ -> diffNext ts

100+ firstValidToken l =

101+ case head l of

102+ SixteenBit _ -> True

103+ DoubleColon -> True

104+ AllZeros -> True

105+ _ -> False

106+ countDoubleColon l = length $ elemIndices DoubleColon l

107+ tok1 = "1"

108+

109+countIPv4Addr = foldr oneMoreIPv4Addr 0

110+ where

111+ oneMoreIPv4Addr t c = case t of

112+ IPv4Addr _ -> c + 1

113+ otherwise -> c

114+

115+-- | This is the main function which returns 'Just' the list of a tokenized IPv6

116+-- address text representation validated against RFC 4291 and canonized

117+-- in conformation with RFC 5952, or 'Nothing'.

118+maybeTokIPv6Addr :: T.Text -> Maybe [IPv6AddrToken]

119+maybeTokIPv6Addr t =

120+ case maybeIPv6AddrTokens t of

121+ Just ltks -> if isIPv6Addr ltks

122+ then Just $ (ipv4AddrReplacement . toDoubleColon . fromDoubleColon) ltks

123+ else Nothing

124+ Nothing -> Nothing

125+ where

126+ ipv4AddrReplacement ltks =

127+ if ipv4AddrRewrite ltks

128+ then init ltks ++ ipv4AddrToIPv6AddrTokens (last ltks)

129+ else ltks

130+

131+-- | Returns 'Just' the list of tokenized pure IPv6 address, always rewriting an

132+-- embedded IPv4 address if present.

133+maybeTokPureIPv6Addr :: T.Text -> Maybe [IPv6AddrToken]

134+maybeTokPureIPv6Addr t = do

135+ ltks <- maybeIPv6AddrTokens t

136+ if isIPv6Addr ltks

137+ then Just $ (toDoubleColon . ipv4AddrReplacement . fromDoubleColon) ltks

138+ else Nothing

139+ where

140+ ipv4AddrReplacement ltks' = init ltks' ++ ipv4AddrToIPv6AddrTokens (last ltks')

141+

142+-- | Tokenize a 'T.Text' into 'Just' a list of 'IPv6AddrToken', or 'Nothing'.

143+maybeIPv6AddrTokens :: T.Text -> Maybe [IPv6AddrToken]

144+maybeIPv6AddrTokens s =

145+ case readText s of

146+ Done r l -> traceShow (r,l) $ if r==T.empty then Just l else Nothing

147+ Fail {} -> Nothing

148+ where

149+ readText s = feed (parse (many1 $ ipv4Addr <|> sixteenBit <|> doubleColon <|> colon) s) T.empty

150+

151+-- | An embedded IPv4 address have to be rewritten to output a pure IPv6 Address

152+-- text representation in hexadecimal digits. But some well-known prefixed IPv6

153+-- addresses have to keep visible in their text representation the fact that

154+-- they deals with IPv4 to IPv6 transition process (RFC 5952 Section 5):

155+--

156+-- IPv4-compatible IPv6 address like "::1.2.3.4"

157+--

158+-- IPv4-mapped IPv6 address like "::ffff:1.2.3.4"

159+--

160+-- IPv4-translated address like "::ffff:0:1.2.3.4"

161+--

162+-- IPv4-translatable address like "64:ff9b::1.2.3.4"

163+--

164+-- ISATAP address like "fe80::5efe:1.2.3.4"

165+--

166+ipv4AddrRewrite :: [IPv6AddrToken] -> Bool

167+ipv4AddrRewrite tks =

168+ case last tks of

169+ IPv4Addr _ -> do

170+ let itks = init tks

171+ not (itks == [DoubleColon]

172+ || itks == [DoubleColon,SixteenBit tokffff,Colon]

173+ || itks == [DoubleColon,SixteenBit tokffff,Colon,AllZeros,Colon]

174+ || itks == [SixteenBit "64",Colon,SixteenBit "ff9b",DoubleColon]

175+ || [SixteenBit "200",Colon,SixteenBit tok5efe,Colon] `isSuffixOf` itks

176+ || [AllZeros,Colon,SixteenBit tok5efe,Colon] `isSuffixOf` itks

177+ || [DoubleColon,SixteenBit tok5efe,Colon] `isSuffixOf` itks)

178+ _ -> False

179+ where

180+ tokffff = "ffff"

181+ tok5efe = "5efe"

182+

183+-- | Rewrites an embedded 'IPv4Addr' into the corresponding list of pure 'IPv6Addr' tokens.

184+--

185+-- > ipv4AddrToIPv6AddrTokens (IPv4Addr "127.0.0.1") == [SixteenBits "7f0",Colon,SixteenBits "1"]

186+--

187+ipv4AddrToIPv6AddrTokens :: IPv6AddrToken -> [IPv6AddrToken]

188+ipv4AddrToIPv6AddrTokens t =

189+ case t of

190+ IPv4Addr a -> do

191+ let m = toHex a

192+ [ SixteenBit ((!!) m 0 <> addZero ((!!) m 1))

193+ , Colon

194+ , SixteenBit ((!!) m 2 <> addZero ((!!) m 3)) ]

195+ _ -> [t]

196+ where

197+ toHex a = map (\x -> T.pack $ showHex (read (T.unpack x)::Int) "") $ T.split (=='.') a

198+ addZero d = if T.length d == 1 then tok0 <> d else d

199+

200+expandTokens :: [IPv6AddrToken] -> [IPv6AddrToken]

201+expandTokens = map expandToken

202+ where expandToken (SixteenBit s) = SixteenBit $ T.justifyRight 4 '0' s

203+ expandToken AllZeros = SixteenBit "0000"

204+ expandToken t = t

205+

206+fromDoubleColon :: [IPv6AddrToken] -> [IPv6AddrToken]

207+fromDoubleColon tks =

208+ if DoubleColon `notElem` tks

209+ then tks

210+ else do let s = splitAt (fromJust $ elemIndex DoubleColon tks) tks

211+ let fsts = fst s

212+ let snds = if not (null (snd s)) then tail(snd s) else []

213+ let fste = if null fsts then [] else fsts ++ [Colon]

214+ let snde = if null snds then [] else Colon : snds

215+ fste ++ allZerosTokensReplacement(quantityOfAllZerosTokenToReplace tks) ++ snde

216+ where

217+ allZerosTokensReplacement x = intersperse Colon (replicate x AllZeros)

218+ quantityOfAllZerosTokenToReplace x =

219+ ntks tks - foldl (\c x -> if (x /= DoubleColon) && (x /= Colon) then c+1 else c) 0 x

220+ where

221+ ntks tks = if countIPv4Addr tks == 1 then 7 else 8

222+

223+toDoubleColon :: [IPv6AddrToken] -> [IPv6AddrToken]

224+toDoubleColon tks =

225+ zerosToDoubleColon tks (zerosRunToReplace $ zerosRunsList tks)

226+ where

227+ zerosToDoubleColon :: [IPv6AddrToken] -> (Int,Int) -> [IPv6AddrToken]

228+ -- No all zeros token, so no double colon replacement...

229+ zerosToDoubleColon ls (_,0) = ls

230+ -- "The symbol '::' MUST NOT be used to shorten just one 16-bit 0 field" (RFC 5952 4.2.2)

231+ zerosToDoubleColon ls (_,1) = ls

232+ zerosToDoubleColon ls (i,l) =

233+ let ls' = filter (/= Colon) ls

234+ in intersperse Colon (Prelude.take i ls') ++ [DoubleColon] ++ intersperse Colon (drop (i+l) ls')

235+ zerosRunToReplace t =

236+ let l = longestLengthZerosRun t

237+ in (firstLongestZerosRunIndex t l,l)

238+ where

239+ firstLongestZerosRunIndex x y = sum . snd . unzip $ Prelude.takeWhile (/=(True,y)) x

240+ longestLengthZerosRun x =

241+ maximum $ map longest x

242+ where longest t = case t of

243+ (True,i) -> i

244+ _ -> 0

245+ zerosRunsList x = map helper $ groupZerosRuns x

246+ where

247+ helper h = (head h == AllZeros, lh) where lh = length h

248+ groupZerosRuns = group . filter (/= Colon)

249+

250+ipv6TokensToIPv6Addr :: [IPv6AddrToken] -> Maybe IPv6Addr

251+ipv6TokensToIPv6Addr l = Just $ IPv6Addr $ ipv6TokensToText l

252+

253+fullSixteenBit :: T.Text -> Maybe IPv6AddrToken

254+fullSixteenBit t =

255+ case parse ipv6AddrFullChunk t of

256+ Done a b -> if a==T.empty then Just $ SixteenBit $ T.pack b else Nothing

257+ _ -> Nothing

258+

259+macAddr :: Parser (Maybe [IPv6AddrToken])

260+macAddr = do

261+ n1 <- count 2 hexaChar <* ":"

262+ n2 <- count 2 hexaChar <* ":"

263+ n3 <- count 2 hexaChar <* ":"

264+ n4 <- count 2 hexaChar <* ":"

265+ n5 <- count 2 hexaChar <* ":"

266+ n6 <- count 2 hexaChar

267+ return $ maybeIPv6AddrTokens $ T.pack $ concat [n1,n2,n3,n4,n5,n6]

268+

269+sixteenBit :: Parser IPv6AddrToken

270+sixteenBit = do

271+ r <- ipv6AddrFullChunk <|> count 3 hexaChar <|> count 2 hexaChar <|> count 1 hexaChar

272+ -- "Leading zeros MUST be suppressed" (RFC 5952, 4.1)

273+ let r' = T.dropWhile (=='0') $ T.pack r

274+ return $ if T.null r'

275+ then AllZeros

276+ -- Hexadecimal digits MUST be in lowercase (RFC 5952 4.3)

277+ else SixteenBit $ T.toLower r'

278+

279+ipv4Addr :: Parser IPv6AddrToken

280+ipv4Addr = do

281+ n1 <- manyDigits <* "."

282+ if n1 /= T.empty

283+ then do n2 <- manyDigits <* "."

284+ if n2 /= T.empty

285+ then do n3 <- manyDigits <* "."

286+ if n3 /= T.empty

287+ then do n4 <- manyDigits

288+ if n4 /= T.empty

289+ then return $ IPv4Addr $ T.intercalate "." [n1,n2,n3,n4]

290+ else parserFailure

291+ else parserFailure

292+ else parserFailure

293+ else parserFailure

294+ where

295+ parserFailure = fail "ipv4Addr parsing failure"

296+ manyDigits = do

297+ ds <- takeWhile1 isDigit

298+ case R.decimal ds of

299+ Right (n,_) -> return (if n < 256 then T.pack $ show n else T.empty)

300+ Left _ -> return T.empty

301+

302+doubleColon :: Parser IPv6AddrToken

303+doubleColon = do

304+ string "::"

305+ return DoubleColon

306+

307+colon :: Parser IPv6AddrToken

308+colon = do

309+ string ":"

310+ return Colon

311+

312+ipv6AddrFullChunk :: Parser String

313+ipv6AddrFullChunk = count 4 hexaChar

314+

315+hexaChar :: Parser Char

316+hexaChar = satisfy (inClass "0-9a-fA-F")

tests/QC/IPv6/Types.hsnew file+29

@@ -0,0 +1,29 @@

1+-- -----------------------------------------------------------------------------

3+-- |

4+-- Module : Text.IPv6Addr

6+-- License : BSD-Style

7+-- Maintainer : michel.boucey@gmail.com

8+--

9+-- Dealing with IPv6 address text representations, canonization and manipulations.

10+--

11+

12+-- -----------------------------------------------------------------------------

13+

14+module QC.IPv6.Types where

15+

16+import qualified Data.Text as T

17+

18+data IPv6Addr = IPv6Addr T.Text

19+

20+instance Show IPv6Addr where

21+ show (IPv6Addr addr) = T.unpack addr

22+

23+data IPv6AddrToken

24+ = SixteenBit T.Text -- ^ A four hexadecimal digits group representing a 16-Bit chunk

25+ | AllZeros -- ^ An all zeros 16-Bit chunk

26+ | Colon -- ^ A separator between 16-Bit chunks

27+ | DoubleColon -- ^ A double-colon stands for a unique compression of many consecutive 16-Bit chunks

28+ | IPv4Addr T.Text -- ^ An embedded IPv4 address as representation of the last 32-Bit

29+ deriving (Eq,Show)

tests/QC/Rechunked.hsnew file+56

@@ -0,0 +1,56 @@

1+{-# LANGUAGE BangPatterns #-}

3+module QC.Rechunked (

4+ rechunkBS

5+ , rechunkT

6+ ) where

8+import Control.Monad (forM, forM_)

9+import Control.Monad.ST (ST, runST)

10+import Data.List (unfoldr)

11+import Test.QuickCheck (Gen, choose)

12+import qualified Data.ByteString as B

13+import qualified Data.Text as T

14+import qualified Data.Vector as V

15+import qualified Data.Vector.Generic as G

16+import qualified Data.Vector.Generic.Mutable as M

17+

18+rechunkBS :: B.ByteString -> Gen [B.ByteString]

19+rechunkBS = fmap (map B.copy) . rechunk_ B.splitAt B.length

20+

21+rechunkT :: T.Text -> Gen [T.Text]

22+rechunkT = fmap (map T.copy) . rechunk_ T.splitAt T.length

23+

24+rechunk_ :: (Int -> a -> (a,a)) -> (a -> Int) -> a -> Gen [a]

25+rechunk_ split len xs = (unfoldr go . (,) xs) `fmap` rechunkSizes (len xs)

26+ where go (b,r:rs) = Just (h, (t,rs))

27+ where (h,t) = split r b

28+ go (_,_) = Nothing

29+

30+rechunkSizes :: Int -> Gen [Int]

31+rechunkSizes n0 = shuffle =<< loop [] (0:repeat 1) n0

32+ where loop _ [] _ = error "it's 2015, where's my Stream type?"

33+ loop acc (lb:lbs) n

34+ | n <= 0 = shuffle (reverse acc)

35+ | otherwise = do

36+ !i <- choose (lb,n)

37+ loop (i:acc) lbs (n-i)

38+

39+shuffle :: [Int] -> Gen [Int]

40+shuffle (0:xs) = (0:) `fmap` shuffle xs

41+shuffle xs = fisherYates xs

42+

43+fisherYates :: [a] -> Gen [a]

44+fisherYates xs = (V.toList . V.backpermute v) `fmap` swapIndices (G.length v)

45+ where

46+ v = V.fromList xs

47+ swapIndices n0 = do

48+ swaps <- forM [0..n] $ \i -> ((,) i) `fmap` choose (i,n)

49+ return (runST (swapAll swaps))

50+ where

51+ n = n0 - 1

52+ swapAll :: [(Int,Int)] -> ST s (V.Vector Int)

53+ swapAll ijs = do

54+ mv <- G.unsafeThaw (G.enumFromTo 0 n :: V.Vector Int)

55+ forM_ ijs $ uncurry (M.swap mv)

56+ G.unsafeFreeze mv

tests/QC/Simple.hsnew file+37

@@ -0,0 +1,37 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

4+module QC.Simple (

5+ tests

6+ ) where

8+import Control.Applicative ((<|>))

9+import Data.ByteString (ByteString)

10+import Data.List (foldl')

11+import Data.Maybe (fromMaybe)

12+import QC.Rechunked (rechunkBS)

13+import Test.Tasty (TestTree)

14+import Test.Tasty.QuickCheck (testProperty)

15+import Test.QuickCheck (Property, counterexample, forAll)

16+import qualified Data.Attoparsec.ByteString.Char8 as A

17+

18+t_issue75 = expect issue75 "ab" (A.Done "" "b")

19+

20+issue75 :: A.Parser ByteString

21+issue75 = "a" >> ("b" <|> "")

22+

23+expect :: (Show r, Eq r) => A.Parser r -> ByteString -> A.Result r -> Property

24+expect p input wanted =

25+ forAll (rechunkBS input) $ \in' ->

26+ let result = parse p in'

27+ in counterexample (show result ++ " /= " ++ show wanted) $

28+ fromMaybe False (A.compareResults result wanted)

29+

30+parse :: A.Parser r -> [ByteString] -> A.Result r

31+parse p (x:xs) = foldl' A.feed (A.parse p x) xs

32+parse p [] = A.parse p ""

33+

34+tests :: [TestTree]

35+tests = [

36+ testProperty "issue75" t_issue75

37+ ]

tests/QC/Text.hs+100−66

@@ -1,67 +1,84 @@

1−{-# LANGUAGE BangPatterns, OverloadedStrings #-}

1+{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-}

22{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}

33module QC.Text (tests) where

5−import Control.Applicative ((<$>), (<*>))

5+#if !MIN_VERSION_base(4,8,0)

6+import Control.Applicative ((<*>), (<$>))

7+#endif

68import Data.Int (Int64)

9+import Data.Word (Word8)

710import Prelude hiding (take, takeWhile)

8−import QC.Common (parseT)

9−import Test.Framework (Test)

10−import Test.Framework.Providers.QuickCheck2 (testProperty)

11+import QC.Common (liftOp, parseT)

12+import qualified QC.Text.FastSet as FastSet

13+import qualified QC.Text.Regressions as Regressions

14+import Test.Tasty (TestTree, testGroup)

15+import Test.Tasty.QuickCheck (testProperty)

1116import Test.QuickCheck

1217import qualified Data.Attoparsec.Text as P

1318import qualified Data.Attoparsec.Text.Lazy as PL

19+import qualified Data.Attoparsec.Text.FastSet as S

20+import qualified Data.ByteString as BS

1421import qualified Data.Char as Char

1522import qualified Data.Text as T

23+import qualified Data.Text.Encoding as TE

1624import qualified Data.Text.Lazy as L

1725

1826-- Basic byte-level combinators.

1927

20−satisfy :: Char -> L.Text -> Bool

21−satisfy w s = parseT (P.satisfy (<=w)) (L.cons w s) == Just w

28+satisfy :: Char -> L.Text -> Property

29+satisfy w s = parseT (P.satisfy (<=w)) (L.cons w s) === Just w

2230

23−satisfyWith :: Char -> L.Text -> Bool

24−satisfyWith c s = parseT (P.satisfyWith id (<=c)) (L.cons c s) == Just c

31+satisfyWith :: Char -> L.Text -> Property

32+satisfyWith c s = parseT (P.satisfyWith id (<=c)) (L.cons c s) === Just c

2533

26−char :: Char -> L.Text -> Bool

27−char w s = parseT (P.char w) (L.cons w s) == Just w

34+char :: Char -> L.Text -> Property

35+char w s = parseT (P.char w) (L.cons w s) === Just w

2836

29−skip :: Char -> L.Text -> Bool

37+skip :: Char -> L.Text -> Property

3038skip w s =

3139 case (parseT (P.skip (<w)) s, L.uncons s) of

32− (Nothing, mcs) -> maybe True (not . it) mcs

33− (Just _, mcs) -> maybe False it mcs

34− where it cs = fst cs < w

40+ (Nothing, mcs) -> maybe (property True) (expectFailure . it) mcs

41+ (Just _, mcs) -> maybe (property False) it mcs

42+ where it cs = liftOp "<" (<) (fst cs) w

3543

36−anyChar :: L.Text -> Bool

44+anyChar :: L.Text -> Property

3745anyChar s

38− | L.null s = p == Nothing

39− | otherwise = p == Just (L.head s)

46+ | L.null s = p === Nothing

47+ | otherwise = p === Just (L.head s)

4048 where p = parseT P.anyChar s

4149

42−notChar :: Char -> NonEmptyList Char -> Bool

43−notChar w (NonEmpty s) = parseT (P.notChar w) bs == if v == w

50+notChar :: Char -> NonEmptyList Char -> Property

51+notChar w (NonEmpty s) = parseT (P.notChar w) bs === if v == w

4452 then Nothing

4553 else Just v

4654 where v = L.head bs

4755 bs = L.pack s

4856

49−peekChar :: L.Text -> Bool

57+peekChar :: L.Text -> Property

5058peekChar s

51− | L.null s = p == Just (Nothing, s)

52− | otherwise = p == Just (Just (L.head s), s)

59+ | L.null s = p === Just (Nothing, s)

60+ | otherwise = p === Just (Just (L.head s), s)

5361 where p = parseT ((,) <$> P.peekChar <*> P.takeLazyText) s

5462

55−peekChar' :: L.Text -> Bool

56−peekChar' s = parseT P.peekChar' s == (fst <$> L.uncons s)

63+peekChar' :: L.Text -> Property

64+peekChar' s = parseT P.peekChar' s === (fst <$> L.uncons s)

5765

58−string :: L.Text -> L.Text -> Bool

59−string s t = parseT (P.string s') (s `L.append` t) == Just s'

66+string :: L.Text -> L.Text -> Property

67+string s t = parseT (P.string s') (s `L.append` t) === Just s'

6068 where s' = toStrict s

6169

62−stringCI :: T.Text -> Bool

63−stringCI s = P.parseOnly (P.stringCI fs) s == Right s

70+strings :: L.Text -> L.Text -> L.Text -> Property

71+strings s t u =

72+ parseT (P.string (toStrict s) >> P.string t') (L.concat [s,t,u])

73+ === Just t'

74+ where t' = toStrict t

75+

76+-- | Note: "simple, and efficient" works for well formed input...

77+-- i.e. e.g. Latin1 texts

78+stringCI :: [Word8] -> Property

79+stringCI ws = P.parseOnly (P.stringCI fs) s === Right s

6480 where fs = T.toCaseFold s

81+ s = TE.decodeLatin1 (BS.pack ws)

6582

6683asciiCI :: T.Text -> Gen Bool

6784asciiCI x =

@@ -76,72 +93,84 @@ asciiCI x =

7693toStrict :: L.Text -> T.Text

7794toStrict = T.concat . L.toChunks

7895

79−skipWhile :: Char -> L.Text -> Bool

96+skipWhile :: Char -> L.Text -> Property

8097skipWhile w s =

8198 let t = L.dropWhile (<=w) s

8299 in case PL.parse (P.skipWhile (<=w)) s of

83− PL.Done t' () -> t == t'

84− _ -> False

100+ PL.Done t' () -> t === t'

101+ _ -> property False

85102

86−take :: Int -> L.Text -> Bool

87−take n s = maybe (L.length s < fromIntegral n) (== T.take n (toStrict s)) $

103+take :: Int -> L.Text -> Property

104+take n s = maybe (liftOp "<" (<) (L.length s) (fromIntegral n))

105+ (=== T.take n (toStrict s)) $

88106 parseT (P.take n) s

89107

90−takeText :: L.Text -> Bool

91−takeText s = maybe False (== toStrict s) . parseT P.takeText $ s

108+takeText :: L.Text -> Property

109+takeText s = maybe (property False) (=== toStrict s) . parseT P.takeText $ s

92110

93−takeLazyText :: L.Text -> Bool

94−takeLazyText s = maybe False (== s) . parseT P.takeLazyText $ s

111+takeLazyText :: L.Text -> Property

112+takeLazyText s = maybe (property False) (=== s) . parseT P.takeLazyText $ s

95113

96−takeCount :: Positive Int -> L.Text -> Bool

114+takeCount :: Positive Int -> L.Text -> Property

97115takeCount (Positive k) s =

98116 case parseT (P.take k) s of

99− Nothing -> fromIntegral k > L.length s

100− Just _s -> fromIntegral k <= L.length s

117+ Nothing -> liftOp ">" (>) (fromIntegral k) (L.length s)

118+ Just _s -> liftOp "<=" (<=) (fromIntegral k) (L.length s)

101119

102−takeWhile :: Char -> L.Text -> Bool

120+takeWhile :: Char -> L.Text -> Property

103121takeWhile w s =

104122 let (h,t) = L.span (==w) s

105123 in case PL.parse (P.takeWhile (==w)) s of

106− PL.Done t' h' -> t == t' && toStrict h == h'

107− _ -> False

124+ PL.Done t' h' -> t === t' .&&. toStrict h === h'

125+ _ -> property False

108126

109−takeWhile1 :: Char -> L.Text -> Bool

127+takeWhile1 :: Char -> L.Text -> Property

110128takeWhile1 w s =

111− let s' = L.cons w s

112− (h,t) = L.span (<=w) s'

129+ let s' = L.cons w s

130+ (h,t) = L.span (<=w) s'

113131 in case PL.parse (P.takeWhile1 (<=w)) s' of

114− PL.Done t' h' -> t == t' && toStrict h == h'

115− _ -> False

132+ PL.Done t' h' -> t === t' .&&. toStrict h === h'

133+ _ -> property False

116134

117−takeTill :: Char -> L.Text -> Bool

135+takeTill :: Char -> L.Text -> Property

118136takeTill w s =

119137 let (h,t) = L.break (==w) s

120138 in case PL.parse (P.takeTill (==w)) s of

121− PL.Done t' h' -> t == t' && toStrict h == h'

122− _ -> False

139+ PL.Done t' h' -> t === t' .&&. toStrict h === h'

140+ _ -> property False

123141

124−takeWhile1_empty :: Bool

125−takeWhile1_empty = parseT (P.takeWhile1 undefined) L.empty == Nothing

142+takeWhile1_empty :: Property

143+takeWhile1_empty = parseT (P.takeWhile1 undefined) L.empty === Nothing

126144

127−endOfInput :: L.Text -> Bool

128−endOfInput s = parseT P.endOfInput s == if L.null s

129− then Just ()

130− else Nothing

145+endOfInput :: L.Text -> Property

146+endOfInput s = parseT P.endOfInput s === if L.null s

147+ then Just ()

148+ else Nothing

131149

132−endOfLine :: L.Text -> Bool

150+endOfLine :: L.Text -> Property

133151endOfLine s =

134152 case (parseT P.endOfLine s, L.uncons s) of

135− (Nothing, mcs) -> maybe True (not . eol) mcs

136− (Just _, mcs) -> maybe False eol mcs

137− where eol (c,s') = c == '\n' || (c, fst <$> L.uncons s') == ('\r', Just '\n')

138−

139−scan :: L.Text -> Positive Int64 -> Bool

140−scan s (Positive k) = parseT p s == (Just $ toStrict $ L.take k s)

153+ (Nothing, mcs) -> maybe (property True) (expectFailure . eol) mcs

154+ (Just _, mcs) -> maybe (property False) eol mcs

155+ where eol (c,s') = c === '\n' .||.

156+ (c, fst <$> L.uncons s') === ('\r', Just '\n')

157+

158+scan :: L.Text -> Positive Int64 -> Property

159+-- for some reason, if counterexample is removed, this test fails?

160+scan s (Positive k) = counterexample (show s)

161+ $ parseT p s === Just (toStrict $ L.take k s)

141162 where p = P.scan k $ \ n _ ->

142163 if n > 0 then let !n' = n - 1 in Just n' else Nothing

143164

144−tests :: [Test]

165+members :: String -> Property

166+members s = property $ all (`S.member` set) s

167+ where set = S.fromList s

168+

169+nonmembers :: String -> String -> Property

170+nonmembers s s' = property . not . any (`S.member` set) $ filter (not . (`elem` s)) s'

171+ where set = S.fromList s

172+

173+tests :: [TestTree]

145174tests = [

146175 testProperty "anyChar" anyChar

147176 , testProperty "asciiCI" asciiCI

@@ -157,6 +186,7 @@ tests = [

157186 , testProperty "skip" skip

158187 , testProperty "skipWhile" skipWhile

159188 , testProperty "string" string

189+ , testProperty "strings" strings

160190 , testProperty "stringCI" stringCI

161191 , testProperty "take" take

162192 , testProperty "takeText" takeText

@@ -166,4 +196,8 @@ tests = [

166196 , testProperty "takeWhile" takeWhile

167197 , testProperty "takeWhile1" takeWhile1

168198 , testProperty "takeWhile1_empty" takeWhile1_empty

199+ , testProperty "members" members

200+ , testProperty "nonmembers" nonmembers

201+ , testGroup "FastSet" FastSet.tests

202+ , testGroup "Regressions" Regressions.tests

169203 ]

tests/QC/Text/FastSet.hsnew file+15

@@ -0,0 +1,15 @@

1+module QC.Text.FastSet where

3+import Test.Tasty (TestTree)

4+import Test.Tasty.QuickCheck (testProperty)

5+import Test.QuickCheck

6+import qualified Data.Attoparsec.Text.FastSet as FastSet

8+membershipCorrect :: String -> String -> Property

9+membershipCorrect members others =

10+ let fs = FastSet.fromList members

11+ correct c = (c `FastSet.member` fs) == (c `elem` members)

12+ in property $ all correct (members ++ others)

13+

14+tests :: [TestTree]

15+tests = [ testProperty "membership is correct" membershipCorrect ]

tests/QC/Text/Regressions.hsnew file+54

@@ -0,0 +1,54 @@

1+{-# LANGUAGE OverloadedStrings #-}

3+module QC.Text.Regressions (

4+ tests

5+ ) where

7+import Data.Text (Text)

8+import qualified Data.Text as T

9+import Data.List (foldl')

10+import Data.Maybe (fromMaybe)

11+import Data.Char (isLower)

12+import Data.Monoid ((<>))

13+import QC.Rechunked (rechunkT)

14+import Test.Tasty (TestTree)

15+import Test.Tasty.QuickCheck (testProperty)

16+import Test.QuickCheck (Property, counterexample, forAll)

17+import qualified Data.Attoparsec.Text as A

18+

19+

20+--------------------------------------------------------------------------------

21+-- 105 was about runScanner not always returning the final state. The result

22+-- did depend on how the data was fed to the parser.

23+

24+t_issue105 :: Property

25+t_issue105 = expect issue105 "lowER" (A.Done "ER" "low")

26+

27+issue105 :: A.Parser Text

28+issue105 = do

29+ (_, firstFourLowercaseLetters) <- A.runScanner "" f

30+ return $ firstFourLowercaseLetters

31+

32+ where

33+ f :: Text -> Char -> Maybe Text

34+ f acc c = if T.length acc < 4 && isLower c

35+ then Just $ acc <> T.singleton c

36+ else Nothing

37+

38+

39+expect :: (Show r, Eq r) => A.Parser r -> Text -> A.Result r -> Property

40+expect p input wanted =

41+ forAll (rechunkT input) $ \in' ->

42+ let result = parse p in'

43+ in counterexample (show result ++ " /= " ++ show wanted) $

44+ fromMaybe False (A.compareResults result wanted)

45+

46+parse :: A.Parser r -> [Text] -> A.Result r

47+parse p (x:xs) = foldl' A.feed (A.parse p x) xs

48+parse p [] = A.parse p ""

49+

50+

51+tests :: [TestTree]

52+tests = [

53+ testProperty "issue105" t_issue105

54+ ]

tests/TestFastSet.hsdeleted−25

@@ -1,25 +0,0 @@

1−module Main (main) where

2−

3−import Data.Word (Word8)

4−import qualified Data.Attoparsec.FastSet as F

5−import System.Random (Random(..), RandomGen)

6−import Test.QuickCheck

7−

8−integralRandomR :: (Integral a, RandomGen g) => (a, a) -> g -> (a, g)

9−integralRandomR (a,b) g = case randomR (fromIntegral a :: Int,

10− fromIntegral b :: Int) g

11− of (x,g') -> (fromIntegral x, g')

12−

13−instance Random Word8 where

14− randomR = integralRandomR

15− random = randomR (minBound,maxBound)

16−

17−instance Arbitrary Word8 where

18− arbitrary = choose (minBound, maxBound)

19−

20−prop_AllMembers s =

21− let set = F.fromList s

22− in all (`F.memberWord8` set) s

23−

24−main = do

25− quickCheck prop_AllMembers