a3e555e...master · typeable/attoparsec

git.iko.soy/typeable/attoparsec

67 files changed+4424−1251

since splitsnapshots

unifiedsplit

.gitignore+1 .hgignore+5−1 .hgtags+13 .travis.yml+161 Data/Attoparsec.hs+8−3 Data/Attoparsec/ByteString.hs+60−32 Data/Attoparsec/ByteString/Buffer.hs+156 Data/Attoparsec/ByteString/Char8.hs+110−88 Data/Attoparsec/ByteString/FastSet.hs+1−1 Data/Attoparsec/ByteString/Internal.hs+247−130 Data/Attoparsec/ByteString/Lazy.hs+10−3 Data/Attoparsec/Char8.hs+7−2 Data/Attoparsec/Combinator.hs+41−60 Data/Attoparsec/Internal.hs+125−79 Data/Attoparsec/Internal/Fhthagn.hs+18 Data/Attoparsec/Internal/Types.hs+152−162 Data/Attoparsec/Lazy.hs+1−1 Data/Attoparsec/Number.hs+15−2 Data/Attoparsec/Text.hs+124−89 Data/Attoparsec/Text/Buffer.hs+172 Data/Attoparsec/Text/FastSet.hs+85−27 Data/Attoparsec/Text/Internal.hs+238−119 Data/Attoparsec/Text/Lazy.hs+14−10 Data/Attoparsec/Types.hs+2−2 Data/Attoparsec/Zepto.hs+88−46 README.markdown−6 attoparsec.cabal+108−30 benchmarks/Aeson.hs+8−3 benchmarks/Benchmarks.hs+16−17 benchmarks/Common.hs+47 benchmarks/Genome.hs+75 benchmarks/HeadersByteString.hs+27−36 benchmarks/HeadersByteString/Atto.hs+57 benchmarks/HeadersText.hs+15−5 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+15−4 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+93 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+8−2 tests/QC/Buffer.hs+96 tests/QC/ByteString.hs+149−78 tests/QC/Combinator.hs+52 tests/QC/Common.hs+113 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+151−74 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+13

@@ -48,3 +48,16 @@ ec23283e88c00af34c3144a8775ca4358daea3f7 0.10.4.0

484848809d7716468fe2bbc47b191b1d64358daaf6d1 0.11.2.1

4949856a772f83a6e382bbcfe53e221a5a92623b107c 0.11.3.0

5050a3c7a521fd58595d6a470ab890cc54a80dd45bd7 0.11.3.1

51+38326ce07aca6c8c3a014b0d454d2a5bfdbd6a52 0.11.3.2

52+694039f4fc157a8ca5dce37959391615b6c3f535 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+8−3

@@ -1,16 +1,21 @@

11-- |

22-- Module : Data.Attoparsec

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

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

44-- License : BSD3

55--

66-- Maintainer : bos@serpentine.com

77-- Stability : experimental

88-- Portability : unknown

99--

10−-- Simple, efficient combinator parsing for 'ByteString' strings,

11−-- loosely based on the Parsec library.

10+-- Simple, efficient combinator parsing for

11+-- 'Data.ByteString.ByteString' strings, loosely based on the Parsec

12+-- library.

13+--

14+-- This module is deprecated. Use "Data.Attoparsec.ByteString"

15+-- instead.

1216

1317module Data.Attoparsec

18+ {-# DEPRECATED "This module will be removed in the next major release." #-}

1419 (

1520 module Data.Attoparsec.ByteString

1621 ) where

Data/Attoparsec/ByteString.hs+60−32

@@ -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-2011

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

48-- License : BSD3

59--

610-- Maintainer : bos@serpentine.com

@@ -38,9 +42,6 @@ module Data.Attoparsec.ByteString

3842 , maybeResult

3943 , eitherResult

4044

41− -- * Combinators

42− , module Data.Attoparsec.Combinator

43−

4445 -- * Parsing individual bytes

4546 , I.word8

4647 , I.anyWord8

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

6263 , I.skipWhile

6364 , I.take

6465 , I.scan

66+ , I.runScanner

6567 , I.takeWhile

6668 , I.takeWhile1

6769 , I.takeTill

@@ -69,9 +71,33 @@ module Data.Attoparsec.ByteString

6971 -- ** Consume all remaining input

7072 , I.takeByteString

7173 , I.takeLazyByteString

74+

75+ -- * Combinators

76+ , try

77+ , (<?>)

78+ , choice

79+ , count

80+ , option

81+ , many'

82+ , many1

83+ , many1'

84+ , manyTill

85+ , manyTill'

86+ , sepBy

87+ , sepBy'

88+ , sepBy1

89+ , sepBy1'

90+ , skipMany

91+ , skipMany1

92+ , eitherP

93+ , I.match

94+ -- * State observation and manipulation functions

95+ , I.endOfInput

96+ , I.atEnd

7297 ) where

7398

7499import Data.Attoparsec.Combinator

100+import Data.List (intercalate)

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

76102import qualified Data.Attoparsec.Internal as I

77103import qualified Data.ByteString as B

@@ -80,49 +106,51 @@ import qualified Data.Attoparsec.Internal.Types as T

80106

81107-- $parsec

82108--

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

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

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

85111--

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

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

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

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

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

90116-- model to use.

91117--

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

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

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

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

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

96122-- libraries.

97123--

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

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

99125-- monad transformer.

100126--

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

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

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

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

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

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

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

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

107−-- takes place. If you must use lazy bytestrings, see the 'Lazy'

108−-- module, which feeds lazy chunks to a regular parser.

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

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

135+-- to a regular parser.

109136--

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

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

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

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

113140

114141-- $incremental

115142--

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

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

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

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

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

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

121148--

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

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

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

125−-- '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.

126154--

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

128156-- continuation with an empty bytestring.

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

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

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

136164-- 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.)

137172

138173-- $performance

139174--

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

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

142−-- 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).

143178--

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

145180-- that it is useful to follow.

@@ -160,14 +195,6 @@ import qualified Data.Attoparsec.Internal.Types as T

160195-- Make active use of benchmarking and profiling tools to measure,

161196-- find the problems with, and improve the performance of your parser.

162197

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

164−-- input.

165−feed :: Result r -> B.ByteString -> Result r

166−feed f@(T.Fail _ _ _) _ = f

167−feed (T.Partial k) d = k d

168−feed (T.Done bs r) d = T.Done (B.append bs d) r

169−{-# INLINE feed #-}

170−

171198-- | Run a parser and print its result to standard output.

172199parseTest :: (Show a) => I.Parser a -> B.ByteString -> IO ()

173200parseTest p s = print (parse p s)

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

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

198225-- result is treated as failure.

199226eitherResult :: Result r -> Either String r

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

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

202−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+110−88

@@ -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-2011

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

811-- License : BSD3

912--

1013-- Maintainer : bos@serpentine.com

@@ -29,16 +32,13 @@ module Data.Attoparsec.ByteString.Char8

2932 , A.parse

3033 , A.feed

3134 , A.parseOnly

32− , A.parseTest

3335 , A.parseWith

36+ , A.parseTest

3437

3538 -- ** Result conversion

3639 , A.maybeResult

3740 , A.eitherResult

3841

39− -- * Combinators

40− , module Data.Attoparsec.Combinator

41−

4242 -- * Parsing individual characters

4343 , char

4444 , char8

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

7070

7171 -- * Efficient string handling

7272 , I.string

73− , stringCI

73+ , I.stringCI

7474 , skipSpace

7575 , skipWhile

7676 , I.take

@@ -102,9 +102,37 @@ module Data.Attoparsec.ByteString.Char8

102102 , number

103103 , rational

104104 , scientific

105+

106+ -- * Combinators

107+ , try

108+ , (<?>)

109+ , choice

110+ , count

111+ , option

112+ , many'

113+ , many1

114+ , many1'

115+ , manyTill

116+ , manyTill'

117+ , sepBy

118+ , sepBy'

119+ , sepBy1

120+ , sepBy1'

121+ , skipMany

122+ , skipMany1

123+ , eitherP

124+ , I.match

125+ -- * State observation and manipulation functions

126+ , I.endOfInput

127+ , I.atEnd

105128 ) where

106129

107−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 ((<|>))

135+import Control.Monad (void, when)

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

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

110138import Data.Attoparsec.Combinator

@@ -113,9 +141,9 @@ import Data.Bits (Bits, (.|.), shiftL)

113141import Data.ByteString.Internal (c2w, w2c)

114142import Data.Int (Int8, Int16, Int32, Int64)

115143import Data.String (IsString(..))

116−import Data.Scientific (Scientific, coefficient, base10Exponent)

117−import qualified Data.Scientific as Sci (scientific)

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

144+import Data.Scientific (Scientific)

145+import qualified Data.Scientific as Sci

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

119147import Prelude hiding (takeWhile)

120148import qualified Data.Attoparsec.ByteString as A

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

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

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

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

143171

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

145−toLower :: Word8 -> Word8

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

147− | otherwise = w

148−

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

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

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

152−{-# INLINE stringCI #-}

153−

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

155173-- the consumed input.

156174--

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

214232

215233-- | A fast digit predicate.

216234isDigit_w8 :: Word8 -> Bool

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

235+isDigit_w8 w = w - 48 <= 9

218236{-# INLINE isDigit_w8 #-}

219237

220238-- | Match any character.

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

251269

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

253271isSpace_w8 :: Word8 -> Bool

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

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

255273{-# INLINE isSpace_w8 #-}

256274

257275

@@ -353,30 +371,39 @@ skipSpace = I.skipWhile isSpace_w8

353371

354372-- $specalt

355373--

356−-- The '.*>' and '<*.' combinators are intended for use with the

357−-- @OverloadedStrings@ language extension. They simplify the common

358−-- task of matching a statically known string, then immediately

359−-- parsing something else.

374+-- If you enable the @OverloadedStrings@ language extension, you can

375+-- use the '*>' and '<*' combinators to simplify the common task of

376+-- matching a statically known string, then immediately parsing

377+-- something else.

378+--

379+-- Instead of writing something like this:

360380--

361−-- An example makes this easier to understand:

381+-- @

382+--'I.string' \"foo\" '*>' wibble

383+-- @

362384--

363−-- @{-\# LANGUAGE OverloadedStrings #-}

385+-- Using @OverloadedStrings@, you can omit the explicit use of

386+-- 'I.string', and write a more compact version:

364387--

365−-- shoeSize = \"Shoe size: \" '.*>' 'decimal'

388+-- @

389+-- \"foo\" '*>' wibble

366390-- @

367391--

368−-- If we were to try to use '*>' above instead, the type checker would

369−-- not be able to tell which 'IsString' instance to use for the text

370−-- in quotes. We would have to be explicit, using either a type

371−-- signature or the 'I.string' parser.

392+-- (Note: the '.*>' and '<*.' combinators that were originally

393+-- provided for this purpose are obsolete and unnecessary, and will be

394+-- removed in the next major version.)

372395

373−-- | Type-specialized version of '*>' for 'B.ByteString'.

396+-- | /Obsolete/. A type-specialized version of '*>' for

397+-- 'B.ByteString'. Use '*>' instead.

374398(.*>) :: B.ByteString -> Parser a -> Parser a

375399s .*> f = I.string s *> f

400+{-# DEPRECATED (.*>) "This is no longer necessary, and will be removed. Use '*>' instead." #-}

376401

377−-- | Type-specialized version of '<*' for 'B.ByteString'.

402+-- | /Obsolete/. A type-specialized version of '<*' for

403+-- 'B.ByteString'. Use '<*' instead.

378404(<*.) :: Parser a -> B.ByteString -> Parser a

379405f <*. s = f <* I.string s

406+{-# DEPRECATED (<*.) "This is no longer necessary, and will be removed. Use '<*' instead." #-}

380407

381408-- | A predicate that matches either a carriage return @\'\\r\'@ or

382409-- newline @\'\\n\'@ character.

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

417444

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

419446decimal :: Integral a => Parser a

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

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

422− 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)

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

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

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

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

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

446472 <|> p

447473

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+

448492-- | Parse a rational number.

449493--

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

@@ -472,79 +516,57 @@ signed p = (negate <$> (char8 '-' *> p))

472516--

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

474518-- \"Infinity\".

475−rational :: Fractional a => Parser a

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

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

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

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

480−rational = scientifically realToFrac

481−

482−-- | Parse a rational number.

483−--

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

485−--

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

487−-- but is slightly less accurate.

488−--

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

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

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

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

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

494−--

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

496−-- \"Infinity\".

497519double :: Parser Double

498−double = rational

520+double = scientifically Sci.toRealFloat

499521

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

501523--

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

503−--

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

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

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

507−-- 'rational'.

508−--

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

510−-- \"

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

511525number :: Parser Number

512526number = scientifically $ \s ->

513− let e = base10Exponent s

514− c = coefficient s

527+ let e = Sci.base10Exponent s

528+ c = Sci.coefficient s

515529 in if e >= 0

516530 then I (c * 10 ^ e)

517− else D (fromInteger c / 10 ^ negate e)

531+ else D (Sci.toRealFloat s)

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

518533

519534-- | Parse a scientific number.

520535--

521−-- 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'.

522537scientific :: Parser Scientific

523538scientific = scientifically id

524539

540+-- A strict pair

541+data SP = SP !Integer {-# UNPACK #-}!Int

542+

525543{-# INLINE scientifically #-}

526544scientifically :: (Scientific -> a) -> Parser a

527545scientifically h = do

528546 let minus = 45

529547 plus = 43

530− !positive <- ((== plus) <$> I.satisfy (\c -> c == minus || c == plus)) <|>

531− pure True

548+ sign <- I.peekWord8'

549+ let !positive = sign == plus || sign /= minus

550+ when (sign == plus || sign == minus) $

551+ void $ I.anyWord8

532552

533553 n <- decimal

534554

535− let f fracDigits = Sci.scientific (B8.foldl' step n fracDigits)

536− (negate $ B8.length fracDigits)

555+ let f fracDigits = SP (B8.foldl' step n fracDigits)

556+ (negate $ B8.length fracDigits)

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

538558

539− s <- let dot = 46 in

540− (I.satisfy (==dot) *> (f <$> I.takeWhile isDigit_w8)) <|>

541− pure (Sci.scientific n 0)

559+ dotty <- I.peekWord8

560+ -- '.' -> ascii 46

561+ SP c e <- case dotty of

562+ Just 46 -> I.anyWord8 *> (f <$> I.takeWhile isDigit_w8)

563+ _ -> pure (SP n 0)

542564

543− let !signedCoeff | positive = coefficient s

544− | otherwise = negate $ coefficient s

565+ let !signedCoeff | positive = c

566+ | otherwise = -c

545567

546568 let littleE = 101

547569 bigE = 69

548− (I.satisfy (\c -> c == littleE || c == bigE) *>

549− fmap (h . Sci.scientific signedCoeff . (base10Exponent s +)) (signed decimal)) <|>

550− return (h $ Sci.scientific signedCoeff (base10Exponent s))

570+ (I.satisfy (\ex -> ex == littleE || ex == bigE) *>

571+ fmap (h . Sci.scientific signedCoeff . (e +)) (signed decimal)) <|>

572+ return (h $ Sci.scientific signedCoeff e)

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

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

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

44-- |

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

6−-- Copyright : Bryan O'Sullivan 2008

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

77-- License : BSD3

88--

99-- Maintainer : bos@serpentine.com

Data/Attoparsec/ByteString/Internal.hs+247−130

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

1−{-# LANGUAGE BangPatterns, Rank2Types, OverloadedStrings,

2− RecordWildCards, MagicHash, UnboxedTuples #-}

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

2+ RecordWildCards #-}

33-- |

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

5−-- Copyright : Bryan O'Sullivan 2007-2011

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

66-- License : BSD3

77--

88-- Maintainer : bos@serpentine.com

99-- Stability : experimental

1010-- Portability : unknown

1111--

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

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

1313-- loosely based on the Parsec library.

1414

1515module Data.Attoparsec.ByteString.Internal

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

4747 -- * Efficient string handling

4848 , skipWhile

4949 , string

50− , stringTransform

50+ , stringCI

5151 , take

5252 , scan

5353 , runScanner

@@ -61,21 +61,30 @@ module Data.Attoparsec.ByteString.Internal

6161

6262 -- * Utilities

6363 , endOfLine

64+ , endOfInput

65+ , match

66+ , atEnd

6467 ) where

6568

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

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

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

71+#endif

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

6773import Control.Monad (when)

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

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

69−import Data.Attoparsec.Combinator

70−import Data.Attoparsec.Internal.Types

71− hiding (Parser, Input, Added, Failure, Success)

76+import Data.Attoparsec.Combinator ((<?>))

7277import Data.Attoparsec.Internal

73−import Data.Monoid (Monoid(..))

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

79+import 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))

78−import Prelude hiding (getChar, take, takeWhile)

86+import Prelude hiding (getChar, succ, take, takeWhile)

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

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

8089import qualified Data.ByteString as B8

8190import qualified Data.ByteString.Char8 as B

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

8392import qualified Data.ByteString.Lazy as L

8493import qualified Data.ByteString.Unsafe as B

8594

86−import GHC.Base (realWorld#)

87−import GHC.IO (IO(IO))

88−

89−type Parser = T.Parser B.ByteString

90−type Result = IResult B.ByteString

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

92−type Success a r = T.Success 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

9399

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

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

@@ -98,7 +104,11 @@ type Success a r = T.Success B.ByteString a r

98104-- >digit = satisfy isDigit

99105-- > where isDigit w = w >= 48 && w <= 57

100106satisfy :: (Word8 -> Bool) -> Parser Word8

101−satisfy = satisfyElem

107+satisfy p = do

108+ h <- peekWord8'

109+ if p h

110+ then advance 1 >> return h

111+ else fail "satisfy"

102112{-# INLINE satisfy #-}

103113

104114-- | The parser @skip p@ succeeds for any byte for which the predicate

@@ -108,9 +118,9 @@ satisfy = satisfyElem

108118-- > where isDigit w = w >= 48 && w <= 57

109119skip :: (Word8 -> Bool) -> Parser ()

110120skip p = do

111− s <- ensure 1

112− if p (B.unsafeHead s)

113− then put (B.unsafeTail s)

121+ h <- peekWord8'

122+ if p h

123+ then advance 1

114124 else fail "skip"

115125

116126-- | The parser @satisfyWith f p@ transforms a byte, and succeeds if

@@ -118,11 +128,10 @@ skip p = do

118128-- parser returns the transformed byte that was parsed.

119129satisfyWith :: (Word8 -> a) -> (a -> Bool) -> Parser a

120130satisfyWith f p = do

121− s <- ensure 1

122− let c = f $! B.unsafeHead s

131+ h <- peekWord8'

132+ let c = f h

123133 if p c

124− then let !t = B.unsafeTail s

125− in put t >> return c

134+ then advance 1 >> return c

126135 else fail "satisfyWith"

127136{-# INLINE satisfyWith #-}

128137

@@ -132,24 +141,15 @@ storable = hack undefined

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

133142 hack dummy = do

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

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

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

136145 peek (castPtr $ p `plusPtr` o)

137146

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

139−-- returns 'True'.

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

141−takeWith n0 p = do

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

148+take :: Int -> Parser ByteString

149+take n0 = do

142150 let n = max n0 0

143151 s <- ensure n

144− let h = B.unsafeTake n s

145− t = B.unsafeDrop n s

146− if p h

147− then put t >> return h

148− else fail "takeWith"

149−

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

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

152−take n = takeWith n (const True)

152+ advance n >> return s

153153{-# INLINE take #-}

154154

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

@@ -165,27 +165,71 @@ take n = takeWith n (const True)

165165--

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

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

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

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

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

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

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

170+string :: ByteString -> Parser ByteString

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

172172{-# INLINE string #-}

173173

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

175− -> Parser B.ByteString

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

177−{-# 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"

178224

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

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

181227skipWhile p = go

182228 where

183229 go = do

184− t <- B8.dropWhile p <$> get

185− put t

186− when (B.null t) $ do

187− input <- wantInput

188− when input go

230+ t <- B8.takeWhile p <$> get

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

232+ when continue go

189233{-# INLINE skipWhile #-}

190234

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

@@ -195,9 +239,10 @@ skipWhile p = go

195239-- predicate returns 'True' on the first byte of input.

196240--

197241-- /Note/: Because this parser does not fail, do not use it with

198−-- combinators such as 'many', because such parsers loop until a

199−-- failure occurs. Careless use will thus result in an infinite loop.

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

242+-- combinators such as 'Control.Applicative.many', because such

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

244+-- in an infinite loop.

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

201246takeTill p = takeWhile (not . p)

202247{-# INLINE takeTill #-}

203248

@@ -208,24 +253,30 @@ takeTill p = takeWhile (not . p)

208253-- predicate returns 'False' on the first byte of input.

209254--

210255-- /Note/: Because this parser does not fail, do not use it with

211−-- combinators such as 'many', because such parsers loop until a

212−-- failure occurs. Careless use will thus result in an infinite loop.

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

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

215− where

216− go acc = do

217− (h,t) <- B8.span p <$> get

218− put t

219− if B.null t

220− then do

221− input <- wantInput

222− if input

223− then go (h:acc)

224− else return (h:acc)

225− else return (h:acc)

256+-- combinators such as 'Control.Applicative.many', because such

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

258+-- in an infinite loop.

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

226266{-# INLINE takeWhile #-}

227267

228−takeRest :: Parser [B.ByteString]

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

269+takeWhileAcc p = go

270+ where

271+ go acc = do

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

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

274+ if continue

275+ then go (s:acc)

276+ else return $ concatReverse (s:acc)

277+{-# INLINE takeWhileAcc #-}

278+

279+takeRest :: Parser [ByteString]

229280takeRest = go []

230281 where

231282 go acc = do

@@ -233,12 +284,12 @@ takeRest = go []

233284 if input

234285 then do

235286 s <- get

236− put B.empty

287+ advance (B.length s)

237288 go (s:acc)

238289 else return (reverse acc)

239290

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

241−takeByteString :: Parser B.ByteString

292+takeByteString :: Parser ByteString

242293takeByteString = B.concat `fmap` takeRest

243294

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

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

247298

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

249300

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

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

251302 -> Parser r

252303scan_ f s0 p = go [] s0

253304 where

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

268319 bs <- get

269320 let T i s' = inlinePerformIO $ scanner bs

270321 !h = B.unsafeTake i bs

271− !t = B.unsafeDrop i bs

272− put t

273− if B.null t

274− then do

275− input <- wantInput

276− if input

277− then go (h:acc) s'

278− else f s' (h:acc)

322+ continue <- inputSpansChunks i

323+ if continue

324+ then go (h:acc) s'

279325 else f s' (h:acc)

280326{-# INLINE scan_ #-}

281327

@@ -288,19 +334,17 @@ scan_ f s0 p = go [] s0

288334-- predicate returns 'Nothing' on the first byte of input.

289335--

290336-- /Note/: Because this parser does not fail, do not use it with

291−-- combinators such as 'many', because such parsers loop until a

292−-- failure occurs. Careless use will thus result in an infinite loop.

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

294−scan = scan_ $ \_ chunks ->

295− case chunks of

296− [x] -> return x

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

337+-- combinators such as 'Control.Applicative.many', because such

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

339+-- in an infinite loop.

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

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

298342{-# INLINE scan #-}

299343

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

301345-- scanner.

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

303−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)

304348{-# INLINE runScanner #-}

305349

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

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

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

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

311355-- there is no input left.

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

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

313357takeWhile1 p = do

314− (`when` demandInput) =<< B.null <$> get

315− (h,t) <- B8.span p <$> get

316− when (B.null h) $ fail "takeWhile1"

317− put t

318− if B.null t

319− then (h<>) `fmap` takeWhile p

320− else return h

358+ (`when` demandInput) =<< endOfChunk

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

360+ let len = B.length s

361+ if len == 0

362+ then fail "takeWhile1"

363+ else do

364+ advance len

365+ eoc <- endOfChunk

366+ if eoc

367+ then takeWhileAcc p [s]

368+ else return s

369+{-# INLINE takeWhile1 #-}

321370

322371-- | Match any byte in a set.

323372--

@@ -359,27 +408,32 @@ notWord8 c = satisfy (/= c) <?> "not " ++ show c

359408-- input has been reached. Does not consume any input.

360409--

361410-- /Note/: Because this parser does not fail, do not use it with

362−-- combinators such as 'many', because such parsers loop until a

363−-- failure occurs. Careless use will thus result in an infinite loop.

411+-- combinators such as 'Control.Applicative.many', because such

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

413+-- in an infinite loop.

364414peekWord8 :: Parser (Maybe Word8)

365−peekWord8 = T.Parser $ \i0 a0 m0 _kf ks ->

366− if B.null (unI i0)

367− then if m0 == Complete

368− then ks i0 a0 m0 Nothing

369− else let ks' i a m = let !w = B.unsafeHead (unI i)

370− in ks i a m (Just w)

371− kf' i a m = ks i a m Nothing

372− in prompt i0 a0 m0 kf' ks'

373− else let !w = B.unsafeHead (unI i0)

374− in ks i0 a0 m0 (Just w)

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

416+ case () of

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

418+ let !w = Buf.unsafeIndex t pos_

419+ in succ t pos more (Just w)

420+ | more == Complete ->

421+ succ t pos more Nothing

422+ | otherwise ->

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

424+ in succ t' pos' more' (Just w)

425+ lose' t' pos' more' = succ t' pos' more' Nothing

426+ in prompt t pos more lose' succ'

375427{-# INLINE peekWord8 #-}

376428

377429-- | Match any byte, to perform lookahead. Does not consume any

378430-- input, but will fail if end of input has been reached.

379431peekWord8' :: Parser Word8

380−peekWord8' = do

381− s <- ensure 1

382− return $! B.unsafeHead s

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

433+ if lengthAtLeast pos 1 t

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

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

436+ in ensureSuspended 1 t pos more lose succ'

383437{-# INLINE peekWord8' #-}

384438

385439-- | Match either a single newline character @\'\\n\'@, or a carriage

@@ -389,31 +443,94 @@ endOfLine = (word8 10 >> return ()) <|> (string "\r\n" >> return ())

389443

390444-- | Terminal failure continuation.

391445failK :: Failure a

392−failK i0 _a0 _m0 stack msg = Fail (unI i0) stack msg

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

393447{-# INLINE failK #-}

394448

395449-- | Terminal success continuation.

396450successK :: Success a a

397−successK i0 _a0 _m0 a = Done (unI i0) a

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

398452{-# INLINE successK #-}

399453

400454-- | Run a parser.

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

402−parse m s = T.runParser m (I s) mempty Incomplete failK successK

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

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

403457{-# INLINE parse #-}

404458

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

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

407−parseOnly m s = case T.runParser m (I s) mempty Complete failK successK of

408− Fail _ _ err -> Left err

409− Done _ a -> Right a

410− _ -> 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!"

411474{-# INLINE parseOnly #-}

412475

413−-- | Just like unsafePerformIO, but we inline it. Big performance gains as

414−-- it exposes lots of things to further inlining. /Very unsafe/. In

415−-- particular, you should do no memory allocation inside an

416−-- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@.

417−inlinePerformIO :: IO a -> a

418−inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r

419−{-# INLINE inlinePerformIO #-}

476+get :: Parser ByteString

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

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

479+{-# INLINE get #-}

480+

481+endOfChunk :: Parser Bool

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

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

484+{-# INLINE endOfChunk #-}

485+

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+

496+advance :: Int -> Parser ()

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

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

499+{-# INLINE advance #-}

500+

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

502+ -> Failure r

503+ -> Success ByteString r

504+ -> Result r

505+ensureSuspended n t pos more lose succ =

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

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

508+ if lengthAtLeast pos' n t'

509+ then succ' t' pos' more' (substring pos (Pos n) t')

510+ else runParser (demandInput >> go) t' pos' more' lose' succ'

511+

512+-- | If at least @n@ elements of input are available, return the

513+-- current input, otherwise fail.

514+ensure :: Int -> Parser ByteString

515+ensure n = T.Parser $ \t pos more lose succ ->

516+ if lengthAtLeast pos n t

517+ then succ t pos more (substring pos (Pos n) t)

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

519+ else ensureSuspended n t pos more lose succ

520+{-# INLINE ensure #-}

521+

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

523+-- that was consumed while it was being parsed.

524+match :: Parser a -> Parser (ByteString, a)

525+match p = T.Parser $ \t pos more lose succ ->

526+ let succ' t' pos' more' a =

527+ succ t' pos' more' (substring pos (pos'-pos) t', a)

528+ in runParser p t pos more lose succ'

529+

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

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

532+{-# INLINE lengthAtLeast #-}

533+

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

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

536+{-# 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 2010, 2011

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+7−2

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

11-- |

22-- Module : Data.Attoparsec.Char8

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

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

44-- License : BSD3

55--

66-- Maintainer : bos@serpentine.com

@@ -8,9 +8,14 @@

88-- Portability : unknown

99--

1010-- Simple, efficient, character-oriented combinator parsing for

11−-- 'ByteString' strings, loosely based on the Parsec library.

11+-- 'Data.ByteString.ByteString' strings, loosely based on the Parsec

12+-- library.

13+--

14+-- This module is deprecated. Use "Data.Attoparsec.ByteString.Char8"

15+-- instead.

1216

1317module Data.Attoparsec.Char8

18+ {-# DEPRECATED "This module will be removed in the next major release." #-}

1419 (

1520 module Data.Attoparsec.ByteString.Char8

1621 ) where

Data/Attoparsec/Combinator.hs+41−60

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

11{-# 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 2009-2010

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

58-- License : BSD3

69--

710-- Maintainer : bos@serpentine.com

@@ -29,43 +32,42 @@ module Data.Attoparsec.Combinator

2932 , skipMany

3033 , skipMany1

3134 , eitherP

32− -- * Parsing individual chunk elements

35+ , feed

3336 , satisfyElem

34− -- * State observation and manipulation functions

3537 , endOfInput

3638 , atEnd

39+ , lookAhead

3740 ) where

3841

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

40− (<|>), (*>), (<$>))

41−import Control.Monad (MonadPlus(..))

42−#if !MIN_VERSION_base(4,2,0)

43−import Control.Applicative (many)

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

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

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

4445#endif

45−

46−import Data.Attoparsec.Internal (demandInput, ensure, put, wantInput)

47−import Data.Attoparsec.Internal.Types (Chunk(..), Input(..), Parser(..), addS)

48−import Data.Attoparsec.Internal.Types (More(..))

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

47+import Control.Monad (MonadPlus(..))

48+import Data.Attoparsec.Internal.Types (Parser(..), IResult(..))

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

4950import Data.ByteString (ByteString)

5051import Data.Text (Text)

5152import qualified Data.Attoparsec.Zepto as Z

53+import Prelude hiding (succ)

5254

5355-- | Attempt a parse, and if it fails, rewind the input so that no

5456-- input appears to have been consumed.

5557--

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

57−-- Attoparsec parsers always backtrack on failure.

58−try :: Parser t a -> Parser t a

59+-- attoparsec parsers always backtrack on failure.

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

5961try p = p

6062{-# INLINE try #-}

6163

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

63−(<?>) :: Parser t a

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

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

65− -> Parser t a

66−p <?> msg0 = Parser $ \i0 a0 m0 kf ks ->

67− let kf' i a m strs msg = kf i a m (msg0:strs) msg

68− in runParser p i0 a0 m0 kf' ks

67+ -> Parser i a

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

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

70+ in runParser p t pos more lose' succ

6971{-# INLINE (<?>) #-}

7072infix 0 <?>

7173

@@ -74,7 +76,8 @@ infix 0 <?>

7476-- action.

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

7678choice = foldr (<|>) empty

77−{-# SPECIALIZE choice :: [Parser ByteString a] -> Parser ByteString a #-}

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

80+ -> Parser ByteString a #-}

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

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

8083

@@ -129,7 +132,7 @@ many1' p = liftM2' (:) p (many' p)

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

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

131134--

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

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

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

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

135138{-# SPECIALIZE sepBy :: Parser ByteString a -> Parser ByteString s

@@ -141,7 +144,7 @@ sepBy p s = liftA2 (:) p ((s *> sepBy1 p s) <|> pure []) <|> pure []

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

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

143146--

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

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

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

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

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

@@ -153,7 +156,7 @@ sepBy' p s = scan `mplus` return []

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

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

155158--

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

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

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

158161sepBy1 p s = scan

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

@@ -166,7 +169,7 @@ sepBy1 p s = scan

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

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

168171--

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

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

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

171174sepBy1' p s = scan

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

@@ -236,39 +239,17 @@ eitherP :: (Alternative f) => f a -> f b -> f (Either a b)

236239eitherP a b = (Left <$> a) <|> (Right <$> b)

237240{-# INLINE eitherP #-}

238241

239−-- | The parser @satisfyElem p@ succeeds for any chunk element for which the

240−-- predicate @p@ returns 'True'. Returns the element that is

241−-- actually parsed.

242−--

243−-- >digit = satisfyElem isDigit

244−-- > where isDigit c = c >= '0' && c <= '9'

245−satisfyElem :: Chunk t => (ChunkElem t -> Bool) -> Parser t (ChunkElem t)

246−satisfyElem p = do

247− c <- ensure 1

248− let !h = unsafeChunkHead c

249− if p h

250− then put (unsafeChunkTail c) >> return h

251− else fail "satisfyElem"

252−{-# INLINE satisfyElem #-}

253−

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

255−endOfInput :: Chunk t => Parser t ()

256−endOfInput = Parser $ \i0 a0 m0 kf ks ->

257− if nullChunk (unI i0)

258− then if m0 == Complete

259− then ks i0 a0 m0 ()

260− else let kf' i1 a1 m1 _ _ = addS i0 a0 m0 i1 a1 m1 $

261− \ i2 a2 m2 -> ks i2 a2 m2 ()

262− ks' i1 a1 m1 _ = addS i0 a0 m0 i1 a1 m1 $

263− \ i2 a2 m2 -> kf i2 a2 m2 []

264− "endOfInput"

265− in runParser demandInput i0 a0 m0 kf' ks'

266− else kf i0 a0 m0 [] "endOfInput"

267−{-# SPECIALIZE endOfInput :: Parser ByteString () #-}

268−{-# SPECIALIZE endOfInput :: Parser Text () #-}

269−

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

271−-- reached.

272−atEnd :: Chunk t => Parser t Bool

273−atEnd = not <$> wantInput

274−{-# INLINE atEnd #-}

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

243+-- input.

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

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

246+feed (Partial k) d = k d

247+feed (Done t r) d = Done (mappend t d) r

248+{-# 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+125−79

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

1−{-# LANGUAGE BangPatterns #-}

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

22-- |

33-- Module : Data.Attoparsec.Internal

4−-- Copyright : Bryan O'Sullivan 2012

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

55-- License : BSD3

66--

77-- Maintainer : bos@serpentine.com

@@ -12,114 +12,160 @@

1212-- library.

1313

1414module Data.Attoparsec.Internal

15− (

16− compareResults

17− , get

18− , put

19− , ensure

15+ ( compareResults

2016 , prompt

2117 , demandInput

18+ , demandInput_

2219 , wantInput

20+ , endOfInput

21+ , atEnd

22+ , satisfyElem

23+ , concatReverse

2324 ) where

2425

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

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

28+import Data.Monoid (Monoid, mconcat)

29+#endif

2530import Data.Attoparsec.Internal.Types

2631import Data.ByteString (ByteString)

2732import Data.Text (Text)

33+import Prelude hiding (succ)

2834

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

3036--

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

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

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

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

35−compareResults (Fail i0 ctxs0 msg0) (Fail i1 ctxs1 msg1) =

36− Just (i0 == i1 && ctxs0 == ctxs1 && msg0 == msg1)

37−compareResults (Done i0 r0) (Done i1 r1) =

38− Just (i0 == i1 && r0 == r1)

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

41+compareResults (Fail t0 ctxs0 msg0) (Fail t1 ctxs1 msg1) =

42+ Just (t0 == t1 && ctxs0 == ctxs1 && msg0 == msg1)

43+compareResults (Done t0 r0) (Done t1 r1) =

44+ Just (t0 == t1 && r0 == r1)

3945compareResults (Partial _) (Partial _) = Nothing

4046compareResults _ _ = Just False

4147

42−get :: Parser t t

43−get = Parser $ \i0 a0 m0 _kf ks -> ks i0 a0 m0 (unI i0)

44−{-# INLINE get #-}

45−

46−put :: t -> Parser t ()

47−put c = Parser $ \_i0 a0 m0 _kf ks -> ks (I c) a0 m0 ()

48−{-# INLINE put #-}

49−

50−ensure' :: Chunk t

51− => Int -> Input t -> Added t -> More -> Failure t r -> Success t t r

52− -> IResult t r

53−ensure' !n0 i0 a0 m0 kf0 ks0 =

54− runParser (demandInput >> go n0) i0 a0 m0 kf0 ks0

55− where

56− go !n = Parser $ \i a m kf ks ->

57− if chunkLengthAtLeast (unI i) n

58− then ks i a m (unI i)

59− else runParser (demandInput >> go n) i a m kf ks

60−{-# SPECIALIZE ensure' :: Int -> Input ByteString -> Added ByteString -> More

61− -> Failure ByteString r

62− -> Success ByteString ByteString r

63− -> IResult ByteString r #-}

64−{-# SPECIALIZE ensure' :: Int -> Input Text -> Added Text -> More

65− -> Failure Text r -> Success Text Text r

66− -> IResult Text r #-}

67−

68−-- | If at least @n@ elements of input are available, return the

69−-- current input, otherwise fail.

70−ensure :: Chunk t => Int -> Parser t t

71−ensure !n = Parser $ \i0 a0 m0 kf ks ->

72− if chunkLengthAtLeast (unI i0) n

73− then ks i0 a0 m0 (unI i0)

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

75− else ensure' n i0 a0 m0 kf ks

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

77−{-# INLINE ensure #-}

78−

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

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

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

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

8150prompt :: Chunk t

82− => Input t -> Added t -> More

83− -> (Input t -> Added t -> More -> IResult t r)

84− -> (Input t -> Added t -> More -> IResult t r)

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

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

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

8554 -> IResult t r

86−prompt i0 a0 _m0 kf ks = Partial $ \s ->

87− if nullChunk s

88− then kf i0 a0 Complete

89− else ks (i0 <> I s) (a0 <> A s) Incomplete

90−{-# SPECIALIZE prompt :: Input ByteString -> Added ByteString -> More

91− -> (Input ByteString -> Added ByteString -> More

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

9261 -> IResult ByteString r)

93− -> (Input ByteString -> Added ByteString -> More

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

9463 -> IResult ByteString r)

9564 -> IResult ByteString r #-}

96−{-# SPECIALIZE prompt :: Input Text -> Added Text -> More

97− -> (Input Text -> Added Text -> More -> IResult Text r)

98− -> (Input Text -> Added Text-> More -> IResult Text r)

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

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

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

9968 -> IResult Text r #-}

10069

10170-- | Immediately demand more input via a 'Partial' continuation

10271-- result.

10372demandInput :: Chunk t => Parser t ()

104−demandInput = Parser $ \i0 a0 m0 kf ks ->

105− if m0 == Complete

106− then kf i0 a0 m0 ["demandInput"] "not enough input"

107− else let kf' i a m = kf i a m ["demandInput"] "not enough input"

108− ks' i a m = ks i a m ()

109− in prompt i0 a0 m0 kf' ks'

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'

11079{-# SPECIALIZE demandInput :: Parser ByteString () #-}

11180{-# SPECIALIZE demandInput :: Parser Text () #-}

11281

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+

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

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

11597-- of all input has been reached.

116−wantInput :: Chunk t => Parser t Bool

117−wantInput = Parser $ \i0 a0 m0 _kf ks ->

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

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

118100 case () of

119− _ | not (nullChunk (unI i0)) -> ks i0 a0 m0 True

120− | m0 == Complete -> ks i0 a0 m0 False

121− | otherwise -> let kf' i a m = ks i a m False

122− ks' i a m = ks i a m True

123− in prompt i0 a0 m0 kf' ks'

124−{-# SPECIALIZE wantInput :: Parser ByteString Bool #-}

125−{-# SPECIALIZE wantInput :: Parser Text Bool #-}

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/Internal/Fhthagn.hsnew file+18

@@ -0,0 +1,18 @@

1+{-# LANGUAGE BangPatterns, Rank2Types, OverloadedStrings,

2+ RecordWildCards, MagicHash, UnboxedTuples #-}

4+module Data.Attoparsec.Internal.Fhthagn

5+ (

6+ inlinePerformIO

7+ ) where

9+import GHC.Base (realWorld#)

10+import GHC.IO (IO(IO))

11+

12+-- | Just like unsafePerformIO, but we inline it. Big performance gains as

13+-- it exposes lots of things to further inlining. /Very unsafe/. In

14+-- particular, you should do no memory allocation inside an

15+-- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@.

16+inlinePerformIO :: IO a -> a

17+inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r

18+{-# INLINE inlinePerformIO #-}

Data/Attoparsec/Internal/Types.hs+152−162

@@ -1,8 +1,8 @@

1−{-# LANGUAGE BangPatterns, CPP, 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-2011

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

66-- License : BSD3

77--

88-- Maintainer : bos@serpentine.com

@@ -15,78 +15,82 @@

1515module Data.Attoparsec.Internal.Types

1616 (

1717 Parser(..)

18+ , State

1819 , Failure

1920 , Success

21+ , Pos(..)

2022 , IResult(..)

21− , Input(..)

22− , Added(..)

2323 , More(..)

24− , addS

2524 , (<>)

2625 , Chunk(..)

2726 ) where

2827

29−import Control.Applicative (Alternative(..), Applicative(..), (<$>))

28+import Control.Applicative as App (Applicative(..), (<$>))

29+import Control.Applicative (Alternative(..))

3030import Control.DeepSeq (NFData(rnf))

3131import Control.Monad (MonadPlus(..))

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)

3236import Data.ByteString (ByteString)

37+import qualified Data.ByteString as BS

3338import Data.ByteString.Internal (w2c)

34−import Data.Monoid (Monoid(..))

3539import Data.Text (Text)

36−import Data.Word (Word8)

37−import Prelude hiding (getChar, take, takeWhile)

38−import qualified Data.ByteString as BS

39−import qualified Data.ByteString.Unsafe as BS

40−import qualified Data.Text as T

41−import qualified Data.Text.Unsafe as T

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

4245

43−-- | The result of a parse. This is parameterised over the type @t@

46+newtype Pos = Pos { fromPos :: Int }

47+ deriving (Eq, Ord, Show, Num)

48+

49+-- | The result of a parse. This is parameterised over the type @i@

4450-- of string that was processed.

4551--

4652-- This type is an instance of 'Functor', where 'fmap' transforms the

4753-- value in a 'Done' result.

48−data IResult t r = Fail t [String] String

49− -- ^ The parse failed. The 't' parameter is the

50− -- input that had not yet been consumed when the

51− -- failure occurred. The @[@'String'@]@ is a list of

52− -- contexts in which the error occurred. The

53− -- 'String' is the message describing the error, if

54− -- any.

55− | Partial (t -> IResult t r)

56− -- ^ Supply this continuation with more input so that

57− -- the parser can resume. To indicate that no more

58− -- input is available, use an empty string.

59− | Done t r

60− -- ^ The parse succeeded. The 't' parameter is the

61− -- input that had not yet been consumed (if any) when

62− -- the parse succeeded.

63−

64−instance (Show t, Show r) => Show (IResult t r) where

65− show (Fail t stk msg) =

66− "Fail " ++ show t ++ " " ++ show stk ++ " " ++ show msg

67− show (Partial _) = "Partial _"

68− show (Done t r) = "Done " ++ show t ++ " " ++ show r

69−

70−instance (NFData t, NFData r) => NFData (IResult t r) where

54+data IResult i r =

55+ Fail i [String] String

56+ -- ^ The parse failed. The @i@ parameter is the input that had

57+ -- not yet been consumed when the failure occurred. The

58+ -- @[@'String'@]@ is a list of contexts in which the error

59+ -- occurred. The 'String' is the message describing the error, if

60+ -- any.

61+ | Partial (i -> IResult i r)

62+ -- ^ Supply this continuation with more input so that the parser

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.

68+ | Done i r

69+ -- ^ The parse succeeded. The @i@ parameter is the input that had

70+ -- not yet been consumed (if any) when the parse succeeded.

71+

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

80+

81+instance (NFData i, NFData r) => NFData (IResult i r) where

7182 rnf (Fail t stk msg) = rnf t `seq` rnf stk `seq` rnf msg

7283 rnf (Partial _) = ()

7384 rnf (Done t r) = rnf t `seq` rnf r

7485 {-# INLINE rnf #-}

7586

76−fmapR :: (a -> b) -> IResult t a -> IResult t b

77−fmapR _ (Fail t stk msg) = Fail t stk msg

78−fmapR f (Partial k) = Partial (fmapR f . k)

79−fmapR f (Done t r) = Done t (f r)

80−

81−instance Functor (IResult t) where

82− fmap = fmapR

83− {-# INLINE fmap #-}

84−

85−newtype Input t = I {unI :: t} deriving (Monoid)

86−newtype Added t = A {unA :: t} deriving (Monoid)

87+instance Functor (IResult i) where

88+ fmap _ (Fail t stk msg) = Fail t stk msg

89+ fmap f (Partial k) = Partial (fmap f . k)

90+ fmap f (Done t r) = Done t (f r)

8791

88−-- | The core parser type. This is parameterised over the type @t@ of

89−-- string being processed.

92+-- | The core parser type. This is parameterised over the type @i@

93+-- of string being processed.

9094--

9195-- This type is an instance of the following classes:

9296--

@@ -99,123 +103,115 @@ newtype Added t = A {unA :: t} deriving (Monoid)

99103-- 'mplus' executes the right-hand parser if the left-hand one

100104-- fails. When the parser on the right executes, the input is reset

101105-- to the same state as the parser on the left started with. (In

102−-- other words, Attoparsec is a backtracking parser that supports

106+-- other words, attoparsec is a backtracking parser that supports

103107-- arbitrary lookahead.)

104108--

105109-- * 'Alternative', which follows 'MonadPlus'.

106−newtype Parser t a = Parser {

107− runParser :: forall r. Input t -> Added t -> More

108− -> Failure t r

109− -> Success t a r

110− -> IResult 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

111116 }

112117

113−type Failure t r = Input t -> Added t -> More -> [String] -> String

114− -> IResult t r

115−type Success t a r = Input t -> Added t -> More -> a -> IResult t r

118+type family State i

119+type instance State ByteString = B.Buffer

120+type instance State Text = T.Buffer

121+

122+type Failure i t r = t -> Pos -> More -> [String] -> String

123+ -> IResult i r

124+type Success i t a r = t -> Pos -> More -> a -> IResult i r

116125

117126-- | Have we read all available input?

118127data More = Complete | Incomplete

119128 deriving (Eq, Show)

120129

121−instance Monoid More where

122− mappend c@Complete _ = c

123− mappend _ m = m

124− mempty = Incomplete

125−

126−addS :: (Monoid t) =>

127− Input t -> Added t -> More

128− -> Input t -> Added t -> More

129− -> (Input t -> Added t -> More -> r) -> r

130−addS i0 a0 m0 _i1 a1 m1 f =

131− let !i = i0 <> I (unA a1)

132− a = a0 <> a1

133− !m = m0 <> m1

134− in f i a m

135−{-# INLINE addS #-}

136−

137−bindP :: Parser t a -> (a -> Parser t b) -> Parser t b

138−bindP m g =

139− Parser $ \i0 a0 m0 kf ks -> runParser m i0 a0 m0 kf $

140− \i1 a1 m1 a -> runParser (g a) i1 a1 m1 kf ks

141−{-# INLINE bindP #-}

142−

143−returnP :: a -> Parser t a

144−returnP a = Parser (\i0 a0 m0 _kf ks -> ks i0 a0 m0 a)

145−{-# INLINE returnP #-}

146−

147−instance Monad (Parser t) where

148− return = returnP

149− (>>=) = bindP

150− fail = failDesc

151−

152−noAdds :: (Monoid t) =>

153− Input t -> Added t -> More

154− -> (Input t -> Added t -> More -> r) -> r

155−noAdds i0 _a0 m0 f = f i0 mempty m0

156−{-# INLINE noAdds #-}

157−

158−plus :: (Monoid t) => Parser t a -> Parser t a -> Parser t a

159−plus a b = Parser $ \i0 a0 m0 kf ks ->

160− let kf' i1 a1 m1 _ _ = addS i0 a0 m0 i1 a1 m1 $

161− \ i2 a2 m2 -> runParser b i2 a2 m2 kf ks

162− ks' i1 a1 m1 = ks i1 (a0 <> a1) m1

163− in noAdds i0 a0 m0 $ \i2 a2 m2 -> runParser a i2 a2 m2 kf' ks'

164−

165−instance (Monoid t) => MonadPlus (Parser t) where

166− mzero = failDesc "mzero"

130+instance Semigroup More where

131+ c@Complete <> _ = c

132+ _ <> m = m

133+

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

141+ {-# INLINE fail #-}

142+#endif

143+

144+ return = App.pure

145+ {-# INLINE return #-}

146+

147+ m >>= k = Parser $ \t !pos more lose succ ->

148+ let succ' t' !pos' more' a = runParser (k a) t' pos' more' lose succ

149+ in runParser m t pos more lose succ'

150+ {-# INLINE (>>=) #-}

151+

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

162+plus f g = Parser $ \t pos more lose succ ->

163+ let lose' t' _pos' more' _ctx _msg = runParser g t' pos more' lose succ

164+ in runParser f t pos more lose' succ

165+

166+instance MonadPlus (Parser i) where

167+ mzero = fail "mzero"

167168 {-# INLINE mzero #-}

168169 mplus = plus

169170

170−fmapP :: (a -> b) -> Parser t a -> Parser t b

171−fmapP p m = Parser $ \i0 a0 m0 f k ->

172− runParser m i0 a0 m0 f $ \i1 a1 s1 a -> k i1 a1 s1 (p a)

173−{-# INLINE fmapP #-}

174−

175−instance Functor (Parser t) where

176− fmap = fmapP

171+instance Functor (Parser i) where

172+ fmap f p = Parser $ \t pos more lose succ ->

173+ let succ' t' pos' more' a = succ t' pos' more' (f a)

174+ in runParser p t pos more lose succ'

177175 {-# INLINE fmap #-}

178176

179−apP :: Parser t (a -> b) -> Parser t a -> Parser t b

177+apP :: Parser i (a -> b) -> Parser i a -> Parser i b

180178apP d e = do

181179 b <- d

182180 a <- e

183181 return (b a)

184182{-# INLINE apP #-}

185183

186−instance Applicative (Parser t) where

187− pure = returnP

184+instance Applicative (Parser i) where

185+ pure v = Parser $ \t !pos more _lose succ -> succ t pos more v

188186 {-# INLINE pure #-}

189187 (<*>) = apP

190188 {-# INLINE (<*>) #-}

191−

192−#if MIN_VERSION_base(4,2,0)

193− -- These definitions are equal to the defaults, but this

194− -- way the optimizer doesn't have to work so hard to figure

195− -- that out.

196− (*>) = (>>)

189+ m *> k = m >>= \_ -> k

197190 {-# INLINE (*>) #-}

198− x <* y = x >>= \a -> y >> return a

191+ x <* y = x >>= \a -> y >> pure a

199192 {-# INLINE (<*) #-}

200−#endif

201193

202−instance (Monoid t) => Monoid (Parser t a) where

203− mempty = failDesc "mempty"

194+instance Semigroup (Parser i a) where

195+ (<>) = plus

196+ {-# INLINE (<>) #-}

197+

198+instance Monoid (Parser i a) where

199+ mempty = fail "mempty"

204200 {-# INLINE mempty #-}

205− mappend = plus

201+ mappend = (<>)

206202 {-# INLINE mappend #-}

207203

208−instance (Monoid t) => Alternative (Parser t) where

209− empty = failDesc "empty"

204+instance Alternative (Parser i) where

205+ empty = fail "empty"

210206 {-# INLINE empty #-}

211207

212208 (<|>) = plus

213209 {-# INLINE (<|>) #-}

214210

215−#if MIN_VERSION_base(4,2,0)

216211 many v = many_v

217− where many_v = some_v <|> pure []

218− some_v = (:) <$> v <*> many_v

212+ where

213+ many_v = some_v <|> pure []

214+ some_v = (:) <$> v <*> many_v

219215 {-# INLINE many #-}

220216

221217 some v = some_v

@@ -223,28 +219,18 @@ instance (Monoid t) => Alternative (Parser t) where

223219 many_v = some_v <|> pure []

224220 some_v = (:) <$> v <*> many_v

225221 {-# INLINE some #-}

226−#endif

227−

228−failDesc :: String -> Parser t a

229−failDesc err = Parser (\i0 a0 m0 kf _ks -> kf i0 a0 m0 [] msg)

230− where msg = "Failed reading: " ++ err

231−{-# INLINE failDesc #-}

232−

233−(<>) :: (Monoid m) => m -> m -> m

234−(<>) = mappend

235−{-# INLINE (<>) #-}

236222

237223-- | A common interface for input chunks.

238224class Monoid c => Chunk c where

239225 type ChunkElem c

240226 -- | Test if the chunk is empty.

241227 nullChunk :: c -> Bool

242− -- | Get the head element of a non-empty chunk.

243− unsafeChunkHead :: c -> ChunkElem c

244− -- | Get the tail of a non-empty chunk.

245− unsafeChunkTail :: c -> c

246− -- | Check if the chunk has the length of at least @n@ elements.

247− chunkLengthAtLeast :: c -> Int -> 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)

248234 -- | Map an element to the corresponding character.

249235 -- The first argument is ignored.

250236 chunkElemToChar :: c -> ChunkElem c -> Char

@@ -253,24 +239,28 @@ instance Chunk ByteString where

253239 type ChunkElem ByteString = Word8

254240 nullChunk = BS.null

255241 {-# INLINE nullChunk #-}

256− unsafeChunkHead = BS.unsafeHead

257− {-# INLINE unsafeChunkHead #-}

258− unsafeChunkTail = BS.unsafeTail

259− {-# INLINE unsafeChunkTail #-}

260− chunkLengthAtLeast bs n = BS.length bs >= n

261− {-# INLINE chunkLengthAtLeast #-}

262− chunkElemToChar = const w2c

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

263251 {-# INLINE chunkElemToChar #-}

264252

265253instance Chunk Text where

266254 type ChunkElem Text = Char

267− nullChunk = T.null

255+ nullChunk = Text.null

268256 {-# INLINE nullChunk #-}

269− unsafeChunkHead = T.unsafeHead

270− {-# INLINE unsafeChunkHead #-}

271− unsafeChunkTail = T.unsafeTail

272− {-# INLINE unsafeChunkTail #-}

273− chunkLengthAtLeast t n = T.lengthWord16 t `quot` 2 >= n || T.length t >= n

274− {-# INLINE chunkLengthAtLeast #-}

275− chunkElemToChar = const id

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

276266 {-# INLINE chunkElemToChar #-}

Data/Attoparsec/Lazy.hs+1−1

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

11-- |

22-- Module : Data.Attoparsec.Lazy

3−-- Copyright : Bryan O'Sullivan 2010

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 2011

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+124−89

@@ -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 2011

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

610-- License : BSD3

711--

812-- Maintainer : bos@serpentine.com

@@ -40,9 +44,6 @@ module Data.Attoparsec.Text

4044 , maybeResult

4145 , eitherResult

4246

43− -- * Combinators

44− , module Data.Attoparsec.Combinator

45−

4647 -- * Parsing individual characters

4748 , I.char

4849 , I.anyChar

@@ -71,6 +72,7 @@ module Data.Attoparsec.Text

7172 , skipSpace

7273 , I.skipWhile

7374 , I.scan

75+ , I.runScanner

7476 , I.take

7577 , I.takeWhile

7678 , I.takeWhile1

@@ -99,19 +101,47 @@ module Data.Attoparsec.Text

99101 , number

100102 , rational

101103 , scientific

104+

105+ -- * Combinators

106+ , try

107+ , (<?>)

108+ , choice

109+ , count

110+ , option

111+ , many'

112+ , many1

113+ , many1'

114+ , manyTill

115+ , manyTill'

116+ , sepBy

117+ , sepBy'

118+ , sepBy1

119+ , sepBy1'

120+ , skipMany

121+ , skipMany1

122+ , eitherP

123+ , I.match

124+ -- * State observation and manipulation functions

125+ , I.endOfInput

126+ , I.atEnd

102127 ) where

103128

104−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 ((<|>))

105134import Data.Attoparsec.Combinator

106135import Data.Attoparsec.Number (Number(..))

107−import Data.Scientific (Scientific, coefficient, base10Exponent)

108−import qualified Data.Scientific as Sci (scientific)

136+import Data.Scientific (Scientific)

137+import qualified Data.Scientific as Sci

109138import Data.Attoparsec.Text.Internal (Parser, Result, parse, takeWhile1)

110139import Data.Bits (Bits, (.|.), shiftL)

111140import Data.Char (isAlpha, isDigit, isSpace, ord)

112141import Data.Int (Int8, Int16, Int32, Int64)

142+import Data.List (intercalate)

113143import Data.Text (Text)

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

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

115145import qualified Data.Attoparsec.Internal as I

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

117147import qualified Data.Attoparsec.Text.Internal as I

@@ -119,49 +149,50 @@ import qualified Data.Text as T

119149

120150-- $parsec

121151--

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

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

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

124154--

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

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

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

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

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

129159-- model to use.

130160--

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

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

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

133163-- If you use complicated combinators that return lists of

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

135165-- libraries.

136166--

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

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

138168-- monad transformer.

139169--

140−-- * Attoparsec is specialised to deal only with strict 'Text'

170+-- * attoparsec is specialised to deal only with strict 'Text'

141171-- input. Efficiency concerns rule out both lists and lazy text.

142172-- The usual use for lazy text would be to allow consumption of very

143173-- large input without a large footprint. For this need,

144−-- Attoparsec's incremental input provides an excellent substitute,

174+-- attoparsec's incremental input provides an excellent substitute,

145175-- with much more control over when input takes place. If you must

146176-- use lazy text, see the 'Lazy' module, which feeds lazy chunks to

147177-- a regular parser.

148178--

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

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

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

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

152182

153183-- $incremental

154184--

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

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

156186-- a 'Text' that represents only part of the expected total amount

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

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

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

160190--

161191-- Supplying the 'T.Partial' continuation with another string will

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

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

164−-- '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.

165196--

166197-- To indicate that you have no more input, supply the 'Partial'

167198-- continuation with an 'T.empty' 'Text'.

@@ -173,12 +204,19 @@ import qualified Data.Text as T

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

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

175206-- 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.)

176214

177215-- $performance

178216--

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

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

181−-- 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).

182220--

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

184222-- that it is useful to follow.

@@ -199,14 +237,6 @@ import qualified Data.Text as T

199237-- Make active use of benchmarking and profiling tools to measure,

200238-- find the problems with, and improve the performance of your parser.

201239

202−-- | If a parser has returned a 'Partial' result, supply it with more

203−-- input.

204−feed :: Result r -> Text -> Result r

205−feed f@(T.Fail _ _ _) _ = f

206−feed (T.Partial k) d = k d

207−feed (T.Done bs r) d = T.Done (T.append bs d) r

208−{-# INLINE feed #-}

209−

210240-- | Run a parser and print its result to standard output.

211241parseTest :: (Show a) => I.Parser a -> Text -> IO ()

212242parseTest p s = print (parse p s)

@@ -236,9 +266,10 @@ maybeResult _ = Nothing

236266-- | Convert a 'Result' value to an 'Either' value. A 'Partial' result

237267-- is treated as failure.

238268eitherResult :: Result r -> Either String r

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

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

241−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"

242273

243274-- | A predicate that matches either a carriage return @\'\\r\'@ or

244275-- newline @\'\\n\'@ character.

@@ -311,6 +342,24 @@ signed p = (negate <$> (I.char '-' *> p))

311342 <|> (I.char '+' *> p)

312343 <|> p

313344

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+

314363-- | Parse a rational number.

315364--

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

@@ -338,56 +387,33 @@ signed p = (negate <$> (I.char '-' *> p))

338387--

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

340389-- \"Infinity\".

341−rational :: Fractional a => Parser a

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

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

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

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

346−rational = scientifically realToFrac

347−

348−-- | Parse a rational number.

349−--

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

351−--

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

353−-- but is slightly less accurate.

354−--

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

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

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

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

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

360−--

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

362−-- \"Infinity\".

363390double :: Parser Double

364−double = rational

391+double = scientifically Sci.toRealFloat

365392

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

367394--

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

369−--

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

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

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

373−-- 'rational'.

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

374396--

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

376398-- \"Infinity\".

377399number :: Parser Number

378400number = scientifically $ \s ->

379− let e = base10Exponent s

380− c = coefficient s

401+ let e = Sci.base10Exponent s

402+ c = Sci.coefficient s

381403 in if e >= 0

382404 then I (c * 10 ^ e)

383− else D (fromInteger c / 10 ^ negate e)

405+ else D (Sci.toRealFloat s)

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

384407

385408-- | Parse a scientific number.

386409--

387−-- 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'.

388411scientific :: Parser Scientific

389412scientific = scientifically id

390413

414+-- A strict pair

415+data SP = SP !Integer {-# UNPACK #-}!Int

416+

391417{-# INLINE scientifically #-}

392418scientifically :: (Scientific -> a) -> Parser a

393419scientifically h = do

@@ -396,19 +422,19 @@ scientifically h = do

396422

397423 n <- decimal

398424

399− let f fracDigits = Sci.scientific (T.foldl' step n fracDigits)

400− (negate $ T.length fracDigits)

425+ let f fracDigits = SP (T.foldl' step n fracDigits)

426+ (negate $ T.length fracDigits)

401427 step a c = a * 10 + fromIntegral (ord c - 48)

402428

403− s <- (I.satisfy (=='.') *> (f <$> I.takeWhile isDigit)) <|>

404− pure (Sci.scientific n 0)

429+ SP c e <- (I.satisfy (=='.') *> (f <$> I.takeWhile isDigit)) <|>

430+ pure (SP n 0)

405431

406− let !signedCoeff | positive = coefficient s

407− | otherwise = negate $ coefficient s

432+ let !signedCoeff | positive = c

433+ | otherwise = -c

408434

409− (I.satisfy (\c -> c == 'e' || c == 'E') *>

410− fmap (h . Sci.scientific signedCoeff . (base10Exponent s +)) (signed decimal)) <|>

411− return (h $ Sci.scientific signedCoeff (base10Exponent s))

435+ (I.satisfy (\w -> w == 'e' || w == 'E') *>

436+ fmap (h . Sci.scientific signedCoeff . (e +)) (signed decimal)) <|>

437+ return (h $ Sci.scientific signedCoeff e)

412438

413439-- | Parse a single digit, as recognised by 'isDigit'.

414440digit :: Parser Char

@@ -432,27 +458,36 @@ skipSpace = I.skipWhile isSpace

432458

433459-- $specalt

434460--

435−-- The '.*>' and '<*.' combinators are intended for use with the

436−-- @OverloadedStrings@ language extension. They simplify the common

437−-- task of matching a statically known string, then immediately

438−-- parsing something else.

461+-- If you enable the @OverloadedStrings@ language extension, you can

462+-- use the '*>' and '<*' combinators to simplify the common task of

463+-- matching a statically known string, then immediately parsing

464+-- something else.

439465--

440−-- An example makes this easier to understand:

466+-- Instead of writing something like this:

441467--

442−-- @{-\# LANGUAGE OverloadedStrings #-}

468+-- @

469+--'I.string' \"foo\" '*>' wibble

470+-- @

443471--

444−-- shoeSize = \"Shoe size: \" '.*>' 'decimal'

472+-- Using @OverloadedStrings@, you can omit the explicit use of

473+-- 'I.string', and write a more compact version:

474+--

475+-- @

476+-- \"foo\" '*>' wibble

445477-- @

446478--

447−-- If we were to try to use '*>' above instead, the type checker would

448−-- not be able to tell which 'IsString' instance to use for the text

449−-- in quotes. We would have to be explicit, using either a type

450−-- signature or the 'I.string' parser.

479+-- (Note: the '.*>' and '<*.' combinators that were originally

480+-- provided for this purpose are obsolete and unnecessary, and will be

481+-- removed in the next major version.)

451482

452−-- | Type-specialized version of '*>' for 'Text'.

483+-- | /Obsolete/. A type-specialized version of '*>' for 'Text'. Use

484+-- '*>' instead.

453485(.*>) :: Text -> Parser a -> Parser a

454486s .*> f = I.string s *> f

487+{-# DEPRECATED (.*>) "This is no longer necessary, and will be removed. Use '*>' instead." #-}

455488

456−-- | Type-specialized version of '<*' for 'Text'.

489+-- | /Obsolete/. A type-specialized version of '<*' for 'Text'. Use

490+-- '*>' instead.

457491(<*.) :: Parser a -> Text -> Parser a

458492f <*. s = f <* I.string s

493+{-# DEPRECATED (<*.) "This is no longer necessary, and will be removed. Use '<*' instead." #-}

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 2008

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+238−119

@@ -1,16 +1,16 @@

1−{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, GADTs, OverloadedStrings,

1+{-# LANGUAGE BangPatterns, FlexibleInstances, GADTs, OverloadedStrings,

22 Rank2Types, RecordWildCards, TypeFamilies, TypeSynonymInstances #-}

33{-# OPTIONS_GHC -fno-warn-orphans #-}

44-- |

55-- Module : Data.Attoparsec.Text.Internal

6−-- Copyright : Bryan O'Sullivan 2011

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

@@ -60,43 +60,37 @@ module Data.Attoparsec.Text.Internal

6060

6161 -- * Utilities

6262 , endOfLine

63+ , endOfInput

64+ , match

65+ , atEnd

6366 ) where

6467

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

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

6669import Control.Monad (when)

67−import Data.Attoparsec.Combinator

68−import Data.Attoparsec.Internal.Types hiding (Parser, Input, Added, Failure, Success)

70+import Data.Attoparsec.Combinator ((<?>))

6971import Data.Attoparsec.Internal

70−import Data.Monoid (Monoid(..))

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

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)

7177import Data.String (IsString(..))

72−import Data.Text (Text)

73−import Prelude hiding (getChar, take, takeWhile)

74−import Data.Char (chr, ord)

78+import Data.Text.Internal (Text(..))

79+import Prelude hiding (getChar, succ, take, takeWhile)

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

7681import qualified Data.Attoparsec.Text.FastSet as Set

7782import qualified Data.Text as T

7883import qualified Data.Text.Lazy as L

84+import qualified Data.Text.Unsafe as T

7985

8086type Parser = T.Parser Text

8187type Result = IResult Text

82−type Failure r = T.Failure Text r

83−type Success a r = T.Success Text a r

88+type Failure r = T.Failure Text Buffer r

89+type Success a r = T.Success Text Buffer a r

8490

8591instance (a ~ Text) => IsString (Parser a) where

8692 fromString = string . T.pack

8793

88−unsafeHead :: Text -> Char

89−unsafeHead = T.head

90−

91−unsafeTail :: Text -> Text

92−unsafeTail = T.tail

93−

94−unsafeTake :: Int -> Text -> Text

95−unsafeTake = T.take

96−

97−unsafeDrop :: Int -> Text -> Text

98−unsafeDrop = T.drop

99−

10094-- | The parser @satisfy p@ succeeds for any character for which the

10195-- predicate @p@ returns 'True'. Returns the character that is

10296-- actually parsed.

@@ -104,7 +98,12 @@ unsafeDrop = T.drop

10498-- >digit = satisfy isDigit

10599-- > where isDigit c = c >= '0' && c <= '9'

106100satisfy :: (Char -> Bool) -> Parser Char

107−satisfy = satisfyElem

101+satisfy p = do

102+ (k,c) <- ensure 1

103+ let !h = T.unsafeHead c

104+ if p h

105+ then advance k >> return h

106+ else fail "satisfy"

108107{-# INLINE satisfy #-}

109108

110109-- | The parser @skip p@ succeeds for any character for which the

@@ -114,9 +113,9 @@ satisfy = satisfyElem

114113-- > where isDigit c = c >= '0' && c <= '9'

115114skip :: (Char -> Bool) -> Parser ()

116115skip p = do

117− s <- ensure 1

118− if p (unsafeHead s)

119− then put (unsafeTail s)

116+ (k,s) <- ensure 1

117+ if p (T.unsafeHead s)

118+ then advance k

120119 else fail "skip"

121120

122121-- | The parser @satisfyWith f p@ transforms a character, and succeeds

@@ -124,11 +123,10 @@ skip p = do

124123-- parser returns the transformed character that was parsed.

125124satisfyWith :: (Char -> a) -> (a -> Bool) -> Parser a

126125satisfyWith f p = do

127− s <- ensure 1

128− let c = f $! unsafeHead s

126+ (k,s) <- ensure 1

127+ let c = f $! T.unsafeHead s

129128 if p c

130− then let !t = unsafeTail s

131− in put t >> return c

129+ then advance k >> return c

132130 else fail "satisfyWith"

133131{-# INLINE satisfyWith #-}

134132

@@ -136,15 +134,14 @@ satisfyWith f p = do

136134-- predicate returns 'True'.

137135takeWith :: Int -> (Text -> Bool) -> Parser Text

138136takeWith n p = do

139− s <- ensure n

140− let (h,t) = T.splitAt n s

141− if p h

142− then put t >> return h

137+ (k,s) <- ensure n

138+ if p s

139+ then advance k >> return s

143140 else fail "takeWith"

144141

145142-- | Consume exactly @n@ characters of input.

146143take :: Int -> Parser Text

147−take n = takeWith n (const True)

144+take n = takeWith (max n 0) (const True)

148145{-# INLINE take #-}

149146

150147-- | @string s@ parses a sequence of characters that identically match

@@ -160,12 +157,49 @@ take n = takeWith n (const True)

160157--

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

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

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

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

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

165162string :: Text -> Parser Text

166−string s = takeWith (T.length s) (==s)

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

167164{-# INLINE string #-}

168165

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+

169203-- | Satisfy a literal string, ignoring case.

170204--

171205-- Note: this function is currently quite inefficient. Unicode case

@@ -178,10 +212,9 @@ stringCI s = go 0

178212 go !n

179213 | n > T.length fs = fail "stringCI"

180214 | otherwise = do

181− t <- ensure n

182− let h = unsafeTake n t

183− if T.toCaseFold h == fs

184− then put (unsafeDrop n t) >> return h

215+ (k,t) <- ensure n

216+ if T.toCaseFold t == fs

217+ then advance k >> return t

185218 else go (n+1)

186219 fs = T.toCaseFold s

187220{-# INLINE stringCI #-}

@@ -189,34 +222,24 @@ stringCI s = go 0

189222

190223-- | Satisfy a literal string, ignoring case for characters in the ASCII range.

191224asciiCI :: Text -> Parser Text

192−asciiCI input = do

193− t <- ensure n

194− let h = unsafeTake n t

195− if asciiToLower h == s

196− then put (unsafeDrop n t) >> return h

197− else fail "asciiCI"

198− where

199− n = T.length input

200− s = asciiToLower input

201−

202− -- convert letters in the ASCII range to lower-case

203− asciiToLower = T.map f

204− where

205− offset = ord 'a' - ord 'A'

206− f c | 'A' <= c && c <= 'Z' = chr (ord c + offset)

207− | otherwise = c

225+asciiCI s = fmap fst $ match $ T.foldr ((*>) . asciiCharCI) (pure ()) s

208226{-# INLINE asciiCI #-}

209227

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+

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

211236skipWhile :: (Char -> Bool) -> Parser ()

212237skipWhile p = go

213238 where

214239 go = do

215− t <- T.dropWhile p <$> get

216− put t

217− when (T.null t) $ do

218− input <- wantInput

219− when input go

240+ t <- T.takeWhile p <$> get

241+ continue <- inputSpansChunks (size t)

242+ when continue go

220243{-# INLINE skipWhile #-}

221244

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

@@ -226,8 +249,9 @@ skipWhile p = go

226249-- predicate returns 'True' on the first character of input.

227250--

228251-- /Note/: Because this parser does not fail, do not use it with

229−-- combinators such as 'many', because such parsers loop until a

230−-- failure occurs. Careless use will thus result in an infinite loop.

252+-- combinators such as 'Control.Applicative.many', because such

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

254+-- in an infinite loop.

231255takeTill :: (Char -> Bool) -> Parser Text

232256takeTill p = takeWhile (not . p)

233257{-# INLINE takeTill #-}

@@ -239,21 +263,29 @@ takeTill p = takeWhile (not . p)

239263-- predicate returns 'False' on the first character of input.

240264--

241265-- /Note/: Because this parser does not fail, do not use it with

242−-- combinators such as 'many', because such parsers loop until a

243−-- failure occurs. Careless use will thus result in an infinite loop.

266+-- combinators such as 'Control.Applicative.many', because such

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

268+-- in an infinite loop.

244269takeWhile :: (Char -> Bool) -> Parser Text

245−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

246281 where

247282 go acc = do

248− (h,t) <- T.span p <$> get

249− put t

250− if T.null t

251− then do

252− input <- wantInput

253− if input

254− then go (h:acc)

255− else return (h:acc)

256− else return (h:acc)

283+ h <- T.takeWhile p <$> get

284+ continue <- inputSpansChunks (size h)

285+ if continue

286+ then go (h:acc)

287+ else return $ concatReverse (h:acc)

288+{-# INLINE takeWhileAcc #-}

257289

258290takeRest :: Parser [Text]

259291takeRest = go []

@@ -263,7 +295,7 @@ takeRest = go []

263295 if input

264296 then do

265297 s <- get

266− put T.empty

298+ advance (size s)

267299 go (s:acc)

268300 else return (reverse acc)

269301

@@ -276,7 +308,7 @@ takeLazyText :: Parser L.Text

276308takeLazyText = L.fromChunks `fmap` takeRest

277309

278310data Scan s = Continue s

279− | Finished {-# UNPACK #-} !Int T.Text

311+ | Finished s {-# UNPACK #-} !Int Text

280312

281313scan_ :: (s -> [Text] -> Parser r) -> s -> (s -> Char -> Maybe s) -> Parser r

282314scan_ f s0 p = go [] s0

@@ -285,17 +317,17 @@ scan_ f s0 p = go [] s0

285317 case T.uncons t of

286318 Just (c,t') -> case p s c of

287319 Just s' -> scanner s' (n+1) t'

288− Nothing -> Finished n t

320+ Nothing -> Finished s n t

289321 Nothing -> Continue s

290322 go acc s = do

291323 input <- get

292324 case scanner s 0 input of

293− Continue s' -> do put T.empty

294− more <- wantInput

295− if more

325+ Continue s' -> do continue <- inputSpansChunks (size input)

326+ if continue

296327 then go (input : acc) s'

297328 else f s' (input : acc)

298− Finished n t -> put t >> 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)

299331{-# INLINE scan_ #-}

300332

301333-- | A stateful scanner. The predicate consumes and transforms a

@@ -307,19 +339,17 @@ scan_ f s0 p = go [] s0

307339-- predicate returns 'Nothing' on the first character of input.

308340--

309341-- /Note/: Because this parser does not fail, do not use it with

310−-- combinators such as 'many', because such parsers loop until a

311−-- failure occurs. Careless use will thus result in an infinite loop.

342+-- combinators such as 'Control.Applicative.many', because such

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

344+-- in an infinite loop.

312345scan :: s -> (s -> Char -> Maybe s) -> Parser Text

313−scan = scan_ $ \_ chunks ->

314− case chunks of

315− [x] -> return x

316− xs -> return . T.concat . reverse $ xs

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

317347{-# INLINE scan #-}

318348

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

320350-- scanner.

321351runScanner :: s -> (s -> Char -> Maybe s) -> Parser (Text, s)

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

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

323353{-# INLINE runScanner #-}

324354

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

@@ -330,13 +360,16 @@ runScanner = scan_ $ \s xs -> return (T.concat (reverse xs), s)

330360-- 'True' or if there is no input left.

331361takeWhile1 :: (Char -> Bool) -> Parser Text

332362takeWhile1 p = do

333− (`when` demandInput) =<< T.null <$> get

334− (h,t) <- T.span p <$> get

335− when (T.null h) $ fail "takeWhile1"

336− put t

337− if T.null t

338− then (h<>) `fmap` takeWhile p

363+ (`when` demandInput) =<< endOfChunk

364+ h <- T.takeWhile p <$> get

365+ let size' = size h

366+ when (size' == 0) $ fail "takeWhile1"

367+ advance size'

368+ eoc <- endOfChunk

369+ if eoc

370+ then takeWhileAcc p [h]

339371 else return h

372+{-# INLINE takeWhile1 #-}

340373

341374-- | Match any character in a set.

342375--

@@ -378,27 +411,31 @@ notChar c = satisfy (/= c) <?> "not " ++ show c

378411-- end of input has been reached. Does not consume any input.

379412--

380413-- /Note/: Because this parser does not fail, do not use it with

381−-- combinators such as 'many', because such parsers loop until a

382−-- failure occurs. Careless use will thus result in an infinite loop.

414+-- combinators such as 'Control.Applicative.many', because such

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

416+-- in an infinite loop.

383417peekChar :: Parser (Maybe Char)

384−peekChar = T.Parser $ \i0 a0 m0 _kf ks ->

385− if T.null (unI i0)

386− then if m0 == Complete

387− then ks i0 a0 m0 Nothing

388− else let ks' i a m = let !c = unsafeHead (unI i)

389− in ks i a m (Just c)

390− kf' i a m = ks i a m Nothing

391− in prompt i0 a0 m0 kf' ks'

392− else let !c = unsafeHead (unI i0)

393− in ks i0 a0 m0 (Just c)

418+peekChar = T.Parser $ \t pos more _lose succ ->

419+ case () of

420+ _| pos < lengthOf t ->

421+ let T.Iter !c _ = Buf.iter t (fromPos pos)

422+ in succ t pos more (Just c)

423+ | more == Complete ->

424+ succ t pos more Nothing

425+ | otherwise ->

426+ let succ' t' pos' more' =

427+ let T.Iter !c _ = Buf.iter t' (fromPos pos')

428+ in succ t' pos' more' (Just c)

429+ lose' t' pos' more' = succ t' pos' more' Nothing

430+ in prompt t pos more lose' succ'

394431{-# INLINE peekChar #-}

395432

396433-- | Match any character, to perform lookahead. Does not consume any

397434-- input, but will fail if end of input has been reached.

398435peekChar' :: Parser Char

399436peekChar' = do

400− s <- ensure 1

401− return $! unsafeHead s

437+ (_,s) <- ensure 1

438+ return $! T.unsafeHead s

402439{-# INLINE peekChar' #-}

403440

404441-- | Match either a single newline character @\'\\n\'@, or a carriage

@@ -408,23 +445,105 @@ endOfLine = (char '\n' >> return ()) <|> (string "\r\n" >> return ())

408445

409446-- | Terminal failure continuation.

410447failK :: Failure a

411−failK i0 _a0 _m0 stack msg = Fail (unI i0) stack msg

448+failK t (Pos pos) _more stack msg = Fail (Buf.dropWord16 pos t) stack msg

412449{-# INLINE failK #-}

413450

414451-- | Terminal success continuation.

415452successK :: Success a a

416−successK i0 _a0 _m0 a = Done (unI i0) a

453+successK t (Pos pos) _more a = Done (Buf.dropWord16 pos t) a

417454{-# INLINE successK #-}

418455

419456-- | Run a parser.

420457parse :: Parser a -> Text -> Result a

421−parse m s = runParser m (I s) mempty Incomplete failK successK

458+parse m s = runParser m (buffer s) 0 Incomplete failK successK

422459{-# INLINE parse #-}

423460

424461-- | 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+-- @

425470parseOnly :: Parser a -> Text -> Either String a

426−parseOnly m s = case runParser m (I s) mempty Complete failK successK of

427− Fail _ _ err -> Left err

428− Done _ a -> Right a

429− _ -> 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!"

430476{-# INLINE parseOnly #-}

477+

478+get :: Parser Text

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

480+ succ t pos more (Buf.dropWord16 (fromPos pos) t)

481+{-# INLINE get #-}

482+

483+endOfChunk :: Parser Bool

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

485+ succ t pos more (pos == lengthOf t)

486+{-# INLINE endOfChunk #-}

487+

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+

498+advance :: Pos -> Parser ()

499+advance n = T.Parser $ \t pos more _lose succ -> succ t (pos+n) more ()

500+{-# INLINE advance #-}

501+

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

503+ -> Failure r -> Success (Pos, Text) r

504+ -> Result r

505+ensureSuspended n t pos more lose succ =

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

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

508+ case lengthAtLeast pos' n t' of

509+ Just n' -> succ' t' pos' more' (n', substring pos n' t')

510+ Nothing -> runParser (demandInput >> go) t' pos' more' lose' succ'

511+

512+-- | If at least @n@ elements of input are available, return the

513+-- current input, otherwise fail.

514+ensure :: Int -> Parser (Pos, Text)

515+ensure n = T.Parser $ \t pos more lose succ ->

516+ case lengthAtLeast pos n t of

517+ Just n' -> succ t pos more (n', substring pos n' t)

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

519+ Nothing -> ensureSuspended n t pos more lose succ

520+{-# INLINE ensure #-}

521+

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

523+-- that was consumed while it was being parsed.

524+match :: Parser a -> Parser (Text, a)

525+match p = T.Parser $ \t pos more lose succ ->

526+ let succ' t' pos' more' a = succ t' pos' more'

527+ (substring pos (pos'-pos) t', a)

528+ in runParser p t pos more lose succ'

529+

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

533+lengthAtLeast pos n t = go 0 (fromPos pos)

534+ where go i !p

535+ | i == n = Just (Pos p - pos)

536+ | p == len = Nothing

537+ | otherwise = go (i+1) (p + Buf.iter_ t p)

538+ Pos len = lengthOf t

539+{-# INLINE lengthAtLeast #-}

540+

541+substring :: Pos -> Pos -> Buffer -> Text

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

543+{-# INLINE substring #-}

544+

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+14−10

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

1+{-# LANGUAGE CPP #-}

2+#if __GLASGOW_HASKELL__ >= 702

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

4+#endif

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

17-- |

28-- Module : Data.Attoparsec.Text.Lazy

3−-- Copyright : Bryan O'Sullivan 2011

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

410-- License : BSD3

511--

612-- Maintainer : bos@serpentine.com

@@ -35,6 +41,7 @@ module Data.Attoparsec.Text.Lazy

3541 ) where

3642

3743import Control.DeepSeq (NFData(rnf))

44+import Data.List (intercalate)

3845import Data.Text.Lazy.Internal (Text(..), chunk)

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

4047import qualified Data.Attoparsec.Text as A

@@ -44,20 +51,16 @@ import Data.Attoparsec.Text hiding (IResult(..), Result, eitherResult,

4451

4552-- | The result of a parse.

4653data Result r = Fail Text [String] String

47− -- ^ The parse failed. The 'ByteString' is the input

54+ -- ^ The parse failed. The 'Text' is the input

4855 -- that had not yet been consumed when the failure

4956 -- occurred. The @[@'String'@]@ is a list of contexts

5057 -- in which the error occurred. The 'String' is the

5158 -- message describing the error, if any.

5259 | Done Text r

53− -- ^ The parse succeeded. The 'ByteString' is the

60+ -- ^ The parse succeeded. The 'Text' is the

5461 -- input that had not yet been consumed (if any) when

5562 -- the parse succeeded.

56−

57−instance Show r => Show (Result r) where

58− show (Fail bs stk msg) =

59− "Fail " ++ show bs ++ " " ++ show stk ++ " " ++ show msg

60− show (Done bs r) = "Done " ++ show bs ++ " " ++ show r

63+ deriving (Show)

6164

6265instance NFData r => NFData (Result r) where

6366 rnf (Fail bs ctxs msg) = rnf bs `seq` rnf ctxs `seq` rnf msg

@@ -93,5 +96,6 @@ maybeResult _ = Nothing

9396

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

9598eitherResult :: Result r -> Either String r

96−eitherResult (Done _ r) = Right r

97−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+2−2

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

11-- |

22-- Module : Data.Attoparsec.Types

3−-- Copyright : Bryan O'Sullivan 2011

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

44-- License : BSD3

55--

66-- Maintainer : bos@serpentine.com

@@ -14,7 +14,7 @@ module Data.Attoparsec.Types

1414 (

1515 Parser

1616 , IResult(..)

17− , Chunk(..)

17+ , Chunk(chunkElemToChar)

1818 ) where

1919

2020import 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 2011

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+108−30

@@ -1,12 +1,13 @@

11name: attoparsec

2−version: 0.11.3.1

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

@@ -18,19 +19,19 @@ description:

1819 file formats.

1920extra-source-files:

2021 README.markdown

22+ benchmarks/*.cabal

2123 benchmarks/*.hs

2224 benchmarks/*.txt

25+ benchmarks/json-data/*.json

2326 benchmarks/Makefile

24− benchmarks/attoparsec-benchmarks.cabal

2527 benchmarks/med.txt.bz2

2628 changelog.md

2729 examples/*.c

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,12 +40,21 @@ Flag developer

3940

4041library

4142 build-depends: array,

42− base >= 3 && < 5,

43+ base >= 4.3 && < 5,

4344 bytestring,

4445 containers,

4546 deepseq,

46− text >= 0.11.3.1,

47− scientific >= 0.2 && < 0.3

47+ scientific >= 0.3.1 && < 0.4,

48+ transformers >= 0.2 && (< 0.4 || >= 0.4.1.0) && < 0.6,

49+ text >= 1.1.1.3

50+ if impl(ghc < 7.4)

51+ build-depends:

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

4858

4959 exposed-modules: Data.Attoparsec

5060 Data.Attoparsec.ByteString

@@ -52,65 +62,133 @@ library

5262 Data.Attoparsec.ByteString.Lazy

5363 Data.Attoparsec.Char8

5464 Data.Attoparsec.Combinator

65+ Data.Attoparsec.Internal

66+ Data.Attoparsec.Internal.Types

5567 Data.Attoparsec.Lazy

5668 Data.Attoparsec.Number

5769 Data.Attoparsec.Text

5870 Data.Attoparsec.Text.Lazy

5971 Data.Attoparsec.Types

6072 Data.Attoparsec.Zepto

61− other-modules: Data.Attoparsec.ByteString.FastSet

73+ other-modules: Data.Attoparsec.ByteString.Buffer

74+ Data.Attoparsec.ByteString.FastSet

6275 Data.Attoparsec.ByteString.Internal

63− Data.Attoparsec.Internal

64− Data.Attoparsec.Internal.Types

76+ Data.Attoparsec.Internal.Fhthagn

77+ Data.Attoparsec.Text.Buffer

6578 Data.Attoparsec.Text.FastSet

6679 Data.Attoparsec.Text.Internal

6780 ghc-options: -O2 -Wall

6881

6982 if flag(developer)

7083 ghc-prof-options: -auto-all

84+ ghc-options: -Werror

7185

7286test-suite tests

7387 type: exitcode-stdio-1.0

74− hs-source-dirs: tests

88+ hs-source-dirs: tests .

7589 main-is: QC.hs

76− other-modules: QC.ByteString

90+ other-modules: QC.Buffer

91+ QC.ByteString

92+ QC.Combinator

93+ QC.Common

94+ QC.IPv6.Internal

95+ QC.IPv6.Types

96+ QC.Rechunked

97+ QC.Simple

7798 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

78119

79120 ghc-options:

80121 -Wall -threaded -rtsopts

81122

123+ if flag(developer)

124+ ghc-options: -Werror

125+

82126 build-depends:

83− attoparsec,

84− base >= 4 && < 5,

127+ array,

128+ base,

85129 bytestring,

86− QuickCheck >= 2.4,

87− test-framework >= 0.4,

88− test-framework-quickcheck2 >= 0.2,

89− 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

90144

91145benchmark benchmarks

92146 type: exitcode-stdio-1.0

93− hs-source-dirs: benchmarks

94− ghc-options: -O2 -Wall

147+ hs-source-dirs: benchmarks benchmarks/warp-3.0.1.1 .

148+ ghc-options: -O2 -Wall -rtsopts

95149 main-is: Benchmarks.hs

96150 other-modules:

151+ Common

97152 HeadersByteString

153+ HeadersByteString.Atto

98154 HeadersText

99155 Links

156+ Network.Wai.Handler.Warp.ReadInt

157+ Network.Wai.Handler.Warp.RequestHeader

100158 Numbers

159+ Sets

160+ TextFastSet

161+ Warp

162+ ghc-options: -O2 -Wall

163+

164+ if flag(developer)

165+ ghc-options: -Werror

166+

101167 build-depends:

102− attoparsec,

103− base,

104− bytestring,

105− criterion >= 0.5,

168+ array,

169+ base == 4.*,

170+ bytestring >= 0.10.4.0,

171+ case-insensitive,

172+ containers,

173+ criterion >= 1.0,

106174 deepseq >= 1.1,

175+ directory,

176+ filepath,

177+ ghc-prim,

178+ http-types,

107179 parsec >= 3.1.2,

108− text

180+ scientific,

181+ text >= 1.1.1.0,

182+ transformers >= 0.2 && (< 0.4 || >= 0.4.1.0) && < 0.6,

183+ unordered-containers,

184+ vector

185+

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

109190

110191source-repository head

111192 type: git

112193 location: https://github.com/bos/attoparsec

113194

114−source-repository head

115− type: mercurial

116− 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+16−17

@@ -1,17 +1,19 @@

11{-# LANGUAGE BangPatterns, CPP #-}

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

3+import Common ()

44import Control.Applicative (many)

5−import Control.DeepSeq (NFData(rnf))

65import Criterion.Main (bench, bgroup, defaultMain, nf)

76import Data.Bits

87import Data.Char (isAlpha)

98import Data.Word (Word32)

109import Data.Word (Word8)

1110import Numbers (numbers)

11+import 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,21 +28,7 @@ import qualified HeadersByteString

2628import qualified HeadersText

2729import qualified Links

2830import qualified Text.Parsec as P

29−

30−#if !MIN_VERSION_bytestring(0,10,0)

31−import Data.ByteString.Internal (ByteString(..))

32−instance NFData ByteString where

33− rnf (PS _ _ _) = ()

34−#endif

35−

36−instance NFData P.ParseError where

37− rnf = rnf . show

38−

39−chunksOf :: Int -> [a] -> [[a]]

40−chunksOf k = go

41− where go xs = case splitAt k xs of

42− ([],_) -> []

43− (y, ys) -> y : go ys

31+import qualified Sets

4432

4533main :: IO ()

4634main = do

@@ -83,6 +71,14 @@ main = do

8371 , bench "isAlpha_ascii" $ nf (ABL.parse (AC.takeWhile AC.isAlpha_ascii)) bl

8472 , bench "isAlpha_iso8859_15" $

8573 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

76+ ]

77+ , bgroup "takeWhile1" [

78+ bench "isAlpha" $ nf (ABL.parse (AC.takeWhile1 isAlpha)) bl

79+ , 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

8682 ]

8783 , bench "word32LE" $ nf (AB.parse word32LE) b

8884 , bgroup "scan" [

@@ -90,10 +86,13 @@ main = do

9086 , bench "long" $ nf (AB.parse quotedString) b

9187 ]

9288 , aeson

89+ , Genome.genome

9390 , headersBS

9491 , headersT

9592 , Links.links

9693 , numbers

94+ , Sets.benchmarks

95+ , Warp.benchmarks

9796 ]

9897

9998-- Benchmarks bind and (potential) bounds-check merging.

benchmarks/Common.hsnew file+47

@@ -0,0 +1,47 @@

1+{-# LANGUAGE CPP #-}

2+{-# OPTIONS_GHC -fno-warn-orphans #-}

4+module Common (

5+ chunksOf

6+ , pathTo

7+ , rechunkBS

8+ , rechunkT

9+ ) where

10+

11+import Control.DeepSeq (NFData(rnf))

12+import System.Directory (doesDirectoryExist)

13+import System.FilePath ((</>))

14+import Text.Parsec (ParseError)

15+import qualified Data.ByteString as B

16+import qualified Data.ByteString.Lazy as BL

17+import qualified Data.Text as T

18+import qualified Data.Text.Lazy as TL

19+

20+#if !MIN_VERSION_bytestring(0,10,0)

21+import Data.ByteString.Internal (ByteString(..))

22+

23+instance NFData ByteString where

24+ rnf (PS _ _ _) = ()

25+#endif

26+

27+instance NFData ParseError where

28+ rnf = rnf . show

29+

30+chunksOf :: Int -> [a] -> [[a]]

31+chunksOf k = go

32+ where go xs = case splitAt k xs of

33+ ([],_) -> []

34+ (y, ys) -> y : go ys

35+

36+rechunkBS :: Int -> B.ByteString -> BL.ByteString

37+rechunkBS n = BL.fromChunks . map B.pack . chunksOf n . B.unpack

38+

39+rechunkT :: Int -> T.Text -> TL.Text

40+rechunkT 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+27−36

@@ -1,46 +1,37 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

31module HeadersByteString (headers) where

5−import Control.Applicative

6−import Criterion.Main (bench, bgroup, nf)

3+import Common (pathTo, rechunkBS)

4+import Criterion.Main (bench, bgroup, nf, nfIO)

75import Criterion.Types (Benchmark)

6+import HeadersByteString.Atto (request, response)

7+import Network.Wai.Handler.Warp.RequestHeader (parseHeaderLines)

88import qualified Data.Attoparsec.ByteString.Char8 as B

9+import qualified Data.Attoparsec.ByteString.Lazy as BL

910import qualified Data.ByteString.Char8 as B

1011

11−header = do

12− name <- B.takeWhile1 (B.inClass "a-zA-Z0-9_-") <* B.char ':' <* B.skipSpace

13− body <- (:) <$> bodyLine <*> many (B.takeWhile1 B.isSpace *> bodyLine)

14− return (name, body)

15−

16−bodyLine = B.takeTill (\c -> c == '\r' || c == '\n') <* B.endOfLine

17−

18−requestLine =

19− (,,) <$>

20− (method <* B.skipSpace) <*>

21− (B.takeTill B.isSpace <* B.skipSpace) <*>

22− httpVersion

23− where method = "GET" <|> "POST"

24−

25−httpVersion = "HTTP/" *> ((,) <$> (int <* B.char '.') <*> int)

26−

27−responseLine = (,,) <$>

28− (httpVersion <* B.skipSpace) <*>

29− (int <* B.skipSpace) <*>

30− bodyLine

31−

32−int :: B.Parser Int

33−int = B.decimal

34−

35−request = (,) <$> (requestLine <* B.endOfLine) <*> many header

36−

37−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.

3820

3921headers :: IO Benchmark

4022headers = do

41− req <- B.readFile "http-request.txt"

42− resp <- B.readFile "http-response.txt"

43− return $ bgroup "headersBS" [

44− bench "request" $ nf (B.parseOnly request) req

45− , bench "response" $ nf (B.parseOnly response) resp

23+ req <- B.readFile =<< pathTo "http-request.txt"

24+ resp <- B.readFile =<< pathTo "http-response.txt"

25+ let reql = rechunkBS 4 req

26+ respl = rechunkBS 4 resp

27+ return $ bgroup "headers" [

28+ bgroup "B" [

29+ bench "request" $ nf (B.parseOnly request) req

30+ , bench "warp" $ nfIO (parseHeaderLines (B.split '\n' req))

31+ , bench "response" $ nf (B.parseOnly response) resp

32+ ]

33+ , bgroup "BL" [

34+ bench "request" $ nf (BL.parse request) reql

35+ , bench "response" $ nf (BL.parse response) respl

36+ ]

4637 ]

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+15−5

@@ -2,11 +2,13 @@

22{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

33module HeadersText (headers) where

5+import Common (pathTo, rechunkT)

56import Control.Applicative

67import Criterion.Main (bench, bgroup, nf)

78import Criterion.Types (Benchmark)

89import Data.Char (isSpace)

910import qualified Data.Attoparsec.Text as T

11+import qualified Data.Attoparsec.Text.Lazy as TL

1012import qualified Data.Text.IO as T

1113

1214header = do

@@ -39,9 +41,17 @@ response = (,) <$> responseLine <*> many header

3941

4042headers :: IO Benchmark

4143headers = do

42− req <- T.readFile "http-request.txt"

43− resp <- T.readFile "http-response.txt"

44− return $ bgroup "headersT" [

45− bench "request" $ nf (T.parseOnly request) req

46− , bench "response" $ nf (T.parseOnly response) resp

44+ req <- T.readFile =<< pathTo "http-request.txt"

45+ resp <- T.readFile =<< pathTo "http-response.txt"

46+ let reql = rechunkT 4 req

47+ respl = rechunkT 4 resp

48+ return $ bgroup "headers" [

49+ bgroup "T" [

50+ bench "request" $ nf (T.parseOnly request) req

51+ , bench "response" $ nf (T.parseOnly response) resp

52+ ]

53+ , bgroup "TL" [

54+ bench "request" $ nf (TL.parse request) reql

55+ , bench "response" $ nf (TL.parse response) respl

56+ ]

4757 ]

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+15−4

@@ -9,22 +9,33 @@ build-type: Simple

99executable attoparsec-benchmarks

1010 main-is: Benchmarks.hs

1111 other-modules:

12+ Common

1213 HeadersByteString

14+ HeadersByteString.Atto

1315 HeadersText

1416 Links

1517 Numbers

16− hs-source-dirs: .. .

17− 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

1824 build-depends:

1925 array,

2026 base == 4.*,

2127 bytestring >= 0.10.4.0,

22− criterion >= 0.5,

28+ case-insensitive,

29+ containers,

30+ criterion >= 1.0,

2331 deepseq >= 1.1,

2432 directory,

2533 filepath,

34+ ghc-prim,

35+ http-types,

2636 parsec >= 3.1.2,

27− scientific,

37+ scientific >= 0.3.1,

2838 text >= 1.1.1.0,

39+ transformers,

2940 unordered-containers,

3041 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+93

@@ -1,3 +1,96 @@

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+

72+0.12.0.0

73+

74+* A new internal representation makes almost all real-world parsers

75+ faster, sometimes by big margins. For example, parsing JSON data

76+ with aeson is now up to 70% faster. These performance improvements

77+ also come with reduced memory consumption and some new capabilities.

78+

79+* The new match combinator gives both the result of a parse and the

80+ input that it matched.

81+

82+* The test suite has doubled in size. This made it possible to switch

83+ to the new internal representation with a decent degree of

84+ confidence that everything was more or less working.

85+

86+* The benchmark suite now contains a small family of benchmarks taken

87+ from real-world uses of attoparsec.

88+

89+* A few types that ought to have been private now are.

90+

91+* A few obsolete modules and functions have been marked as deprecated.

92+ They will be removed from the next major release.

93+

1940.11.3.0

295

396* New function scientific is compatible with rational, but parses

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+8−2

@@ -1,13 +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

6+import qualified QC.Combinator as Combinator

7+import qualified QC.Simple as Simple

58import qualified QC.Text as Text

6−import Test.Framework (defaultMain, testGroup)

9+import Test.Tasty (defaultMain, testGroup)

710

811main = defaultMain tests

912

10−tests = [

13+tests = testGroup "tests" [

1114 testGroup "bs" ByteString.tests

15+ , testGroup "buf" Buffer.tests

16+ , testGroup "combinator" Combinator.tests

17+ , testGroup "simple" Simple.tests

1218 , testGroup "text" Text.tests

1319 ]

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+149−78

@@ -1,116 +1,187 @@

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

2−{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-orphans #-}

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

32module QC.ByteString (tests) where

5−import Control.Applicative ((<$>), (<*>))

6−import Prelude hiding (takeWhile)

7−import Test.Framework.Providers.QuickCheck2 (testProperty)

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

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

6+#endif

7+import Data.Char (chr, ord, toUpper)

8+import Data.Int (Int64)

9+import Data.Word (Word8)

10+import Prelude hiding (take, takeWhile)

11+import QC.Common (ASCII(..), liftOp, parseBS, toStrictBS)

12+import Test.Tasty (TestTree)

13+import Test.Tasty.QuickCheck (testProperty)

814import Test.QuickCheck

915import qualified Data.Attoparsec.ByteString as P

16+import qualified Data.Attoparsec.ByteString.Char8 as P8

17+import qualified Data.Attoparsec.ByteString.FastSet as S

1018import qualified Data.Attoparsec.ByteString.Lazy as PL

1119import qualified Data.ByteString as B

20+import qualified Data.ByteString.Char8 as B8

1221import qualified Data.ByteString.Lazy as L

13−

14−instance Arbitrary B.ByteString where

15− arbitrary = B.pack <$> arbitrary

16−

17−instance Arbitrary L.ByteString where

18− arbitrary = sized $ \n -> resize (round (sqrt (toEnum n :: Double)))

19− ((L.fromChunks . map (B.pack . nonEmpty)) <$> arbitrary)

20− where nonEmpty (NonEmpty a) = a

21−

22−-- Naming.

23−

24−{-

25−label (NonEmpty s) = case parse (anyWord8 <?> s) B.empty of

26− (_, Left err) -> s `isInfixOf` err

27− _ -> False

28−-}

22+import qualified Data.ByteString.Lazy.Char8 as L8

2923

3024-- Basic byte-level combinators.

3125

32−maybeP p = PL.maybeResult . PL.parse p

26+satisfy :: Word8 -> L.ByteString -> Property

27+satisfy w s = parseBS (P.satisfy (<=w)) (L.cons w s) === Just w

3328

34−defP p = PL.parse p

29+satisfyWith :: Word8 -> L.ByteString -> Property

30+satisfyWith w s = parseBS (P.satisfyWith (chr . fromIntegral) (<=c))

31+ (L.cons (fromIntegral (ord c)) s) === Just c

32+ where

33+ c = chr (fromIntegral w)

3534

36−satisfy w s = maybeP (P.satisfy (<=w)) (L.cons w s) == Just w

35+word8 :: Word8 -> L.ByteString -> Property

36+word8 w s = parseBS (P.word8 w) (L.cons w s) === Just w

3737

38−word8 w s = maybeP (P.word8 w) (L.cons w s) == Just w

38+skip :: Word8 -> L.ByteString -> Property

39+skip w s =

40+ case (parseBS (P.skip (<w)) s, L.uncons s) of

41+ (Nothing, mcs) -> maybe (property True) (expectFailure . it) mcs

42+ (Just _, mcs) -> maybe (property False) it mcs

43+ where it cs = liftOp "<" (<) (fst cs) w

3944

45+anyWord8 :: L.ByteString -> Property

4046anyWord8 s

41− | L.null s = p == Nothing

42− | otherwise = p == Just (L.head s)

43− where p = maybeP P.anyWord8 s

44−

45−notWord8 w (NonEmpty s) = maybeP (P.notWord8 w) bs == if v == w

46− then Nothing

47− else Just v

47+ | L.null s = p === Nothing

48+ | otherwise = p === Just (L.head s)

49+ where p = parseBS P.anyWord8 s

50+

51+notWord8 :: Word8 -> NonEmptyList Word8 -> Property

52+notWord8 w (NonEmpty s) = parseBS (P.notWord8 w) bs === if v == w

53+ then Nothing

54+ else Just v

4855 where v = L.head bs

4956 bs = L.pack s

5057

58+peekWord8 :: L.ByteString -> Property

5159peekWord8 s

52− | L.null s = p == Just (Nothing, s)

53− | otherwise = p == Just (Just (L.head s), s)

54− where p = maybeP ((,) <$> P.peekWord8 <*> P.takeLazyByteString) s

55−

56−string s t = maybeP (P.string s') (s `L.append` t) == Just s'

57− where s' = toStrict s

58−

59−toStrict = B.concat . L.toChunks

60−

60+ | L.null s = p === Just (Nothing, s)

61+ | otherwise = p === Just (Just (L.head s), s)

62+ where p = parseBS ((,) <$> P.peekWord8 <*> P.takeLazyByteString) s

63+

64+peekWord8' :: L.ByteString -> Property

65+peekWord8' s = parseBS P.peekWord8' s === (fst <$> L.uncons s)

66+

67+string :: L.ByteString -> L.ByteString -> Property

68+string s t = parseBS (P.string s') (s `L.append` t) === Just s'

69+ where s' = toStrictBS s

70+

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+

83+skipWhile :: Word8 -> L.ByteString -> Property

6184skipWhile w s =

6285 let t = L.dropWhile (<=w) s

63− in case defP (P.skipWhile (<=w)) s of

64− PL.Done t' () -> t == t'

65− _ -> False

86+ in case PL.parse (P.skipWhile (<=w)) s of

87+ PL.Done t' () -> t === t'

88+ _ -> property False

6689

90+takeCount :: Positive Int -> L.ByteString -> Property

6791takeCount (Positive k) s =

68− case maybeP (P.take k) s of

69− Nothing -> fromIntegral k > L.length s

70− Just _ -> fromIntegral k <= L.length s

92+ case parseBS (P.take k) s of

93+ Nothing -> liftOp ">" (>) (fromIntegral k) (L.length s)

94+ Just _s -> liftOp "<=" (<=) (fromIntegral k) (L.length s)

7195

96+takeWhile :: Word8 -> L.ByteString -> Property

7297takeWhile w s =

7398 let (h,t) = L.span (==w) s

74− in case defP (P.takeWhile (==w)) s of

75− PL.Done t' h' -> t == t' && toStrict h == h'

76− _ -> False

99+ in case PL.parse (P.takeWhile (==w)) s of

100+ PL.Done t' h' -> t === t' .&&. toStrictBS h === h'

101+ _ -> property False

77102

103+take :: Int -> L.ByteString -> Property

104+take n s = maybe (property $ L.length s < fromIntegral n)

105+ (=== B.take n (toStrictBS s)) $

106+ parseBS (P.take n) s

107+

108+takeByteString :: L.ByteString -> Property

109+takeByteString s = maybe (property False) (=== toStrictBS s) .

110+ parseBS P.takeByteString $ s

111+

112+takeLazyByteString :: L.ByteString -> Property

113+takeLazyByteString s = maybe (property False) (=== s) .

114+ parseBS P.takeLazyByteString $ s

115+

116+takeWhile1 :: Word8 -> L.ByteString -> Property

78117takeWhile1 w s =

79118 let s' = L.cons w s

80119 (h,t) = L.span (<=w) s'

81− in case defP (P.takeWhile1 (<=w)) s' of

82− PL.Done t' h' -> t == t' && toStrict h == h'

83− _ -> False

120+ in case PL.parse (P.takeWhile1 (<=w)) s' of

121+ PL.Done t' h' -> t === t' .&&. toStrictBS h === h'

122+ _ -> property False

84123

124+takeTill :: Word8 -> L.ByteString -> Property

85125takeTill w s =

86126 let (h,t) = L.break (==w) s

87− in case defP (P.takeTill (==w)) s of

88− PL.Done t' h' -> t == t' && toStrict h == h'

89− _ -> False

90−

91−takeWhile1_empty = maybeP (P.takeWhile1 undefined) L.empty == Nothing

92−

93−endOfInput s = maybeP P.endOfInput s == if L.null s

94− then Just ()

95− else Nothing

96−

97−scan s (Positive k) = maybeP p s == (Just $ toStrict $ L.take k s)

127+ in case PL.parse (P.takeTill (==w)) s of

128+ PL.Done t' h' -> t === t' .&&. toStrictBS h === h'

129+ _ -> property False

130+

131+takeWhile1_empty :: Property

132+takeWhile1_empty = parseBS (P.takeWhile1 undefined) L.empty === Nothing

133+

134+endOfInput :: L.ByteString -> Property

135+endOfInput s = parseBS P.endOfInput s === if L.null s

136+ then Just ()

137+ else Nothing

138+

139+endOfLine :: L.ByteString -> Property

140+endOfLine s =

141+ case (parseBS P8.endOfLine s, L8.uncons s) of

142+ (Nothing, mcs) -> maybe (property True) (expectFailure . eol) mcs

143+ (Just _, mcs) -> maybe (property False) eol mcs

144+ where eol (c,s') = c === '\n' .||.

145+ (c, fst <$> L8.uncons s') === ('\r', Just '\n')

146+

147+scan :: L.ByteString -> Positive Int64 -> Property

148+scan s (Positive k) = parseBS p s === Just (toStrictBS $ L.take k s)

98149 where p = P.scan k $ \ n _ ->

99150 if n > 0 then let !n' = n - 1 in Just n' else Nothing

100151

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]

101161tests = [

102− testProperty "satisfy" satisfy,

103− testProperty "word8" word8,

104− testProperty "notWord8" notWord8,

105− testProperty "anyWord8" anyWord8,

106− testProperty "peekWord8" peekWord8,

107− testProperty "string" string,

108− testProperty "skipWhile" skipWhile,

109− testProperty "takeCount" takeCount,

110− testProperty "takeWhile" takeWhile,

111− testProperty "takeWhile1" takeWhile1,

112− testProperty "takeWhile1_empty" takeWhile1_empty,

113− testProperty "takeTill" takeTill,

114− testProperty "endOfInput" endOfInput,

115− testProperty "scan" scan

162+ testProperty "anyWord8" anyWord8

163+ , testProperty "endOfInput" endOfInput

164+ , testProperty "endOfLine" endOfLine

165+ , testProperty "notWord8" notWord8

166+ , testProperty "peekWord8" peekWord8

167+ , testProperty "peekWord8'" peekWord8'

168+ , testProperty "satisfy" satisfy

169+ , testProperty "satisfyWith" satisfyWith

170+ , testProperty "scan" scan

171+ , testProperty "skip" skip

172+ , testProperty "skipWhile" skipWhile

173+ , testProperty "string" string

174+ , testProperty "stringCI" stringCI

175+ , testProperty "strings" strings

176+ , testProperty "take" take

177+ , testProperty "takeByteString" takeByteString

178+ , testProperty "takeCount" takeCount

179+ , testProperty "takeLazyByteString" takeLazyByteString

180+ , testProperty "takeTill" takeTill

181+ , testProperty "takeWhile" takeWhile

182+ , testProperty "takeWhile1" takeWhile1

183+ , testProperty "takeWhile1_empty" takeWhile1_empty

184+ , testProperty "word8" word8

185+ , testProperty "members" members

186+ , testProperty "nonmembers" nonmembers

116187 ]

tests/QC/Combinator.hsnew file+52

@@ -0,0 +1,52 @@

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

3+module QC.Combinator where

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

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

7+#endif

8+import Data.Maybe (fromJust, isJust)

9+import Data.Word (Word8)

10+import QC.Common (Repack, parseBS, repackBS, toLazyBS)

11+import Test.Tasty (TestTree)

12+import Test.Tasty.QuickCheck (testProperty)

13+import Test.QuickCheck

14+import qualified Data.Attoparsec.ByteString.Char8 as P

15+import qualified Data.Attoparsec.Combinator as C

16+import qualified Data.ByteString as B

17+import qualified Data.ByteString.Char8 as B8

18+

19+choice :: NonEmptyList (NonEmptyList Word8) -> Gen Property

20+choice (NonEmpty xs) = do

21+ let ys = map (B.pack . getNonEmpty) xs

22+ return . forAll (repackBS <$> arbitrary <*> elements ys) $

23+ maybe False (`elem` ys) . parseBS (C.choice (map P.string ys))

24+

25+count :: Positive (Small Int) -> Repack -> B.ByteString -> Bool

26+count (Positive (Small n)) rs s =

27+ (length <$> parseBS (C.count n (P.string s)) input) == Just n

28+ where input = repackBS rs (B.concat (replicate (n+1) s))

29+

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+

37+match :: Int -> NonNegative Int -> NonNegative Int -> Repack -> Bool

38+match n (NonNegative x) (NonNegative y) rs =

39+ parseBS (P.match parser) (repackBS rs input) == Just (input, n)

40+ where parser = P.skipWhile (=='x') *> P.signed P.decimal <*

41+ P.skipWhile (=='y')

42+ input = B.concat [

43+ B8.replicate x 'x', B8.pack (show n), B8.replicate y 'y'

44+ ]

45+

46+tests :: [TestTree]

47+tests = [

48+ testProperty "choice" choice

49+ , testProperty "count" count

50+ , testProperty "lookAhead" lookAhead

51+ , testProperty "match" match

52+ ]

tests/QC/Common.hsnew file+113

@@ -0,0 +1,113 @@

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

2+{-# OPTIONS_GHC -fno-warn-orphans #-}

3+module QC.Common

4+ (

5+ ASCII(..)

6+ , parseBS

7+ , parseT

8+ , toLazyBS

9+ , toStrictBS

10+ , Repack

11+ , repackBS

12+ , repackBS_

13+ , repackT

14+ , repackT_

15+ , liftOp

16+ ) where

17+

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

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

20+#endif

21+import Data.Char (isAlpha)

22+import Test.QuickCheck

23+import Test.QuickCheck.Unicode (shrinkChar, string)

24+import qualified Data.ByteString as B

25+import qualified Data.ByteString.Lazy as BL

26+import qualified Data.Text as T

27+import qualified Data.Text.Lazy as TL

28+import qualified Data.Attoparsec.ByteString.Lazy as BL

29+import qualified Data.Attoparsec.Text.Lazy as TL

30+

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+

41+parseBS :: BL.Parser r -> BL.ByteString -> Maybe r

42+parseBS p = BL.maybeResult . BL.parse p

43+

44+parseT :: TL.Parser r -> TL.Text -> Maybe r

45+parseT p = TL.maybeResult . TL.parse p

46+

47+toStrictBS :: BL.ByteString -> B.ByteString

48+toStrictBS = B.concat . BL.toChunks

49+

50+toLazyBS :: B.ByteString -> BL.ByteString

51+toLazyBS = BL.fromChunks . (:[])

52+

53+instance Arbitrary B.ByteString where

54+ arbitrary = B.pack <$> arbitrary

55+ shrink = map B.pack . shrink . B.unpack

56+

57+instance Arbitrary BL.ByteString where

58+ 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

71+

72+type Repack = NonEmptyList (Positive (Small Int))

73+

74+repackBS :: Repack -> B.ByteString -> BL.ByteString

75+repackBS (NonEmpty bs) =

76+ BL.fromChunks . repackBS_ (map (getSmall . getPositive) bs)

77+

78+repackBS_ :: [Int] -> B.ByteString -> [B.ByteString]

79+repackBS_ = go . cycle

80+ where go (b:bs) s

81+ | B.null s = []

82+ | otherwise = let (h,t) = B.splitAt b s

83+ in h : go bs t

84+ go _ _ = error "unpossible"

85+

86+instance Arbitrary T.Text where

87+ arbitrary = T.pack <$> string

88+ shrink = map T.pack . shrinkList shrinkChar . T.unpack

89+

90+instance Arbitrary TL.Text where

91+ arbitrary = TL.pack <$> string

92+ shrink = map TL.pack . shrinkList shrinkChar . TL.unpack

93+

94+repackT :: Repack -> T.Text -> TL.Text

95+repackT (NonEmpty bs) =

96+ TL.fromChunks . repackT_ (map (getSmall . getPositive) bs)

97+

98+repackT_ :: [Int] -> T.Text -> [T.Text]

99+repackT_ = go . cycle

100+ where go (b:bs) s

101+ | T.null s = []

102+ | otherwise = let (h,t) = T.splitAt b s

103+ in h : go bs t

104+ go _ _ = error "unpossible"

105+

106+liftOp :: (Show a, Testable prop) =>

107+ String -> (a -> a -> prop) -> a -> a -> Property

108+liftOp name f x y = counterexample desc (f x y)

109+ where op = case name of

110+ (c:_) | isAlpha c -> " `" ++ name ++ "` "

111+ | otherwise -> " " ++ name ++ " "

112+ _ -> " ??? "

113+ desc = "not (" ++ show x ++ op ++ show y ++ ")"

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+151−74

@@ -1,65 +1,86 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-orphans #-}

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

2+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}

33module QC.Text (tests) where

5−import Control.Applicative ((<$>), (<*>))

6−import Prelude hiding (takeWhile)

7−import Test.Framework.Providers.QuickCheck2 (testProperty)

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

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

7+#endif

8+import Data.Int (Int64)

9+import Data.Word (Word8)

10+import Prelude hiding (take, takeWhile)

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)

816import Test.QuickCheck

9−import qualified Data.Char as Char

1017import qualified Data.Attoparsec.Text as P

1118import qualified Data.Attoparsec.Text.Lazy as PL

19+import qualified Data.Attoparsec.Text.FastSet as S

20+import qualified Data.ByteString as BS

21+import qualified Data.Char as Char

1222import qualified Data.Text as T

23+import qualified Data.Text.Encoding as TE

1324import qualified Data.Text.Lazy as L

1425

15−instance Arbitrary T.Text where

16− arbitrary = T.pack <$> arbitrary

17−

18−instance Arbitrary L.Text where

19− arbitrary = sized $ \n -> resize (round (sqrt (toEnum n :: Double)))

20− ((L.fromChunks . map (T.pack . nonEmpty)) <$> arbitrary)

21− where nonEmpty (NonEmpty a) = a

22−

23−-- Naming.

24−

25−{-

26−label (NonEmpty s) = case parse (anyChar <?> s) T.empty of

27− (_, Left err) -> s `isInfixOf` err

28− _ -> False

29−-}

30−

3126-- Basic byte-level combinators.

3227

33−maybeP p = PL.maybeResult . PL.parse p

28+satisfy :: Char -> L.Text -> Property

29+satisfy w s = parseT (P.satisfy (<=w)) (L.cons w s) === Just w

3430

35−defP p = PL.parse p

31+satisfyWith :: Char -> L.Text -> Property

32+satisfyWith c s = parseT (P.satisfyWith id (<=c)) (L.cons c s) === Just c

3633

37−satisfy w s = maybeP (P.satisfy (<=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

3836

39−char w s = maybeP (P.char w) (L.cons w s) == Just w

37+skip :: Char -> L.Text -> Property

38+skip w s =

39+ case (parseT (P.skip (<w)) s, L.uncons s) of

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

4043

44+anyChar :: L.Text -> Property

4145anyChar s

42− | L.null s = p == Nothing

43− | otherwise = p == Just (L.head s)

44− where p = maybeP P.anyChar s

46+ | L.null s = p === Nothing

47+ | otherwise = p === Just (L.head s)

48+ where p = parseT P.anyChar s

4549

46−notChar w (NonEmpty s) = maybeP (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

4752 then Nothing

4853 else Just v

4954 where v = L.head bs

5055 bs = L.pack s

5156

57+peekChar :: L.Text -> Property

5258peekChar s

53− | L.null s = p == Just (Nothing, s)

54− | otherwise = p == Just (Just (L.head s), s)

55− where p = maybeP ((,) <$> P.peekChar <*> P.takeLazyText) s

59+ | L.null s = p === Just (Nothing, s)

60+ | otherwise = p === Just (Just (L.head s), s)

61+ where p = parseT ((,) <$> P.peekChar <*> P.takeLazyText) s

62+

63+peekChar' :: L.Text -> Property

64+peekChar' s = parseT P.peekChar' s === (fst <$> L.uncons s)

5665

57−string s t = maybeP (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'

5868 where s' = toStrict s

5969

60−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

6180 where fs = T.toCaseFold s

81+ s = TE.decodeLatin1 (BS.pack ws)

6282

83+asciiCI :: T.Text -> Gen Bool

6384asciiCI x =

6485 (\s i -> P.parseOnly (P.asciiCI s) i == Right i)

6586 <$> maybeModifyCase x

@@ -69,58 +90,114 @@ asciiCI x =

6990 toLower = T.map (\c -> if c < Char.chr 127 then Char.toLower c else c)

7091 toUpper = T.map (\c -> if c < Char.chr 127 then Char.toUpper c else c)

7192

93+toStrict :: L.Text -> T.Text

7294toStrict = T.concat . L.toChunks

7395

96+skipWhile :: Char -> L.Text -> Property

7497skipWhile w s =

7598 let t = L.dropWhile (<=w) s

76− in case defP (P.skipWhile (<=w)) s of

77− PL.Done t' () -> t == t'

78− _ -> False

99+ in case PL.parse (P.skipWhile (<=w)) s of

100+ PL.Done t' () -> t === t'

101+ _ -> property False

102+

103+take :: Int -> L.Text -> Property

104+take n s = maybe (liftOp "<" (<) (L.length s) (fromIntegral n))

105+ (=== T.take n (toStrict s)) $

106+ parseT (P.take n) s

107+

108+takeText :: L.Text -> Property

109+takeText s = maybe (property False) (=== toStrict s) . parseT P.takeText $ s

110+

111+takeLazyText :: L.Text -> Property

112+takeLazyText s = maybe (property False) (=== s) . parseT P.takeLazyText $ s

79113

114+takeCount :: Positive Int -> L.Text -> Property

80115takeCount (Positive k) s =

81− case maybeP (P.take k) s of

82− Nothing -> fromIntegral k > L.length s

83− Just s' -> fromIntegral k <= L.length s

116+ case parseT (P.take k) s of

117+ Nothing -> liftOp ">" (>) (fromIntegral k) (L.length s)

118+ Just _s -> liftOp "<=" (<=) (fromIntegral k) (L.length s)

84119

120+takeWhile :: Char -> L.Text -> Property

85121takeWhile w s =

86122 let (h,t) = L.span (==w) s

87− in case defP (P.takeWhile (==w)) s of

88− PL.Done t' h' -> t == t' && toStrict h == h'

89− _ -> False

123+ in case PL.parse (P.takeWhile (==w)) s of

124+ PL.Done t' h' -> t === t' .&&. toStrict h === h'

125+ _ -> property False

90126

127+takeWhile1 :: Char -> L.Text -> Property

91128takeWhile1 w s =

92− let s' = L.cons w s

93− (h,t) = L.span (<=w) s'

94− in case defP (P.takeWhile1 (<=w)) s' of

95− PL.Done t' h' -> t == t' && toStrict h == h'

96− _ -> False

129+ let s' = L.cons w s

130+ (h,t) = L.span (<=w) s'

131+ in case PL.parse (P.takeWhile1 (<=w)) s' of

132+ PL.Done t' h' -> t === t' .&&. toStrict h === h'

133+ _ -> property False

97134

135+takeTill :: Char -> L.Text -> Property

98136takeTill w s =

99137 let (h,t) = L.break (==w) s

100− in case defP (P.takeTill (==w)) s of

101− PL.Done t' h' -> t == t' && toStrict h == h'

102− _ -> False

103−

104−takeWhile1_empty = maybeP (P.takeWhile1 undefined) L.empty == Nothing

105−

106−endOfInput s = maybeP P.endOfInput s == if L.null s

107− then Just ()

108− else Nothing

109−

138+ in case PL.parse (P.takeTill (==w)) s of

139+ PL.Done t' h' -> t === t' .&&. toStrict h === h'

140+ _ -> property False

141+

142+takeWhile1_empty :: Property

143+takeWhile1_empty = parseT (P.takeWhile1 undefined) L.empty === Nothing

144+

145+endOfInput :: L.Text -> Property

146+endOfInput s = parseT P.endOfInput s === if L.null s

147+ then Just ()

148+ else Nothing

149+

150+endOfLine :: L.Text -> Property

151+endOfLine s =

152+ case (parseT P.endOfLine s, L.uncons s) of

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)

162+ where p = P.scan k $ \ n _ ->

163+ if n > 0 then let !n' = n - 1 in Just n' else Nothing

164+

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]

110174tests = [

111− testProperty "satisfy" satisfy,

112− testProperty "char" char,

113− testProperty "notChar" notChar,

114− testProperty "anyChar" anyChar,

115− testProperty "peekChar" peekChar,

116− testProperty "string" string,

117− testProperty "stringCI" stringCI,

118− testProperty "asciiCI" asciiCI,

119− testProperty "skipWhile" skipWhile,

120− testProperty "takeCount" takeCount,

121− testProperty "takeWhile" takeWhile,

122− testProperty "takeWhile1" takeWhile1,

123− testProperty "takeWhile1_empty" takeWhile1_empty,

124− testProperty "takeTill" takeTill,

125− testProperty "endOfInput" endOfInput

175+ testProperty "anyChar" anyChar

176+ , testProperty "asciiCI" asciiCI

177+ , testProperty "char" char

178+ , testProperty "endOfInput" endOfInput

179+ , testProperty "endOfLine" endOfLine

180+ , testProperty "notChar" notChar

181+ , testProperty "peekChar" peekChar

182+ , testProperty "peekChar'" peekChar'

183+ , testProperty "satisfy" satisfy

184+ , testProperty "satisfyWith" satisfyWith

185+ , testProperty "scan" scan

186+ , testProperty "skip" skip

187+ , testProperty "skipWhile" skipWhile

188+ , testProperty "string" string

189+ , testProperty "strings" strings

190+ , testProperty "stringCI" stringCI

191+ , testProperty "take" take

192+ , testProperty "takeText" takeText

193+ , testProperty "takeCount" takeCount

194+ , testProperty "takeLazyText" takeLazyText

195+ , testProperty "takeTill" takeTill

196+ , testProperty "takeWhile" takeWhile

197+ , testProperty "takeWhile1" takeWhile1

198+ , testProperty "takeWhile1_empty" takeWhile1_empty

199+ , testProperty "members" members

200+ , testProperty "nonmembers" nonmembers

201+ , testGroup "FastSet" FastSet.tests

202+ , testGroup "Regressions" Regressions.tests

126203 ]

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