master..39d782a · typeable/attoparsec

.gitignore−1

since splitsnapshots

unifiedsplit

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

3/dist/

4.cabal-sandbox

5cabal.sandbox.config

6−*.sw[op]

.hgignore−1

@@ -6,7 +6,6 @@ benchmarks/Arse

6benchmarks/dist

7benchmarks/med.txt

8benchmarks/tiny

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

10cabal.sandbox.config

9cabal.sandbox.config

11examples/c-http

10examples/c-http

12examples/http_parser.[ch]

11examples/http_parser.[ch]

.hgtags−11

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

50a3c7a521fd58595d6a470ab890cc54a80dd45bd7 0.11.3.1

5138326ce07aca6c8c3a014b0d454d2a5bfdbd6a52 0.11.3.2

52694039f4fc157a8ca5dce37959391615b6c3f535 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.ymldeleted−161

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

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

2−#

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

4−#

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

6−#

7−# version: 0.3.20190815

8−#

9−language: c

10−dist: xenial

11−git:

12− # whether to recursively clone submodules

13− submodules: false

14−cache:

15− directories:

16− - $HOME/.cabal/packages

17− - $HOME/.cabal/store

18−before_cache:

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

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

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

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

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

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

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

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

27−matrix:

28− include:

29− - compiler: ghc-8.8.1

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

31− - compiler: ghc-8.6.5

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

33− - compiler: ghc-8.4.4

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

35− - compiler: ghc-8.2.2

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

37− - compiler: ghc-8.0.2

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

39− - compiler: ghc-7.10.3

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

41− - compiler: ghc-7.8.4

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

43− - compiler: ghc-7.6.3

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

45− - compiler: ghc-7.4.2

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

47− - compiler: ghc-7.2.2

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

49− - compiler: ghc-7.0.4

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

51−before_install:

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

53− - WITHCOMPILER="-w $HC"

54− - HCPKG="$HC-pkg"

55− - unset CC

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

57− - CABALHOME=$HOME/.cabal

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

59− - TOP=$(pwd)

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

61− - echo $HCNUMVER

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

63− - set -o pipefail

64− - |

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

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

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

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

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

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

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

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

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

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

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

76− - cat .colorful.awk

77− - |

78− color_cabal_output () {

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

80− }

81− - echo text | color_cabal_output

82−install:

83− - ${CABAL} --version

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

85− - TEST=--enable-tests

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

87− - BENCH=--enable-benchmarks

88− - BENCH=--disable-benchmarks

89− - HEADHACKAGE=false

90− - rm -f $CABALHOME/config

91− - |

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

107− - cat $CABALHOME/config

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

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

110− # Generate cabal.project

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

112− - touch cabal.project

113− - |

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

115− - |

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

117− - cat cabal.project || true

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

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

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

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

122− - rm cabal.project.freeze

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

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

125−script:

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

127− # Packaging...

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

129− # Unpacking...

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

131− - cd ${DISTDIR} || false

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

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

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

135− # Generate cabal.project

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

137− - touch cabal.project

138− - |

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

140− - |

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

142− - cat cabal.project || true

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

144− # Building...

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

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

147− # Building with tests and benchmarks...

148− # build & run tests, build benchmarks

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

150− # Testing...

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

152− # cabal check...

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

154− # haddock...

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

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

157− - rm -f cabal.project.local

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

159−

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

161−# EOF

Data/Attoparsec.hs+1−1

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

1-- |

2-- Module : Data.Attoparsec

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

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

4-- License : BSD3

5--

6-- Maintainer : bos@serpentine.com

Data/Attoparsec/ByteString.hs+19−34

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

1−{-# LANGUAGE CPP #-}

2−#if __GLASGOW_HASKELL__ >= 702

3−{-# LANGUAGE Trustworthy #-}

4−#endif

5-- |

1-- |

6-- Module : Data.Attoparsec.ByteString

2-- Module : Data.Attoparsec.ByteString

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

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

8-- License : BSD3

4-- License : BSD3

9--

5--

10-- Maintainer : bos@serpentine.com

6-- Maintainer : bos@serpentine.com

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

63 , I.skipWhile

59 , I.skipWhile

64 , I.take

60 , I.take

65 , I.scan

61 , I.scan

66− , I.runScanner

67 , I.takeWhile

62 , I.takeWhile

68 , I.takeWhile1

63 , I.takeWhile1

69 , I.takeTill

64 , I.takeTill

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

97 ) where

92 ) where

98

93

99import Data.Attoparsec.Combinator

94import Data.Attoparsec.Combinator

100−import Data.List (intercalate)

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

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

102import qualified Data.Attoparsec.Internal as I

96import qualified Data.Attoparsec.Internal as I

103import qualified Data.ByteString as B

97import qualified Data.ByteString as B

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

106

100

107-- $parsec

101-- $parsec

108--

102--

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

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

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

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

111--

105--

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

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

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

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

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

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

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

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

116-- model to use.

110-- model to use.

117--

111--

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

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

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

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

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

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

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

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

122-- libraries.

116-- libraries.

123--

117--

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

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

125-- monad transformer.

119-- monad transformer.

126--

120--

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

135-- to a regular parser.

129-- to a regular parser.

136--

130--

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

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

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

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

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

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

140

134

141-- $incremental

135-- $incremental

142--

136--

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

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

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

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

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

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

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

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

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

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

148--

142--

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

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

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

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

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

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

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

146+-- 'T.Partial' continuation.

154--

147--

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

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

156-- continuation with an empty bytestring.

149-- continuation with an empty bytestring.

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

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

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

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

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

164-- prompt for more input.

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

172

158

173-- $performance

159-- $performance

174--

160--

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

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

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

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

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

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

178--

164--

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

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

180-- that it is useful to follow.

166-- that it is useful to follow.

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

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

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

225-- result is treated as failure.

211-- result is treated as failure.

226eitherResult :: Result r -> Either String r

212eitherResult :: Result r -> Either String r

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

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

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

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

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

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

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

Data/Attoparsec/ByteString/Buffer.hs+43−80

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

1−{-# LANGUAGE BangPatterns #-}

2-- |

1-- |

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

2-- Module : Data.Attoparsec.ByteString.Buffer

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

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

5-- License : BSD3

4-- License : BSD3

6--

5--

7-- Maintainer : bos@serpentine.com

6-- Maintainer : bos@serpentine.com

8-- Stability : experimental

7-- Stability : experimental

9-- Portability : GHC

8-- Portability : GHC

10--

9--

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

10+-- An immutable buffer that supports cheap appends.

12−--

11+

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

12-- 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.

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

15--

14--

@@ -20,59 +19,40 @@

20--

19--

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

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

22-- doubling of the buffer size.

21-- 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

22

44module Data.Attoparsec.ByteString.Buffer

23module Data.Attoparsec.ByteString.Buffer

45 (

24 (

46 Buffer

25 Buffer

47 , buffer

26 , buffer

48 , unbuffer

27 , unbuffer

49− , pappend

50 , length

28 , length

51 , unsafeIndex

29 , unsafeIndex

52 , substring

30 , substring

53 , unsafeDrop

31 , unsafeDrop

54 ) where

32 ) where

55

33

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

56import Control.Exception (assert)

35import Control.Exception (assert)

36+import Data.Attoparsec.ByteString.Fhthagn (inlinePerformIO)

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

37import Data.ByteString.Internal (ByteString(..), memcpy, nullForeignPtr)

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

38+import Data.IORef (IORef, atomicModifyIORef, newIORef)

59import Data.List (foldl1')

39import Data.List (foldl1')

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

40+import Data.Monoid (Monoid(..))

61−import Data.Semigroup (Semigroup(..))

62import Data.Word (Word8)

41import Data.Word (Word8)

63import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)

42import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)

64−import Foreign.Ptr (castPtr, plusPtr)

43+import Foreign.Ptr (plusPtr)

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

44+import Foreign.Storable (peekByteOff)

66import GHC.ForeignPtr (mallocPlainForeignPtrBytes)

45import GHC.ForeignPtr (mallocPlainForeignPtrBytes)

67import Prelude hiding (length)

46import Prelude hiding (length)

47+import System.IO.Unsafe (unsafePerformIO)

68

48

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

70data Buffer = Buf {

49data Buffer = Buf {

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

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

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

51 , _off :: {-# UNPACK #-} !Int

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

52 , _len :: {-# UNPACK #-} !Int

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

53 , _cap :: {-# UNPACK #-} !Int

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

54 , _gen :: {-# UNPACK #-} !Int

55+ , _ref :: {-# UNPACK #-} !(IORef Int)

76 }

56 }

77

57

78instance Show Buffer where

58instance Show Buffer where

@@ -82,75 +62,58 @@ instance Show Buffer where

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

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

83-- to us.

63-- to us.

84buffer :: ByteString -> Buffer

64buffer :: ByteString -> Buffer

65+buffer (PS fp off len) = inlinePerformIO $

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

66+ Buf fp off len len 0 <$> newIORef 0

86

67

87unbuffer :: Buffer -> ByteString

68unbuffer :: Buffer -> ByteString

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

69+unbuffer (Buf fp off len _cap _gen _ref) = 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

70

95instance Monoid Buffer where

71instance Monoid Buffer where

96− mempty = Buf nullForeignPtr 0 0 0 0

72+ mempty = unsafePerformIO $ Buf nullForeignPtr 0 0 0 0 <$> newIORef 0

97−

73+ {-# NOINLINE mempty #-}

74+

98− mappend = (<>)

75+ mappend (Buf _ _ _ 0 _ _) b = b

99−

76+ mappend a (Buf _ _ _ 0 _ _) = a

77+ mappend (Buf fp0 off0 len0 cap0 gen ref) (Buf fp1 off1 len1 _ _ _) =

78+ inlinePerformIO . withForeignPtr fp0 $ \ptr0 ->

79+ withForeignPtr fp1 $ \ptr1 -> do

80+ gen' <- atomicModifyIORef ref (\a -> let a' = a+1 in (a',a'))

81+ let newlen = len0 + len1

82+ if gen' == gen+1 && newlen <= cap0

83+ then do

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

85+ (ptr1 `plusPtr` off1)

86+ len1

87+ return (Buf fp0 off0 newlen cap0 gen' ref)

88+ else do

89+ let newcap = newlen * 2

90+ fp <- mallocPlainForeignPtrBytes newcap

91+ withForeignPtr fp $ \ptr -> do

92+ memcpy ptr (ptr0 `plusPtr` off0) len0

93+ memcpy (ptr `plusPtr` len0) (ptr1 `plusPtr` off1) len1

94+ return (Buf fp 0 newlen newcap gen' ref)

95+

100− mconcat [] = Mon.mempty

96+ mconcat [] = mempty

101 mconcat xs = foldl1' mappend xs

97 mconcat xs = foldl1' mappend xs

102

98

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−

136length :: Buffer -> Int

99length :: Buffer -> Int

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

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

138{-# INLINE length #-}

101{-# INLINE length #-}

139

102

140unsafeIndex :: Buffer -> Int -> Word8

103unsafeIndex :: Buffer -> Int -> Word8

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

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

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

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

143{-# INLINE unsafeIndex #-}

106{-# INLINE unsafeIndex #-}

144

107

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

108substring :: Int -> Int -> Buffer -> ByteString

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

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

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

110 assert (s >= 0 && s <= len) .

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

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

149 PS fp (off+s) l

112 PS fp (off+s) l

150{-# INLINE substring #-}

113{-# INLINE substring #-}

151

114

152unsafeDrop :: Int -> Buffer -> ByteString

115unsafeDrop :: Int -> Buffer -> ByteString

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

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

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

117 assert (s >= 0 && s <= len) $

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

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

156{-# INLINE unsafeDrop #-}

119{-# INLINE unsafeDrop #-}

Data/Attoparsec/ByteString/Char8.hs+53−38

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

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

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

2 TypeSynonymInstances, GADTs #-}

3−#if __GLASGOW_HASKELL__ >= 702

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

5−#endif

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

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

7

4

8-- |

5-- |

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

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

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

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

11-- License : BSD3

8-- License : BSD3

12--

9--

13-- Maintainer : bos@serpentine.com

10-- Maintainer : bos@serpentine.com

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

70

67

71 -- * Efficient string handling

68 -- * Efficient string handling

72 , I.string

69 , I.string

73− , I.stringCI

70+ , stringCI

74 , skipSpace

71 , skipSpace

75 , skipWhile

72 , skipWhile

76 , I.take

73 , I.take

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

127 , I.atEnd

124 , I.atEnd

128 ) where

125 ) where

129

126

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

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

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

132−import Data.Word (Word)

133−#endif

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

135import Control.Monad (void, when)

128import Control.Monad (void, when)

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

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

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

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

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

143import Data.String (IsString(..))

136import Data.String (IsString(..))

144import Data.Scientific (Scientific)

137import Data.Scientific (Scientific)

145import qualified Data.Scientific as Sci

138import qualified Data.Scientific as Sci

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

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

147import Prelude hiding (takeWhile)

140import Prelude hiding (takeWhile)

148import qualified Data.Attoparsec.ByteString as A

141import qualified Data.Attoparsec.ByteString as A

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

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

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

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

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

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

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

171

164

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

166+toLower :: Word8 -> Word8

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

168+ | otherwise = w

169+

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

171+stringCI :: B.ByteString -> Parser B.ByteString

172+stringCI = I.stringTransform (B8.map toLower)

173+{-# INLINE stringCI #-}

174+

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

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

173-- the consumed input.

176-- the consumed input.

174--

177--

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

232

235

233-- | A fast digit predicate.

236-- | A fast digit predicate.

234isDigit_w8 :: Word8 -> Bool

237isDigit_w8 :: Word8 -> Bool

235−isDigit_w8 w = w - 48 <= 9

238+isDigit_w8 w = w >= 48 && w <= 57

236{-# INLINE isDigit_w8 #-}

239{-# INLINE isDigit_w8 #-}

237

240

238-- | Match any character.

241-- | Match any character.

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

269

272

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

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

271isSpace_w8 :: Word8 -> Bool

274isSpace_w8 :: Word8 -> Bool

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

275+isSpace_w8 w = (w == 32) || (9 <= w && w <= 13)

273{-# INLINE isSpace_w8 #-}

276{-# INLINE isSpace_w8 #-}

274

277

275

278

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

444

447

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

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

446decimal :: Integral a => Parser a

449decimal :: Integral a => Parser a

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

450+decimal = B8.foldl' step 0 `fmap` I.takeWhile1 isDig

451+ where isDig w = w >= 48 && w <= 57

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

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

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

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

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

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

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

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

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

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

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

472 <|> p

476 <|> p

473

477

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−

492-- | Parse a rational number.

478-- | Parse a rational number.

493--

479--

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

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

@@ -516,12 +502,42 @@ rational = scientifically realToFrac

516--

502--

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

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

518-- \"Infinity\".

504-- \"Infinity\".

505+rational :: Fractional a => Parser a

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

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

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

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

510+rational = scientifically realToFrac

511+

512+-- | Parse a rational number.

513+--

514+-- The syntax accepted by this parser is the same as for 'rational'.

515+--

516+-- /Note/: This function is almost ten times faster than 'rational',

517+-- but is slightly less accurate.

518+--

519+-- The 'Double' type supports about 16 decimal places of accuracy.

520+-- For 94.2% of numbers, this function and 'rational' give identical

521+-- results, but for the remaining 5.8%, this function loses precision

522+-- around the 15th decimal place. For 0.001% of numbers, this

523+-- function will lose precision at the 13th or 14th decimal place.

524+--

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

526+-- \"Infinity\".

519double :: Parser Double

527double :: Parser Double

520double = scientifically Sci.toRealFloat

528double = scientifically Sci.toRealFloat

521

529

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

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

523--

531--

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

532+-- The syntax accepted by this parser is the same as for 'rational'.

533+--

534+-- /Note/: This function is almost ten times faster than 'rational'.

535+-- On integral inputs, it gives perfectly accurate answers, and on

536+-- floating point inputs, it is slightly less accurate than

537+-- 'rational'.

538+--

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

540+-- \"

525number :: Parser Number

541number :: Parser Number

526number = scientifically $ \s ->

542number = scientifically $ \s ->

527 let e = Sci.base10Exponent s

543 let e = Sci.base10Exponent s

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

529 in if e >= 0

545 in if e >= 0

530 then I (c * 10 ^ e)

546 then I (c * 10 ^ e)

531 else D (Sci.toRealFloat s)

547 else D (Sci.toRealFloat s)

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

533

548

534-- | Parse a scientific number.

549-- | Parse a scientific number.

535--

550--

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

551+-- The syntax accepted by this parser is the same as for 'rational'.

537scientific :: Parser Scientific

552scientific :: Parser Scientific

538scientific = scientifically id

553scientific = scientifically id

539

554

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

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

3-----------------------------------------------------------------------------

4-- |

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

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

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

7-- License : BSD3

8--

9-- Maintainer : bos@serpentine.com

Data/Attoparsec/Internal/Fhthagn.hs → Data/Attoparsec/ByteString/Fhthagn.hsrenamed+1−1

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

1{-# LANGUAGE BangPatterns, Rank2Types, OverloadedStrings,

2 RecordWildCards, MagicHash, UnboxedTuples #-}

3

4−module Data.Attoparsec.Internal.Fhthagn

4+module Data.Attoparsec.ByteString.Fhthagn

5 (

6 inlinePerformIO

7 ) where

Data/Attoparsec/ByteString/Internal.hs+125−131

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

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

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

2− RecordWildCards #-}

3-- |

2-- |

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

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

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

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

6-- License : BSD3

5-- License : BSD3

7--

6--

8-- Maintainer : bos@serpentine.com

7-- Maintainer : bos@serpentine.com

9-- Stability : experimental

8-- Stability : experimental

10-- Portability : unknown

9-- Portability : unknown

11--

10--

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

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

13-- loosely based on the Parsec library.

12-- loosely based on the Parsec library.

14

13

15module Data.Attoparsec.ByteString.Internal

14module Data.Attoparsec.ByteString.Internal

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

47 -- * Efficient string handling

46 -- * Efficient string handling

48 , skipWhile

47 , skipWhile

49 , string

48 , string

50− , stringCI

49+ , stringTransform

51 , take

50 , take

52 , scan

51 , scan

53 , runScanner

52 , runScanner

@@ -66,19 +65,14 @@ module Data.Attoparsec.ByteString.Internal

66 , atEnd

65 , atEnd

67 ) where

66 ) where

68

67

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

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

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

71−#endif

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

73import Control.Monad (when)

69import Control.Monad (when)

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

70import Data.Attoparsec.ByteString.Buffer (Buffer, buffer)

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

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

72+import Data.Attoparsec.ByteString.Fhthagn (inlinePerformIO)

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

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

77−import Data.Attoparsec.Internal

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

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

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

80import Data.ByteString (ByteString)

75import Data.ByteString (ByteString)

81−import Data.List (intercalate)

82import Data.Word (Word8)

76import Data.Word (Word8)

83import Foreign.ForeignPtr (withForeignPtr)

77import Foreign.ForeignPtr (withForeignPtr)

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

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

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

92import qualified Data.ByteString.Lazy as L

86import qualified Data.ByteString.Lazy as L

93import qualified Data.ByteString.Unsafe as B

87import qualified Data.ByteString.Unsafe as B

94

88

95−type Parser = T.Parser ByteString

89+type Parser = T.Parser B.ByteString Buffer

96−type Result = IResult ByteString

90+type Result = IResult B.ByteString Buffer

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

91+type Failure r = T.Failure B.ByteString Buffer r

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

92+type Success a r = T.Success B.ByteString Buffer a r

99

93

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

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

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

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

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

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

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

142 hack dummy = do

136 hack dummy = do

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

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

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

138+ return . B.inlinePerformIO . withForeignPtr fp $ \p ->

145 peek (castPtr $ p `plusPtr` o)

139 peek (castPtr $ p `plusPtr` o)

146

140

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

141+-- | Consume @n@ bytes of input, but succeed only if the predicate

142+-- returns 'True'.

148−take :: Int -> Parser ByteString

143+takeWith :: Int -> (B.ByteString -> Bool) -> Parser B.ByteString

149−take n0 = do

144+takeWith n0 p = do

150 let n = max n0 0

145 let n = max n0 0

151 s <- ensure n

146 s <- ensure n

147+ if p s

152− advance n >> return s

148+ then advance n >> return s

149+ else fail "takeWith"

150+

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

152+take :: Int -> Parser B.ByteString

153+take n = takeWith n (const True)

153{-# INLINE take #-}

154{-# INLINE take #-}

154

155

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

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

@@ -165,62 +166,16 @@ take n0 = do

165--

166--

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

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

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

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

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

169+-- before failing. In Attoparsec, the above parser will /succeed/ on

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

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

170−string :: ByteString -> Parser ByteString

171+string :: B.ByteString -> Parser B.ByteString

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

172+string s = takeWith (B.length s) (==s)

172{-# INLINE string #-}

173{-# INLINE string #-}

173

174

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

175+stringTransform :: (B.ByteString -> B.ByteString) -> B.ByteString

175−toLower :: Word8 -> Word8

176+ -> Parser B.ByteString

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

177+stringTransform f s = takeWith (B.length s) ((==f s) . f)

177− | otherwise = w

178+{-# INLINE stringTransform #-}

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"

224

179

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

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

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

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

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

228 where

183 where

229 go = do

184 go = do

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

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

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

186+ advance (B.length t)

232− when continue go

187+ eoc <- endOfChunk

188+ when eoc $ do

189+ input <- wantInput

190+ when input go

233{-# INLINE skipWhile #-}

191{-# INLINE skipWhile #-}

234

192

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

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

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

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

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

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

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

244-- in an infinite loop.

202-- in an infinite loop.

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

203+takeTill :: (Word8 -> Bool) -> Parser B.ByteString

246takeTill p = takeWhile (not . p)

204takeTill p = takeWhile (not . p)

247{-# INLINE takeTill #-}

205{-# INLINE takeTill #-}

248

206

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

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

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

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

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

258-- in an infinite loop.

216-- in an infinite loop.

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

217+takeWhile :: (Word8 -> Bool) -> Parser B.ByteString

260−takeWhile p = do

218+takeWhile p = (B.concat . reverse) `fmap` go []

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

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

263− if continue

264− then takeWhileAcc p [s]

265− else return s

266−{-# INLINE takeWhile #-}

267−

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

269−takeWhileAcc p = go

270 where

219 where

271 go acc = do

220 go acc = do

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

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

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

222+ advance (B.length s)

274− if continue

223+ eoc <- endOfChunk

224+ if eoc

225+ then do

226+ input <- wantInput

227+ if input

275− then go (s:acc)

228+ then go (s:acc)

276− else return $ concatReverse (s:acc)

229+ else return (s:acc)

277−{-# INLINE takeWhileAcc #-}

230+ else return (s:acc)

231+{-# INLINE takeWhile #-}

278

232

279−takeRest :: Parser [ByteString]

233+takeRest :: Parser [B.ByteString]

280takeRest = go []

234takeRest = go []

281 where

235 where

282 go acc = do

236 go acc = do

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

289 else return (reverse acc)

243 else return (reverse acc)

290

244

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

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

292−takeByteString :: Parser ByteString

246+takeByteString :: Parser B.ByteString

293takeByteString = B.concat `fmap` takeRest

247takeByteString = B.concat `fmap` takeRest

294

248

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

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

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

298

252

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

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

300

254

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

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

302 -> Parser r

256 -> Parser r

303scan_ f s0 p = go [] s0

257scan_ f s0 p = go [] s0

304 where

258 where

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

319 bs <- get

273 bs <- get

320 let T i s' = inlinePerformIO $ scanner bs

274 let T i s' = inlinePerformIO $ scanner bs

321 !h = B.unsafeTake i bs

275 !h = B.unsafeTake i bs

322− continue <- inputSpansChunks i

276+ advance i

323− if continue

277+ eoc <- endOfChunk

278+ if eoc

279+ then do

280+ input <- wantInput

281+ if input

324− then go (h:acc) s'

282+ then go (h:acc) s'

283+ else f s' (h:acc)

325 else f s' (h:acc)

284 else f s' (h:acc)

326{-# INLINE scan_ #-}

285{-# INLINE scan_ #-}

327

286

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

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

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

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

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

339-- in an infinite loop.

298-- in an infinite loop.

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

299+scan :: s -> (s -> Word8 -> Maybe s) -> Parser B.ByteString

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

300+scan = scan_ $ \_ chunks ->

301+ case chunks of

302+ [x] -> return x

303+ xs -> return $! B.concat $ reverse xs

342{-# INLINE scan #-}

304{-# INLINE scan #-}

343

305

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

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

345-- scanner.

307-- scanner.

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

308+runScanner :: s -> (s -> Word8 -> Maybe s) -> Parser (B.ByteString, s)

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

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

348{-# INLINE runScanner #-}

310{-# INLINE runScanner #-}

349

311

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

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

@@ -353,7 +315,7 @@ runScanner = scan_ $ \s xs -> let !sx = concatReverse xs in return (sx, s)

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

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

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

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

355-- there is no input left.

317-- there is no input left.

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

318+takeWhile1 :: (Word8 -> Bool) -> Parser B.ByteString

357takeWhile1 p = do

319takeWhile1 p = do

358 (`when` demandInput) =<< endOfChunk

320 (`when` demandInput) =<< endOfChunk

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

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

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

364 advance len

326 advance len

365 eoc <- endOfChunk

327 eoc <- endOfChunk

366 if eoc

328 if eoc

367− then takeWhileAcc p [s]

329+ then (s<>) `fmap` takeWhile p

368 else return s

330 else return s

369−{-# INLINE takeWhile1 #-}

370

331

371-- | Match any byte in a set.

332-- | Match any byte in a set.

372--

333--

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

420 | more == Complete ->

381 | more == Complete ->

421 succ t pos more Nothing

382 succ t pos more Nothing

422 | otherwise ->

383 | otherwise ->

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

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

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

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

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

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

426 in prompt t pos more lose' succ'

387 in prompt t pos more lose' succ'

@@ -452,25 +413,16 @@ successK t (Pos pos) _more a = Done (Buf.unsafeDrop pos t) a

452{-# INLINE successK #-}

413{-# INLINE successK #-}

453

414

454-- | Run a parser.

415-- | Run a parser.

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

416+parse :: Parser a -> B.ByteString -> Result a

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

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

457{-# INLINE parse #-}

418{-# INLINE parse #-}

458

419

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

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

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

421+parseOnly :: Parser a -> B.ByteString -> Either String a

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

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

423+ Fail _ _ err -> Left err

472− Done _ a -> Right a

424+ Done _ a -> Right a

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

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

474{-# INLINE parseOnly #-}

426{-# INLINE parseOnly #-}

475

427

476get :: Parser ByteString

428get :: Parser ByteString

@@ -483,16 +435,6 @@ endOfChunk = T.Parser $ \t pos more _lose succ ->

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

435 succ t pos more (fromPos pos == Buf.length t)

484{-# INLINE endOfChunk #-}

436{-# INLINE endOfChunk #-}

485

437

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−

496advance :: Int -> Parser ()

438advance :: Int -> Parser ()

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

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

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

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

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

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

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

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

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

519 else ensureSuspended n t pos more lose succ

461 else ensureSuspended n t pos more lose succ

462+-- Non-recursive so the bounds check can be inlined:

520{-# INLINE ensure #-}

463{-# INLINE ensure #-}

521

464

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

466+-- continuation, otherwise to a failure continuation.

467+prompt :: Buffer -> Pos -> More

468+ -> (Buffer -> Pos -> More -> IResult ByteString Buffer r)

469+ -> (Buffer -> Pos -> More -> IResult ByteString Buffer r)

470+ -> IResult ByteString Buffer r

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

472+ if B.null s

473+ then lose t pos Complete

474+ else succ (t <> buffer s) pos Incomplete

475+

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

477+-- result.

478+demandInput :: Parser ()

479+demandInput = T.Parser $ \t pos more lose succ ->

480+ case more of

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

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

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

484+ in prompt t pos more lose' succ'

485+

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

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

488+-- of all input has been reached.

489+wantInput :: Parser Bool

490+wantInput = T.Parser $ \t pos more _lose succ ->

491+ case () of

492+ _ | lengthAtLeast pos 1 t -> succ t pos more True

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

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

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

496+ in prompt t pos more lose' succ'

497+{-# INLINE wantInput #-}

498+

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

500+endOfInput :: Parser ()

501+endOfInput = T.Parser $ \t pos more lose succ ->

502+ case () of

503+ _| lengthAtLeast pos 1 t -> lose t pos more [] "endOfInput"

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

505+ | otherwise ->

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

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

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

509+

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

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

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

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

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

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

@@ -527,6 +515,12 @@ match p = T.Parser $ \t pos more lose succ ->

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

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

528 in runParser p t pos more lose succ'

516 in runParser p t pos more lose succ'

529

517

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

519+-- reached.

520+atEnd :: Parser Bool

521+atEnd = not <$> wantInput

522+{-# INLINE atEnd #-}

523+

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

524lengthAtLeast :: Pos -> Int -> Buffer -> Bool

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

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

532{-# INLINE lengthAtLeast #-}

526{-# INLINE lengthAtLeast #-}

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

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

1−{-# LANGUAGE CPP #-}

2−#if __GLASGOW_HASKELL__ >= 702

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

4−#endif

5−

6-- |

1-- |

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

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

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

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

9-- License : BSD3

4-- License : BSD3

10--

5--

11-- Maintainer : bos@serpentine.com

6-- Maintainer : bos@serpentine.com

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

41

36

42import Control.DeepSeq (NFData(rnf))

37import Control.DeepSeq (NFData(rnf))

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

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

44−import Data.List (intercalate)

45import qualified Data.ByteString as B

39import qualified Data.ByteString as B

46import qualified Data.Attoparsec.ByteString as A

40import qualified Data.Attoparsec.ByteString as A

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

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

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

105

99

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

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

107eitherResult :: Result r -> Either String r

101eitherResult :: Result r -> Either String r

108−eitherResult (Done _ r) = Right r

102+eitherResult (Done _ r) = Right r

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

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

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

Data/Attoparsec/Char8.hs+1−1

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

1-- |

2-- Module : Data.Attoparsec.Char8

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

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

4-- License : BSD3

5--

6-- Maintainer : bos@serpentine.com

Data/Attoparsec/Combinator.hs+42−59

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

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

1+{-# LANGUAGE BangPatterns #-}

2−#if __GLASGOW_HASKELL__ >= 702

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

4−#endif

5-- |

2-- |

6-- Module : Data.Attoparsec.Combinator

3-- Module : Data.Attoparsec.Combinator

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

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

8-- License : BSD3

5-- License : BSD3

9--

6--

10-- Maintainer : bos@serpentine.com

7-- Maintainer : bos@serpentine.com

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

33 , skipMany1

30 , skipMany1

34 , eitherP

31 , eitherP

35 , feed

32 , feed

36− , satisfyElem

37− , endOfInput

38− , atEnd

39− , lookAhead

40 ) where

33 ) where

41

34

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

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

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

45−#endif

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

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

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

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

37import Control.Monad (MonadPlus(..))

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

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

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

50import Data.ByteString (ByteString)

39import Data.ByteString (ByteString)

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

51import Data.Text (Text)

41import Data.Text (Text)

52import qualified Data.Attoparsec.Zepto as Z

42import qualified Data.Attoparsec.Zepto as Z

53import Prelude hiding (succ)

43import Prelude hiding (succ)

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

56-- input appears to have been consumed.

46-- input appears to have been consumed.

57--

47--

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

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

59−-- attoparsec parsers always backtrack on failure.

49+-- Attoparsec parsers always backtrack on failure.

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

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

61try p = p

51try p = p

62{-# INLINE try #-}

52{-# INLINE try #-}

63

53

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

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

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

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

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

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

67− -> Parser i a

57+ -> Parser i t a

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

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

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

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

70 in runParser p t pos more lose' succ

60 in runParser p t pos more lose' succ

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

76-- action.

66-- action.

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

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

78choice = foldr (<|>) empty

68choice = foldr (<|>) empty

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

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

80− -> Parser ByteString a #-}

70+ -> Parser ByteString ByteString a #-}

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

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

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

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

83

73

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

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

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

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

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

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

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

90option x p = p <|> pure x

80option x p = p <|> pure x

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

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

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

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

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

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

94

84

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

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

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

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

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

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

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

134--

124--

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

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

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

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

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

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

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

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

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

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

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

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

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

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

142

132

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

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

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

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

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

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

146--

136--

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

155

145

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

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

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

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

158--

148--

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

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

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

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

161sepBy1 p s = scan

151sepBy1 p s = scan

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

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

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

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

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

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

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

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

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

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

167

157

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

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

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

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

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

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

171--

161--

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

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

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

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

174sepBy1' p s = scan

164sepBy1' p s = scan

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

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

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

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

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

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

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

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

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

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

180

170

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

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

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

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

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

191manyTill p end = scan

181manyTill p end = scan

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

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

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

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

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

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

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

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

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

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

197

187

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

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

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

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

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

210manyTill' p end = scan

200manyTill' p end = scan

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

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

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

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

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

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

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

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

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

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

216

206

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

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

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

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

219skipMany p = scan

209skipMany p = scan

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

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

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

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

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

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

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

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

224

214

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

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

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

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

227skipMany1 p = p *> skipMany p

217skipMany1 p = p *> skipMany p

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

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

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

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

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

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

231

221

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

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

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

241

231

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

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

243-- input.

233-- input.

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

234+feed :: Monoid i => IResult i t r -> i -> IResult i t r

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

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

246feed (Partial k) d = k d

236feed (Partial k) d = k d

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

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

248{-# INLINE feed #-}

238{-# 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+5−143

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

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

1+{-# LANGUAGE BangPatterns #-}

2-- |

3-- Module : Data.Attoparsec.Internal

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

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

5-- License : BSD3

6--

7-- Maintainer : bos@serpentine.com

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

12-- library.

13

14module Data.Attoparsec.Internal

15+ (

15− ( compareResults

16+ compareResults

16− , prompt

17− , demandInput

18− , demandInput_

19− , wantInput

20− , endOfInput

21− , atEnd

22− , satisfyElem

23− , concatReverse

24 ) where

17 ) where

25

18

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

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

28−import Data.Monoid (Monoid, mconcat)

29−#endif

30import Data.Attoparsec.Internal.Types

19import Data.Attoparsec.Internal.Types

31−import Data.ByteString (ByteString)

32−import Data.Text (Text)

33import Prelude hiding (succ)

20import Prelude hiding (succ)

34

21

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

45compareResults (Partial _) (Partial _) = Nothing

32compareResults (Partial _) (Partial _) = Nothing

46compareResults _ _ = Just False

33compareResults _ _ = Just False

47−

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

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

50−prompt :: Chunk t

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

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

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

54− -> IResult t r

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

56− if nullChunk s

57− then lose t pos Complete

58− else succ (pappendChunk t s) pos Incomplete

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

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

61− -> IResult ByteString r)

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

63− -> IResult ByteString r)

64− -> IResult ByteString r #-}

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

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

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

68− -> IResult Text r #-}

69−

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

71−-- result.

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

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

74− case more of

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

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

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

78− in prompt t pos more lose' succ'

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

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

81−

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

83−-- result. Return the new input.

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

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

86− case more of

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

88− _ -> Partial $ \s ->

89− if nullChunk s

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

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

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

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

94−

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

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

97−-- of all input has been reached.

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

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

100− case () of

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

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

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

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

105− in prompt t pos more lose' succ'

106−{-# INLINE wantInput #-}

107−

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

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

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

111− case () of

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

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

114− | otherwise ->

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

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

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

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

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

120−

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

122−-- reached.

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

124−atEnd = not <$> wantInput

125−{-# INLINE atEnd #-}

126−

127−satisfySuspended :: forall t r . Chunk t

128− => (ChunkElem t -> Bool)

129− -> State t -> Pos -> More

130− -> Failure t (State t) r

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

132− -> IResult t r

133−satisfySuspended p t pos more lose succ =

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

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

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

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

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

139− Nothing -> runParser (demandInput >> go) t' pos' more' lose' succ'

140−{-# SPECIALIZE satisfySuspended :: (ChunkElem ByteString -> Bool)

141− -> State ByteString -> Pos -> More

142− -> Failure ByteString (State ByteString) r

143− -> Success ByteString (State ByteString)

144− (ChunkElem ByteString) r

145− -> IResult ByteString r #-}

146−{-# SPECIALIZE satisfySuspended :: (ChunkElem Text -> Bool)

147− -> State Text -> Pos -> More

148− -> Failure Text (State Text) r

149− -> Success Text (State Text)

150− (ChunkElem Text) r

151− -> IResult Text r #-}

152−

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

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

155−-- actually parsed.

156−satisfyElem :: forall t . Chunk t

157− => (ChunkElem t -> Bool) -> Parser t (ChunkElem t)

158−satisfyElem p = Parser $ \t pos more lose succ ->

159− case bufferElemAt (undefined :: t) pos t of

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

161− | otherwise -> lose t pos more [] "satisfyElem"

162− Nothing -> satisfySuspended p t pos more lose succ

163−{-# INLINE satisfyElem #-}

164−

165−-- | Concatenate a monoid after reversing its elements. Used to

166−-- glue together a series of textual chunks that have been accumulated

167−-- \"backwards\".

168−concatReverse :: Monoid m => [m] -> m

169−concatReverse [x] = x

170−concatReverse xs = mconcat (reverse xs)

171−{-# INLINE concatReverse #-}

Data/Attoparsec/Internal/Types.hs+57−137

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

1−{-# LANGUAGE CPP, BangPatterns, GeneralizedNewtypeDeriving, OverloadedStrings,

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

2 Rank2Types, RecordWildCards, TypeFamilies #-}

3-- |

4-- Module : Data.Attoparsec.Internal.Types

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

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

6-- License : BSD3

7--

8-- Maintainer : bos@serpentine.com

@@ -15,82 +15,62 @@

15module Data.Attoparsec.Internal.Types

16 (

17 Parser(..)

18− , State

19 , Failure

18 , Failure

20 , Success

19 , Success

21 , Pos(..)

20 , Pos(..)

22 , IResult(..)

21 , IResult(..)

23 , More(..)

22 , More(..)

24 , (<>)

23 , (<>)

25− , Chunk(..)

26 ) where

24 ) where

27

25

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

26+import Control.Applicative (Alternative(..), Applicative(..), (<$>))

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

30import Control.DeepSeq (NFData(rnf))

27import Control.DeepSeq (NFData(rnf))

31import Control.Monad (MonadPlus(..))

28import Control.Monad (MonadPlus(..))

32−import qualified Control.Monad.Fail as Fail (MonadFail(..))

33−import Data.Monoid as Mon (Monoid(..))

29+import Data.Monoid (Monoid(..))

34−import Data.Semigroup (Semigroup(..))

35−import Data.Word (Word8)

36−import Data.ByteString (ByteString)

37−import qualified Data.ByteString as BS

38−import Data.ByteString.Internal (w2c)

39−import Data.Text (Text)

40−import qualified Data.Text as Text

41−import Data.Text.Unsafe (Iter(..))

42−import Prelude hiding (succ)

30+import Prelude hiding (getChar, succ)

43−import qualified Data.Attoparsec.ByteString.Buffer as B

44−import qualified Data.Attoparsec.Text.Buffer as T

45

31

46newtype Pos = Pos { fromPos :: Int }

32newtype Pos = Pos { fromPos :: Int }

47 deriving (Eq, Ord, Show, Num)

33 deriving (Eq, Ord, Show, Num)

48

34

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

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

50-- of string that was processed.

36-- of string that was processed.

51--

37--

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

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

53-- value in a 'Done' result.

39-- value in a 'Done' result.

54−data IResult i r =

40+data IResult i t r =

55 Fail i [String] String

41 Fail i [String] String

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

42+ -- ^ The parse failed. The 'i' parameter is the input that had

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

43 -- not yet been consumed when the failure occurred. The

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

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

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

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

60 -- any.

46 -- any.

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

47+ | Partial (i -> IResult i t r)

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

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

63− -- can resume. To indicate that no more input is available, pass

49+ -- can resume. To indicate that no more input is available, use

64− -- an empty string to the continuation.

50+ -- an empty string.

65− --

66− -- __Note__: if you get a 'Partial' result, do not call its

67− -- continuation more than once.

68 | Done i r

51 | Done i r

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

52+ -- ^ The parse succeeded. The 'i' parameter is the input that had

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

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

71

54

72−instance (Show i, Show r) => Show (IResult i r) where

55+instance (Show i, Show r) => Show (IResult i t 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

56+ show (Fail t stk msg) =

57+ unwords [ "Fail", show t, show stk, show msg]

76− (Partial _) -> showString "Partial _"

58+ show (Partial _) = "Partial _"

77− (Done t r) -> showString "Done" . f t . f r

59+ show (Done t r) = unwords ["Done", show t, show r]

78− where f :: Show a => a -> ShowS

79− f x = showChar ' ' . showsPrec 11 x

80

60

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

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

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

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

83 rnf (Partial _) = ()

63 rnf (Partial _) = ()

84 rnf (Done t r) = rnf t `seq` rnf r

64 rnf (Done t r) = rnf t `seq` rnf r

85 {-# INLINE rnf #-}

65 {-# INLINE rnf #-}

86

66

87−instance Functor (IResult i) where

67+instance Functor (IResult i t) where

88 fmap _ (Fail t stk msg) = Fail t stk msg

68 fmap _ (Fail t stk msg) = Fail t stk msg

89 fmap f (Partial k) = Partial (fmap f . k)

69 fmap f (Partial k) = Partial (fmap f . k)

90 fmap f (Done t r) = Done t (f r)

70 fmap f (Done t r) = Done t (f r)

91

71

92−-- | The core parser type. This is parameterised over the type @i@

72+-- | The core parser type. This is parameterised over the type @t@ of

93−-- of string being processed.

73+-- string being processed.

94--

74--

95-- This type is an instance of the following classes:

75-- This type is an instance of the following classes:

96--

76--

@@ -103,45 +83,36 @@ instance Functor (IResult i) where

103-- 'mplus' executes the right-hand parser if the left-hand one

83-- 'mplus' executes the right-hand parser if the left-hand one

104-- fails. When the parser on the right executes, the input is reset

84-- fails. When the parser on the right executes, the input is reset

105-- to the same state as the parser on the left started with. (In

85-- to the same state as the parser on the left started with. (In

106−-- other words, attoparsec is a backtracking parser that supports

86+-- other words, Attoparsec is a backtracking parser that supports

107-- arbitrary lookahead.)

87-- arbitrary lookahead.)

108--

88--

109-- * 'Alternative', which follows 'MonadPlus'.

89-- * 'Alternative', which follows 'MonadPlus'.

110−newtype Parser i a = Parser {

90+newtype Parser i t a = Parser {

111− runParser :: forall r.

91+ runParser :: forall r. t -> Pos -> More

112− State i -> Pos -> More

113− -> Failure i (State i) r

92+ -> Failure i t r

114− -> Success i (State i) a r

93+ -> Success i t a r

115− -> IResult i r

94+ -> IResult i t r

116 }

95 }

117

96

118−type family State i

119−type instance State ByteString = B.Buffer

120−type instance State Text = T.Buffer

121−

122type Failure i t r = t -> Pos -> More -> [String] -> String

97type Failure i t r = t -> Pos -> More -> [String] -> String

123− -> IResult i r

98+ -> IResult i t r

124−type Success i t a r = t -> Pos -> More -> a -> IResult i r

99+type Success i t a r = t -> Pos -> More -> a -> IResult i t r

125

100

126-- | Have we read all available input?

101-- | Have we read all available input?

127data More = Complete | Incomplete

102data More = Complete | Incomplete

128 deriving (Eq, Show)

103 deriving (Eq, Show)

129

104

130−instance Semigroup More where

105+instance Monoid More where

131− c@Complete <> _ = c

106+ mappend c@Complete _ = c

132− _ <> m = m

107+ mappend _ m = m

133−

134−instance Mon.Monoid More where

135− mappend = (<>)

136− mempty = Incomplete

108+ mempty = Incomplete

137

109

138−instance Monad (Parser i) where

110+instance Monad (Parser i t) where

139−#if !(MIN_VERSION_base(4,13,0))

111+ fail err = Parser $ \t pos more lose _succ -> lose t pos more [] msg

140− fail = Fail.fail

112+ where msg = "Failed reading: " ++ err

141 {-# INLINE fail #-}

113 {-# INLINE fail #-}

142−#endif

143

114

144− return = App.pure

115+ return v = Parser $ \t pos more _lose succ -> succ t pos more v

145 {-# INLINE return #-}

116 {-# INLINE return #-}

146

117

147 m >>= k = Parser $ \t !pos more lose succ ->

118 m >>= k = Parser $ \t !pos more lose succ ->

@@ -149,59 +120,50 @@ instance Monad (Parser i) where

149 in runParser m t pos more lose succ'

120 in runParser m t pos more lose succ'

150 {-# INLINE (>>=) #-}

121 {-# INLINE (>>=) #-}

151

122

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

123+plus :: (Monoid t) => Parser i t a -> Parser i t a -> Parser i t a

162plus f g = Parser $ \t pos more lose succ ->

124plus f g = Parser $ \t pos more lose succ ->

163 let lose' t' _pos' more' _ctx _msg = runParser g t' pos more' lose succ

125 let lose' t' _pos' more' _ctx _msg = runParser g t' pos more' lose succ

164 in runParser f t pos more lose' succ

126 in runParser f t pos more lose' succ

165

127

166−instance MonadPlus (Parser i) where

128+instance (Monoid t) => MonadPlus (Parser i t) where

167 mzero = fail "mzero"

129 mzero = fail "mzero"

168 {-# INLINE mzero #-}

130 {-# INLINE mzero #-}

169 mplus = plus

131 mplus = plus

170

132

171−instance Functor (Parser i) where

133+instance Functor (Parser i t) where

172 fmap f p = Parser $ \t pos more lose succ ->

134 fmap f p = Parser $ \t pos more lose succ ->

173 let succ' t' pos' more' a = succ t' pos' more' (f a)

135 let succ' t' pos' more' a = succ t' pos' more' (f a)

174 in runParser p t pos more lose succ'

136 in runParser p t pos more lose succ'

175 {-# INLINE fmap #-}

137 {-# INLINE fmap #-}

176

138

177−apP :: Parser i (a -> b) -> Parser i a -> Parser i b

139+apP :: Parser i t (a -> b) -> Parser i t a -> Parser i t b

178apP d e = do

140apP d e = do

179 b <- d

141 b <- d

180 a <- e

142 a <- e

181 return (b a)

143 return (b a)

182{-# INLINE apP #-}

144{-# INLINE apP #-}

183

145

184−instance Applicative (Parser i) where

146+instance Applicative (Parser i t) where

185− pure v = Parser $ \t !pos more _lose succ -> succ t pos more v

147+ pure = return

186 {-# INLINE pure #-}

148 {-# INLINE pure #-}

187 (<*>) = apP

149 (<*>) = apP

188 {-# INLINE (<*>) #-}

150 {-# INLINE (<*>) #-}

189− m *> k = m >>= \_ -> k

151+

152+ -- These definitions are equal to the defaults, but this

153+ -- way the optimizer doesn't have to work so hard to figure

154+ -- that out.

155+ (*>) = (>>)

190 {-# INLINE (*>) #-}

156 {-# INLINE (*>) #-}

191− x <* y = x >>= \a -> y >> pure a

157+ x <* y = x >>= \a -> y >> return a

192 {-# INLINE (<*) #-}

158 {-# INLINE (<*) #-}

193

159

194−instance Semigroup (Parser i a) where

195− (<>) = plus

196− {-# INLINE (<>) #-}

197−

198−instance Monoid (Parser i a) where

160+instance (Monoid t) => Monoid (Parser i t a) where

199 mempty = fail "mempty"

161 mempty = fail "mempty"

200 {-# INLINE mempty #-}

162 {-# INLINE mempty #-}

201− mappend = (<>)

163+ mappend = plus

202 {-# INLINE mappend #-}

164 {-# INLINE mappend #-}

203

165

204−instance Alternative (Parser i) where

166+instance (Monoid t) => Alternative (Parser i t) where

205 empty = fail "empty"

167 empty = fail "empty"

206 {-# INLINE empty #-}

168 {-# INLINE empty #-}

207

169

@@ -209,9 +171,8 @@ instance Alternative (Parser i) where

209 {-# INLINE (<|>) #-}

171 {-# INLINE (<|>) #-}

210

172

211 many v = many_v

173 many v = many_v

212− where

213− many_v = some_v <|> pure []

174+ where many_v = some_v <|> pure []

214− some_v = (:) <$> v <*> many_v

175+ some_v = (:) <$> v <*> many_v

215 {-# INLINE many #-}

176 {-# INLINE many #-}

216

177

217 some v = some_v

178 some v = some_v

@@ -220,47 +181,6 @@ instance Alternative (Parser i) where

220 some_v = (:) <$> v <*> many_v

181 some_v = (:) <$> v <*> many_v

221 {-# INLINE some #-}

182 {-# INLINE some #-}

222

183

223−-- | A common interface for input chunks.

184+(<>) :: (Monoid m) => m -> m -> m

224−class Monoid c => Chunk c where

185+(<>) = mappend

225− type ChunkElem c

226− -- | Test if the chunk is empty.

227− nullChunk :: c -> Bool

228− -- | Append chunk to a buffer.

229− pappendChunk :: State c -> c -> State c

230− -- | Position at the end of a buffer. The first argument is ignored.

231− atBufferEnd :: c -> State c -> Pos

232− -- | Return the buffer element at the given position along with its length.

233− bufferElemAt :: c -> Pos -> State c -> Maybe (ChunkElem c, Int)

234− -- | Map an element to the corresponding character.

235− -- The first argument is ignored.

236− chunkElemToChar :: c -> ChunkElem c -> Char

237−

238−instance Chunk ByteString where

239− type ChunkElem ByteString = Word8

240− nullChunk = BS.null

241− {-# INLINE nullChunk #-}

186+{-# INLINE (<>) #-}

242− pappendChunk = B.pappend

243− {-# INLINE pappendChunk #-}

244− atBufferEnd _ = Pos . B.length

245− {-# INLINE atBufferEnd #-}

246− bufferElemAt _ (Pos i) buf

247− | i < B.length buf = Just (B.unsafeIndex buf i, 1)

248− | otherwise = Nothing

249− {-# INLINE bufferElemAt #-}

250− chunkElemToChar _ = w2c

251− {-# INLINE chunkElemToChar #-}

252−

253−instance Chunk Text where

254− type ChunkElem Text = Char

255− nullChunk = Text.null

256− {-# INLINE nullChunk #-}

257− pappendChunk = T.pappend

258− {-# INLINE pappendChunk #-}

259− atBufferEnd _ = Pos . T.length

260− {-# INLINE atBufferEnd #-}

261− bufferElemAt _ (Pos i) buf

262− | i < T.length buf = let Iter c l = T.iter buf i in Just (c, l)

263− | otherwise = Nothing

264− {-# INLINE bufferElemAt #-}

265− chunkElemToChar _ = id

266− {-# INLINE chunkElemToChar #-}

Data/Attoparsec/Lazy.hs+1−1

@@ -1,6 +1,6 @@

1-- |

2-- Module : Data.Attoparsec.Lazy

3−-- Copyright : Bryan O'Sullivan 2007-2015

3+-- Copyright : Bryan O'Sullivan 2007-2014

4-- License : BSD3

5--

6-- Maintainer : bos@serpentine.com

Data/Attoparsec/Number.hs+2−15

@@ -1,25 +1,16 @@

1{-# LANGUAGE DeriveDataTypeable #-}

2-- |

3-- Module : Data.Attoparsec.Number

4−-- Copyright : Bryan O'Sullivan 2007-2015

4+-- Copyright : Bryan O'Sullivan 2007-2014

5-- License : BSD3

6--

7-- Maintainer : bos@serpentine.com

8-- Stability : experimental

9-- Portability : unknown

10--

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−--

16-- A simple number type, useful for parsing both exact and inexact

11-- A simple number type, useful for parsing both exact and inexact

17-- quantities without losing much precision.

12-- quantities without losing much precision.

18−module Data.Attoparsec.Number

13+module Data.Attoparsec.Number ( Number(..) ) where

19− {-# DEPRECATED "This module will be removed in the next major release." #-}

20− (

21− Number(..)

22− ) where

23

14

24import Control.DeepSeq (NFData(rnf))

15import Control.DeepSeq (NFData(rnf))

25import Data.Data (Data)

16import Data.Data (Data)

@@ -28,13 +19,9 @@ import Data.Typeable (Typeable)

28

19

29-- | A numeric type that can represent integers accurately, and

20-- | A numeric type that can represent integers accurately, and

30-- floating point numbers to the precision of a 'Double'.

21-- 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.

34data Number = I !Integer

22data Number = I !Integer

35 | D {-# UNPACK #-} !Double

23 | D {-# UNPACK #-} !Double

36 deriving (Typeable, Data)

24 deriving (Typeable, Data)

37−{-# DEPRECATED Number "Use Scientific instead." #-}

38

25

39instance Show Number where

26instance Show Number where

40 show (I a) = show a

27 show (I a) = show a

Data/Attoparsec/Text.hs+50−61

@@ -1,12 +1,8 @@

1−{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, TypeSynonymInstances #-}

1+{-# LANGUAGE BangPatterns, FlexibleInstances, TypeSynonymInstances #-}

2−#if __GLASGOW_HASKELL__ >= 702

3−{-# LANGUAGE Trustworthy #-} -- Imports internal modules

4−#endif

5−{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}

6

2

7-- |

3-- |

8-- Module : Data.Attoparsec.Text

4-- Module : Data.Attoparsec.Text

9−-- Copyright : Bryan O'Sullivan 2007-2015

5+-- Copyright : Bryan O'Sullivan 2007-2014

10-- License : BSD3

6-- License : BSD3

11--

7--

12-- Maintainer : bos@serpentine.com

8-- Maintainer : bos@serpentine.com

@@ -72,7 +68,6 @@ module Data.Attoparsec.Text

72 , skipSpace

68 , skipSpace

73 , I.skipWhile

69 , I.skipWhile

74 , I.scan

70 , I.scan

75− , I.runScanner

76 , I.take

71 , I.take

77 , I.takeWhile

72 , I.takeWhile

78 , I.takeWhile1

73 , I.takeWhile1

@@ -126,11 +121,7 @@ module Data.Attoparsec.Text

126 , I.atEnd

121 , I.atEnd

127 ) where

122 ) where

128

123

129−#if !MIN_VERSION_base(4,8,0)

130−import Control.Applicative (pure, (*>), (<*), (<$>))

124+import Control.Applicative (pure, (<$>), (*>), (<*), (<|>))

131−import Data.Word (Word)

132−#endif

133−import Control.Applicative ((<|>))

134import Data.Attoparsec.Combinator

125import Data.Attoparsec.Combinator

135import Data.Attoparsec.Number (Number(..))

126import Data.Attoparsec.Number (Number(..))

136import Data.Scientific (Scientific)

127import Data.Scientific (Scientific)

@@ -139,9 +130,8 @@ import Data.Attoparsec.Text.Internal (Parser, Result, parse, takeWhile1)

139import Data.Bits (Bits, (.|.), shiftL)

130import Data.Bits (Bits, (.|.), shiftL)

140import Data.Char (isAlpha, isDigit, isSpace, ord)

131import Data.Char (isAlpha, isDigit, isSpace, ord)

141import Data.Int (Int8, Int16, Int32, Int64)

132import Data.Int (Int8, Int16, Int32, Int64)

142−import Data.List (intercalate)

143import Data.Text (Text)

133import Data.Text (Text)

144−import Data.Word (Word8, Word16, Word32, Word64)

134+import Data.Word (Word8, Word16, Word32, Word64, Word)

145import qualified Data.Attoparsec.Internal as I

135import qualified Data.Attoparsec.Internal as I

146import qualified Data.Attoparsec.Internal.Types as T

136import qualified Data.Attoparsec.Internal.Types as T

147import qualified Data.Attoparsec.Text.Internal as I

137import qualified Data.Attoparsec.Text.Internal as I

@@ -149,50 +139,49 @@ import qualified Data.Text as T

149

139

150-- $parsec

140-- $parsec

151--

141--

152−-- Compared to Parsec 3, attoparsec makes several tradeoffs. It is

142+-- Compared to Parsec 3, Attoparsec makes several tradeoffs. It is

153-- not intended for, or ideal for, all possible uses.

143-- not intended for, or ideal for, all possible uses.

154--

144--

155−-- * While attoparsec can consume input incrementally, Parsec cannot.

145+-- * While Attoparsec can consume input incrementally, Parsec cannot.

156-- Incremental input is a huge deal for efficient and secure network

146-- Incremental input is a huge deal for efficient and secure network

157-- and system programming, since it gives much more control to users

147-- and system programming, since it gives much more control to users

158-- of the library over matters such as resource usage and the I/O

148-- of the library over matters such as resource usage and the I/O

159-- model to use.

149-- model to use.

160--

150--

161−-- * Much of the performance advantage of attoparsec is gained via

151+-- * Much of the performance advantage of Attoparsec is gained via

162-- high-performance parsers such as 'I.takeWhile' and 'I.string'.

152-- high-performance parsers such as 'I.takeWhile' and 'I.string'.

163-- If you use complicated combinators that return lists of

153-- If you use complicated combinators that return lists of

164-- characters, there is less performance difference between the two

154-- characters, there is less performance difference between the two

165-- libraries.

155-- libraries.

166--

156--

167−-- * Unlike Parsec 3, attoparsec does not support being used as a

157+-- * Unlike Parsec 3, Attoparsec does not support being used as a

168-- monad transformer.

158-- monad transformer.

169--

159--

170−-- * attoparsec is specialised to deal only with strict 'Text'

160+-- * Attoparsec is specialised to deal only with strict 'Text'

171-- input. Efficiency concerns rule out both lists and lazy text.

161-- input. Efficiency concerns rule out both lists and lazy text.

172-- The usual use for lazy text would be to allow consumption of very

162-- The usual use for lazy text would be to allow consumption of very

173-- large input without a large footprint. For this need,

163-- large input without a large footprint. For this need,

174−-- attoparsec's incremental input provides an excellent substitute,

164+-- Attoparsec's incremental input provides an excellent substitute,

175-- with much more control over when input takes place. If you must

165-- with much more control over when input takes place. If you must

176-- use lazy text, see the 'Lazy' module, which feeds lazy chunks to

166-- use lazy text, see the 'Lazy' module, which feeds lazy chunks to

177-- a regular parser.

167-- a regular parser.

178--

168--

179-- * Parsec parsers can produce more helpful error messages than

169-- * Parsec parsers can produce more helpful error messages than

180−-- attoparsec parsers. This is a matter of focus: attoparsec avoids

170+-- Attoparsec parsers. This is a matter of focus: Attoparsec avoids

181-- the extra book-keeping in favour of higher performance.

171-- the extra book-keeping in favour of higher performance.

182

172

183-- $incremental

173-- $incremental

184--

174--

185−-- attoparsec supports incremental input, meaning that you can feed it

175+-- Attoparsec supports incremental input, meaning that you can feed it

186-- a 'Text' that represents only part of the expected total amount

176-- a 'Text' that represents only part of the expected total amount

187-- of data to parse. If your parser reaches the end of a fragment of

177-- of data to parse. If your parser reaches the end of a fragment of

188-- input and could consume more input, it will suspend parsing and

178-- input and could consume more input, it will suspend parsing and

189-- return a 'T.Partial' continuation.

179-- return a 'T.Partial' continuation.

190--

180--

191-- Supplying the 'T.Partial' continuation with another string will

181-- Supplying the 'T.Partial' continuation with another string will

192−-- resume parsing at the point where it was suspended, with the string

182+-- resume parsing at the point where it was suspended. You must be

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

183+-- prepared for the result of the resumed parse to be another

195−-- be another 'Partial' continuation.

184+-- 'Partial' continuation.

196--

185--

197-- To indicate that you have no more input, supply the 'Partial'

186-- To indicate that you have no more input, supply the 'Partial'

198-- continuation with an 'T.empty' 'Text'.

187-- continuation with an 'T.empty' 'Text'.

@@ -204,19 +193,12 @@ import qualified Data.Text as T

204-- If you do not need support for incremental input, consider using

193-- If you do not need support for incremental input, consider using

205-- the 'I.parseOnly' function to run your parser. It will never

194-- the 'I.parseOnly' function to run your parser. It will never

206-- prompt for more input.

195-- 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.)

214

196

215-- $performance

197-- $performance

216--

198--

217−-- If you write an attoparsec-based parser carefully, it can be

199+-- If you write an Attoparsec-based parser carefully, it can be

218−-- realistic to expect it to perform similarly to a hand-rolled C

200+-- realistic to expect it to perform within a factor of 2 of a

219−-- parser (measuring megabytes parsed per second).

201+-- hand-rolled C parser (measuring megabytes parsed per second).

220--

202--

221-- To actually achieve high performance, there are a few guidelines

203-- To actually achieve high performance, there are a few guidelines

222-- that it is useful to follow.

204-- that it is useful to follow.

@@ -266,10 +248,9 @@ maybeResult _ = Nothing

266-- | Convert a 'Result' value to an 'Either' value. A 'Partial' result

248-- | Convert a 'Result' value to an 'Either' value. A 'Partial' result

267-- is treated as failure.

249-- is treated as failure.

268eitherResult :: Result r -> Either String r

250eitherResult :: Result r -> Either String r

269−eitherResult (T.Done _ r) = Right r

251+eitherResult (T.Done _ r) = Right r

270−eitherResult (T.Fail _ [] msg) = Left msg

252+eitherResult (T.Fail _ _ msg) = Left msg

271−eitherResult (T.Fail _ ctxs msg) = Left (intercalate " > " ctxs ++ ": " ++ msg)

272−eitherResult _ = Left "Result: incomplete input"

253+eitherResult _ = Left "Result: incomplete input"

273

254

274-- | A predicate that matches either a carriage return @\'\\r\'@ or

255-- | A predicate that matches either a carriage return @\'\\r\'@ or

275-- newline @\'\\n\'@ character.

256-- newline @\'\\n\'@ character.

@@ -342,24 +323,6 @@ signed p = (negate <$> (I.char '-' *> p))

342 <|> (I.char '+' *> p)

323 <|> (I.char '+' *> p)

343 <|> p

324 <|> p

344

325

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−

363-- | Parse a rational number.

326-- | Parse a rational number.

364--

327--

365-- This parser accepts an optional leading sign character, followed by

328-- This parser accepts an optional leading sign character, followed by

@@ -387,12 +350,39 @@ rational = scientifically realToFrac

387--

350--

388-- This function does not accept string representations of \"NaN\" or

351-- This function does not accept string representations of \"NaN\" or

389-- \"Infinity\".

352-- \"Infinity\".

353+rational :: Fractional a => Parser a

354+{-# SPECIALIZE rational :: Parser Double #-}

355+{-# SPECIALIZE rational :: Parser Float #-}

356+{-# SPECIALIZE rational :: Parser Rational #-}

357+{-# SPECIALIZE rational :: Parser Scientific #-}

358+rational = scientifically realToFrac

359+

360+-- | Parse a rational number.

361+--

362+-- The syntax accepted by this parser is the same as for 'rational'.

363+--

364+-- /Note/: This function is almost ten times faster than 'rational',

365+-- but is slightly less accurate.

366+--

367+-- The 'Double' type supports about 16 decimal places of accuracy.

368+-- For 94.2% of numbers, this function and 'rational' give identical

369+-- results, but for the remaining 5.8%, this function loses precision

370+-- around the 15th decimal place. For 0.001% of numbers, this

371+-- function will lose precision at the 13th or 14th decimal place.

372+--

373+-- This function does not accept string representations of \"NaN\" or

374+-- \"Infinity\".

390double :: Parser Double

375double :: Parser Double

391double = scientifically Sci.toRealFloat

376double = scientifically Sci.toRealFloat

392

377

393-- | Parse a number, attempting to preserve both speed and precision.

378-- | Parse a number, attempting to preserve both speed and precision.

394--

379--

395−-- The syntax accepted by this parser is the same as for 'double'.

380+-- The syntax accepted by this parser is the same as for 'rational'.

381+--

382+-- /Note/: This function is almost ten times faster than 'rational'.

383+-- On integral inputs, it gives perfectly accurate answers, and on

384+-- floating point inputs, it is slightly less accurate than

385+-- 'rational'.

396--

386--

397-- This function does not accept string representations of \"NaN\" or

387-- This function does not accept string representations of \"NaN\" or

398-- \"Infinity\".

388-- \"Infinity\".

@@ -403,11 +393,10 @@ number = scientifically $ \s ->

403 in if e >= 0

393 in if e >= 0

404 then I (c * 10 ^ e)

394 then I (c * 10 ^ e)

405 else D (Sci.toRealFloat s)

395 else D (Sci.toRealFloat s)

406−{-# DEPRECATED number "Use 'scientific' instead." #-}

407

396

408-- | Parse a scientific number.

397-- | Parse a scientific number.

409--

398--

410−-- The syntax accepted by this parser is the same as for 'double'.

399+-- The syntax accepted by this parser is the same as for 'rational'.

411scientific :: Parser Scientific

400scientific :: Parser Scientific

412scientific = scientifically id

401scientific = scientifically id

413

402

Data/Attoparsec/Text/Buffer.hs+33−72

@@ -1,9 +1,8 @@

1−{-# LANGUAGE BangPatterns, CPP, MagicHash, RankNTypes, RecordWildCards,

1+{-# LANGUAGE MagicHash, RankNTypes, RecordWildCards, UnboxedTuples #-}

2− UnboxedTuples #-}

3

2

4-- |

3-- |

5-- Module : Data.Attoparsec.Text.Buffer

4-- Module : Data.Attoparsec.Text.Buffer

6−-- Copyright : Bryan O'Sullivan 2007-2015

5+-- Copyright : Bryan O'Sullivan 2007-2014

7-- License : BSD3

6-- License : BSD3

8--

7--

9-- Maintainer : bos@serpentine.com

8-- Maintainer : bos@serpentine.com

@@ -28,9 +27,7 @@ module Data.Attoparsec.Text.Buffer

28 Buffer

27 Buffer

29 , buffer

28 , buffer

30 , unbuffer

29 , unbuffer

31− , unbufferAt

32 , length

30 , length

33− , pappend

34 , iter

31 , iter

35 , iter_

32 , iter_

36 , substring

33 , substring

@@ -38,28 +35,23 @@ module Data.Attoparsec.Text.Buffer

38 ) where

35 ) where

39

36

40import Control.Exception (assert)

37import Control.Exception (assert)

41−import Data.Bits (shiftR)

42import Data.List (foldl1')

38import Data.List (foldl1')

43−import Data.Monoid as Mon (Monoid(..))

39+import Data.Monoid (Monoid(..))

44−import Data.Semigroup (Semigroup(..))

45import Data.Text ()

40import Data.Text ()

46import Data.Text.Internal (Text(..))

41import Data.Text.Internal (Text(..))

47import Data.Text.Internal.Encoding.Utf16 (chr2)

42import Data.Text.Internal.Encoding.Utf16 (chr2)

48import Data.Text.Internal.Unsafe.Char (unsafeChr)

43import Data.Text.Internal.Unsafe.Char (unsafeChr)

49import Data.Text.Unsafe (Iter(..))

44import Data.Text.Unsafe (Iter(..))

50−import Foreign.Storable (sizeOf)

51−import GHC.Base (Int(..), indexIntArray#, unsafeCoerce#, writeIntArray#)

45+import GHC.Base (unsafeCoerce#)

52import GHC.ST (ST(..), runST)

46import GHC.ST (ST(..), runST)

53import Prelude hiding (length)

47import Prelude hiding (length)

54import qualified Data.Text.Array as A

48import qualified Data.Text.Array as A

55

49

56−-- If _cap is zero, this buffer is empty.

57data Buffer = Buf {

50data Buffer = Buf {

58 _arr :: {-# UNPACK #-} !A.Array

51 _arr :: {-# UNPACK #-} !A.Array

59 , _off :: {-# UNPACK #-} !Int

52 , _off :: {-# UNPACK #-} !Int

60 , _len :: {-# UNPACK #-} !Int

53 , _len :: {-# UNPACK #-} !Int

61 , _cap :: {-# UNPACK #-} !Int

54 , _cap :: {-# UNPACK #-} !Int

62− , _gen :: {-# UNPACK #-} !Int

63 }

55 }

64

56

65instance Show Buffer where

57instance Show Buffer where

@@ -69,71 +61,48 @@ instance Show Buffer where

69-- copies in the (hopefully) common case of no further input being fed

61-- copies in the (hopefully) common case of no further input being fed

70-- to us.

62-- to us.

71buffer :: Text -> Buffer

63buffer :: Text -> Buffer

72−buffer (Text arr off len) = Buf arr off len len 0

64+buffer (Text arr off len) = Buf arr off len len

73

65

74unbuffer :: Buffer -> Text

66unbuffer :: Buffer -> Text

75−unbuffer (Buf arr off len _ _) = Text arr off len

67+unbuffer (Buf arr off len _cap) = 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

68

88instance Monoid Buffer where

69instance Monoid Buffer where

89− mempty = Buf A.empty 0 0 0 0

70+ mempty = Buf A.empty 0 0 0

90− {-# INLINE mempty #-}

71+

91−

92− mappend = (<>)

72+ mappend (Buf _ _ _ 0) b = b

93−

73+ mappend a (Buf _ _ _ 0) = a

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

74+ mappend (Buf arr0 off0 len0 cap0) (Buf arr1 off1 len1 _cap1) = runST $ do

103− let woff = sizeOf (0::Int) `shiftR` 1

104− newlen = len0 + len1

75+ let newlen = len0 + len1

105− !gen = if gen0 == 0 then 0 else readGen arr0

106− if gen == gen0 && newlen <= cap0

76+ if newlen <= cap0

107− then do

77+ then do

108− let newgen = gen + 1

109− marr <- unsafeThaw arr0

78+ marr <- unsafeThaw arr0

110− writeGen marr newgen

111− A.copyI marr (off0+len0) arr1 off1 (off0+newlen)

79+ A.copyI marr (off0+len0) arr1 off1 (off0+newlen)

112− arr2 <- A.unsafeFreeze marr

80+ arr2 <- A.unsafeFreeze marr

113− return (Buf arr2 off0 newlen cap0 newgen)

81+ return (Buf arr2 off0 newlen cap0)

114− else do

82+ else do

115− let newcap = newlen * 2

83+ let newcap = newlen * 2

116− newgen = 1

117− marr <- A.new (newcap + woff)

84+ marr <- A.new newcap

118− writeGen marr newgen

119− A.copyI marr woff arr0 off0 (woff+len0)

85+ A.copyI marr 0 arr0 off0 len0

120− A.copyI marr (woff+len0) arr1 off1 (woff+newlen)

86+ A.copyI marr len0 arr1 off1 newlen

121− arr2 <- A.unsafeFreeze marr

87+ arr2 <- A.unsafeFreeze marr

122− return (Buf arr2 woff newlen newcap newgen)

88+ return (Buf arr2 0 newlen newcap)

89+

90+ mconcat [] = mempty

91+ mconcat xs = foldl1' mappend xs

123

92

124length :: Buffer -> Int

93length :: Buffer -> Int

125−length (Buf _ _ len _ _) = len

94+length (Buf _ _ len _) = len

126{-# INLINE length #-}

95{-# INLINE length #-}

127

96

128substring :: Int -> Int -> Buffer -> Text

97substring :: Int -> Int -> Buffer -> Text

129−substring s l (Buf arr off len _ _) =

98+substring s l (Buf arr off len _cap) =

130 assert (s >= 0 && s <= len) .

99 assert (s >= 0 && s <= len) .

131 assert (l >= 0 && l <= len-s) $

100 assert (l >= 0 && l <= len-s) $

132 Text arr (off+s) l

101 Text arr (off+s) l

133{-# INLINE substring #-}

102{-# INLINE substring #-}

134

103

135dropWord16 :: Int -> Buffer -> Text

104dropWord16 :: Int -> Buffer -> Text

136−dropWord16 s (Buf arr off len _ _) =

105+dropWord16 s (Buf arr off len _cap) =

137 assert (s >= 0 && s <= len) $

106 assert (s >= 0 && s <= len) $

138 Text arr (off+s) (len-s)

107 Text arr (off+s) (len-s)

139{-# INLINE dropWord16 #-}

108{-# INLINE dropWord16 #-}

@@ -142,7 +111,7 @@ dropWord16 s (Buf arr off len _ _) =

142-- array, returning the current character and the delta to add to give

111-- array, returning the current character and the delta to add to give

143-- the next offset to iterate at.

112-- the next offset to iterate at.

144iter :: Buffer -> Int -> Iter

113iter :: Buffer -> Int -> Iter

145−iter (Buf arr off _ _ _) i

114+iter (Buf arr off _len _cap) i

146 | m < 0xD800 || m > 0xDBFF = Iter (unsafeChr m) 1

115 | m < 0xD800 || m > 0xDBFF = Iter (unsafeChr m) 1

147 | otherwise = Iter (chr2 m n) 2

116 | otherwise = Iter (chr2 m n) 2

148 where m = A.unsafeIndex arr j

117 where m = A.unsafeIndex arr j

@@ -154,7 +123,7 @@ iter (Buf arr off _ _ _) i

154-- | /O(1)/ Iterate one step through a UTF-16 array, returning the

123-- | /O(1)/ Iterate one step through a UTF-16 array, returning the

155-- delta to add to give the next offset to iterate at.

124-- delta to add to give the next offset to iterate at.

156iter_ :: Buffer -> Int -> Int

125iter_ :: Buffer -> Int -> Int

157−iter_ (Buf arr off _ _ _) i | m < 0xD800 || m > 0xDBFF = 1

126+iter_ (Buf arr off _len _cap) i | m < 0xD800 || m > 0xDBFF = 1

158 | otherwise = 2

127 | otherwise = 2

159 where m = A.unsafeIndex arr (off+i)

128 where m = A.unsafeIndex arr (off+i)

160{-# INLINE iter_ #-}

129{-# INLINE iter_ #-}

@@ -162,11 +131,3 @@ iter_ (Buf arr off _ _ _) i | m < 0xD800 || m > 0xDBFF = 1

162unsafeThaw :: A.Array -> ST s (A.MArray s)

131unsafeThaw :: A.Array -> ST s (A.MArray s)

163unsafeThaw A.Array{..} = ST $ \s# ->

132unsafeThaw A.Array{..} = ST $ \s# ->

164 (# s#, A.MArray (unsafeCoerce# aBA) #)

133 (# 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+27−85

@@ -1,20 +1,16 @@

1−{-# LANGUAGE BangPatterns #-}

1+-----------------------------------------------------------------------------

2−

3−------------------------------------------------------------------------------

4-- |

2-- |

5-- Module : Data.Attoparsec.FastSet

3-- Module : Data.Attoparsec.FastSet

6−-- Copyright : Felipe Lessa 2010, Bryan O'Sullivan 2007-2015

4+-- Copyright : Felipe Lessa 2010, Bryan O'Sullivan 2007-2014

7-- License : BSD3

5-- License : BSD3

8--

6--

9-- Maintainer : felipe.lessa@gmail.com

7-- Maintainer : felipe.lessa@gmail.com

10-- Stability : experimental

8-- Stability : experimental

11-- Portability : unknown

9-- Portability : unknown

12--

10--

13−-- Fast set membership tests for 'Char' values. We test for

11+-- Fast set membership tests for 'Char' values. The set

14−-- membership using a hashtable implemented with Robin Hood

15−-- collision resolution. The set representation is unboxed,

12+-- representation is unboxed for efficiency. We test for

16−-- and the characters and hashes interleaved, for efficiency.

13+-- membership using a binary search.

17−--

18--

14--

19-----------------------------------------------------------------------------

15-----------------------------------------------------------------------------

20module Data.Attoparsec.Text.FastSet

16module Data.Attoparsec.Text.FastSet

@@ -30,92 +26,38 @@ module Data.Attoparsec.Text.FastSet

30 , charClass

26 , charClass

31 ) where

27 ) where

32

28

33−import Data.Bits ((.|.), (.&.), shiftR)

29+import Data.List (sort)

34−import Data.Function (on)

35−import Data.List (sort, sortBy)

36import qualified Data.Array.Base as AB

30import qualified Data.Array.Base as AB

37import qualified Data.Array.Unboxed as A

31import qualified Data.Array.Unboxed as A

38import qualified Data.Text as T

32import qualified Data.Text as T

39

33

40−data FastSet = FastSet {

34+newtype FastSet = FastSet (A.UArray Int Char)

41− table :: {-# UNPACK #-} !(A.UArray Int Int)

35+ deriving (Eq, Ord, Show)

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

36

63−pad :: Int -> [Entry] -> [Entry]

37+-- | Create a set.

64−pad = go 0

38+set :: T.Text -> FastSet

65− where -- ensure that we pad enough so that lookups beyond the

39+set t = mkSet (T.length t) (sort $ T.unpack t)

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

40

96−ordNub :: Eq a => [a] -> [a]

41+fromList :: [Char] -> FastSet

97−ordNub [] = []

42+fromList cs = mkSet (length cs) (sort cs)

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

43

104−set :: T.Text -> FastSet

44+mkSet :: Int -> [Char] -> FastSet

105−set = fromList . T.unpack

45+mkSet l = FastSet . A.listArray (0,l-1)

106

46

107-- | Check the set for membership.

47-- | Check the set for membership.

108member :: Char -> FastSet -> Bool

48member :: Char -> FastSet -> Bool

109−member c a = go (2 * i)

49+member c (FastSet a) = uncurry search (A.bounds a)

110− where i = fastHash c .&. mask a

50+ where search lo hi

111− lookupAt j b = (i' <= i) && (c == c' || b)

51+ | hi < lo = False

112− where c' = toEnum $ AB.unsafeAt (table a) j

52+ | otherwise =

53+ let mid = (lo + hi) `quot` 2

113− i' = AB.unsafeAt (table a) $ j + 1

54+ in case compare c (AB.unsafeAt a mid) of

114− go j = lookupAt j . lookupAt (j + 2) . lookupAt (j + 4) .

55+ GT -> search (mid + 1) hi

115− lookupAt (j + 6) . go $ j + 8

56+ LT -> search lo (mid - 1)

57+ _ -> True

116

58

117charClass :: String -> FastSet

59charClass :: String -> FastSet

118charClass = fromList . go

60charClass = fromList . go

119− where go (a:'-':b:xs) = [a..b] ++ go xs

61+ where go (a:'-':b:xs) = [a..b] ++ go xs

120− go (x:xs) = x : go xs

62+ go (x:xs) = x : go xs

121− go _ = ""

63+ go _ = ""

Data/Attoparsec/Text/Internal.hs+112−114

@@ -3,14 +3,14 @@

3{-# OPTIONS_GHC -fno-warn-orphans #-}

4-- |

5-- Module : Data.Attoparsec.Text.Internal

6−-- Copyright : Bryan O'Sullivan 2007-2015

6+-- Copyright : Bryan O'Sullivan 2007-2014

7-- License : BSD3

8--

9-- Maintainer : bos@serpentine.com

10-- Stability : experimental

11-- Portability : unknown

12--

13−-- Simple, efficient parser combinators for 'Text' strings, loosely

13+-- Simple, efficient parser combinators for 'T.Text' strings, loosely

14-- based on the Parsec library.

15

16module Data.Attoparsec.Text.Internal

@@ -65,26 +65,24 @@ module Data.Attoparsec.Text.Internal

65 , atEnd

66 ) where

67

68−import Control.Applicative ((<|>), (<$>), pure, (*>))

68+import Control.Applicative ((<|>), (<$>))

69import Control.Monad (when)

70import Data.Attoparsec.Combinator ((<?>))

71−import Data.Attoparsec.Internal

72import Data.Attoparsec.Internal.Types hiding (Parser, Failure, Success)

71import Data.Attoparsec.Internal.Types hiding (Parser, Failure, Success)

73import qualified Data.Attoparsec.Text.Buffer as Buf

72import qualified Data.Attoparsec.Text.Buffer as Buf

74import Data.Attoparsec.Text.Buffer (Buffer, buffer)

73import Data.Attoparsec.Text.Buffer (Buffer, buffer)

75−import Data.Char (isAsciiUpper, isAsciiLower, toUpper, toLower)

74+import Data.Char (chr, ord)

76−import Data.List (intercalate)

77import Data.String (IsString(..))

75import Data.String (IsString(..))

78import Data.Text.Internal (Text(..))

76import Data.Text.Internal (Text(..))

79−import Prelude hiding (getChar, succ, take, takeWhile)

77+import Prelude hiding (getChar, length, succ, take, takeWhile)

80import qualified Data.Attoparsec.Internal.Types as T

78import qualified Data.Attoparsec.Internal.Types as T

81import qualified Data.Attoparsec.Text.FastSet as Set

79import qualified Data.Attoparsec.Text.FastSet as Set

82import qualified Data.Text as T

80import qualified Data.Text as T

83import qualified Data.Text.Lazy as L

81import qualified Data.Text.Lazy as L

84import qualified Data.Text.Unsafe as T

82import qualified Data.Text.Unsafe as T

85

83

86−type Parser = T.Parser Text

84+type Parser = T.Parser Text Buffer

87−type Result = IResult Text

85+type Result = IResult Text Buffer

88type Failure r = T.Failure Text Buffer r

86type Failure r = T.Failure Text Buffer r

89type Success a r = T.Success Text Buffer a r

87type Success a r = T.Success Text Buffer a r

90

88

@@ -157,49 +155,12 @@ take n = takeWith (max n 0) (const True)

157--

155--

158-- The reason for its failure is that the first branch is a

156-- The reason for its failure is that the first branch is a

159-- partial match, and will consume the letters @\'f\'@ and @\'o\'@

157-- partial match, and will consume the letters @\'f\'@ and @\'o\'@

160−-- before failing. In attoparsec, the above parser will /succeed/ on

158+-- before failing. In Attoparsec, the above parser will /succeed/ on

161-- that input, because the failed first branch will consume nothing.

159-- that input, because the failed first branch will consume nothing.

162string :: Text -> Parser Text

160string :: Text -> Parser Text

163−string s = string_ (stringSuspended id) id s

161+string s = takeWith (T.length s) (==s)

164{-# INLINE string #-}

162{-# INLINE string #-}

165

163

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−

203-- | Satisfy a literal string, ignoring case.

164-- | Satisfy a literal string, ignoring case.

204--

165--

205-- Note: this function is currently quite inefficient. Unicode case

166-- Note: this function is currently quite inefficient. Unicode case

@@ -222,24 +183,34 @@ stringCI s = go 0

222

183

223-- | Satisfy a literal string, ignoring case for characters in the ASCII range.

184-- | Satisfy a literal string, ignoring case for characters in the ASCII range.

224asciiCI :: Text -> Parser Text

185asciiCI :: Text -> Parser Text

225−asciiCI s = fmap fst $ match $ T.foldr ((*>) . asciiCharCI) (pure ()) s

186+asciiCI input = do

187+ (k,t) <- ensure n

188+ if asciiToLower t == s

189+ then advance k >> return t

190+ else fail "asciiCI"

191+ where

192+ n = T.length input

193+ s = asciiToLower input

194+

195+ -- convert letters in the ASCII range to lower-case

196+ asciiToLower = T.map f

197+ where

198+ offset = ord 'a' - ord 'A'

199+ f c | 'A' <= c && c <= 'Z' = chr (ord c + offset)

200+ | otherwise = c

226{-# INLINE asciiCI #-}

201{-# INLINE asciiCI #-}

227

202

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−

235-- | Skip past input for as long as the predicate returns 'True'.

203-- | Skip past input for as long as the predicate returns 'True'.

236skipWhile :: (Char -> Bool) -> Parser ()

204skipWhile :: (Char -> Bool) -> Parser ()

237skipWhile p = go

205skipWhile p = go

238 where

206 where

239 go = do

207 go = do

240 t <- T.takeWhile p <$> get

208 t <- T.takeWhile p <$> get

241− continue <- inputSpansChunks (size t)

209+ advance (length t)

242− when continue go

210+ eoc <- endOfChunk

211+ when eoc $ do

212+ input <- wantInput

213+ when input go

243{-# INLINE skipWhile #-}

214{-# INLINE skipWhile #-}

244

215

245-- | Consume input as long as the predicate returns 'False'

216-- | Consume input as long as the predicate returns 'False'

@@ -267,25 +238,19 @@ takeTill p = takeWhile (not . p)

267-- parsers loop until a failure occurs. Careless use will thus result

238-- parsers loop until a failure occurs. Careless use will thus result

268-- in an infinite loop.

239-- in an infinite loop.

269takeWhile :: (Char -> Bool) -> Parser Text

240takeWhile :: (Char -> Bool) -> Parser Text

270−takeWhile p = do

241+takeWhile p = (T.concat . reverse) `fmap` go []

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

281 where

242 where

282 go acc = do

243 go acc = do

283 h <- T.takeWhile p <$> get

244 h <- T.takeWhile p <$> get

284− continue <- inputSpansChunks (size h)

245+ advance (length h)

285− if continue

246+ eoc <- endOfChunk

247+ if eoc

248+ then do

249+ input <- wantInput

250+ if input

286− then go (h:acc)

251+ then go (h:acc)

287− else return $ concatReverse (h:acc)

252+ else return (h:acc)

288−{-# INLINE takeWhileAcc #-}

253+ else return (h:acc)

289

254

290takeRest :: Parser [Text]

255takeRest :: Parser [Text]

291takeRest = go []

256takeRest = go []

@@ -295,7 +260,7 @@ takeRest = go []

295 if input

260 if input

296 then do

261 then do

297 s <- get

262 s <- get

298− advance (size s)

263+ advance (length s)

299 go (s:acc)

264 go (s:acc)

300 else return (reverse acc)

265 else return (reverse acc)

301

266

@@ -308,7 +273,7 @@ takeLazyText :: Parser L.Text

308takeLazyText = L.fromChunks `fmap` takeRest

273takeLazyText = L.fromChunks `fmap` takeRest

309

274

310data Scan s = Continue s

275data Scan s = Continue s

311− | Finished s {-# UNPACK #-} !Int Text

276+ | Finished {-# UNPACK #-} !Int T.Text

312

277

313scan_ :: (s -> [Text] -> Parser r) -> s -> (s -> Char -> Maybe s) -> Parser r

278scan_ :: (s -> [Text] -> Parser r) -> s -> (s -> Char -> Maybe s) -> Parser r

314scan_ f s0 p = go [] s0

279scan_ f s0 p = go [] s0

@@ -317,17 +282,18 @@ scan_ f s0 p = go [] s0

317 case T.uncons t of

282 case T.uncons t of

318 Just (c,t') -> case p s c of

283 Just (c,t') -> case p s c of

319 Just s' -> scanner s' (n+1) t'

284 Just s' -> scanner s' (n+1) t'

320− Nothing -> Finished s n t

285+ Nothing -> Finished n t

321 Nothing -> Continue s

286 Nothing -> Continue s

322 go acc s = do

287 go acc s = do

323 input <- get

288 input <- get

324 case scanner s 0 input of

289 case scanner s 0 input of

325− Continue s' -> do continue <- inputSpansChunks (size input)

290+ Continue s' -> do advance (length input)

326− if continue

291+ more <- wantInput

292+ if more

327 then go (input : acc) s'

293 then go (input : acc) s'

328 else f s' (input : acc)

294 else f s' (input : acc)

329− Finished s' n t -> do advance (size input - size t)

295+ Finished n t -> do advance (length input - length t)

330− f s' (T.take n input : acc)

296+ f s (T.take n input : acc)

331{-# INLINE scan_ #-}

297{-# INLINE scan_ #-}

332

298

333-- | A stateful scanner. The predicate consumes and transforms a

299-- | A stateful scanner. The predicate consumes and transforms a

@@ -343,13 +309,16 @@ scan_ f s0 p = go [] s0

343-- parsers loop until a failure occurs. Careless use will thus result

309-- parsers loop until a failure occurs. Careless use will thus result

344-- in an infinite loop.

310-- in an infinite loop.

345scan :: s -> (s -> Char -> Maybe s) -> Parser Text

311scan :: s -> (s -> Char -> Maybe s) -> Parser Text

346−scan = scan_ $ \_ chunks -> return $! concatReverse chunks

312+scan = scan_ $ \_ chunks ->

313+ case chunks of

314+ [x] -> return x

315+ xs -> return . T.concat . reverse $ xs

347{-# INLINE scan #-}

316{-# INLINE scan #-}

348

317

349-- | Like 'scan', but generalized to return the final state of the

318-- | Like 'scan', but generalized to return the final state of the

350-- scanner.

319-- scanner.

351runScanner :: s -> (s -> Char -> Maybe s) -> Parser (Text, s)

320runScanner :: s -> (s -> Char -> Maybe s) -> Parser (Text, s)

352−runScanner = scan_ $ \s xs -> let !sx = concatReverse xs in return (sx, s)

321+runScanner = scan_ $ \s xs -> return (T.concat (reverse xs), s)

353{-# INLINE runScanner #-}

322{-# INLINE runScanner #-}

354

323

355-- | Consume input as long as the predicate returns 'True', and return

324-- | Consume input as long as the predicate returns 'True', and return

@@ -362,14 +331,13 @@ takeWhile1 :: (Char -> Bool) -> Parser Text

362takeWhile1 p = do

331takeWhile1 p = do

363 (`when` demandInput) =<< endOfChunk

332 (`when` demandInput) =<< endOfChunk

364 h <- T.takeWhile p <$> get

333 h <- T.takeWhile p <$> get

365− let size' = size h

334+ let len = length h

366− when (size' == 0) $ fail "takeWhile1"

335+ when (len == 0) $ fail "takeWhile1"

367− advance size'

336+ advance len

368 eoc <- endOfChunk

337 eoc <- endOfChunk

369 if eoc

338 if eoc

370− then takeWhileAcc p [h]

339+ then (h<>) `fmap` takeWhile p

371 else return h

340 else return h

372−{-# INLINE takeWhile1 #-}

373

341

374-- | Match any character in a set.

342-- | Match any character in a set.

375--

343--

@@ -459,20 +427,11 @@ parse m s = runParser m (buffer s) 0 Incomplete failK successK

459{-# INLINE parse #-}

427{-# INLINE parse #-}

460

428

461-- | Run a parser that cannot be resupplied via a 'Partial' result.

429-- | 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−-- @

470parseOnly :: Parser a -> Text -> Either String a

430parseOnly :: Parser a -> Text -> Either String a

471parseOnly m s = case runParser m (buffer s) 0 Complete failK successK of

431parseOnly 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)

432+ Fail _ _ err -> Left err

474− Done _ a -> Right a

433+ Done _ a -> Right a

475− _ -> error "parseOnly: impossible error!"

434+ _ -> error "parseOnly: impossible error!"

476{-# INLINE parseOnly #-}

435{-# INLINE parseOnly #-}

477

436

478get :: Parser Text

437get :: Parser Text

@@ -485,16 +444,6 @@ endOfChunk = T.Parser $ \t pos more _lose succ ->

485 succ t pos more (pos == lengthOf t)

444 succ t pos more (pos == lengthOf t)

486{-# INLINE endOfChunk #-}

445{-# INLINE endOfChunk #-}

487

446

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−

498advance :: Pos -> Parser ()

447advance :: Pos -> Parser ()

499advance n = T.Parser $ \t pos more _lose succ -> succ t (pos+n) more ()

448advance n = T.Parser $ \t pos more _lose succ -> succ t (pos+n) more ()

500{-# INLINE advance #-}

449{-# INLINE advance #-}

@@ -517,8 +466,53 @@ ensure n = T.Parser $ \t pos more lose succ ->

517 Just n' -> succ t pos more (n', substring pos n' t)

466 Just n' -> succ t pos more (n', substring pos n' t)

518 -- The uncommon case is kept out-of-line to reduce code size:

467 -- The uncommon case is kept out-of-line to reduce code size:

519 Nothing -> ensureSuspended n t pos more lose succ

468 Nothing -> ensureSuspended n t pos more lose succ

469+-- Non-recursive so the bounds check can be inlined:

520{-# INLINE ensure #-}

470{-# INLINE ensure #-}

521

471

472+-- | Ask for input. If we receive any, pass it to a success

473+-- continuation, otherwise to a failure continuation.

474+prompt :: Buffer -> Pos -> More

475+ -> (Buffer -> Pos -> More -> IResult Text Buffer r)

476+ -> (Buffer -> Pos -> More -> IResult Text Buffer r)

477+ -> IResult Text Buffer r

478+prompt t pos _more lose succ = Partial $ \s ->

479+ if T.null s

480+ then lose t pos Complete

481+ else succ (t <> buffer s) pos Incomplete

482+

483+-- | Immediately demand more input via a 'Partial' continuation

484+-- result.

485+demandInput :: Parser ()

486+demandInput = T.Parser $ \t pos more lose succ ->

487+ case more of

488+ Complete -> lose t pos more [] "not enough input"

489+ _ -> let lose' t' pos' more' = lose t' pos' more' [] "not enough input"

490+ succ' t' pos' more' = succ t' pos' more' ()

491+ in prompt t pos more lose' succ'

492+

493+-- | This parser always succeeds. It returns 'True' if any input is

494+-- available either immediately or on demand, and 'False' if the end

495+-- of all input has been reached.

496+wantInput :: Parser Bool

497+wantInput = T.Parser $ \t pos more _lose succ ->

498+ case () of

499+ _ | pos < lengthOf t -> succ t pos more True

500+ | more == Complete -> succ t pos more False

501+ | otherwise -> let lose' t' pos' more' = succ t' pos' more' False

502+ succ' t' pos' more' = succ t' pos' more' True

503+ in prompt t pos more lose' succ'

504+

505+-- | Match only if all input has been consumed.

506+endOfInput :: Parser ()

507+endOfInput = T.Parser $ \t pos more lose succ ->

508+ case () of

509+ _| pos < lengthOf t -> lose t pos more [] "endOfInput"

510+ | more == Complete -> succ t pos more ()

511+ | otherwise ->

512+ let lose' t' pos' more' _ctx _msg = succ t' pos' more' ()

513+ succ' t' pos' more' _a = lose t' pos' more' [] "endOfInput"

514+ in runParser demandInput t pos more lose' succ'

515+

522-- | Return both the result of a parse and the portion of the input

516-- | Return both the result of a parse and the portion of the input

523-- that was consumed while it was being parsed.

517-- that was consumed while it was being parsed.

524match :: Parser a -> Parser (Text, a)

518match :: Parser a -> Parser (Text, a)

@@ -527,8 +521,12 @@ match p = T.Parser $ \t pos more lose succ ->

527 (substring pos (pos'-pos) t', a)

521 (substring pos (pos'-pos) t', a)

528 in runParser p t pos more lose succ'

522 in runParser p t pos more lose succ'

529

523

530−-- | Ensure that at least @n@ code points of input are available.

524+-- | Return an indication of whether the end of input has been

531−-- Returns the number of words consumed while traversing.

525+-- reached.

526+atEnd :: Parser Bool

527+atEnd = not <$> wantInput

528+{-# INLINE atEnd #-}

529+

532lengthAtLeast :: Pos -> Int -> Buffer -> Maybe Pos

530lengthAtLeast :: Pos -> Int -> Buffer -> Maybe Pos

533lengthAtLeast pos n t = go 0 (fromPos pos)

531lengthAtLeast pos n t = go 0 (fromPos pos)

534 where go i !p

532 where go i !p

@@ -545,5 +543,5 @@ substring (Pos pos) (Pos n) = Buf.substring pos n

545lengthOf :: Buffer -> Pos

543lengthOf :: Buffer -> Pos

546lengthOf = Pos . Buf.length

544lengthOf = Pos . Buf.length

547

545

548−size :: Text -> Pos

546+length :: Text -> Pos

549−size (Text _ _ l) = Pos l

547+length = Pos . T.length

Data/Attoparsec/Text/Lazy.hs+10−13

@@ -1,12 +1,7 @@

1−{-# LANGUAGE CPP #-}

2−#if __GLASGOW_HASKELL__ >= 702

3−{-# LANGUAGE Trustworthy #-} -- Imports internal modules

4−#endif

5−

6{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}

1{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}

7-- |

2-- |

8-- Module : Data.Attoparsec.Text.Lazy

3-- Module : Data.Attoparsec.Text.Lazy

9−-- Copyright : Bryan O'Sullivan 2007-2015

4+-- Copyright : Bryan O'Sullivan 2007-2014

10-- License : BSD3

5-- License : BSD3

11--

6--

12-- Maintainer : bos@serpentine.com

7-- Maintainer : bos@serpentine.com

@@ -41,7 +36,6 @@ module Data.Attoparsec.Text.Lazy

41 ) where

36 ) where

42

37

43import Control.DeepSeq (NFData(rnf))

38import Control.DeepSeq (NFData(rnf))

44−import Data.List (intercalate)

45import Data.Text.Lazy.Internal (Text(..), chunk)

39import Data.Text.Lazy.Internal (Text(..), chunk)

46import qualified Data.Attoparsec.Internal.Types as T

40import qualified Data.Attoparsec.Internal.Types as T

47import qualified Data.Attoparsec.Text as A

41import qualified Data.Attoparsec.Text as A

@@ -51,16 +45,20 @@ import Data.Attoparsec.Text hiding (IResult(..), Result, eitherResult,

51

45

52-- | The result of a parse.

46-- | The result of a parse.

53data Result r = Fail Text [String] String

47data Result r = Fail Text [String] String

54− -- ^ The parse failed. The 'Text' is the input

48+ -- ^ The parse failed. The 'ByteString' is the input

55 -- that had not yet been consumed when the failure

49 -- that had not yet been consumed when the failure

56 -- occurred. The @[@'String'@]@ is a list of contexts

50 -- occurred. The @[@'String'@]@ is a list of contexts

57 -- in which the error occurred. The 'String' is the

51 -- in which the error occurred. The 'String' is the

58 -- message describing the error, if any.

52 -- message describing the error, if any.

59 | Done Text r

53 | Done Text r

60− -- ^ The parse succeeded. The 'Text' is the

54+ -- ^ The parse succeeded. The 'ByteString' is the

61 -- input that had not yet been consumed (if any) when

55 -- input that had not yet been consumed (if any) when

62 -- the parse succeeded.

56 -- the parse succeeded.

63− deriving (Show)

57+

58+instance Show r => Show (Result r) where

59+ show (Fail bs stk msg) =

60+ "Fail " ++ show bs ++ " " ++ show stk ++ " " ++ show msg

61+ show (Done bs r) = "Done " ++ show bs ++ " " ++ show r

64

62

65instance NFData r => NFData (Result r) where

63instance NFData r => NFData (Result r) where

66 rnf (Fail bs ctxs msg) = rnf bs `seq` rnf ctxs `seq` rnf msg

64 rnf (Fail bs ctxs msg) = rnf bs `seq` rnf ctxs `seq` rnf msg

@@ -96,6 +94,5 @@ maybeResult _ = Nothing

96

94

97-- | Convert a 'Result' value to an 'Either' value.

95-- | Convert a 'Result' value to an 'Either' value.

98eitherResult :: Result r -> Either String r

96eitherResult :: Result r -> Either String r

99−eitherResult (Done _ r) = Right r

97+eitherResult (Done _ r) = Right r

100−eitherResult (Fail _ [] msg) = Left msg

98+eitherResult (Fail _ _ msg) = Left msg

101−eitherResult (Fail _ ctxs msg) = Left (intercalate " > " ctxs ++ ": " ++ msg)

Data/Attoparsec/Types.hs+2−3

@@ -1,6 +1,6 @@

1-- |

2-- Module : Data.Attoparsec.Types

3−-- Copyright : Bryan O'Sullivan 2007-2015

3+-- Copyright : Bryan O'Sullivan 2007-2014

4-- License : BSD3

5--

6-- Maintainer : bos@serpentine.com

@@ -14,7 +14,6 @@ module Data.Attoparsec.Types

14 (

15 Parser

16 , IResult(..)

17− , Chunk(chunkElemToChar)

18 ) where

17 ) where

19

18

20−import Data.Attoparsec.Internal.Types (Parser(..), IResult(..), Chunk(..))

19+import Data.Attoparsec.Internal.Types (Parser(..), IResult(..))

Data/Attoparsec/Zepto.hs+46−88

@@ -1,12 +1,8 @@

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}

2−#if __GLASGOW_HASKELL__ >= 702

3−{-# LANGUAGE Trustworthy #-} -- Data.ByteString.Unsafe

4−#endif

5−{-# LANGUAGE BangPatterns #-}

6

2

7-- |

3-- |

8-- Module : Data.Attoparsec.Zepto

4-- Module : Data.Attoparsec.Zepto

9−-- Copyright : Bryan O'Sullivan 2007-2015

5+-- Copyright : Bryan O'Sullivan 2007-2014

10-- License : BSD3

6-- License : BSD3

11--

7--

12-- Maintainer : bos@serpentine.com

8-- Maintainer : bos@serpentine.com

@@ -16,150 +12,112 @@

16-- A tiny, highly specialized combinator parser for 'B.ByteString'

12-- A tiny, highly specialized combinator parser for 'B.ByteString'

17-- strings.

13-- strings.

18--

14--

19−-- While the main attoparsec module generally performs well, this

15+-- While the main Attoparsec module generally performs well, this

20-- module is particularly fast for simple non-recursive loops that

16-- module is particularly fast for simple non-recursive loops that

21-- should not normally result in failed parses.

17-- should not normally result in failed parses.

22--

18--

23-- /Warning/: on more complex inputs involving recursion or failure,

19-- /Warning/: on more complex inputs involving recursion or failure,

24-- parsers based on this module may be as much as /ten times slower/

20-- parsers based on this module may be as much as /ten times slower/

25−-- than regular attoparsec! You should /only/ use this module when you

21+-- than regular Attoparsec! You should /only/ use this module when you

26-- have benchmarks that prove that its use speeds your code up.

22-- have benchmarks that prove that its use speeds your code up.

27module Data.Attoparsec.Zepto

23module Data.Attoparsec.Zepto

28 (

24 (

29 Parser

25 Parser

30− , ZeptoT

31 , parse

26 , parse

32− , parseT

33 , atEnd

27 , atEnd

34 , string

28 , string

35 , take

29 , take

36 , takeWhile

30 , takeWhile

37 ) where

31 ) where

38

32

39−import Control.Applicative

40−import Control.Monad (MonadPlus(..), ap)

41−import qualified Control.Monad.Fail as Fail

42−import Control.Monad.IO.Class (MonadIO(..))

43−import Data.ByteString (ByteString)

44−import Data.Functor.Identity (Identity(runIdentity))

45−import Data.Monoid as Mon (Monoid(..))

46−import Data.Semigroup (Semigroup(..))

47import Data.Word (Word8)

33import Data.Word (Word8)

48−import Prelude hiding (take, takeWhile)

34+import Control.Applicative

35+import Control.Monad

36+import Data.Monoid

49import qualified Data.ByteString as B

37import qualified Data.ByteString as B

50import qualified Data.ByteString.Unsafe as B

38import qualified Data.ByteString.Unsafe as B

39+import Data.ByteString (ByteString)

40+import Prelude hiding (take, takeWhile)

51

41

52newtype S = S {

42newtype S = S {

53 input :: ByteString

43 input :: ByteString

54 }

44 }

55

45

56data Result a = Fail String

46data Result a = Fail String

57− | OK !a S

47+ | OK !a

58

48

59-- | A simple parser.

49-- | A simple parser.

60--

50--

61-- This monad is strict in its state, and the monadic bind operator

51-- This monad is strict in its state, and the monadic bind operator

62-- ('>>=') evaluates each result to weak head normal form before

52-- ('>>=') evaluates each result to weak head normal form before

63-- passing it along.

53-- passing it along.

64−newtype ZeptoT m a = Parser {

54+newtype Parser a = Parser {

65− runParser :: S -> m (Result a)

55+ runParser :: S -> (# Result a, S #)

66 }

56 }

67

57

68−type Parser a = ZeptoT Identity a

69−

70−instance Monad m => Functor (ZeptoT m) where

58+instance Functor Parser where

71− fmap f m = Parser $ \s -> do

59+ fmap f m = Parser $ \s -> case runParser m s of

72− result <- runParser m s

73− case result of

74− OK a s' -> return (OK (f a) s')

60+ (# OK a, s' #) -> (# OK (f a), s' #)

75− Fail err -> return (Fail err)

61+ (# Fail err, s' #) -> (# Fail err, s' #)

76 {-# INLINE fmap #-}

62 {-# INLINE fmap #-}

77

63

78−instance MonadIO m => MonadIO (ZeptoT m) where

64+instance Monad Parser where

79− liftIO act = Parser $ \s -> do

65+ return a = Parser $ \s -> (# OK a, s #)

80− result <- liftIO act

81− return (OK result s)

82− {-# INLINE liftIO #-}

83−

84−instance Monad m => Monad (ZeptoT m) where

85− return = pure

86 {-# INLINE return #-}

66 {-# INLINE return #-}

87

67

88− m >>= k = Parser $ \s -> do

68+ m >>= k = Parser $ \s -> case runParser m s of

89− result <- runParser m s

90− case result of

91− OK a s' -> runParser (k a) s'

69+ (# OK a, s' #) -> runParser (k a) s'

92− Fail err -> return (Fail err)

70+ (# Fail err, s' #) -> (# Fail err, s' #)

93 {-# INLINE (>>=) #-}

71 {-# INLINE (>>=) #-}

94

72

95−#if !(MIN_VERSION_base(4,13,0))

96− fail = Fail.fail

73+ fail msg = Parser $ \s -> (# Fail msg, s #)

97− {-# INLINE fail #-}

98−#endif

99

74

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

75+instance MonadPlus Parser where

105 mzero = fail "mzero"

76 mzero = fail "mzero"

106 {-# INLINE mzero #-}

77 {-# INLINE mzero #-}

107

78

108− mplus a b = Parser $ \s -> do

79+ mplus a b = Parser $ \s ->

109− result <- runParser a s

80+ case runParser a s of

110− case result of

81+ (# ok@(OK _), s' #) -> (# ok, s' #)

82+ (# _, _ #) -> case runParser b s of

111− ok@(OK _ _) -> return ok

83+ (# ok@(OK _), s'' #) -> (# ok, s'' #)

112− _ -> runParser b s

84+ (# err, s'' #) -> (# err, s'' #)

113 {-# INLINE mplus #-}

85 {-# INLINE mplus #-}

114

86

115−instance (Monad m) => Applicative (ZeptoT m) where

87+instance Applicative Parser where

116− pure a = Parser $ \s -> return (OK a s)

88+ pure = return

117 {-# INLINE pure #-}

89 {-# INLINE pure #-}

118 (<*>) = ap

90 (<*>) = ap

119 {-# INLINE (<*>) #-}

91 {-# INLINE (<*>) #-}

120

92

121−gets :: Monad m => (S -> a) -> ZeptoT m a

93+gets :: (S -> a) -> Parser a

122−gets f = Parser $ \s -> return (OK (f s) s)

94+gets f = Parser $ \s -> (# OK (f s), s #)

123{-# INLINE gets #-}

95{-# INLINE gets #-}

124

96

125−put :: Monad m => S -> ZeptoT m ()

97+put :: S -> Parser ()

126−put s = Parser $ \_ -> return (OK () s)

98+put s = Parser $ \_ -> (# OK (), s #)

127{-# INLINE put #-}

99{-# INLINE put #-}

128

100

129-- | Run a parser.

101-- | Run a parser.

130parse :: Parser a -> ByteString -> Either String a

102parse :: Parser a -> ByteString -> Either String a

131−parse p bs = case runIdentity (runParser p (S bs)) of

103+parse p bs = case runParser p (S bs) of

132− (OK a _) -> Right a

104+ (# 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)

105+ (# Fail err, _ #) -> Left err

143−{-# INLINE parseT #-}

106+

144−

107+instance Monoid (Parser a) where

145−instance Monad m => Semigroup (ZeptoT m a) where

146− (<>) = mplus

147− {-# INLINE (<>) #-}

148−

149−instance Monad m => Mon.Monoid (ZeptoT m a) where

150 mempty = fail "mempty"

108 mempty = fail "mempty"

151 {-# INLINE mempty #-}

109 {-# INLINE mempty #-}

152− mappend = (<>)

110+ mappend = mplus

153 {-# INLINE mappend #-}

111 {-# INLINE mappend #-}

154

112

155−instance Monad m => Alternative (ZeptoT m) where

113+instance Alternative Parser where

156 empty = fail "empty"

114 empty = fail "empty"

157 {-# INLINE empty #-}

115 {-# INLINE empty #-}

158 (<|>) = mplus

116 (<|>) = mplus

159 {-# INLINE (<|>) #-}

117 {-# INLINE (<|>) #-}

160

118

161-- | Consume input while the predicate returns 'True'.

119-- | Consume input while the predicate returns 'True'.

162−takeWhile :: Monad m => (Word8 -> Bool) -> ZeptoT m ByteString

120+takeWhile :: (Word8 -> Bool) -> Parser ByteString

163takeWhile p = do

121takeWhile p = do

164 (h,t) <- gets (B.span p . input)

122 (h,t) <- gets (B.span p . input)

165 put (S t)

123 put (S t)

@@ -167,7 +125,7 @@ takeWhile p = do

167{-# INLINE takeWhile #-}

125{-# INLINE takeWhile #-}

168

126

169-- | Consume @n@ bytes of input.

127-- | Consume @n@ bytes of input.

170−take :: Monad m => Int -> ZeptoT m ByteString

128+take :: Int -> Parser ByteString

171take !n = do

129take !n = do

172 s <- gets input

130 s <- gets input

173 if B.length s >= n

131 if B.length s >= n

@@ -176,7 +134,7 @@ take !n = do

176{-# INLINE take #-}

134{-# INLINE take #-}

177

135

178-- | Match a string exactly.

136-- | Match a string exactly.

179−string :: Monad m => ByteString -> ZeptoT m ()

137+string :: ByteString -> Parser ()

180string s = do

138string s = do

181 i <- gets input

139 i <- gets input

182 if s `B.isPrefixOf` i

140 if s `B.isPrefixOf` i

@@ -185,7 +143,7 @@ string s = do

185{-# INLINE string #-}

143{-# INLINE string #-}

186

144

187-- | Indicate whether the end of the input has been reached.

145-- | Indicate whether the end of the input has been reached.

188−atEnd :: Monad m => ZeptoT m Bool

146+atEnd :: Parser Bool

189atEnd = do

147atEnd = do

190 i <- gets input

148 i <- gets input

191 return $! B.null i

149 return $! B.null i

README.markdown+6

@@ -16,6 +16,12 @@ Master [git repository](https://github.com/bos/attoparsec):

16

17* `git clone git://github.com/bos/attoparsec.git`

18

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+

19Authors

25Authors

20-------

26-------

21

27

attoparsec.cabal+19−71

@@ -1,13 +1,12 @@

1name: attoparsec

2−version: 0.13.2.2

2+version: 0.12.0.0

3−x-revision: 3

4license: BSD3

3license: BSD3

5license-file: LICENSE

4license-file: LICENSE

6category: Text, Parsing

5category: Text, Parsing

7author: Bryan O'Sullivan <bos@serpentine.com>

6author: Bryan O'Sullivan <bos@serpentine.com>

8−maintainer: Bryan O'Sullivan <bos@serpentine.com>, Ben Gamari <ben@smart-cactus.org>

7+maintainer: Bryan O'Sullivan <bos@serpentine.com>

9stability: experimental

8stability: experimental

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

9+tested-with: GHC == 7.0, GHC == 7.2, GHC == 7.4, GHC == 7.6, GHC == 7.8

11synopsis: Fast combinator parsing for bytestrings and text

10synopsis: Fast combinator parsing for bytestrings and text

12cabal-version: >= 1.8

11cabal-version: >= 1.8

13homepage: https://github.com/bos/attoparsec

12homepage: https://github.com/bos/attoparsec

@@ -22,7 +21,6 @@ extra-source-files:

22 benchmarks/*.cabal

21 benchmarks/*.cabal

23 benchmarks/*.hs

22 benchmarks/*.hs

24 benchmarks/*.txt

23 benchmarks/*.txt

25− benchmarks/json-data/*.json

26 benchmarks/Makefile

24 benchmarks/Makefile

27 benchmarks/med.txt.bz2

25 benchmarks/med.txt.bz2

28 changelog.md

26 changelog.md

@@ -30,8 +28,9 @@ extra-source-files:

30 examples/*.hs

28 examples/*.hs

31 examples/Makefile

29 examples/Makefile

32 tests/*.hs

30 tests/*.hs

31+ tests/Makefile

33 tests/QC/*.hs

32 tests/QC/*.hs

34− tests/QC/IPv6/*.hs

33+ tests/TestFastSet.hs

35

34

36Flag developer

35Flag developer

37 Description: Whether to build the library in development mode

36 Description: Whether to build the library in development mode

@@ -40,30 +39,22 @@ Flag developer

40

39

41library

40library

42 build-depends: array,

41 build-depends: array,

43− base >= 4.3 && < 5,

42+ base >= 4.2 && < 5,

44 bytestring,

43 bytestring,

45 containers,

44 containers,

46 deepseq,

45 deepseq,

47 scientific >= 0.3.1 && < 0.4,

46 scientific >= 0.3.1 && < 0.4,

48− transformers >= 0.2 && (< 0.4 || >= 0.4.1.0) && < 0.6,

49 text >= 1.1.1.3

47 text >= 1.1.1.3

50 if impl(ghc < 7.4)

48 if impl(ghc < 7.4)

51 build-depends:

49 build-depends:

52 bytestring < 0.10.4.0

50 bytestring < 0.10.4.0

53

51

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

58−

59 exposed-modules: Data.Attoparsec

52 exposed-modules: Data.Attoparsec

60 Data.Attoparsec.ByteString

53 Data.Attoparsec.ByteString

61 Data.Attoparsec.ByteString.Char8

54 Data.Attoparsec.ByteString.Char8

62 Data.Attoparsec.ByteString.Lazy

55 Data.Attoparsec.ByteString.Lazy

63 Data.Attoparsec.Char8

56 Data.Attoparsec.Char8

64 Data.Attoparsec.Combinator

57 Data.Attoparsec.Combinator

65− Data.Attoparsec.Internal

66− Data.Attoparsec.Internal.Types

67 Data.Attoparsec.Lazy

58 Data.Attoparsec.Lazy

68 Data.Attoparsec.Number

59 Data.Attoparsec.Number

69 Data.Attoparsec.Text

60 Data.Attoparsec.Text

@@ -72,8 +63,10 @@ library

72 Data.Attoparsec.Zepto

63 Data.Attoparsec.Zepto

73 other-modules: Data.Attoparsec.ByteString.Buffer

64 other-modules: Data.Attoparsec.ByteString.Buffer

74 Data.Attoparsec.ByteString.FastSet

65 Data.Attoparsec.ByteString.FastSet

66+ Data.Attoparsec.ByteString.Fhthagn

75 Data.Attoparsec.ByteString.Internal

67 Data.Attoparsec.ByteString.Internal

76− Data.Attoparsec.Internal.Fhthagn

68+ Data.Attoparsec.Internal

69+ Data.Attoparsec.Internal.Types

77 Data.Attoparsec.Text.Buffer

70 Data.Attoparsec.Text.Buffer

78 Data.Attoparsec.Text.FastSet

71 Data.Attoparsec.Text.FastSet

79 Data.Attoparsec.Text.Internal

72 Data.Attoparsec.Text.Internal

@@ -91,31 +84,7 @@ test-suite tests

91 QC.ByteString

84 QC.ByteString

92 QC.Combinator

85 QC.Combinator

93 QC.Common

86 QC.Common

94− QC.IPv6.Internal

95− QC.IPv6.Types

96− QC.Rechunked

97− QC.Simple

98 QC.Text

87 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

119

88

120 ghc-options:

89 ghc-options:

121 -Wall -threaded -rtsopts

90 -Wall -threaded -rtsopts

@@ -125,40 +94,26 @@ test-suite tests

125

94

126 build-depends:

95 build-depends:

127 array,

96 array,

128− base,

97+ base >= 4 && < 5,

129 bytestring,

98 bytestring,

130 deepseq >= 1.1,

99 deepseq >= 1.1,

131− QuickCheck >= 2.13.2 && < 2.14,

100+ QuickCheck >= 2.7,

132− quickcheck-unicode,

133 scientific,

101 scientific,

134− tasty >= 0.11,

102+ test-framework >= 0.8.0.2,

135− tasty-quickcheck >= 0.8,

103+ test-framework-quickcheck2 >= 0.3.0.3,

136− text,

104+ 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

144

105

145benchmark benchmarks

106benchmark benchmarks

146 type: exitcode-stdio-1.0

107 type: exitcode-stdio-1.0

147− hs-source-dirs: benchmarks benchmarks/warp-3.0.1.1 .

108+ hs-source-dirs: benchmarks, .

148 ghc-options: -O2 -Wall -rtsopts

109 ghc-options: -O2 -Wall -rtsopts

149 main-is: Benchmarks.hs

110 main-is: Benchmarks.hs

150 other-modules:

111 other-modules:

151 Common

112 Common

152 HeadersByteString

113 HeadersByteString

153− HeadersByteString.Atto

154 HeadersText

114 HeadersText

155 Links

115 Links

156− Network.Wai.Handler.Warp.ReadInt

157− Network.Wai.Handler.Warp.RequestHeader

158 Numbers

116 Numbers

159− Sets

160− TextFastSet

161− Warp

162 ghc-options: -O2 -Wall

117 ghc-options: -O2 -Wall

163

118

164 if flag(developer)

119 if flag(developer)

@@ -168,27 +123,20 @@ benchmark benchmarks

168 array,

123 array,

169 base == 4.*,

124 base == 4.*,

170 bytestring >= 0.10.4.0,

125 bytestring >= 0.10.4.0,

171− case-insensitive,

172− containers,

173− criterion >= 1.0,

126+ criterion >= 0.8.1.0,

174 deepseq >= 1.1,

127 deepseq >= 1.1,

175 directory,

128 directory,

176 filepath,

129 filepath,

177− ghc-prim,

178− http-types,

179 parsec >= 3.1.2,

130 parsec >= 3.1.2,

180 scientific,

131 scientific,

181 text >= 1.1.1.0,

132 text >= 1.1.1.0,

182− transformers >= 0.2 && (< 0.4 || >= 0.4.1.0) && < 0.6,

183 unordered-containers,

133 unordered-containers,

184 vector

134 vector

185

135

186− if !impl(ghc >= 8.0)

187− -- Data.Semigroup && Control.Monad.Fail are available in base-4.9+

188− build-depends: fail == 4.9.*,

189− semigroups >=0.16.1 && <0.19

190−

191source-repository head

136source-repository head

192 type: git

137 type: git

193 location: https://github.com/bos/attoparsec

138 location: https://github.com/bos/attoparsec

194

139

140+source-repository head

141+ type: mercurial

142+ location: https://bitbucket.org/bos/attoparsec

benchmarks/Aeson.hs+3−8

@@ -10,13 +10,7 @@ module Aeson

10import Data.ByteString.Builder

11 (Builder, byteString, toLazyByteString, charUtf8, word8)

12

13−#if !MIN_VERSION_base(4,8,0)

14−import Control.Applicative ((*>), (<$>), (<*), pure)

13+import Control.Applicative ((*>), (<$>), (<*), liftA2, pure)

15−import Data.Monoid (mappend, mempty)

16−#endif

17−

18−import Common (pathTo)

19−import Control.Applicative (liftA2)

20import Control.DeepSeq (NFData(..))

14import Control.DeepSeq (NFData(..))

21import Control.Monad (forM)

15import Control.Monad (forM)

22import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific,

16import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific,

@@ -25,6 +19,7 @@ import Data.Bits ((.|.), shiftL)

25import Data.ByteString (ByteString)

19import Data.ByteString (ByteString)

26import Data.Char (chr)

20import Data.Char (chr)

27import Data.List (sort)

21import Data.List (sort)

22+import Data.Monoid (mappend, mempty)

28import Data.Scientific (Scientific)

23import Data.Scientific (Scientific)

29import Data.Text (Text)

24import Data.Text (Text)

30import Data.Text.Encoding (decodeUtf8')

25import Data.Text.Encoding (decodeUtf8')

@@ -345,7 +340,7 @@ toByteString = L.toStrict . toLazyByteString

345

340

346aeson :: IO Benchmark

341aeson :: IO Benchmark

347aeson = do

342aeson = do

348− path <- pathTo "json-data"

343+ let path = "json-data"

349 names <- sort . filter (`notElem` [".", ".."]) <$> getDirectoryContents path

344 names <- sort . filter (`notElem` [".", ".."]) <$> getDirectoryContents path

350 benches <- forM names $ \name -> do

345 benches <- forM names $ \name -> do

351 bs <- B.readFile (path </> name)

346 bs <- B.readFile (path </> name)

benchmarks/Benchmarks.hs−10

@@ -11,9 +11,7 @@ import Numbers (numbers)

11import Common (chunksOf)

12import Text.Parsec.Text ()

13import Text.Parsec.Text.Lazy ()

14−import qualified Warp

15import qualified Aeson

14import qualified Aeson

16−import qualified Genome

17import qualified Data.Attoparsec.ByteString as AB

15import qualified Data.Attoparsec.ByteString as AB

18import qualified Data.Attoparsec.ByteString.Char8 as AC

16import qualified Data.Attoparsec.ByteString.Char8 as AC

19import qualified Data.Attoparsec.ByteString.Lazy as ABL

17import qualified Data.Attoparsec.ByteString.Lazy as ABL

@@ -28,7 +26,6 @@ import qualified HeadersByteString

28import qualified HeadersText

26import qualified HeadersText

29import qualified Links

27import qualified Links

30import qualified Text.Parsec as P

28import qualified Text.Parsec as P

31−import qualified Sets

32

29

33main :: IO ()

30main :: IO ()

34main = do

31main = do

@@ -71,14 +68,10 @@ main = do

71 , bench "isAlpha_ascii" $ nf (ABL.parse (AC.takeWhile AC.isAlpha_ascii)) bl

68 , bench "isAlpha_ascii" $ nf (ABL.parse (AC.takeWhile AC.isAlpha_ascii)) bl

72 , bench "isAlpha_iso8859_15" $

69 , bench "isAlpha_iso8859_15" $

73 nf (ABL.parse (AC.takeWhile AC.isAlpha_iso8859_15)) bl

70 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 ]

71 ]

77 , bgroup "takeWhile1" [

72 , bgroup "takeWhile1" [

78 bench "isAlpha" $ nf (ABL.parse (AC.takeWhile1 isAlpha)) bl

73 bench "isAlpha" $ nf (ABL.parse (AC.takeWhile1 isAlpha)) bl

79 , bench "isAlpha_ascii" $ nf (ABL.parse (AC.takeWhile1 AC.isAlpha_ascii)) bl

74 , 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

82 ]

75 ]

83 , bench "word32LE" $ nf (AB.parse word32LE) b

76 , bench "word32LE" $ nf (AB.parse word32LE) b

84 , bgroup "scan" [

77 , bgroup "scan" [

@@ -86,13 +79,10 @@ main = do

86 , bench "long" $ nf (AB.parse quotedString) b

79 , bench "long" $ nf (AB.parse quotedString) b

87 ]

80 ]

88 , aeson

81 , aeson

89− , Genome.genome

90 , headersBS

82 , headersBS

91 , headersT

83 , headersT

92 , Links.links

84 , Links.links

93 , numbers

85 , numbers

94− , Sets.benchmarks

95− , Warp.benchmarks

96 ]

86 ]

97

87

98-- Benchmarks bind and (potential) bounds-check merging.

88-- Benchmarks bind and (potential) bounds-check merging.

benchmarks/Common.hs−10

@@ -3,14 +3,11 @@

3

4module Common (

5 chunksOf

6− , pathTo

7 , rechunkBS

6 , rechunkBS

8 , rechunkT

7 , rechunkT

9 ) where

8 ) where

10

9

11import Control.DeepSeq (NFData(rnf))

10import Control.DeepSeq (NFData(rnf))

12−import System.Directory (doesDirectoryExist)

13−import System.FilePath ((</>))

14import Text.Parsec (ParseError)

11import Text.Parsec (ParseError)

15import qualified Data.ByteString as B

12import qualified Data.ByteString as B

16import qualified Data.ByteString.Lazy as BL

13import qualified Data.ByteString.Lazy as BL

@@ -38,10 +35,3 @@ rechunkBS n = BL.fromChunks . map B.pack . chunksOf n . B.unpack

38

35

39rechunkT :: Int -> T.Text -> TL.Text

36rechunkT :: Int -> T.Text -> TL.Text

40rechunkT n = TL.fromChunks . map T.pack . chunksOf n . T.unpack

37rechunkT 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.hsdeleted−75

@@ -1,75 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−

3−module Genome

4− (

5− genome

6− ) where

7−

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+34−15

@@ -1,33 +1,52 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

1module HeadersByteString (headers) where

3module HeadersByteString (headers) where

2

4

3−import Common (pathTo, rechunkBS)

5+import Common (rechunkBS)

6+import Control.Applicative

4−import Criterion.Main (bench, bgroup, nf, nfIO)

7+import Criterion.Main (bench, bgroup, nf)

5import Criterion.Types (Benchmark)

8import Criterion.Types (Benchmark)

6−import HeadersByteString.Atto (request, response)

7−import Network.Wai.Handler.Warp.RequestHeader (parseHeaderLines)

8import qualified Data.Attoparsec.ByteString.Char8 as B

9import qualified Data.Attoparsec.ByteString.Char8 as B

9import qualified Data.Attoparsec.ByteString.Lazy as BL

10import qualified Data.Attoparsec.ByteString.Lazy as BL

10import qualified Data.ByteString.Char8 as B

11import qualified Data.ByteString.Char8 as B

11

12

12−-- Note: In the benchmarks for parsing an http request

13+header = do

13−-- from a strict bytestring, we consider warp's implementation,

14+ name <- B.takeWhile1 (B.inClass "a-zA-Z0-9_-") <* B.char ':' <* B.skipSpace

14−-- which has highly optimized code for handling the first

15+ body <- (:) <$> bodyLine <*> many (B.takeWhile1 B.isSpace *> bodyLine)

15−-- line in particular. It's treatment of the headers

16+ return (name, body)

16−-- is more relaxed from the treatment they are given by the

17+

17−-- attoparsec parser benchmarked here. Consequently, it

18+bodyLine = B.takeTill (\c -> c == '\r' || c == '\n') <* B.endOfLine

18−-- is should not be possible to match its performance since

19+

19−-- it accepts header names with disallowed characters.

20+requestLine =

21+ (,,) <$>

22+ (method <* B.skipSpace) <*>

23+ (B.takeTill B.isSpace <* B.skipSpace) <*>

24+ httpVersion

25+ where method = "GET" <|> "POST"

26+

27+httpVersion = "HTTP/" *> ((,) <$> (int <* B.char '.') <*> int)

28+

29+responseLine = (,,) <$>

30+ (httpVersion <* B.skipSpace) <*>

31+ (int <* B.skipSpace) <*>

32+ bodyLine

33+

34+int :: B.Parser Int

35+int = B.decimal

36+

37+request = (,) <$> (requestLine <* B.endOfLine) <*> many header

38+

39+response = (,) <$> responseLine <*> many header

20

40

21headers :: IO Benchmark

41headers :: IO Benchmark

22headers = do

42headers = do

23− req <- B.readFile =<< pathTo "http-request.txt"

43+ req <- B.readFile "http-request.txt"

24− resp <- B.readFile =<< pathTo "http-response.txt"

44+ resp <- B.readFile "http-response.txt"

25 let reql = rechunkBS 4 req

45 let reql = rechunkBS 4 req

26 respl = rechunkBS 4 resp

46 respl = rechunkBS 4 resp

27 return $ bgroup "headers" [

47 return $ bgroup "headers" [

28 bgroup "B" [

48 bgroup "B" [

29 bench "request" $ nf (B.parseOnly request) req

49 bench "request" $ nf (B.parseOnly request) req

30− , bench "warp" $ nfIO (parseHeaderLines (B.split '\n' req))

31 , bench "response" $ nf (B.parseOnly response) resp

50 , bench "response" $ nf (B.parseOnly response) resp

32 ]

51 ]

33 , bgroup "BL" [

52 , bgroup "BL" [

benchmarks/HeadersByteString/Atto.hsdeleted−57

@@ -1,57 +0,0 @@

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

8−

9−import Control.Applicative

10−import Control.DeepSeq (NFData(..))

11−import Network.HTTP.Types.Version (HttpVersion, http11)

12−import qualified Data.Attoparsec.ByteString.Char8 as B

13−import qualified Data.ByteString.Char8 as B

14−

15−instance NFData HttpVersion where

16− rnf !_ = ()

17−

18−isHeaderChar :: Char -> Bool

19−isHeaderChar c =

20− (c >= 'a' && c <= 'z') ||

21− (c >= 'A' && c <= 'Z') ||

22− (c >= '0' && c <= '9') ||

23− (c == '_') ||

24− (c == '-')

25−

26−header = do

27− name <- B.takeWhile1 isHeaderChar <* B.char ':' <* B.skipSpace

28− body <- bodyLine

29− return (name, body)

30−

31−bodyLine = B.takeTill (\c -> c == '\r' || c == '\n') <* B.endOfLine

32−

33−requestLine = do

34− m <- (B.takeTill B.isSpace <* B.char ' ')

35− (p,q) <- B.break (=='?') <$> (B.takeTill B.isSpace <* B.char ' ')

36− v <- httpVersion

37− return (m,p,q,v)

38−

39−httpVersion = http11 <$ "HTTP/1.1"

40−

41−responseLine = (,,) <$>

42− (httpVersion <* B.skipSpace) <*>

43− (int <* B.skipSpace) <*>

44− bodyLine

45−

46−int :: B.Parser Int

47−int = B.decimal

48−

49−request = (,) <$> (requestLine <* B.endOfLine) <*> manyheader

50−

51−response = (,) <$> responseLine <*> many header

52−

53−manyheader = do

54− c <- B.peekChar'

55− if c == '\r' || c == '\n'

56− then return []

57− else (:) <$> header <*> manyheader

benchmarks/HeadersText.hs+3−3

@@ -2,7 +2,7 @@

2{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

3module HeadersText (headers) where

4

5−import Common (pathTo, rechunkT)

5+import Common (rechunkT)

6import Control.Applicative

7import Criterion.Main (bench, bgroup, nf)

8import Criterion.Types (Benchmark)

@@ -41,8 +41,8 @@ response = (,) <$> responseLine <*> many header

41

42headers :: IO Benchmark

43headers = do

44− req <- T.readFile =<< pathTo "http-request.txt"

44+ req <- T.readFile "http-request.txt"

45− resp <- T.readFile =<< pathTo "http-response.txt"

45+ resp <- T.readFile "http-response.txt"

46 let reql = rechunkT 4 req

47 respl = rechunkT 4 resp

48 return $ bgroup "headers" [

benchmarks/Links.hs+2−2

@@ -5,8 +5,8 @@ module Links (links) where

5import Control.Applicative

6import Control.DeepSeq (NFData(..))

7import Criterion.Main (Benchmark, bench, nf)

8−import Data.Attoparsec.ByteString as A

8+import Data.Attoparsec as A

9−import Data.Attoparsec.ByteString.Char8 as A8

9+import Data.Attoparsec.Char8 as A8

10import Data.ByteString.Char8 as B8

11

12data Link = Link {

benchmarks/Numbers.hs−1

@@ -1,5 +1,4 @@

1{-# LANGUAGE BangPatterns #-}

2−{-# OPTIONS_GHC -fno-warn-deprecations #-}

3

2

4module Numbers (numbers) where

3module Numbers (numbers) where

5

4

benchmarks/Sets.hsdeleted−21

@@ -1,21 +0,0 @@

1−module Sets (benchmarks) where

2−

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

9−

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.hsdeleted−121

@@ -1,121 +0,0 @@

1−{-# LANGUAGE BangPatterns #-}

2−

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.hsdeleted−17

@@ -1,17 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−

3−module Warp (benchmarks) where

4−

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+2−12

@@ -11,31 +11,21 @@ executable attoparsec-benchmarks

11 other-modules:

12 Common

13 HeadersByteString

14− HeadersByteString.Atto

15 HeadersText

14 HeadersText

16 Links

15 Links

17 Numbers

16 Numbers

18− Network.Wai.Handler.Warp.ReadInt

19− Sets

20− TextFastSet

21− Warp

22− hs-source-dirs: .. . warp-3.0.1.1

17+ hs-source-dirs: .. .

23 ghc-options: -O2 -Wall -rtsopts

18 ghc-options: -O2 -Wall -rtsopts

24 build-depends:

19 build-depends:

25 array,

20 array,

26 base == 4.*,

21 base == 4.*,

27 bytestring >= 0.10.4.0,

22 bytestring >= 0.10.4.0,

28− case-insensitive,

29− containers,

30− criterion >= 1.0,

23+ criterion >= 0.8.1.0,

31 deepseq >= 1.1,

24 deepseq >= 1.1,

32 directory,

25 directory,

33 filepath,

26 filepath,

34− ghc-prim,

35− http-types,

36 parsec >= 3.1.2,

27 parsec >= 3.1.2,

37 scientific >= 0.3.1,

28 scientific >= 0.3.1,

38 text >= 1.1.1.0,

29 text >= 1.1.1.0,

39− transformers,

40 unordered-containers,

30 unordered-containers,

41 vector

31 vector

benchmarks/http-request.txt+8−3

@@ -1,9 +1,14 @@

1GET / HTTP/1.1

2Host: twitter.com

3−Accept: text/html, application/xhtml+xml, application/xml; q=0.9, image/webp, */*; q=0.8

3+Accept: text/html, application/xhtml+xml, application/xml; q=0.9,

4+ image/webp, */*; q=0.8

4Accept-Encoding: gzip,deflate,sdch

5Accept-Encoding: gzip,deflate,sdch

5Accept-Language: en-GB,en-US;q=0.8,en;q=0.6

6Accept-Language: en-GB,en-US;q=0.8,en;q=0.6

6Cache-Control: max-age=0

7Cache-Control: max-age=0

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+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)

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

12+ AppleWebKit/537.36 (KHTML, like Gecko) Chrome/35.0.1916.86

13+ Safari/537.36

9

14

benchmarks/http-response.txt+4−2

@@ -3,8 +3,10 @@ Date: Fri, 09 May 2014 04:24:57 GMT

3Expires: -1

4Cache-Control: private, max-age=0

5Content-Type: text/html; charset=ISO-8859-1

6−Set-Cookie: PREF=ID=1a871afc4240db5e:FF:LM=1399609497:S=e5MZ0itEekjVwNcU; expires=Sun, 08-May-2016 04:24:57 GMT; path=/; domain=.google.com

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

7−Set-Cookie: NID=67=-WlfaDG6VSEPk7abAjrK98HBSoCD2ID6JKkUR95tEumzDmg7Fc8pSQ8; expires=Sat, 08-Nov-2014 04:24:57 GMT; path=/; domain=.google.com; HttpOnly

8+Set-Cookie: NID=67=-WlfaDG6VSEPk7abAjrK98HBSoCD2ID6JKkUR95tEumzDmg7Fc8pSQ8;

9+ expires=Sat, 08-Nov-2014 04:24:57 GMT; path=/; domain=.google.com; HttpOnly

8P3P: CP="This is not a P3P policy! See http://www.google.com/support/accounts/bin/answer.py?hl=en&answer=151657 for more info."

10P3P: CP="This is not a P3P policy! See http://www.google.com/support/accounts/bin/answer.py?hl=en&answer=151657 for more info."

9Server: gws

11Server: gws

10X-XSS-Protection: 1; mode=block

12X-XSS-Protection: 1; mode=block

benchmarks/warp-3.0.1.1/LICENSEdeleted−20

@@ -1,20 +0,0 @@

2−

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.hsdeleted−67

@@ -1,67 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE MagicHash #-}

3−{-# LANGUAGE BangPatterns #-}

4−

5−-- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>

6−-- License : BSD3

7−

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.hsdeleted−172

@@ -1,172 +0,0 @@

1−{-# LANGUAGE DeriveDataTypeable #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE BangPatterns #-}

4−

5−module Network.Wai.Handler.Warp.RequestHeader (

6− parseHeaderLines

7− , parseByteRanges

8− ) where

9−

10−import Control.Exception (Exception, throwIO)

11−import Control.Monad (when)

12−import Data.Typeable (Typeable)

13−import qualified Data.ByteString as S

14−import qualified Data.ByteString.Char8 as B (unpack, readInteger)

15−import Data.ByteString.Internal (ByteString(..), memchr)

16−import qualified Data.CaseInsensitive as CI

17−import Data.Word (Word8)

18−import Foreign.ForeignPtr (withForeignPtr)

19−import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)

20−import Foreign.Storable (peek)

21−import qualified Network.HTTP.Types as H

22−-- import Network.Wai.Handler.Warp.Types

23−import qualified Network.HTTP.Types.Header as HH

24−-- $setup

25−-- >>> :set -XOverloadedStrings

26−

27−data InvalidRequest = NotEnoughLines [String]

28− | BadFirstLine String

29− | NonHttp

30− | IncompleteHeaders

31− | ConnectionClosedByPeer

32− | OverLargeHeader

33− deriving (Eq, Typeable, Show)

34−

35−instance Exception InvalidRequest

36−

37−----------------------------------------------------------------

38−

39−parseHeaderLines :: [ByteString]

40− -> IO (H.Method

41− ,ByteString -- Path

42− ,ByteString -- Path, parsed

43− ,ByteString -- Query

44− ,H.HttpVersion

45− ,H.RequestHeaders

46− )

47−parseHeaderLines [] = throwIO $ NotEnoughLines []

48−parseHeaderLines (firstLine:otherLines) = do

49− (method, path', query, httpversion) <- parseRequestLine firstLine

50− let path = H.extractPath path'

51− hdr = map parseHeader otherLines

52− return (method, path', path, query, httpversion, hdr)

53−

54−----------------------------------------------------------------

55−

56−-- |

57−--

58−-- >>> parseRequestLine "GET / HTTP/1.1"

59−-- ("GET","/","",HTTP/1.1)

60−-- >>> parseRequestLine "POST /cgi/search.cgi?key=foo HTTP/1.0"

61−-- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0)

62−-- >>> parseRequestLine "GET "

63−-- *** Exception: Warp: Invalid first line of request: "GET "

64−-- >>> parseRequestLine "GET /NotHTTP UNKNOWN/1.1"

65−-- *** Exception: Warp: Request line specified a non-HTTP request

66−parseRequestLine :: ByteString

67− -> IO (H.Method

68− ,ByteString -- Path

69− ,ByteString -- Query

70− ,H.HttpVersion)

71−parseRequestLine requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do

72− when (len < 14) $ throwIO baderr

73− let methodptr = ptr `plusPtr` off

74− limptr = methodptr `plusPtr` len

75− lim0 = fromIntegral len

76−

77− pathptr0 <- memchr methodptr 32 lim0 -- ' '

78− when (pathptr0 == nullPtr || (limptr `minusPtr` pathptr0) < 11) $

79− throwIO baderr

80− let pathptr = pathptr0 `plusPtr` 1

81− lim1 = fromIntegral (limptr `minusPtr` pathptr0)

82−

83− httpptr0 <- memchr pathptr 32 lim1 -- ' '

84− when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $

85− throwIO baderr

86− let httpptr = httpptr0 `plusPtr` 1

87− lim2 = fromIntegral (httpptr0 `minusPtr` pathptr)

88−

89− checkHTTP httpptr

90− !hv <- httpVersion httpptr

91− queryptr <- memchr pathptr 63 lim2 -- '?'

92−

93− let !method = bs ptr methodptr pathptr0

94− !path

95− | queryptr == nullPtr = bs ptr pathptr httpptr0

96− | otherwise = bs ptr pathptr queryptr

97− !query

98− | queryptr == nullPtr = S.empty

99− | otherwise = bs ptr queryptr httpptr0

100−

101− return (method,path,query,hv)

102− where

103− baderr = BadFirstLine $ B.unpack requestLine

104− check :: Ptr Word8 -> Int -> Word8 -> IO ()

105− check p n w = do

106− w0 <- peek $ p `plusPtr` n

107− when (w0 /= w) $ throwIO NonHttp

108− checkHTTP httpptr = do

109− check httpptr 0 72 -- 'H'

110− check httpptr 1 84 -- 'T'

111− check httpptr 2 84 -- 'T'

112− check httpptr 3 80 -- 'P'

113− check httpptr 4 47 -- '/'

114− check httpptr 6 46 -- '.'

115− httpVersion httpptr = do

116− major <- peek $ httpptr `plusPtr` 5

117− minor <- peek $ httpptr `plusPtr` 7

118− return $ if major == (49 :: Word8) && minor == (49 :: Word8) then

119− H.http11

120− else

121− H.http10

122− bs ptr p0 p1 = PS fptr o l

123− where

124− o = p0 `minusPtr` ptr

125− l = p1 `minusPtr` p0

126−

127−----------------------------------------------------------------

128−

129−-- |

130−--

131−-- >>> parseHeader "Content-Length:47"

132−-- ("Content-Length","47")

133−-- >>> parseHeader "Accept-Ranges: bytes"

134−-- ("Accept-Ranges","bytes")

135−-- >>> parseHeader "Host: example.com:8080"

136−-- ("Host","example.com:8080")

137−-- >>> parseHeader "NoSemiColon"

138−-- ("NoSemiColon","")

139−

140−parseHeader :: ByteString -> H.Header

141−parseHeader s =

142− let (k, rest) = S.break (== 58) s -- ':'

143− rest' = S.dropWhile (\c -> c == 32 || c == 9) $ S.drop 1 rest

144− in (CI.mk k, rest')

145−

146−parseByteRanges :: S.ByteString -> Maybe HH.ByteRanges

147−parseByteRanges bs1 = do

148− bs2 <- stripPrefix "bytes=" bs1

149− (r, bs3) <- range bs2

150− ranges (r:) bs3

151− where

152− range bs2 =

153− case stripPrefix "-" bs2 of

154− Just bs3 -> do

155− (i, bs4) <- B.readInteger bs3

156− Just (HH.ByteRangeSuffix i, bs4)

157− Nothing -> do

158− (i, bs3) <- B.readInteger bs2

159− bs4 <- stripPrefix "-" bs3

160− case B.readInteger bs4 of

161− Nothing -> Just (HH.ByteRangeFrom i, bs4)

162− Just (j, bs5) -> Just (HH.ByteRangeFromTo i j, bs5)

163− ranges front bs3 =

164− case stripPrefix "," bs3 of

165− Nothing -> Just (front [])

166− Just bs4 -> do

167− (r, bs5) <- range bs4

168− ranges (front . (r:)) bs5

169−

170− stripPrefix x y

171− | x `S.isPrefixOf` y = Just (S.drop (S.length x) y)

172− | otherwise = Nothing

changelog.md−71

@@ -1,74 +1,3 @@

1−0.13.2.1

2−

3−* Improved performance of `Data.Attoparsec.Text.asciiCI`

4−

5−0.13.2.0

6−

7−* `pure` is now strict in `Position`

8−

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−

720.12.0.0

10.12.0.0

73

2

74* A new internal representation makes almost all real-world parsers

3* A new internal representation makes almost all real-world parsers

examples/RFC2616.hs+18−18

@@ -11,55 +11,55 @@ module RFC2616

11

12import Control.Applicative

13import Data.Attoparsec.ByteString as P

14+import qualified Data.Attoparsec.ByteString.Char8 as P8

14import Data.Attoparsec.ByteString.Char8 (char8, endOfLine, isDigit_w8)

15import Data.Attoparsec.ByteString.Char8 (char8, endOfLine, isDigit_w8)

15−import Data.ByteString (ByteString)

16import Data.Word (Word8)

17−import Data.Attoparsec.ByteString.Char8 (isEndOfLine, isHorizontalSpace)

17+import qualified Data.ByteString.Char8 as B

18

19isToken :: Word8 -> Bool

20isToken w = w <= 127 && notInClass "\0-\31()<>@,;:\\\"/[]?={} \t" w

21

22skipSpaces :: Parser ()

23−skipSpaces = satisfy isHorizontalSpace *> skipWhile isHorizontalSpace

23+skipSpaces = satisfy P8.isHorizontalSpace *> skipWhile P8.isHorizontalSpace

24

25data Request = Request {

26− requestMethod :: ByteString

26+ requestMethod :: B.ByteString

27− , requestUri :: ByteString

27+ , requestUri :: B.ByteString

28− , requestVersion :: ByteString

28+ , requestVersion :: B.ByteString

29 } deriving (Eq, Ord, Show)

30

31−httpVersion :: Parser ByteString

31+httpVersion :: Parser B.ByteString

32httpVersion = "HTTP/" *> P.takeWhile (\c -> isDigit_w8 c || c == 46)

33

34requestLine :: Parser Request

35−requestLine = Request <$> (takeWhile1 isToken <* char8 ' ')

35+requestLine = Request <$> (P.takeWhile1 isToken <* char8 ' ')

36− <*> (takeWhile1 (/=32) <* char8 ' ')

36+ <*> (P.takeWhile1 (/=32) <* char8 ' ')

37 <*> (httpVersion <* endOfLine)

38

39data Header = Header {

40− headerName :: ByteString

40+ headerName :: B.ByteString

41− , headerValue :: [ByteString]

41+ , headerValue :: [B.ByteString]

42 } deriving (Eq, Ord, Show)

43

44messageHeader :: Parser Header

45messageHeader = Header

46− <$> (P.takeWhile isToken <* char8 ':' <* skipWhile isHorizontalSpace)

46+ <$> (P.takeWhile isToken <* char8 ':' <* skipWhile P8.isHorizontalSpace)

47− <*> ((:) <$> (takeTill isEndOfLine <* endOfLine)

47+ <*> ((:) <$> (takeTill P8.isEndOfLine <* endOfLine)

48− <*> (many $ skipSpaces *> takeTill isEndOfLine <* endOfLine))

48+ <*> (many $ skipSpaces *> takeTill P8.isEndOfLine <* endOfLine))

49

50request :: Parser (Request, [Header])

51request = (,) <$> requestLine <*> many messageHeader <* endOfLine

52

53data Response = Response {

54− responseVersion :: ByteString

54+ responseVersion :: B.ByteString

55− , responseCode :: ByteString

55+ , responseCode :: B.ByteString

56− , responseMsg :: ByteString

56+ , responseMsg :: B.ByteString

57 } deriving (Eq, Ord, Show)

58

59responseLine :: Parser Response

60responseLine = Response <$> (httpVersion <* char8 ' ')

61 <*> (P.takeWhile isDigit_w8 <* char8 ' ')

62− <*> (takeTill isEndOfLine <* endOfLine)

62+ <*> (P.takeTill P8.isEndOfLine <* endOfLine)

63

64response :: Parser (Response, [Header])

65response = (,) <$> responseLine <*> many messageHeader <* endOfLine

tests/Makefilenew file+14

@@ -0,0 +1,14 @@

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+2−4

@@ -4,16 +4,14 @@ module Main (main) where

4import qualified QC.Buffer as Buffer

5import qualified QC.ByteString as ByteString

6import qualified QC.Combinator as Combinator

7−import qualified QC.Simple as Simple

8import qualified QC.Text as Text

7import qualified QC.Text as Text

9−import Test.Tasty (defaultMain, testGroup)

8+import Test.Framework (defaultMain, testGroup)

10

9

11main = defaultMain tests

10main = defaultMain tests

12

11

13−tests = testGroup "tests" [

12+tests = [

14 testGroup "bs" ByteString.tests

13 testGroup "bs" ByteString.tests

15 , testGroup "buf" Buffer.tests

14 , testGroup "buf" Buffer.tests

16 , testGroup "combinator" Combinator.tests

15 , testGroup "combinator" Combinator.tests

17− , testGroup "simple" Simple.tests

18 , testGroup "text" Text.tests

16 , testGroup "text" Text.tests

19 ]

17 ]

tests/QC/Buffer.hs+7−17

@@ -1,15 +1,12 @@

1−{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, OverloadedStrings,

1+{-# LANGUAGE BangPatterns, FlexibleInstances, OverloadedStrings,

2 TypeSynonymInstances #-}

3

4module QC.Buffer (tests) where

5

6−#if !MIN_VERSION_base(4,8,0)

7−import Control.Applicative ((<$>))

8−import Data.Monoid (Monoid(mconcat))

6+import Data.Monoid (mconcat)

9−#endif

10import QC.Common ()

7import QC.Common ()

11−import Test.Tasty (TestTree)

8+import Test.Framework (Test)

12−import Test.Tasty.QuickCheck (testProperty)

9+import Test.Framework.Providers.QuickCheck2 (testProperty)

13import Test.QuickCheck

10import Test.QuickCheck

14import qualified Data.Attoparsec.ByteString.Buffer as BB

11import qualified Data.Attoparsec.ByteString.Buffer as BB

15import qualified Data.Attoparsec.Text.Buffer as BT

12import qualified Data.Attoparsec.Text.Buffer as BT

@@ -27,19 +24,12 @@ type BPT = BP T.Text BT.Buffer

27instance Arbitrary BPB where

24instance Arbitrary BPB where

28 arbitrary = do

25 arbitrary = do

29 bss <- arbitrary

26 bss <- arbitrary

30− return $! toBP BB.buffer bss

31−

32− shrink (BP bss _ _) = toBP BB.buffer <$> shrink bss

27+ return $! BP bss (mconcat bss) (mconcat (map BB.buffer bss))

33

28

34instance Arbitrary BPT where

29instance Arbitrary BPT where

35 arbitrary = do

30 arbitrary = do

36 bss <- arbitrary

31 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))

32+ return $! BP bss (mconcat bss) (mconcat (map BT.buffer bss))

43

33

44b_unbuffer :: BPB -> Property

34b_unbuffer :: BPB -> Property

45b_unbuffer (BP _ts t buf) = t === BB.unbuffer buf

35b_unbuffer (BP _ts t buf) = t === BB.unbuffer buf

@@ -82,7 +72,7 @@ t_dropWord16 (BP _ts t buf) = do

82 i <- choose (0, T.lengthWord16 t)

72 i <- choose (0, T.lengthWord16 t)

83 return $ T.dropWord16 i t === BT.dropWord16 i buf

73 return $ T.dropWord16 i t === BT.dropWord16 i buf

84

74

85−tests :: [TestTree]

75+tests :: [Test]

86tests = [

76tests = [

87 testProperty "b_unbuffer" b_unbuffer

77 testProperty "b_unbuffer" b_unbuffer

88 , testProperty "t_unbuffer" t_unbuffer

78 , testProperty "t_unbuffer" t_unbuffer

tests/QC/ByteString.hs+9−39

@@ -1,23 +1,19 @@

1−{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-}

1+{-# LANGUAGE BangPatterns, OverloadedStrings #-}

2module QC.ByteString (tests) where

3

4−#if !MIN_VERSION_base(4,8,0)

5−import Control.Applicative ((<*>), (<$>))

4+import Control.Applicative ((<$>), (<*>))

6−#endif

7−import Data.Char (chr, ord, toUpper)

5+import Data.Char (chr, ord)

8import Data.Int (Int64)

6import Data.Int (Int64)

9import Data.Word (Word8)

7import Data.Word (Word8)

10import Prelude hiding (take, takeWhile)

8import Prelude hiding (take, takeWhile)

11−import QC.Common (ASCII(..), liftOp, parseBS, toStrictBS)

9+import QC.Common (liftOp, parseBS, toStrictBS)

12−import Test.Tasty (TestTree)

10+import Test.Framework (Test)

13−import Test.Tasty.QuickCheck (testProperty)

11+import Test.Framework.Providers.QuickCheck2 (testProperty)

14import Test.QuickCheck

12import Test.QuickCheck

15import qualified Data.Attoparsec.ByteString as P

13import qualified Data.Attoparsec.ByteString as P

16import qualified Data.Attoparsec.ByteString.Char8 as P8

14import qualified Data.Attoparsec.ByteString.Char8 as P8

17−import qualified Data.Attoparsec.ByteString.FastSet as S

18import qualified Data.Attoparsec.ByteString.Lazy as PL

15import qualified Data.Attoparsec.ByteString.Lazy as PL

19import qualified Data.ByteString as B

16import qualified Data.ByteString as B

20−import qualified Data.ByteString.Char8 as B8

21import qualified Data.ByteString.Lazy as L

17import qualified Data.ByteString.Lazy as L

22import qualified Data.ByteString.Lazy.Char8 as L8

18import qualified Data.ByteString.Lazy.Char8 as L8

23

19

@@ -26,11 +22,9 @@ import qualified Data.ByteString.Lazy.Char8 as L8

26satisfy :: Word8 -> L.ByteString -> Property

22satisfy :: Word8 -> L.ByteString -> Property

27satisfy w s = parseBS (P.satisfy (<=w)) (L.cons w s) === Just w

23satisfy w s = parseBS (P.satisfy (<=w)) (L.cons w s) === Just w

28

24

29−satisfyWith :: Word8 -> L.ByteString -> Property

25+satisfyWith :: Char -> L.ByteString -> Property

30−satisfyWith w s = parseBS (P.satisfyWith (chr . fromIntegral) (<=c))

26+satisfyWith c s = parseBS (P.satisfyWith (chr . fromIntegral) (<=c))

31 (L.cons (fromIntegral (ord c)) s) === Just c

27 (L.cons (fromIntegral (ord c)) s) === Just c

32− where

33− c = chr (fromIntegral w)

34

28

35word8 :: Word8 -> L.ByteString -> Property

29word8 :: Word8 -> L.ByteString -> Property

36word8 w s = parseBS (P.word8 w) (L.cons w s) === Just w

30word8 w s = parseBS (P.word8 w) (L.cons w s) === Just w

@@ -68,18 +62,6 @@ string :: L.ByteString -> L.ByteString -> Property

68string s t = parseBS (P.string s') (s `L.append` t) === Just s'

62string s t = parseBS (P.string s') (s `L.append` t) === Just s'

69 where s' = toStrictBS s

63 where s' = toStrictBS s

70

64

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−

83skipWhile :: Word8 -> L.ByteString -> Property

65skipWhile :: Word8 -> L.ByteString -> Property

84skipWhile w s =

66skipWhile w s =

85 let t = L.dropWhile (<=w) s

67 let t = L.dropWhile (<=w) s

@@ -149,15 +131,7 @@ scan s (Positive k) = parseBS p s === Just (toStrictBS $ L.take k s)

149 where p = P.scan k $ \ n _ ->

131 where p = P.scan k $ \ n _ ->

150 if n > 0 then let !n' = n - 1 in Just n' else Nothing

132 if n > 0 then let !n' = n - 1 in Just n' else Nothing

151

133

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]

134+tests :: [Test]

161tests = [

135tests = [

162 testProperty "anyWord8" anyWord8

136 testProperty "anyWord8" anyWord8

163 , testProperty "endOfInput" endOfInput

137 , testProperty "endOfInput" endOfInput

@@ -171,8 +145,6 @@ tests = [

171 , testProperty "skip" skip

145 , testProperty "skip" skip

172 , testProperty "skipWhile" skipWhile

146 , testProperty "skipWhile" skipWhile

173 , testProperty "string" string

147 , testProperty "string" string

174− , testProperty "stringCI" stringCI

175− , testProperty "strings" strings

176 , testProperty "take" take

148 , testProperty "take" take

177 , testProperty "takeByteString" takeByteString

149 , testProperty "takeByteString" takeByteString

178 , testProperty "takeCount" takeCount

150 , testProperty "takeCount" takeCount

@@ -182,6 +154,4 @@ tests = [

182 , testProperty "takeWhile1" takeWhile1

154 , testProperty "takeWhile1" takeWhile1

183 , testProperty "takeWhile1_empty" takeWhile1_empty

155 , testProperty "takeWhile1_empty" takeWhile1_empty

184 , testProperty "word8" word8

156 , testProperty "word8" word8

185− , testProperty "members" members

186− , testProperty "nonmembers" nonmembers

187 ]

157 ]

tests/QC/Combinator.hs+5−18

@@ -1,15 +1,10 @@

1−{-# LANGUAGE CPP, OverloadedStrings #-}

2−

3module QC.Combinator where

1module QC.Combinator where

4

2

5−#if !MIN_VERSION_base(4,8,0)

6−import Control.Applicative ((<*>), (<$>), (<*), (*>))

3+import Control.Applicative

7−#endif

8−import Data.Maybe (fromJust, isJust)

9import Data.Word (Word8)

4import Data.Word (Word8)

10−import QC.Common (Repack, parseBS, repackBS, toLazyBS)

5+import QC.Common (Repack, parseBS, repackBS)

11−import Test.Tasty (TestTree)

6+import Test.Framework (Test)

12−import Test.Tasty.QuickCheck (testProperty)

7+import Test.Framework.Providers.QuickCheck2 (testProperty)

13import Test.QuickCheck

8import Test.QuickCheck

14import qualified Data.Attoparsec.ByteString.Char8 as P

9import qualified Data.Attoparsec.ByteString.Char8 as P

15import qualified Data.Attoparsec.Combinator as C

10import qualified Data.Attoparsec.Combinator as C

@@ -27,13 +22,6 @@ count (Positive (Small n)) rs s =

27 (length <$> parseBS (C.count n (P.string s)) input) == Just n

22 (length <$> parseBS (C.count n (P.string s)) input) == Just n

28 where input = repackBS rs (B.concat (replicate (n+1) s))

23 where input = repackBS rs (B.concat (replicate (n+1) s))

29

24

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−

37match :: Int -> NonNegative Int -> NonNegative Int -> Repack -> Bool

25match :: Int -> NonNegative Int -> NonNegative Int -> Repack -> Bool

38match n (NonNegative x) (NonNegative y) rs =

26match n (NonNegative x) (NonNegative y) rs =

39 parseBS (P.match parser) (repackBS rs input) == Just (input, n)

27 parseBS (P.match parser) (repackBS rs input) == Just (input, n)

@@ -43,10 +31,9 @@ match n (NonNegative x) (NonNegative y) rs =

43 B8.replicate x 'x', B8.pack (show n), B8.replicate y 'y'

31 B8.replicate x 'x', B8.pack (show n), B8.replicate y 'y'

44 ]

32 ]

45

33

46−tests :: [TestTree]

34+tests :: [Test]

47tests = [

35tests = [

48 testProperty "choice" choice

36 testProperty "choice" choice

49 , testProperty "count" count

37 , testProperty "count" count

50− , testProperty "lookAhead" lookAhead

51 , testProperty "match" match

38 , testProperty "match" match

52 ]

39 ]

tests/QC/Common.hs+4−34

@@ -1,9 +1,7 @@

1−{-# LANGUAGE CPP, FlexibleInstances #-}

2{-# OPTIONS_GHC -fno-warn-orphans #-}

1{-# OPTIONS_GHC -fno-warn-orphans #-}

3module QC.Common

2module QC.Common

4 (

3 (

5− ASCII(..)

6− , parseBS

4+ parseBS

7 , parseT

5 , parseT

8 , toLazyBS

6 , toLazyBS

9 , toStrictBS

7 , toStrictBS

@@ -15,12 +13,9 @@ module QC.Common

15 , liftOp

13 , liftOp

16 ) where

14 ) where

17

15

18−#if !MIN_VERSION_base(4,8,0)

19−import Control.Applicative ((<*>), (<$>))

16+import Control.Applicative ((<$>), (<*>))

20−#endif

21import Data.Char (isAlpha)

17import Data.Char (isAlpha)

22import Test.QuickCheck

18import Test.QuickCheck

23−import Test.QuickCheck.Unicode (shrinkChar, string)

24import qualified Data.ByteString as B

19import qualified Data.ByteString as B

25import qualified Data.ByteString.Lazy as BL

20import qualified Data.ByteString.Lazy as BL

26import qualified Data.Text as T

21import qualified Data.Text as T

@@ -28,16 +23,6 @@ import qualified Data.Text.Lazy as TL

28import qualified Data.Attoparsec.ByteString.Lazy as BL

23import qualified Data.Attoparsec.ByteString.Lazy as BL

29import qualified Data.Attoparsec.Text.Lazy as TL

24import qualified Data.Attoparsec.Text.Lazy as TL

30

25

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−

41parseBS :: BL.Parser r -> BL.ByteString -> Maybe r

26parseBS :: BL.Parser r -> BL.ByteString -> Maybe r

42parseBS p = BL.maybeResult . BL.parse p

27parseBS p = BL.maybeResult . BL.parse p

43

28

@@ -52,22 +37,9 @@ toLazyBS = BL.fromChunks . (:[])

52

37

53instance Arbitrary B.ByteString where

38instance Arbitrary B.ByteString where

54 arbitrary = B.pack <$> arbitrary

39 arbitrary = B.pack <$> arbitrary

55− shrink = map B.pack . shrink . B.unpack

56

40

57instance Arbitrary BL.ByteString where

41instance Arbitrary BL.ByteString where

58 arbitrary = repackBS <$> arbitrary <*> arbitrary

42 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

43

72type Repack = NonEmptyList (Positive (Small Int))

44type Repack = NonEmptyList (Positive (Small Int))

73

45

@@ -84,12 +56,10 @@ repackBS_ = go . cycle

84 go _ _ = error "unpossible"

56 go _ _ = error "unpossible"

85

57

86instance Arbitrary T.Text where

58instance Arbitrary T.Text where

87− arbitrary = T.pack <$> string

59+ arbitrary = T.pack <$> arbitrary

88− shrink = map T.pack . shrinkList shrinkChar . T.unpack

89

60

90instance Arbitrary TL.Text where

61instance Arbitrary TL.Text where

91− arbitrary = TL.pack <$> string

62+ arbitrary = repackT <$> arbitrary <*> arbitrary

92− shrink = map TL.pack . shrinkList shrinkChar . TL.unpack

93

63

94repackT :: Repack -> T.Text -> TL.Text

64repackT :: Repack -> T.Text -> TL.Text

95repackT (NonEmpty bs) =

65repackT (NonEmpty bs) =

tests/QC/IPv6/Internal.hsdeleted−316

@@ -1,316 +0,0 @@

1−-- -----------------------------------------------------------------------------

2−

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.hsdeleted−29

@@ -1,29 +0,0 @@

1−-- -----------------------------------------------------------------------------

2−

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.hsdeleted−56

@@ -1,56 +0,0 @@

1−{-# LANGUAGE BangPatterns #-}

2−

3−module QC.Rechunked (

4− rechunkBS

5− , rechunkT

6− ) where

7−

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.hsdeleted−37

@@ -1,37 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

3−

4−module QC.Simple (

5− tests

6− ) where

7−

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+10−42

@@ -1,26 +1,18 @@

1−{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-}

1+{-# LANGUAGE BangPatterns, OverloadedStrings #-}

2{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}

3module QC.Text (tests) where

4

5−#if !MIN_VERSION_base(4,8,0)

6−import Control.Applicative ((<*>), (<$>))

5+import Control.Applicative ((<$>), (<*>))

7−#endif

8import Data.Int (Int64)

6import Data.Int (Int64)

9−import Data.Word (Word8)

10import Prelude hiding (take, takeWhile)

7import Prelude hiding (take, takeWhile)

11import QC.Common (liftOp, parseT)

8import QC.Common (liftOp, parseT)

12−import qualified QC.Text.FastSet as FastSet

9+import Test.Framework (Test)

13−import qualified QC.Text.Regressions as Regressions

14−import Test.Tasty (TestTree, testGroup)

15−import Test.Tasty.QuickCheck (testProperty)

10+import Test.Framework.Providers.QuickCheck2 (testProperty)

16import Test.QuickCheck

11import Test.QuickCheck

17import qualified Data.Attoparsec.Text as P

12import qualified Data.Attoparsec.Text as P

18import qualified Data.Attoparsec.Text.Lazy as PL

13import qualified Data.Attoparsec.Text.Lazy as PL

19−import qualified Data.Attoparsec.Text.FastSet as S

20−import qualified Data.ByteString as BS

21import qualified Data.Char as Char

14import qualified Data.Char as Char

22import qualified Data.Text as T

15import qualified Data.Text as T

23−import qualified Data.Text.Encoding as TE

24import qualified Data.Text.Lazy as L

16import qualified Data.Text.Lazy as L

25

17

26-- Basic byte-level combinators.

18-- Basic byte-level combinators.

@@ -67,18 +59,9 @@ string :: L.Text -> L.Text -> Property

67string s t = parseT (P.string s') (s `L.append` t) === Just s'

59string s t = parseT (P.string s') (s `L.append` t) === Just s'

68 where s' = toStrict s

60 where s' = toStrict s

69

61

70−strings :: L.Text -> L.Text -> L.Text -> Property

62+stringCI :: T.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

63+stringCI s = P.parseOnly (P.stringCI fs) s === Right s

80 where fs = T.toCaseFold s

64 where fs = T.toCaseFold s

81− s = TE.decodeLatin1 (BS.pack ws)

82

65

83asciiCI :: T.Text -> Gen Bool

66asciiCI :: T.Text -> Gen Bool

84asciiCI x =

67asciiCI x =

@@ -126,8 +109,8 @@ takeWhile w s =

126

109

127takeWhile1 :: Char -> L.Text -> Property

110takeWhile1 :: Char -> L.Text -> Property

128takeWhile1 w s =

111takeWhile1 w s =

129− let s' = L.cons w s

112+ let s' = L.cons w s

130− (h,t) = L.span (<=w) s'

113+ (h,t) = L.span (<=w) s'

131 in case PL.parse (P.takeWhile1 (<=w)) s' of

114 in case PL.parse (P.takeWhile1 (<=w)) s' of

132 PL.Done t' h' -> t === t' .&&. toStrict h === h'

115 PL.Done t' h' -> t === t' .&&. toStrict h === h'

133 _ -> property False

116 _ -> property False

@@ -156,21 +139,11 @@ endOfLine s =

156 (c, fst <$> L.uncons s') === ('\r', Just '\n')

139 (c, fst <$> L.uncons s') === ('\r', Just '\n')

157

140

158scan :: L.Text -> Positive Int64 -> Property

141scan :: 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)

142+scan s (Positive k) = parseT p s === Just (toStrict $ L.take k s)

162 where p = P.scan k $ \ n _ ->

143 where p = P.scan k $ \ n _ ->

163 if n > 0 then let !n' = n - 1 in Just n' else Nothing

144 if n > 0 then let !n' = n - 1 in Just n' else Nothing

164

145

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]

146+tests :: [Test]

174tests = [

147tests = [

175 testProperty "anyChar" anyChar

148 testProperty "anyChar" anyChar

176 , testProperty "asciiCI" asciiCI

149 , testProperty "asciiCI" asciiCI

@@ -186,7 +159,6 @@ tests = [

186 , testProperty "skip" skip

159 , testProperty "skip" skip

187 , testProperty "skipWhile" skipWhile

160 , testProperty "skipWhile" skipWhile

188 , testProperty "string" string

161 , testProperty "string" string

189− , testProperty "strings" strings

190 , testProperty "stringCI" stringCI

162 , testProperty "stringCI" stringCI

191 , testProperty "take" take

163 , testProperty "take" take

192 , testProperty "takeText" takeText

164 , testProperty "takeText" takeText

@@ -196,8 +168,4 @@ tests = [

196 , testProperty "takeWhile" takeWhile

168 , testProperty "takeWhile" takeWhile

197 , testProperty "takeWhile1" takeWhile1

169 , testProperty "takeWhile1" takeWhile1

198 , testProperty "takeWhile1_empty" takeWhile1_empty

170 , testProperty "takeWhile1_empty" takeWhile1_empty

199− , testProperty "members" members

200− , testProperty "nonmembers" nonmembers

201− , testGroup "FastSet" FastSet.tests

202− , testGroup "Regressions" Regressions.tests

203 ]

171 ]

tests/QC/Text/FastSet.hsdeleted−15

@@ -1,15 +0,0 @@

1−module QC.Text.FastSet where

2−

3−import Test.Tasty (TestTree)

4−import Test.Tasty.QuickCheck (testProperty)

5−import Test.QuickCheck

6−import qualified Data.Attoparsec.Text.FastSet as FastSet

7−

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.hsdeleted−54

@@ -1,54 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−

3−module QC.Text.Regressions (

4− tests

5− ) where

6−

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.hsnew file+25

@@ -0,0 +1,25 @@

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