picoparsec (empty) → 0.1
raw patch · 40 files changed
+4384/−0 lines, 40 filesdep +QuickCheckdep +arraydep +attoparsecsetup-changedbinary-added
Dependencies added: QuickCheck, array, attoparsec, base, bytestring, containers, criterion, deepseq, directory, filepath, hashable, monoid-subclasses, parsec, picoparsec, quickcheck-instances, scientific, tasty, tasty-quickcheck, text, unordered-containers, vector
Files
- Data/Picoparsec.hs +206/−0
- Data/Picoparsec/Combinator.hs +269/−0
- Data/Picoparsec/Internal.hs +99/−0
- Data/Picoparsec/Internal/Types.hs +221/−0
- Data/Picoparsec/Monoid/Internal.hs +610/−0
- Data/Picoparsec/Number.hs +275/−0
- Data/Picoparsec/State.hs +37/−0
- Data/Picoparsec/Text/FastSet.hs +63/−0
- Data/Picoparsec/Types.hs +20/−0
- Data/Picoparsec/Zepto.hs +149/−0
- LICENSE +30/−0
- README.markdown +20/−0
- Setup.lhs +3/−0
- benchmarks/Alternative.hs +20/−0
- benchmarks/AttoAeson.hs +348/−0
- benchmarks/Benchmarks.hs +189/−0
- benchmarks/Data/Monoid/Instances/ByteString/Char8.hs +49/−0
- benchmarks/HeadersByteString.hs +46/−0
- benchmarks/HeadersText.hs +47/−0
- benchmarks/IsSpace.hs +123/−0
- benchmarks/Links.hs +63/−0
- benchmarks/Makefile +10/−0
- benchmarks/Numbers.hs +144/−0
- benchmarks/PicoAeson.hs +362/−0
- benchmarks/Tiny.hs +31/−0
- benchmarks/http-request.txt +14/−0
- benchmarks/http-response.txt +16/−0
- benchmarks/med.txt.bz2 binary
- benchmarks/picoparsec-benchmarks.cabal +31/−0
- changelog.md +3/−0
- examples/Makefile +15/−0
- examples/Parsec_RFC2616.hs +85/−0
- examples/RFC2616.hs +90/−0
- examples/TestRFC2616.hs +37/−0
- examples/rfc2616.c +238/−0
- picoparsec.cabal +119/−0
- tests/Makefile +14/−0
- tests/QC.hs +9/−0
- tests/QC/Monoid.hs +254/−0
- tests/TestFastSet.hs +25/−0
+ Data/Picoparsec.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE Haskell2010 #-}+-- |+-- Module : Data.Picoparsec+-- Copyright : Bryan O'Sullivan 2007-2011, Mario Blažević 2014+-- License : BSD3+--+-- Maintainer : Mario Blažević+-- Stability : experimental+-- Portability : unknown+--+-- Simple, efficient combinator parsing for+-- 'Data.Monoid.Cancellative.LeftGCDMonoid' and+-- 'Data.Monoid.Factorial.FactorialMonoid' inputs, loosely based on+-- Parsec and derived from Attoparsec.++module Data.Picoparsec+ (+ -- * Differences from Parsec+ -- $parsec++ -- * Differences from Attoparsec+ -- $attoparsec+ + -- * Incremental input+ -- $incremental++ -- * Performance considerations+ -- $performance++ -- * Parser types+ I.Parser+ , Result+ , T.IResult(..)+ , I.compareResults++ -- * Running parsers+ , parse+ , feed+ , I.parseOnly+ , parseWith+ , parseTest++ -- ** Result conversion+ , maybeResult+ , eitherResult++ -- * Combinators+ , module Data.Picoparsec.Combinator++ -- * Parsing individual tokens+ , I.anyToken+ , I.peekToken+ , I.satisfy+ , I.satisfyWith+ , I.skip++ -- ** Parsing individual characters+ , I.anyChar+ , I.char+ , I.peekChar+ , I.peekChar'+ , I.satisfyChar++ -- * Efficient string handling+ , I.scan+ , I.string+ , I.skipWhile+ , I.take+ , I.takeWhile+ , I.takeWhile1+ , I.takeTill++ -- ** Efficient character string handling+ , I.scanChars+ , I.skipCharsWhile+ , I.takeCharsWhile+ , I.takeCharsWhile1+ , I.takeCharsTill+ , I.takeTillChar+ , I.takeTillChar1++ -- ** Consume all remaining input+ , I.takeRest++ -- * Text parsing+ , I.endOfLine+ ) where++import Data.Monoid (Monoid, (<>))++import Data.Picoparsec.Combinator+import qualified Data.Picoparsec.Monoid.Internal as I+import qualified Data.Picoparsec.Internal as I+import Data.Picoparsec.Monoid.Internal (Result, parse)+import qualified Data.Picoparsec.Internal.Types as T++-- $parsec+--+-- Compared to Parsec 3, Picoparsec makes several tradeoffs. It is not intended for, or ideal for, all possible uses.+--+-- * While Picoparsec can consume input incrementally, Parsec cannot. Incremental input is a huge deal for efficient+-- and secure network and system programming, since it gives much more control to users of the library over matters such+-- as resource usage and the I/O model to use.+--+-- * Much of the performance advantage of Picoparsec is gained via high-performance parsers such as 'I.takeWhile' and+-- 'I.string'. If you use complicated combinators that return lists of bytes or characters, there is less performance+-- difference between the two libraries.+--+-- * Unlike Parsec 3, Picoparsec does not support being used as a monad transformer.+--+-- * Parsec parsers can produce more helpful error messages than Picoparsec parsers. This is a matter of focus:+-- Picoparsec avoids the extra book-keeping in favour of higher performance.+--+-- * Parsec comes with built-in support for user state. Picoparsec does not maintain any state by default, in order to+-- maximize performance. If your parsing logic needs depends on it, you can track the state by wrapping your input in a+-- 'Stateful' monoid.++-- $attoparsec+--+-- Compared to Attoparsec, Picoparsec trades away some performance for generality. Attoparsec works only with+-- 'ByteString' and 'Text' inputs. If your input type is one of these two, Attoparsec is the better choice. Use+-- Picoparsec if you want your parser to be applicable to a different input type, especially if you wish to leave the+-- choice of that input type to the end user.+--+-- Some Attoparsec primitives like 'word8' are missing because they are specific to ByteString inputs. Picoparsec is+-- otherwise largely compatible with Attoparsec, having copied from it both the core logic and the full set of parsing+-- combinators.++-- $incremental+--+-- Picoparsec supports incremental input, meaning that you can feed it a chunk of input that represents only part of the+-- expected total amount of data to parse. If your parser reaches the end of a fragment of input and could consume more+-- input, it will suspend parsing and return a 'T.Partial' continuation.+--+-- Supplying the 'T.Partial' continuation with another string will resume parsing at the point where it was+-- suspended. You must be prepared for the result of the resumed parse to be another 'T.Partial' continuation.+--+-- To indicate that you have no more input, supply the 'T.Partial' continuation with an empty string.+--+-- Remember that some parsing combinators will not return a result until they reach the end of input. They may thus+-- cause 'T.Partial' results to be returned.+--+-- If you do not need support for incremental input, consider using the 'I.parseOnly' function to run your parser. It+-- will never prompt for more input.++-- $performance+--+-- A Picoparsec-based parser applied to a strict ByteString or Text input will generally be somewhat slower than+-- Attoparsec, but if properly optimized and specialized the difference should be less than 50%.+--+-- To actually achieve high performance, there are a few guidelines that it is useful to follow.+--+-- * Use the input-returning parsers whenever possible, e.g. 'I.takeWhile1' instead of 'many1' 'I.anyToken'. There is a+-- large difference in performance between the two kinds of parsers.+--+-- * If you are parsing textual inputs, use the specialized character parsers; e.g. 'I.takeCharsWhile1' instead of+-- 'I.takeWhile1'.+--+-- * If the 'mappend' operation is slow for the input monoid type, it may drastically slow down the parsing of large+-- inputs. Try wrapping the input with the 'Concat' newtype to make the 'mappend' time constant.+--+-- * Use the INLINE, INLINABLE, and SPECIALIZE pragmas to optimize the more important parts of your parser for the likely+-- input types.+--+-- * Make active use of benchmarking and profiling tools to measure, find the problems with, and improve the performance+-- of your parser.++-- | If a parser has returned a 'T.Partial' result, supply it with more+-- input.+feed :: Monoid t => Result t r -> t -> Result t r+feed f@(T.Fail _ _ _) _ = f+feed (T.Partial k) d = k d+feed (T.Done t r) d = T.Done (t <> d) r+{-# INLINE feed #-}++-- | Run a parser and print its result to standard output.+parseTest :: (Monoid t, Show t, Show a) => I.Parser t a -> t -> IO ()+parseTest p s = print (parse p s)++-- | Run a parser with an initial input string, and a monadic action+-- that can supply more input if needed.+parseWith :: (Monoid t, Monad m) => m t+ -- ^ An action that will be executed to provide the parser+ -- with more input, if necessary. The action must return an+ -- 'mempty' string when there is no more input available.+ -> I.Parser t a+ -> t+ -- ^ Initial input for the parser.+ -> m (Result t a)+parseWith refill p s = step $ parse p s+ where step (T.Partial k) = (step . k) =<< refill+ step r = return r+{-# INLINE parseWith #-}++-- | Convert a 'Result' value to a 'Maybe' value. A 'T.Partial' result+-- is treated as failure.+maybeResult :: Result t r -> Maybe r+maybeResult (T.Done _ r) = Just r+maybeResult _ = Nothing++-- | Convert a 'Result' value to an 'Either' value. A 'T.Partial'+-- result is treated as failure.+eitherResult :: Result t r -> Either String r+eitherResult (T.Done _ r) = Right r+eitherResult (T.Fail _ _ msg) = Left msg+eitherResult _ = Left "Result: incomplete input"
+ Data/Picoparsec/Combinator.hs view
@@ -0,0 +1,269 @@+{-# LANGUAGE BangPatterns, CPP, Haskell2010 #-}+-- |+-- Module : Data.Picoparsec.Combinator+-- Copyright : Daan Leijen 1999-2001, Bryan O'Sullivan 2009-2010, Mario Blažević <blamario@yahoo.com> 2014+-- License : BSD3+--+-- Maintainer : Mario Blažević+-- Stability : experimental+-- Portability : portable+--+-- Useful parser combinators, similar to those provided by Parsec.+module Data.Picoparsec.Combinator+ (+ -- * Combinators+ try+ , (<?>)+ , choice+ , count+ , option+ , many'+ , many1+ , many1'+ , manyTill+ , manyTill'+ , sepBy+ , sepBy'+ , sepBy1+ , sepBy1'+ , skipMany+ , skipMany1+ , eitherP+ -- * State observation and manipulation functions+ , endOfInput+ , atEnd+ ) where++import Prelude hiding (null)++import Control.Applicative (Alternative(..), Applicative(..), empty, liftA2,+ (<|>), (*>), (<$>))+import Control.Monad (MonadPlus(..))+#if !MIN_VERSION_base(4,2,0)+import Control.Applicative (many)+#endif++import Data.Monoid.Null (MonoidNull(null))+import Data.Picoparsec.Internal (demandInput, wantInput)+import Data.Picoparsec.Internal.Types (Input(..), Parser(..), addS)+import Data.Picoparsec.Internal.Types (More(..))+import Data.ByteString (ByteString)+import Data.Text (Text)+import qualified Data.Picoparsec.Zepto as Z++-- | Attempt a parse, and if it fails, rewind the input so that no+-- input appears to have been consumed.+--+-- This combinator is provided for compatibility with Parsec.+-- Picoparsec parsers always backtrack on failure.+try :: Parser t a -> Parser t a+try p = p+{-# INLINE try #-}++-- | Name the parser, in case failure occurs.+(<?>) :: Parser t a+ -> String -- ^ the name to use if parsing fails+ -> Parser t a+p <?> msg0 = Parser $ \i0 a0 m0 kf ks ->+ let kf' i a m strs msg = kf i a m (msg0:strs) msg+ in runParser p i0 a0 m0 kf' ks+{-# INLINE (<?>) #-}+infix 0 <?>++-- | @choice ps@ tries to apply the actions in the list @ps@ in order,+-- until one of them succeeds. Returns the value of the succeeding+-- action.+choice :: Alternative f => [f a] -> f a+choice = foldr (<|>) empty+{-# SPECIALIZE choice :: [Parser ByteString a] -> Parser ByteString a #-}+{-# SPECIALIZE choice :: [Parser Text a] -> Parser Text a #-}+{-# SPECIALIZE choice :: [Z.Parser ByteString a] -> Z.Parser ByteString a #-}+{-# SPECIALIZE choice :: [Z.Parser Text a] -> Z.Parser Text a #-}++-- | @option x p@ tries to apply action @p@. If @p@ fails without+-- consuming input, it returns the value @x@, otherwise the value+-- returned by @p@.+--+-- > priority = option 0 (digitToInt <$> digit)+option :: Alternative f => a -> f a -> f a+option x p = p <|> pure x+{-# SPECIALIZE option :: a -> Parser ByteString a -> Parser ByteString a #-}+{-# SPECIALIZE option :: a -> Parser Text a -> Parser Text a #-}+{-# SPECIALIZE option :: a -> Z.Parser ByteString a -> Z.Parser ByteString a #-}+{-# SPECIALIZE option :: a -> Z.Parser Text a -> Z.Parser Text a #-}++-- | A version of 'liftM2' that is strict in the result of its first+-- action.+liftM2' :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c+liftM2' f a b = do+ !x <- a+ y <- b+ return (f x y)+{-# INLINE liftM2' #-}++-- | @many' p@ applies the action @p@ /zero/ or more times. Returns a+-- list of the returned values of @p@. The value returned by @p@ is+-- forced to WHNF.+--+-- > word = many' letter+many' :: (MonadPlus m) => m a -> m [a]+many' p = many_p+ where many_p = some_p `mplus` return []+ some_p = liftM2' (:) p many_p+{-# INLINE many' #-}++-- | @many1 p@ applies the action @p@ /one/ or more times. Returns a+-- list of the returned values of @p@.+--+-- > word = many1 letter+many1 :: Alternative f => f a -> f [a]+many1 p = liftA2 (:) p (many p)+{-# INLINE many1 #-}++-- | @many1' p@ applies the action @p@ /one/ or more times. Returns a+-- list of the returned values of @p@. The value returned by @p@ is+-- forced to WHNF.+--+-- > word = many1' letter+many1' :: (MonadPlus m) => m a -> m [a]+many1' p = liftM2' (:) p (many' p)+{-# INLINE many1' #-}++-- | @sepBy p sep@ applies /zero/ or more occurrences of @p@, separated+-- by @sep@. Returns a list of the values returned by @p@.+--+-- > commaSep p = p `sepBy` (symbol ",")+sepBy :: Alternative f => f a -> f s -> f [a]+sepBy p s = liftA2 (:) p ((s *> sepBy1 p s) <|> pure []) <|> pure []+{-# SPECIALIZE sepBy :: Parser ByteString a -> Parser ByteString s+ -> Parser ByteString [a] #-}+{-# SPECIALIZE sepBy :: Parser Text a -> Parser Text s -> Parser Text [a] #-}+{-# SPECIALIZE sepBy :: Z.Parser ByteString a -> Z.Parser ByteString s -> Z.Parser ByteString [a] #-}+{-# SPECIALIZE sepBy :: Z.Parser Text a -> Z.Parser Text s -> Z.Parser Text [a] #-}++-- | @sepBy' p sep@ applies /zero/ or more occurrences of @p@, separated+-- by @sep@. Returns a list of the values returned by @p@. The value+-- returned by @p@ is forced to WHNF.+--+-- > commaSep p = p `sepBy'` (symbol ",")+sepBy' :: (MonadPlus m) => m a -> m s -> m [a]+sepBy' p s = scan `mplus` return []+ where scan = liftM2' (:) p ((s >> sepBy1' p s) `mplus` return [])+{-# SPECIALIZE sepBy' :: Parser ByteString a -> Parser ByteString s+ -> Parser ByteString [a] #-}+{-# SPECIALIZE sepBy' :: Z.Parser ByteString a -> Z.Parser ByteString s -> Z.Parser ByteString [a] #-}+{-# SPECIALIZE sepBy' :: Z.Parser Text a -> Z.Parser Text s -> Z.Parser Text [a] #-}++-- | @sepBy1 p sep@ applies /one/ or more occurrences of @p@, separated+-- by @sep@. Returns a list of the values returned by @p@.+--+-- > commaSep p = p `sepBy1` (symbol ",")+sepBy1 :: Alternative f => f a -> f s -> f [a]+sepBy1 p s = scan+ where scan = liftA2 (:) p ((s *> scan) <|> pure [])+{-# SPECIALIZE sepBy1 :: Parser ByteString a -> Parser ByteString s+ -> Parser ByteString [a] #-}+{-# SPECIALIZE sepBy1 :: Parser Text a -> Parser Text s -> Parser Text [a] #-}+{-# SPECIALIZE sepBy1 :: Z.Parser ByteString a -> Z.Parser ByteString s -> Z.Parser ByteString [a] #-}+{-# SPECIALIZE sepBy1 :: Z.Parser Text a -> Z.Parser Text s -> Z.Parser Text [a] #-}++-- | @sepBy1' p sep@ applies /one/ or more occurrences of @p@, separated+-- by @sep@. Returns a list of the values returned by @p@. The value+-- returned by @p@ is forced to WHNF.+--+-- > commaSep p = p `sepBy1'` (symbol ",")+sepBy1' :: (MonadPlus m) => m a -> m s -> m [a]+sepBy1' p s = scan+ where scan = liftM2' (:) p ((s >> scan) `mplus` return [])+{-# SPECIALIZE sepBy1' :: Parser ByteString a -> Parser ByteString s+ -> Parser ByteString [a] #-}+{-# SPECIALIZE sepBy1' :: Parser Text a -> Parser Text s -> Parser Text [a] #-}+{-# SPECIALIZE sepBy1' :: Z.Parser ByteString a -> Z.Parser ByteString s -> Z.Parser ByteString [a] #-}+{-# SPECIALIZE sepBy1' :: Z.Parser Text a -> Z.Parser Text s -> Z.Parser Text [a] #-}++-- | @manyTill p end@ applies action @p@ /zero/ or more times until+-- action @end@ succeeds, and returns the list of values returned by+-- @p@. This can be used to scan comments:+--+-- > simpleComment = string "<!--" *> manyTill anyChar (string "-->")+--+-- (Note the overlapping parsers @anyChar@ and @string \"-->\"@.+-- While this will work, it is not very efficient, as it will cause a+-- lot of backtracking.)+manyTill :: Alternative f => f a -> f b -> f [a]+manyTill p end = scan+ where scan = (end *> pure []) <|> liftA2 (:) p scan+{-# SPECIALIZE manyTill :: Parser ByteString a -> Parser ByteString b+ -> Parser ByteString [a] #-}+{-# SPECIALIZE manyTill :: Parser Text a -> Parser Text b -> Parser Text [a] #-}+{-# SPECIALIZE manyTill :: Z.Parser ByteString a -> Z.Parser ByteString b -> Z.Parser ByteString [a] #-}+{-# SPECIALIZE manyTill :: Z.Parser Text a -> Z.Parser Text b -> Z.Parser Text [a] #-}++-- | @manyTill' p end@ applies action @p@ /zero/ or more times until+-- action @end@ succeeds, and returns the list of values returned by+-- @p@. This can be used to scan comments:+--+-- > simpleComment = string "<!--" *> manyTill' anyChar (string "-->")+--+-- (Note the overlapping parsers @anyChar@ and @string \"-->\"@.+-- While this will work, it is not very efficient, as it will cause a+-- lot of backtracking.)+--+-- The value returned by @p@ is forced to WHNF.+manyTill' :: (MonadPlus m) => m a -> m b -> m [a]+manyTill' p end = scan+ where scan = (end >> return []) `mplus` liftM2' (:) p scan+{-# SPECIALIZE manyTill' :: Parser ByteString a -> Parser ByteString b+ -> Parser ByteString [a] #-}+{-# SPECIALIZE manyTill' :: Parser Text a -> Parser Text b -> Parser Text [a] #-}+{-# SPECIALIZE manyTill' :: Z.Parser ByteString a -> Z.Parser ByteString b -> Z.Parser ByteString [a] #-}+{-# SPECIALIZE manyTill' :: Z.Parser Text a -> Z.Parser Text b -> Z.Parser Text [a] #-}++-- | Skip zero or more instances of an action.+skipMany :: Alternative f => f a -> f ()+skipMany p = scan+ where scan = (p *> scan) <|> pure ()+{-# SPECIALIZE skipMany :: Parser ByteString a -> Parser ByteString () #-}+{-# SPECIALIZE skipMany :: Parser Text a -> Parser Text () #-}+{-# SPECIALIZE skipMany :: Z.Parser ByteString a -> Z.Parser ByteString () #-}+{-# SPECIALIZE skipMany :: Z.Parser Text a -> Z.Parser Text () #-}++-- | Skip one or more instances of an action.+skipMany1 :: Alternative f => f a -> f ()+skipMany1 p = p *> skipMany p+{-# SPECIALIZE skipMany1 :: Parser ByteString a -> Parser ByteString () #-}+{-# SPECIALIZE skipMany1 :: Parser Text a -> Parser Text () #-}+{-# SPECIALIZE skipMany1 :: Z.Parser ByteString a -> Z.Parser ByteString () #-}+{-# SPECIALIZE skipMany1 :: Z.Parser Text a -> Z.Parser Text () #-}++-- | Apply the given action repeatedly, returning every result.+count :: Monad m => Int -> m a -> m [a]+count n p = sequence (replicate n p)+{-# INLINE count #-}++-- | Combine two alternatives.+eitherP :: (Alternative f) => f a -> f b -> f (Either a b)+eitherP a b = (Left <$> a) <|> (Right <$> b)+{-# INLINE eitherP #-}++-- | Match only if all input has been consumed.+endOfInput :: MonoidNull t => Parser t ()+endOfInput = Parser $ \i0 a0 m0 kf ks ->+ if null (unI i0)+ then if m0 == Complete+ then ks i0 a0 m0 ()+ else let kf' i1 a1 m1 _ _ = addS i0 a0 m0 i1 a1 m1 $+ \ i2 a2 m2 -> ks i2 a2 m2 ()+ ks' i1 a1 m1 _ = addS i0 a0 m0 i1 a1 m1 $+ \ i2 a2 m2 -> kf i2 a2 m2 []+ "endOfInput"+ in runParser demandInput i0 a0 m0 kf' ks'+ else kf i0 a0 m0 [] "endOfInput"+{-# SPECIALIZE endOfInput :: Parser ByteString () #-}+{-# SPECIALIZE endOfInput :: Parser Text () #-}++-- | Return an indication of whether the end of input has been+-- reached.+atEnd :: MonoidNull t => Parser t Bool+atEnd = not <$> wantInput+{-# INLINE atEnd #-}
+ Data/Picoparsec/Internal.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE BangPatterns, Haskell2010 #-}+-- |+-- Module : Data.Picoparsec.Internal+-- Copyright : Bryan O'Sullivan 2012, Mario Blažević <blamario@yahoo.com> 2014+-- License : BSD3+--+-- Maintainer : Mario Blažević+-- Stability : experimental+-- Portability : unknown+--+-- Simple, efficient parser combinators, loosely based on the Parsec+-- library.++module Data.Picoparsec.Internal+ (+ compareResults+ , get+ , put+ , prompt+ , demandInput+ , wantInput+ ) where++import Prelude hiding (null)++import Data.Picoparsec.Internal.Types+import Data.ByteString (ByteString)+import Data.Monoid ((<>))+import Data.Monoid.Null (MonoidNull(null))+import Data.Text (Text)++-- | Compare two 'IResult' values for equality.+--+-- If both 'IResult's are 'Partial', the result will be 'Nothing', as+-- they are incomplete and hence their equality cannot be known.+-- (This is why there is no 'Eq' instance for 'IResult'.)+compareResults :: (Eq t, Eq r) => IResult t r -> IResult t r -> Maybe Bool+compareResults (Fail i0 ctxs0 msg0) (Fail i1 ctxs1 msg1) =+ Just (i0 == i1 && ctxs0 == ctxs1 && msg0 == msg1)+compareResults (Done i0 r0) (Done i1 r1) =+ Just (i0 == i1 && r0 == r1)+compareResults (Partial _) (Partial _) = Nothing+compareResults _ _ = Just False++get :: Parser t t+get = Parser $ \i0 a0 m0 _kf ks -> ks i0 a0 m0 (unI i0)+{-# INLINE get #-}++put :: t -> Parser t ()+put c = Parser $ \_i0 a0 m0 _kf ks -> ks (I c) a0 m0 ()+{-# INLINE put #-}++-- | Ask for input. If we receive any, pass it to a success+-- continuation, otherwise to a failure continuation.+prompt :: MonoidNull t+ => Input t -> Added t -> More+ -> (Input t -> Added t -> More -> IResult t r)+ -> (Input t -> Added t -> More -> IResult t r)+ -> IResult t r+prompt i0 a0 _m0 kf ks = Partial $ \s ->+ if null s+ then kf i0 a0 Complete+ else ks (i0 <> I s) (a0 <> A s) Incomplete+{-# SPECIALIZE prompt :: Input ByteString -> Added ByteString -> More+ -> (Input ByteString -> Added ByteString -> More+ -> IResult ByteString r)+ -> (Input ByteString -> Added ByteString -> More+ -> IResult ByteString r)+ -> IResult ByteString r #-}+{-# SPECIALIZE prompt :: Input Text -> Added Text -> More+ -> (Input Text -> Added Text -> More -> IResult Text r)+ -> (Input Text -> Added Text-> More -> IResult Text r)+ -> IResult Text r #-}++-- | Immediately demand more input via a 'Partial' continuation+-- result.+demandInput :: MonoidNull t => Parser t ()+demandInput = Parser $ \i0 a0 m0 kf ks ->+ if m0 == Complete+ then kf i0 a0 m0 ["demandInput"] "not enough input"+ else let kf' i a m = kf i a m ["demandInput"] "not enough input"+ ks' i a m = ks i a m ()+ in prompt i0 a0 m0 kf' ks'+{-# SPECIALIZE demandInput :: Parser ByteString () #-}+{-# SPECIALIZE demandInput :: Parser Text () #-}++-- | This parser always succeeds. It returns 'True' if any input is+-- available either immediately or on demand, and 'False' if the end+-- of all input has been reached.+wantInput :: MonoidNull t => Parser t Bool+wantInput = Parser $ \i0 a0 m0 _kf ks ->+ case () of+ _ | not (null (unI i0)) -> ks i0 a0 m0 True+ | m0 == Complete -> ks i0 a0 m0 False+ | otherwise -> let kf' i a m = ks i a m False+ ks' i a m = ks i a m True+ in prompt i0 a0 m0 kf' ks'+{-# SPECIALIZE wantInput :: Parser ByteString Bool #-}+{-# SPECIALIZE wantInput :: Parser Text Bool #-}
+ Data/Picoparsec/Internal/Types.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE BangPatterns, CPP, Haskell2010, Rank2Types, Safe #-}+-- |+-- Module : Data.Picoparsec.Internal.Types+-- Copyright : Bryan O'Sullivan 2007-2011, Mario Blažević <blamario@yahoo.com> 2014+-- License : BSD3+--+-- Maintainer : Mario Blažević+-- Stability : experimental+-- Portability : unknown+--+-- Simple, efficient parser combinators, loosely based on the Parsec+-- library.++module Data.Picoparsec.Internal.Types+ (+ Parser(..)+ , Failure+ , Success+ , IResult(..)+ , Input(..)+ , Added(..)+ , More(..)+ , addS+ ) where++import Control.Applicative (Alternative(..), Applicative(..), (<$>))+import Control.DeepSeq (NFData(rnf))+import Control.Monad (MonadPlus(..))+import Data.Monoid (Monoid(..), (<>))++-- | The result of a parse. This is parameterised over the type @t@+-- of string that was processed.+--+-- This type is an instance of 'Functor', where 'fmap' transforms the+-- value in a 'Done' result.+data IResult t r = Fail t [String] String+ -- ^ The parse failed. The 't' parameter is the+ -- input that had not yet been consumed when the+ -- failure occurred. The @[@'String'@]@ is a list of+ -- contexts in which the error occurred. The+ -- 'String' is the message describing the error, if+ -- any.+ | Partial (t -> IResult t r)+ -- ^ Supply this continuation with more input so that+ -- the parser can resume. To indicate that no more+ -- input is available, use an empty string.+ | Done t r+ -- ^ The parse succeeded. The 't' parameter is the+ -- input that had not yet been consumed (if any) when+ -- the parse succeeded.++instance (Show t, Show r) => Show (IResult t r) where+ show (Fail t stk msg) =+ "Fail " ++ show t ++ " " ++ show stk ++ " " ++ show msg+ show (Partial _) = "Partial _"+ show (Done t r) = "Done " ++ show t ++ " " ++ show r++instance (NFData t, NFData r) => NFData (IResult t r) where+ rnf (Fail t stk msg) = rnf t `seq` rnf stk `seq` rnf msg+ rnf (Partial _) = ()+ rnf (Done t r) = rnf t `seq` rnf r+ {-# INLINE rnf #-}++fmapR :: (a -> b) -> IResult t a -> IResult t b+fmapR _ (Fail t stk msg) = Fail t stk msg+fmapR f (Partial k) = Partial (fmapR f . k)+fmapR f (Done t r) = Done t (f r)++instance Functor (IResult t) where+ fmap = fmapR+ {-# INLINE fmap #-}++newtype Input t = I {unI :: t}+newtype Added t = A {unA :: t}++instance Monoid t => Monoid (Input t) where+ mempty = I mempty+ I a `mappend` I b = I (mappend a b)++instance Monoid t => Monoid (Added t) where+ mempty = A mempty+ A a `mappend` A b = A (mappend a b)++-- | The core parser type. This is parameterised over the type @t@ of+-- string being processed.+--+-- This type is an instance of the following classes:+--+-- * 'Monad', where 'fail' throws an exception (i.e. fails) with an+-- error message.+--+-- * 'Functor' and 'Applicative', which follow the usual definitions.+--+-- * 'MonadPlus', where 'mzero' fails (with no error message) and+-- 'mplus' executes the right-hand parser if the left-hand one+-- fails. When the parser on the right executes, the input is reset+-- to the same state as the parser on the left started with. (In+-- other words, Picoparsec is a backtracking parser that supports+-- arbitrary lookahead.)+--+-- * 'Alternative', which follows 'MonadPlus'.+newtype Parser t a = Parser {+ runParser :: forall r. Input t -> Added t -> More+ -> Failure t r+ -> Success t a r+ -> IResult t r+ }++type Failure t r = Input t -> Added t -> More -> [String] -> String+ -> IResult t r+type Success t a r = Input t -> Added t -> More -> a -> IResult t r++-- | Have we read all available input?+data More = Complete | Incomplete+ deriving (Eq, Show)++instance Monoid More where+ mappend c@Complete _ = c+ mappend _ m = m+ mempty = Incomplete++addS :: (Monoid t) =>+ Input t -> Added t -> More+ -> Input t -> Added t -> More+ -> (Input t -> Added t -> More -> r) -> r+addS i0 a0 m0 _i1 a1 m1 f =+ let !i = i0 <> I (unA a1)+ a = a0 <> a1+ !m = m0 <> m1+ in f i a m+{-# INLINE addS #-}++bindP :: Parser t a -> (a -> Parser t b) -> Parser t b+bindP m g =+ Parser $ \i0 a0 m0 kf ks -> runParser m i0 a0 m0 kf $+ \i1 a1 m1 a -> runParser (g a) i1 a1 m1 kf ks+{-# INLINE bindP #-}++returnP :: a -> Parser t a+returnP a = Parser (\i0 a0 m0 _kf ks -> ks i0 a0 m0 a)+{-# INLINE returnP #-}++instance Monad (Parser t) where+ return = returnP+ (>>=) = bindP+ fail = failDesc++noAdds :: (Monoid t) =>+ Input t -> Added t -> More+ -> (Input t -> Added t -> More -> r) -> r+noAdds i0 _a0 m0 f = f i0 mempty m0+{-# INLINE noAdds #-}++plus :: (Monoid t) => Parser t a -> Parser t a -> Parser t a+plus a b = Parser $ \i0 a0 m0 kf ks ->+ let kf' i1 a1 m1 _ _ = addS i0 a0 m0 i1 a1 m1 $+ \ i2 a2 m2 -> runParser b i2 a2 m2 kf ks+ ks' i1 a1 m1 = ks i1 (a0 <> a1) m1+ in noAdds i0 a0 m0 $ \i2 a2 m2 -> runParser a i2 a2 m2 kf' ks'++instance (Monoid t) => MonadPlus (Parser t) where+ mzero = failDesc "mzero"+ {-# INLINE mzero #-}+ mplus = plus++fmapP :: (a -> b) -> Parser t a -> Parser t b+fmapP p m = Parser $ \i0 a0 m0 f k ->+ runParser m i0 a0 m0 f $ \i1 a1 s1 a -> k i1 a1 s1 (p a)+{-# INLINE fmapP #-}++instance Functor (Parser t) where+ fmap = fmapP+ {-# INLINE fmap #-}++apP :: Parser t (a -> b) -> Parser t a -> Parser t b+apP d e = do+ b <- d+ a <- e+ return (b a)+{-# INLINE apP #-}++instance Applicative (Parser t) where+ pure = returnP+ {-# INLINE pure #-}+ (<*>) = apP+ {-# INLINE (<*>) #-}++#if MIN_VERSION_base(4,2,0)+ -- These definitions are equal to the defaults, but this+ -- way the optimizer doesn't have to work so hard to figure+ -- that out.+ (*>) = (>>)+ {-# INLINE (*>) #-}+ x <* y = x >>= \a -> y >> return a+ {-# INLINE (<*) #-}+#endif++instance (Monoid t) => Alternative (Parser t) where+ empty = failDesc "empty"+ {-# INLINE empty #-}++ (<|>) = plus+ {-# INLINE (<|>) #-}++#if MIN_VERSION_base(4,2,0)+ many v = many_v+ where many_v = some_v <|> pure []+ some_v = (:) <$> v <*> many_v+ {-# INLINE many #-}++ some v = some_v+ where+ many_v = some_v <|> pure []+ some_v = (:) <$> v <*> many_v+ {-# INLINE some #-}+#endif++failDesc :: String -> Parser t a+failDesc err = Parser (\i0 a0 m0 kf _ks -> kf i0 a0 m0 [] msg)+ where msg = "Failed reading: " ++ err+{-# INLINE failDesc #-}
+ Data/Picoparsec/Monoid/Internal.hs view
@@ -0,0 +1,610 @@+{-# LANGUAGE BangPatterns, CPP, Rank2Types, OverloadedStrings #-}+-- |+-- Module : Data.Picoparsec.Monoid.Internal+-- Copyright : Bryan O'Sullivan 2007-2011, Mario Blažević <blamario@yahoo.com> 2014+-- License : BSD3+--+-- Maintainer : Mario Blažević+-- Stability : experimental+-- Portability : unknown+--+-- Simple, efficient combinator parsing for+-- 'Data.Monoid.Cancellative.LeftGCDMonoid' and+-- 'Data.Monoid.Factorial.FactorialMonoid' inputs, loosely based on+-- the Parsec library.++module Data.Picoparsec.Monoid.Internal+ (+ -- * Parser types+ Parser+ , Result++ -- * Running parsers+ , parse+ , parseOnly++ -- * Combinators+ , module Data.Picoparsec.Combinator++ -- * Parsing individual tokens+ , satisfy+ , satisfyWith+ , anyToken+ , skip+ , peekToken+ + -- ** Parsing individual characters+ , anyChar+ , char+ , satisfyChar+ , peekChar+ , peekChar'++ -- * Efficient string handling+ , scan+ , skipWhile+ , string+ , stringTransform+ , take+ , takeWhile+ , takeWhile1+ , takeWith+ , takeTill++ -- ** Efficient character string handling+ , scanChars+ , skipCharsWhile+ , takeCharsWhile+ , takeCharsWhile1+ , takeCharsTill+ , takeTillChar+ , takeTillChar1++ -- ** Consume all remaining input+ , takeRest++ -- * Utilities+ , endOfLine+ , ensureOne+ ) where++import Control.Applicative ((<|>), (<$>))+import Control.Monad (when)+import Data.Picoparsec.Combinator+import Data.Picoparsec.Internal.Types+import Data.Monoid (Monoid(..), (<>))+import Data.Monoid.Cancellative (LeftGCDMonoid(..))+import Data.Monoid.Null (MonoidNull(null))+import qualified Data.Monoid.Factorial as Factorial+import Data.Monoid.Factorial (FactorialMonoid)+import Data.Monoid.Textual (TextualMonoid)+import qualified Data.Monoid.Textual as Textual+import Prelude hiding (getChar, null, span, take, takeWhile)+import qualified Data.Picoparsec.Internal.Types as T++type Result = IResult++ensure' :: FactorialMonoid t => Int -> T.Input t -> T.Added t -> More -> T.Failure t r -> T.Success t t r+ -> IResult t r+ensure' !n0 i0 a0 m0 kf0 ks0 =+ T.runParser (demandInput >> go n0) i0 a0 m0 kf0 ks0+ where+ go !n = T.Parser $ \i a m kf ks ->+ if Factorial.length (unI i) >= n+ then ks i a m (unI i)+ else T.runParser (demandInput >> go n) i a m kf ks++-- | If at least one token of input is available, return the current+-- input, otherwise fail.+ensureOne :: FactorialMonoid t => Parser t t+ensureOne = T.Parser $ \i0 a0 m0 kf ks ->+ if null (unI i0)+ -- The uncommon case is kept out-of-line to reduce code size:+ then ensure' 1 i0 a0 m0 kf ks+ else ks i0 a0 m0 (unI i0)+-- Non-recursive so the bounds check can be inlined:+{-# INLINE ensureOne #-}++-- | Ask for input. If we receive any, pass it to a success+-- continuation, otherwise to a failure continuation.+prompt :: MonoidNull t => Input t -> Added t -> More+ -> (Input t -> Added t -> More -> IResult t r)+ -> (Input t -> Added t -> More -> IResult t r)+ -> IResult t r+prompt i0 a0 _m0 kf ks = Partial $ \s ->+ if null s+ then kf i0 a0 Complete+ else ks (i0 <> I s) (a0 <> A s) Incomplete++-- | Immediately demand more input via a 'Partial' continuation+-- result.+demandInput :: MonoidNull t => Parser t ()+demandInput = T.Parser $ \i0 a0 m0 kf ks ->+ if m0 == Complete+ then kf i0 a0 m0 ["demandInput"] "not enough input"+ else let kf' i a m = kf i a m ["demandInput"] "not enough input"+ ks' i a m = ks i a m ()+ in prompt i0 a0 m0 kf' ks'++-- | This parser always succeeds. It returns 'True' if any input is+-- available either immediately or on demand, and 'False' if the end+-- of all input has been reached.+wantInput :: MonoidNull t => Parser t Bool+wantInput = T.Parser $ \i0 a0 m0 _kf ks ->+ case () of+ _ | not (null (unI i0)) -> ks i0 a0 m0 True+ | m0 == Complete -> ks i0 a0 m0 False+ | otherwise -> let kf' i a m = ks i a m False+ ks' i a m = ks i a m True+ in prompt i0 a0 m0 kf' ks'++-- | This parser always succeeds. It returns 'True' if any input is+-- available on demand, and 'False' if the end of all input has been reached.+wantMoreInput :: MonoidNull t => Parser t Bool+wantMoreInput = T.Parser $ \i0 a0 m0 _kf ks ->+ if m0 == Complete + then ks i0 a0 m0 False+ else let kf' i a m = ks i a m False+ ks' i a m = ks i a m True+ in prompt i0 a0 m0 kf' ks'++get :: Parser t t+get = T.Parser $ \i0 a0 m0 _kf ks -> ks i0 a0 m0 (unI i0)++put :: t -> Parser t ()+put s = T.Parser $ \_i0 a0 m0 _kf ks -> ks (I s) a0 m0 ()++-- | The parser @satisfy p@ succeeds for any prime input token for+-- which the predicate @p@ returns 'True'. Returns the token that is+-- actually parsed.+--+-- >digit = satisfy isDigit+-- > where isDigit w = w >= "0" && w <= "9"+satisfy :: FactorialMonoid t => (t -> Bool) -> Parser t t+satisfy p = do+ s <- ensureOne+ let Just (first, rest) = Factorial.splitPrimePrefix s+ if p first then put rest >> return first else fail "satisfy"+{-# INLINE satisfy #-}++-- | The parser @satisfy p@ succeeds for any input character for+-- which the predicate @p@ returns 'True'. Returns the character that +-- is actually parsed.+--+-- >digit = satisfy isDigit+-- > where isDigit w = w >= "0" && w <= "9"+satisfyChar :: TextualMonoid t => (Char -> Bool) -> Parser t Char+satisfyChar p = do+ s <- ensureOne+ case Textual.splitCharacterPrefix s + of Just (first, rest) | p first -> put rest >> return first + _ -> fail "satisfy"+{-# INLINE satisfyChar #-}++-- | The parser @skip p@ succeeds for any prime input token for which+-- the predicate @p@ returns 'True'.+--+-- >skipDigit = skip isDigit+-- > where isDigit w = w >= "0" && w <= "9"+skip :: FactorialMonoid t => (t -> Bool) -> Parser t ()+skip p = do+ s <- ensureOne+ let Just (first, rest) = Factorial.splitPrimePrefix s+ if p first then put rest else fail "skip"++-- | The parser @satisfyWith f p@ transforms an input token, and+-- succeeds if the predicate @p@ returns 'True' on the transformed+-- value. The parser returns the transformed token that was parsed.+satisfyWith :: FactorialMonoid t => (t -> a) -> (a -> Bool) -> Parser t a+satisfyWith f p = do+ s <- ensureOne+ let Just (first, rest) = Factorial.splitPrimePrefix s+ c = f $! first+ if p c then put rest >> return c else fail "satisfyWith"+{-# INLINE satisfyWith #-}++-- | Consume @n@ tokens of input, but succeed only if the predicate+-- returns 'True'.+takeWith :: FactorialMonoid t => Int -> (t -> Bool) -> Parser t t+takeWith n0 p =+ get >>= \i->+ let !(h, t) = Factorial.splitAt n0 i+ n1 = Factorial.length h+ in if null t && n1 < n0+ then put mempty+ >> demandInput+ >> takeWith' h n1 p+ else if p h+ then put t+ >> return h+ else fail "takeWith"+{-# INLINABLE takeWith #-}++-- The uncommon case+takeWith' :: FactorialMonoid t => t -> Int -> (t -> Bool) -> Parser t t+takeWith' h0 n0 p =+ get >>= \i->+ let !(h, t) = Factorial.splitAt n0 i+ n1 = Factorial.length h+ h1 = h0 <> h+ in if null t && n1 < n0+ then put mempty+ >> demandInput+ >> takeWith' h1 n1 p+ else if p h1+ then put t+ >> return h1+ else fail "takeWith"+{-# INLINABLE takeWith' #-}++-- | Consume exactly @n@ prime input tokens.+take :: FactorialMonoid t => Int -> Parser t t+take n = takeWith n (const True)+{-# INLINE take #-}++-- | @string s@ parses a prefix of input that identically matches+-- @s@. Returns the parsed string (i.e. @s@). This parser consumes no+-- input if it fails (even if a partial match).+--+-- /Note/: The behaviour of this parser is different to that of the+-- similarly-named parser in Parsec, as this one is all-or-nothing.+-- To illustrate the difference, the following parser will fail under+-- Parsec given an input of @\"for\"@:+--+-- >string "foo" <|> string "for"+--+-- The reason for its failure is that the first branch is a+-- partial match, and will consume the letters @\'f\'@ and @\'o\'@+-- before failing. In Attoparsec, the above parser will /succeed/ on+-- that input, because the failed first branch will consume nothing.+string :: (LeftGCDMonoid t, MonoidNull t) => t -> Parser t t+string s =+ get >>= \i->+ let !(p, s', i') = stripCommonPrefix s i+ in if null s'+ then put i' >> return s+ else if null i'+ then put mempty+ >> demandInput+ >> string' p s'+ else fail "string"+{-# INLINE string #-}++-- The uncommon case+string' :: (LeftGCDMonoid t, MonoidNull t) => t -> t -> Parser t t+string' consumed rest =+ get >>= \i->+ let !(p, s', i') = stripCommonPrefix rest i+ in if null s'+ then put i' >> return (consumed <> rest)+ else if null i'+ then put mempty+ >> demandInput+ >> string' (consumed <> p) s'+ else put (consumed <> i) + >> fail "string"++stringTransform :: (FactorialMonoid t, Eq t) => (t -> t) -> t+ -> Parser t t+stringTransform f s = takeWith (Factorial.length s) ((==f s) . f)+{-# INLINE stringTransform #-}++-- | Skip past input for as long as the predicate returns 'True'.+skipWhile :: FactorialMonoid t => (t -> Bool) -> Parser t ()+skipWhile p = go+ where+ go = do+ t <- Factorial.dropWhile p <$> get+ put t+ when (null t) $ do+ input <- wantMoreInput+ when input go+{-# INLINE skipWhile #-}++-- | Skip past input characters for as long as the predicate returns 'True'.+skipCharsWhile :: TextualMonoid t => (Char -> Bool) -> Parser t ()+skipCharsWhile p = go+ where+ go = do+ t <- Textual.dropWhile_ False p <$> get+ put t+ when (null t) $ do+ input <- wantMoreInput+ when input go+{-# INLINE skipCharsWhile #-}++-- | Consume input as long as the predicate returns 'False'+-- (i.e. until it returns 'True'), and return the consumed input.+--+-- This parser does not fail. It will return an empty string if the+-- predicate returns 'True' on the first input token.+--+-- /Note/: Because this parser does not fail, do not use it with+-- combinators such as 'many', because such parsers loop until a+-- failure occurs. Careless use will thus result in an infinite loop.+takeTill :: FactorialMonoid t => (t -> Bool) -> Parser t t+takeTill p = takeWhile (not . p)+{-# INLINE takeTill #-}++-- | Consume input characters as long as the predicate returns 'False'+-- (i.e. until it returns 'True'), and return the consumed input.+--+-- This parser does not fail. It will return an empty string if the+-- predicate returns 'True' on the first input token.+--+-- /Note/: Because this parser does not fail, do not use it with+-- combinators such as 'many', because such parsers loop until a+-- failure occurs. Careless use will thus result in an infinite loop.+takeCharsTill :: TextualMonoid t => (Char -> Bool) -> Parser t t+takeCharsTill p = takeCharsWhile (not . p)++-- | Consume all input until the character for which the predicate +-- returns 'True' and return the consumed input.+--+-- The only difference between 'takeCharsTill' and 'takeTillChar' is+-- in their handling of non-character data: The former never consumes+-- it, the latter always does.+--+-- This parser does not fail. It will return an empty string if the+-- predicate returns 'True' on the first input token.+--+-- /Note/: Because this parser does not fail, do not use it with+-- combinators such as 'many', because such parsers loop until a+-- failure occurs. Careless use will thus result in an infinite loop.+takeTillChar :: TextualMonoid t => (Char -> Bool) -> Parser t t+takeTillChar p = go id+ where+ go acc = do+ (h,t) <- Textual.break_ False p <$> get+ put t+ if null t+ then do+ input <- wantInput+ if input+ then go (acc . mappend h)+ else return (acc h)+ else return (acc h)+{-# INLINE takeTillChar #-}++-- | Consume all input until the character for which the predicate +-- returns 'True' and return the consumed input.+--+-- This parser always consumes at least one token: it will fail if the +-- input starts with a character for which the predicate returns +-- 'True' or if there is no input left.+takeTillChar1 :: TextualMonoid t => (Char -> Bool) -> Parser t t+takeTillChar1 p = do+ (`when` demandInput) =<< null <$> get+ (h,t) <- Textual.break_ False p <$> get+ when (null h && maybe True p (Textual.characterPrefix t)) $ fail "takeTillChar1"+ put t+ if null t+ then (h<>) <$> takeTillChar p+ else return h+{-# INLINE takeTillChar1 #-}++-- | Consume input as long as the predicate returns 'True', and return+-- the consumed input.+--+-- This parser does not fail. It will return an empty string if the+-- predicate returns 'False' on the first input token.+--+-- /Note/: Because this parser does not fail, do not use it with+-- combinators such as 'many', because such parsers loop until a+-- failure occurs. Careless use will thus result in an infinite loop.+takeWhile :: FactorialMonoid t => (t -> Bool) -> Parser t t+takeWhile p = go id+ where+ go acc = do+ (h,t) <- Factorial.span p <$> get+ put t+ if null t+ then do+ input <- wantMoreInput+ if input+ then go (acc . mappend h)+ else return (acc h)+ else return (acc h)+{-# INLINE takeWhile #-}++-- | Consume input characters as long as the predicate returns 'True', +-- and return the consumed input.+--+-- This parser does not fail. It will return an empty string if the+-- predicate returns 'False' on the first input token.+--+-- /Note/: Because this parser does not fail, do not use it with+-- combinators such as 'many', because such parsers loop until a+-- failure occurs. Careless use will thus result in an infinite loop.+takeCharsWhile :: TextualMonoid t => (Char -> Bool) -> Parser t t+takeCharsWhile p = {-# SCC takeCharsWhile #-} go id+ where+ go acc = do+ (h,t) <- Textual.span_ False p <$> get+ put t+ if null t+ then do+ input <- wantMoreInput+ if input+ then go (acc . mappend h)+ else return (acc h)+ else return (acc h)+{-# INLINE takeCharsWhile #-}++-- | Consume all remaining input and return it as a single string.+takeRest :: MonoidNull t => Parser t t+takeRest = go []+ where+ go acc = do+ input <- wantInput+ if input+ then do+ s <- get+ put mempty+ go (s:acc)+ else return (mconcat $ reverse acc)+{-# INLINABLE takeRest #-}++-- | Consume input as long as the predicate returns 'True', and return+-- the consumed input.+--+-- This parser requires the predicate to succeed on at least one input+-- token: it will fail if the predicate never returns 'True'+-- or if there is no input left.+takeWhile1 :: FactorialMonoid t => (t -> Bool) -> Parser t t+takeWhile1 p = do+ (`when` demandInput) =<< null <$> get+ (h,t) <- Factorial.span p <$> get+ when (null h) $ fail "takeWhile1"+ put t+ if null t+ then (h<>) `fmap` takeWhile p+ else return h+{-# INLINE takeWhile1 #-}++takeCharsWhile1 :: TextualMonoid t => (Char -> Bool) -> Parser t t+takeCharsWhile1 p = do+ (`when` demandInput) =<< null <$> get+ (h,t) <- Textual.span_ False p <$> get+ when (null h) $ fail "takeCharsWhile1"+ put t+ if null t+ then (h<>) `fmap` takeCharsWhile p+ else return h+{-# INLINE takeCharsWhile1 #-}++-- | A stateful scanner. The predicate consumes and transforms a+-- state argument, and each transformed state is passed to successive+-- invocations of the predicate on each token of the input until one+-- returns 'Nothing' or the input ends.+--+-- This parser does not fail. It will return an empty string if the+-- predicate returns 'Nothing' on the first prime input factor.+--+-- /Note/: Because this parser does not fail, do not use it with+-- combinators such as 'many', because such parsers loop until a+-- failure occurs. Careless use will thus result in an infinite loop.+scan :: FactorialMonoid t => s -> (s -> t -> Maybe s) -> Parser t t+scan s0 f = go s0 id+ where+ go s acc = do+ (h,t,s') <- Factorial.spanMaybe' s f <$> get+ put t+ if null t+ then do+ input <- wantMoreInput+ if input+ then go s' (acc . mappend h)+ else return (acc h)+ else return (acc h)+{-# INLINE scan #-}++-- | A stateful scanner. The predicate consumes and transforms a+-- state argument, and each transformed state is passed to successive+-- invocations of the predicate on each token of the input until one+-- returns 'Nothing' or the input ends.+--+-- This parser does not fail. It will return an empty string if the+-- predicate returns 'Nothing' on the first prime input factor.+--+-- /Note/: Because this parser does not fail, do not use it with+-- combinators such as 'many', because such parsers loop until a+-- failure occurs. Careless use will thus result in an infinite loop.+scanChars :: TextualMonoid t => s -> (s -> Char -> Maybe s) -> Parser t t+scanChars s0 fc = go s0 id+ where+ go s acc = do+ (h,t,s') <- Textual.spanMaybe_' s fc <$> get+ put t+ if null t+ then do+ input <- wantMoreInput+ if input+ then go s' (acc . mappend h)+ else return (acc h)+ else return (acc h)+{-# INLINE scanChars #-}++-- | Match any prime input token.+anyToken :: FactorialMonoid t => Parser t t+anyToken = satisfy $ const True+{-# INLINE anyToken #-}++-- | Match any prime input token. Returns 'mempty' if end of input+-- has been reached. Does not consume any input.+--+-- /Note/: Because this parser does not fail, do not use it with+-- combinators such as 'many', because such parsers loop until a+-- failure occurs. Careless use will thus result in an infinite loop.+peekToken :: FactorialMonoid t => Parser t t+peekToken = T.Parser $ \i0 a0 m0 _kf ks ->+ if null (unI i0)+ then if m0 == Complete+ then ks i0 a0 m0 mempty+ else let k' i a m = ks i a m $! Factorial.primePrefix (unI i)+ in prompt i0 a0 m0 k' k'+ else ks i0 a0 m0 $! Factorial.primePrefix (unI i0)+{-# INLINE peekToken #-}++-- | Match any character.+anyChar :: TextualMonoid t => Parser t Char+anyChar = satisfyChar $ const True+{-# INLINE anyChar #-}++-- | Match a specific character.+char :: TextualMonoid t => Char -> Parser t Char+char c = satisfyChar (== c) <?> show c+{-# INLINE char #-}++-- | Match any input character, if available. Does not consume any input.+--+-- /Note/: Because this parser does not fail, do not use it with+-- combinators such as 'many', because such parsers loop until a+-- failure occurs. Careless use will thus result in an infinite loop.+peekChar :: TextualMonoid t => Parser t (Maybe Char)+peekChar = T.Parser $ \i0 a0 m0 _kf ks ->+ if null (unI i0)+ then if m0 == Complete+ then ks i0 a0 m0 Nothing+ else let k' i a m = ks i a m $! Textual.characterPrefix (unI i)+ in prompt i0 a0 m0 k' k'+ else ks i0 a0 m0 $! Textual.characterPrefix (unI i0)+{-# INLINE peekChar #-}++-- | Match any input character, failing if the input doesn't start+-- with any. Does not consume any input.+peekChar' :: TextualMonoid t => Parser t Char+peekChar' = do+ s <- ensureOne+ case Textual.characterPrefix s + of Just c -> return c+ _ -> fail "peekChar'"+{-# INLINE peekChar' #-}++-- | Match either a single newline character @\'\\n\'@, or a carriage+-- return followed by a newline character @\"\\r\\n\"@.+endOfLine :: (Eq t, TextualMonoid t) => Parser t ()+endOfLine = (char '\n' >> return ()) <|> (string "\r\n" >> return ())++-- | Terminal failure continuation.+failK :: Failure t a+failK i0 _a0 _m0 stack msg = Fail (unI i0) stack msg+{-# INLINE failK #-}++-- | Terminal success continuation.+successK :: Success t a a+successK i0 _a0 _m0 a = Done (unI i0) a+{-# INLINE successK #-}++-- | Run a parser.+parse :: Monoid t => Parser t a -> t -> IResult t a+parse m s = T.runParser m (I s) mempty Incomplete failK successK+{-# INLINE parse #-}++-- | Run a parser that cannot be resupplied via a 'Partial' result.+parseOnly :: Monoid t => Parser t a -> t -> Either String a+parseOnly m s = case T.runParser m (I s) mempty Complete failK successK of+ Fail _ _ err -> Left err+ Done _ a -> Right a+ _ -> error "parseOnly: impossible error!"+{-# INLINE parseOnly #-}
+ Data/Picoparsec/Number.hs view
@@ -0,0 +1,275 @@+{-# LANGUAGE BangPatterns, DeriveDataTypeable, Haskell2010, OverloadedStrings #-}+-- |+-- Module : Data.Picoparsec.Number+-- Copyright : Bryan O'Sullivan 2011, Mario Blažević <blamario@yahoo.com> 2014+-- License : BSD3+--+-- Maintainer : Mario Blažević+-- Stability : experimental+-- Portability : unknown+--+-- A simple number type, useful for parsing both exact and inexact+-- quantities without losing much precision.+module Data.Picoparsec.Number (+ Number(..)++ -- * Numeric parsers+ , decimal+ , hexadecimal+ , signed+ , double+ , number+ , rational+ , scientific+ ) where++import Prelude hiding (length)++import Control.Applicative (pure, (*>), (<$>), (<|>))+import Control.DeepSeq (NFData(rnf))+import Control.Monad (void, when)+import Data.Monoid.Factorial (length)+import Data.Monoid.Textual (TextualMonoid, foldl_')+import Data.Bits (Bits, (.|.), shiftL)+import Data.Char (digitToInt, isDigit, isHexDigit, ord)+import Data.Data (Data)+import Data.Function (on)+import Data.Scientific (Scientific, coefficient, base10Exponent)+import qualified Data.Scientific as Sci (scientific)+import Data.Typeable (Typeable)+import GHC.Exts (inline)++import Data.Picoparsec (Parser, string)+import qualified Data.Picoparsec.Monoid.Internal as I++-- | A numeric type that can represent integers accurately, and+-- floating point numbers to the precision of a 'Double'.+data Number = I !Integer+ | D {-# UNPACK #-} !Double+ deriving (Typeable, Data)++instance Show Number where+ show (I a) = show a+ show (D a) = show a++instance NFData Number where+ rnf (I _) = ()+ rnf (D _) = ()+ {-# INLINE rnf #-}++binop :: (Integer -> Integer -> a) -> (Double -> Double -> a)+ -> Number -> Number -> a+binop _ d (D a) (D b) = d a b+binop i _ (I a) (I b) = i a b+binop _ d (D a) (I b) = d a (fromIntegral b)+binop _ d (I a) (D b) = d (fromIntegral a) b+{-# INLINE binop #-}++instance Eq Number where+ (==) = binop (==) (==)+ {-# INLINE (==) #-}++ (/=) = binop (/=) (/=)+ {-# INLINE (/=) #-}++instance Ord Number where+ (<) = binop (<) (<)+ {-# INLINE (<) #-}++ (<=) = binop (<=) (<=)+ {-# INLINE (<=) #-}++ (>) = binop (>) (>)+ {-# INLINE (>) #-}++ (>=) = binop (>=) (>=)+ {-# INLINE (>=) #-}++ compare = binop compare compare+ {-# INLINE compare #-}++instance Num Number where+ (+) = binop (((I$!).) . (+)) (((D$!).) . (+))+ {-# INLINE (+) #-}++ (-) = binop (((I$!).) . (-)) (((D$!).) . (-))+ {-# INLINE (-) #-}++ (*) = binop (((I$!).) . (*)) (((D$!).) . (*))+ {-# INLINE (*) #-}++ abs (I a) = I $! abs a+ abs (D a) = D $! abs a+ {-# INLINE abs #-}++ negate (I a) = I $! negate a+ negate (D a) = D $! negate a+ {-# INLINE negate #-}++ signum (I a) = I $! signum a+ signum (D a) = D $! signum a+ {-# INLINE signum #-}++ fromInteger = (I$!) . fromInteger+ {-# INLINE fromInteger #-}++instance Real Number where+ toRational (I a) = fromIntegral a+ toRational (D a) = toRational a+ {-# INLINE toRational #-}++instance Fractional Number where+ fromRational = (D$!) . fromRational+ {-# INLINE fromRational #-}++ (/) = binop (((D$!).) . (/) `on` fromIntegral)+ (((D$!).) . (/))+ {-# INLINE (/) #-}++ recip (I a) = D $! recip (fromIntegral a)+ recip (D a) = D $! recip a+ {-# INLINE recip #-}++instance RealFrac Number where+ properFraction (I a) = (fromIntegral a,0)+ properFraction (D a) = case properFraction a of+ (i,d) -> (i,D d)+ {-# INLINE properFraction #-}+ truncate (I a) = fromIntegral a+ truncate (D a) = truncate a+ {-# INLINE truncate #-}+ round (I a) = fromIntegral a+ round (D a) = round a+ {-# INLINE round #-}+ ceiling (I a) = fromIntegral a+ ceiling (D a) = ceiling a+ {-# INLINE ceiling #-}+ floor (I a) = fromIntegral a+ floor (D a) = floor a+ {-# INLINE floor #-}++-- | Parse and decode an unsigned hexadecimal number. The hex digits+-- @\'a\'@ through @\'f\'@ may be upper or lower case.+--+-- This parser does not accept a leading @\"0x\"@ string.+hexadecimal :: (TextualMonoid t, Integral a, Bits a) => Parser t a+hexadecimal = foldl_' step 0 <$> I.takeCharsWhile1 isHexDigit+ where step a c = (a `shiftL` 4) .|. fromIntegral (digitToInt c)+{-# INLINEABLE hexadecimal #-}++-- | Parse and decode an unsigned decimal number.+decimal :: (TextualMonoid t, Integral a) => Parser t a+decimal = foldl_' step 0 <$> I.takeCharsWhile1 isDigit+ where step a c = a * 10 + fromIntegral (digitToInt c)+{-# INLINEABLE decimal #-}++-- | Parse a number with an optional leading @\'+\'@ or @\'-\'@ sign+-- character.+signed :: (TextualMonoid t, Num a) => Parser t a -> Parser t a+{-# INLINEABLE signed #-}+signed p = (negate <$> (string "-" *> p))+ <|> (string "+" *> p)+ <|> p++-- | Parse a rational number.+--+-- This parser accepts an optional leading sign character, followed by+-- at least one decimal digit. The syntax similar to that accepted by+-- the 'read' function, with the exception that a trailing @\'.\'@ or+-- @\'e\'@ /not/ followed by a number is not consumed.+--+-- Examples with behaviour identical to 'read', if you feed an empty+-- continuation to the first result:+--+-- >rational "3" == Done 3.0 ""+-- >rational "3.1" == Done 3.1 ""+-- >rational "3e4" == Done 30000.0 ""+-- >rational "3.1e4" == Done 31000.0, ""+--+-- Examples with behaviour identical to 'read':+--+-- >rational ".3" == Fail "input does not start with a digit"+-- >rational "e3" == Fail "input does not start with a digit"+--+-- Examples of differences from 'read':+--+-- >rational "3.foo" == Done 3.0 ".foo"+-- >rational "3e" == Done 3.0 "e"+--+-- This function does not accept string representations of \"NaN\" or+-- \"Infinity\".+rational :: (TextualMonoid t, Fractional a) => Parser t a+rational = inline scientifically realToFrac+{-# INLINABLE rational #-}++-- | Parse a rational number.+--+-- The syntax accepted by this parser is the same as for 'rational'.+--+-- /Note/: This function is almost ten times faster than 'rational',+-- but is slightly less accurate.+--+-- The 'Double' type supports about 16 decimal places of accuracy.+-- For 94.2% of numbers, this function and 'rational' give identical+-- results, but for the remaining 5.8%, this function loses precision+-- around the 15th decimal place. For 0.001% of numbers, this+-- function will lose precision at the 13th or 14th decimal place.+--+-- This function does not accept string representations of \"NaN\" or+-- \"Infinity\".+double :: TextualMonoid t => Parser t Double+double = rational+{-# INLINE double #-}++-- | Parse a number, attempting to preserve both speed and precision.+--+-- The syntax accepted by this parser is the same as for 'rational'.+--+-- /Note/: This function is almost ten times faster than 'rational'.+-- On integral inputs, it gives perfectly accurate answers, and on+-- floating point inputs, it is slightly less accurate than+-- 'rational'.+--+-- This function does not accept string representations of \"NaN\" or+-- \"+number :: TextualMonoid t => Parser t Number+number = inline scientifically $ \s ->+ let e = base10Exponent s+ c = coefficient s+ in if e >= 0+ then I (c * 10 ^ e)+ else D (fromInteger c / 10 ^ negate e)+{-# INLINABLE number #-}++-- | Parse a scientific number.+--+-- The syntax accepted by this parser is the same as for 'rational'.+scientific :: TextualMonoid t => Parser t Scientific+scientific = inline scientifically id+{-# INLINABLE scientific #-}++scientifically :: TextualMonoid t => (Scientific -> a) -> Parser t a+scientifically h = do+ sign <- I.peekChar'+ let !positive = sign /= '-'+ when (sign == '+' || sign == '-') $+ void I.anyToken++ n <- decimal++ let f fracDigits = Sci.scientific (foldl_' step n fracDigits)+ (negate $ length fracDigits)+ step a c = a * 10 + fromIntegral (ord c - ord '0')++ dotty <- I.peekChar+ s <- case dotty of+ Just '.' -> I.anyToken *> (f <$> I.takeCharsWhile isDigit)+ _ -> pure (Sci.scientific n 0)++ let !signedCoeff | positive = coefficient s+ | otherwise = negate $ coefficient s++ (I.satisfyChar (\c -> c == 'e' || c == 'E') *>+ fmap (h . Sci.scientific signedCoeff . (base10Exponent s +)) (signed decimal)) <|>+ return (h $ Sci.scientific signedCoeff (base10Exponent s))+{-# INLINABLE scientifically #-}
+ Data/Picoparsec/State.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE Haskell2010 #-}+-- |+-- Module : Data.Picoparsec.Number+-- Copyright : Mario Blažević <blamario@yahoo.com> 2015+-- License : BSD3+--+-- Maintainer : Mario Blažević+-- Stability : experimental+-- Portability : unknown+--+-- This module provides the basic support for parsing state.+--+-- To support state, the parser input must be a 'Stateful' monoid. The parsing state thus becomes the final part of the+-- input, accessible and modifiable during the parse. Be careful to account for the presence of state before the+-- 'Data.Picoparsec.Combinator.endOfInput'! The following parser, for example, would loop forever:+--+-- > many (setState "more" *> anyToken)++module Data.Picoparsec.State (getState, putState, modifyState) where++import Data.Functor ((<$>))+import Data.Monoid.Instances.Stateful (Stateful)+import qualified Data.Monoid.Instances.Stateful as Stateful+import Data.Picoparsec (Parser)+import qualified Data.Picoparsec.Internal as I++-- | Returns the current user state.+getState :: Parser (Stateful s t) s+getState = Stateful.state <$> I.get++-- | Sets the current state.+putState :: s -> Parser (Stateful s t) ()+putState s = I.get >>= (I.put . Stateful.setState s)++-- | Modifies the current state.+modifyState :: (s -> s) -> Parser (Stateful s t) ()+modifyState f = I.get >>= \i-> I.put (Stateful.setState (f $ Stateful.state i) i)
+ Data/Picoparsec/Text/FastSet.hs view
@@ -0,0 +1,63 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Picoparsec.FastSet+-- Copyright : Felipe Lessa 2010, Bryan O'Sullivan 2008, Mario Blažević <blamario@yahoo.com> 2014+-- License : BSD3+--+-- Maintainer : Mario Blažević+-- Stability : experimental+-- Portability : unknown+--+-- Fast set membership tests for 'Char' values. The set+-- representation is unboxed for efficiency. We test for+-- membership using a binary search.+--+-----------------------------------------------------------------------------+module Data.Picoparsec.Text.FastSet+ (+ -- * Data type+ FastSet+ -- * Construction+ , fromList+ , set+ -- * Lookup+ , member+ -- * Handy interface+ , charClass+ ) where++import Data.List (sort)+import qualified Data.Array.Base as AB+import qualified Data.Array.Unboxed as A+import qualified Data.Text as T++newtype FastSet = FastSet (A.UArray Int Char)+ deriving (Eq, Ord, Show)++-- | Create a set.+set :: T.Text -> FastSet+set t = mkSet (T.length t) (sort $ T.unpack t)++fromList :: [Char] -> FastSet+fromList cs = mkSet (length cs) (sort cs)++mkSet :: Int -> [Char] -> FastSet+mkSet l = FastSet . A.listArray (0,l-1)++-- | Check the set for membership.+member :: Char -> FastSet -> Bool+member c (FastSet a) = uncurry search (A.bounds a)+ where search lo hi+ | hi < lo = False+ | otherwise =+ let mid = (lo + hi) `quot` 2+ in case compare c (AB.unsafeAt a mid) of+ GT -> search (mid + 1) hi+ LT -> search lo (mid - 1)+ _ -> True++charClass :: String -> FastSet+charClass = fromList . go+ where go (a:'-':b:xs) = [a..b] ++ go xs+ go (x:xs) = x : go xs+ go _ = ""
+ Data/Picoparsec/Types.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE Haskell2010 #-}+-- |+-- Module : Data.Picoparsec.Types+-- Copyright : Bryan O'Sullivan 2011, Mario Blažević <blamario@yahoo.com> 2014+-- License : BSD3+--+-- Maintainer : Mario Blažević+-- Stability : experimental+-- Portability : unknown+--+-- Simple, efficient parser combinators for strings, loosely based on+-- the Parsec library.++module Data.Picoparsec.Types+ (+ Parser+ , IResult(..)+ ) where++import Data.Picoparsec.Internal.Types (Parser(..), IResult(..))
+ Data/Picoparsec/Zepto.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE BangPatterns, Haskell2010, MagicHash, UnboxedTuples #-}++-- |+-- Module : Data.Picoparsec.Zepto+-- Copyright : Bryan O'Sullivan 2011, Mario Blažević <blamario@yahoo.com> 2014+-- License : BSD3+--+-- Maintainer : blamario@yahoo.com+-- Stability : experimental+-- Portability : unknown+--+-- A tiny, highly specialized combinator parser for monoidal inputs.+--+-- While the main Picoparsec module generally performs well, this+-- module is particularly fast for simple non-recursive loops that+-- should not normally result in failed parses.+--+-- /Warning/: on more complex inputs involving recursion or failure,+-- parsers based on this module may be as much as /ten times slower/+-- than regular Picoparsec! You should /only/ use this module when you+-- have benchmarks that prove that its use speeds your code up.+module Data.Picoparsec.Zepto+ (+ Parser+ , parse+ , atEnd+ , string+ , take+ , takeCharsWhile+ , takeWhile+ ) where++import Control.Applicative+import Control.Monad+import Data.Monoid.Cancellative (LeftReductiveMonoid(..))+import Data.Monoid.Null (MonoidNull(null))+import qualified Data.Monoid.Factorial as Factorial+import Data.Monoid.Factorial (FactorialMonoid)+import Data.Monoid.Textual (TextualMonoid)+import qualified Data.Monoid.Textual as Textual+import Prelude hiding (null, take, takeWhile)++data Result a = Fail String+ | OK !a++-- | A simple parser.+--+-- This monad is strict in its state, and the monadic bind operator+-- ('>>=') evaluates each result to weak head normal form before+-- passing it along.+newtype Parser t a = Parser {+ runParser :: t -> (# Result a, t #)+ }++instance Functor (Parser t) where+ fmap f m = Parser $ \s -> case runParser m s of+ (# OK a, s' #) -> (# OK (f a), s' #)+ (# Fail err, s' #) -> (# Fail err, s' #)+ {-# INLINE fmap #-}++instance Monad (Parser t) where+ return a = Parser $ \s -> (# OK a, s #)+ {-# INLINE return #-}++ m >>= k = Parser $ \s -> case runParser m s of+ (# OK a, s' #) -> runParser (k a) s'+ (# Fail err, s' #) -> (# Fail err, s' #)+ {-# INLINE (>>=) #-}++ fail msg = Parser $ \s -> (# Fail msg, s #)++instance MonadPlus (Parser t) where+ mzero = fail "mzero"+ {-# INLINE mzero #-}++ mplus a b = Parser $ \s ->+ case runParser a s of+ (# ok@(OK _), s' #) -> (# ok, s' #)+ (# _, _ #) -> case runParser b s of+ (# ok@(OK _), s'' #) -> (# ok, s'' #)+ (# err, s'' #) -> (# err, s'' #)+ {-# INLINE mplus #-}++instance Applicative (Parser t) where+ pure = return+ {-# INLINE pure #-}+ (<*>) = ap+ {-# INLINE (<*>) #-}++gets :: (t -> a) -> Parser t a+gets f = Parser $ \s -> (# OK (f s), s #)+{-# INLINE gets #-}++put :: t -> Parser t ()+put s = Parser $ \_ -> (# OK (), s #)+{-# INLINE put #-}++-- | Run a parser.+parse :: Parser t a -> t -> Either String a+parse p s = case runParser p s of+ (# OK a, _ #) -> Right a+ (# Fail err, _ #) -> Left err++instance Alternative (Parser t) where+ empty = fail "empty"+ {-# INLINE empty #-}+ (<|>) = mplus+ {-# INLINE (<|>) #-}++-- | Consume input while the predicate returns 'True'.+takeWhile :: FactorialMonoid t => (t -> Bool) -> Parser t t+takeWhile p = do+ (h,t) <- gets (Factorial.span p)+ put t+ return h+{-# INLINE takeWhile #-}++-- | Consume input while the predicate returns 'True'.+takeCharsWhile :: TextualMonoid t => (Char -> Bool) -> Parser t t+takeCharsWhile p = do+ (h,t) <- gets (Textual.span_ False p)+ put t+ return h+{-# INLINE takeCharsWhile #-}++-- | Consume @n@ prime tokens of input.+take :: FactorialMonoid t => Int -> Parser t t+take !n = do+ s <- gets id+ if Factorial.length s >= n+ then put (Factorial.drop n s) >> return (Factorial.take n s)+ else fail "insufficient input"+{-# INLINE take #-}++-- | Match a string exactly.+string :: LeftReductiveMonoid t => t -> Parser t ()+string s = do+ i <- gets id+ case stripPrefix s i+ of Just suffix -> put suffix >> return ()+ Nothing -> fail "string"+{-# INLINE string #-}++-- | Indicate whether the end of the input has been reached.+atEnd :: MonoidNull t => Parser t Bool+atEnd = do+ i <- gets id+ return $! null i+{-# INLINE atEnd #-}
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) Lennart Kolmodin++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README.markdown view
@@ -0,0 +1,20 @@+# Welcome to picoparsec++Picoparsec is a fast and flexible parser combinator library, accepting any input type that is an instance of an+ appropriate monoid subclass.++# Join in!++I'm happy to receive bug reports, fixes, documentation enhancements,+and other improvements.++Please report bugs via the+[Mercurial repository](https://bitbucket.org/blamario/picoparsec):++* `hg clone https://bitbucket.org/blamario/picoparsec`++Authors+-------++This library is a fork of attoparsec written and maintained by Bryan+O'Sullivan, <bos@serpentine.com>.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ benchmarks/Alternative.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE OverloadedStrings #-}++-- This benchmark reveals a huge performance regression that showed up+-- under GHC 7.8.1 (https://github.com/bos/attoparsec/issues/56).+--+-- With GHC 7.6.3 and older, this program runs in 0.04 seconds. Under+-- GHC 7.8.1 with (<|>) inlined, time jumps to 12 seconds!++import Control.Applicative+import Data.Text (Text)+import qualified Data.Attoparsec.Text as A+import qualified Data.Text as T++testParser :: Text -> Either String Int+testParser f = fmap length -- avoid printing out the entire matched list+ . A.parseOnly (many ((() <$ A.string "b") <|> (() <$ A.anyChar)))+ $ f++main :: IO ()+main = print . testParser $ T.replicate 50000 "a"
+ benchmarks/AttoAeson.hs view
@@ -0,0 +1,348 @@+{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}++module AttoAeson+ (+ aeson+ , value'+ ) where++import Data.ByteString.Builder+ (Builder, byteString, toLazyByteString, charUtf8, word8)++import Control.Applicative ((*>), (<$>), (<*), liftA2, pure)+import Control.DeepSeq (NFData(..))+import Control.Monad (forM)+import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific,+ skipSpace, string)+import Data.Bits ((.|.), shiftL)+import Data.ByteString (ByteString)+import Data.Char (chr)+import Data.List (sort)+import Data.Monoid (mappend, mempty)+import Data.Scientific (Scientific)+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8')+import Data.Vector as Vector (Vector, foldl', fromList)+import Data.Word (Word8)+import System.Directory (getDirectoryContents)+import System.FilePath ((</>), dropExtension)+import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.Lazy as L+import qualified Data.Attoparsec.Zepto as Z+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Unsafe as B+import qualified Data.HashMap.Strict as H+import Criterion.Main++#define BACKSLASH 92+#define CLOSE_CURLY 125+#define CLOSE_SQUARE 93+#define COMMA 44+#define DOUBLE_QUOTE 34+#define OPEN_CURLY 123+#define OPEN_SQUARE 91+#define C_0 48+#define C_9 57+#define C_A 65+#define C_F 70+#define C_a 97+#define C_f 102+#define C_n 110+#define C_t 116++data Result a = Error String+ | Success a+ deriving (Eq, Show)+++-- | A JSON \"object\" (key\/value map).+type Object = H.HashMap Text Value++-- | A JSON \"array\" (sequence).+type Array = Vector Value++-- | A JSON value represented as a Haskell value.+data Value = Object !Object+ | Array !Array+ | String !Text+ | Number !Scientific+ | Bool !Bool+ | Null+ deriving (Eq, Show)++instance NFData Value where+ rnf (Object o) = rnf o+ rnf (Array a) = Vector.foldl' (\x y -> rnf y `seq` x) () a+ rnf (String s) = rnf s+ rnf (Number n) = rnf n+ rnf (Bool b) = rnf b+ rnf Null = ()++-- | Parse a top-level JSON value. This must be either an object or+-- an array, per RFC 4627.+--+-- The conversion of a parsed value to a Haskell value is deferred+-- until the Haskell value is needed. This may improve performance if+-- only a subset of the results of conversions are needed, but at a+-- cost in thunk allocation.+json :: Parser Value+json = json_ object_ array_++-- | Parse a top-level JSON value. This must be either an object or+-- an array, per RFC 4627.+--+-- This is a strict version of 'json' which avoids building up thunks+-- during parsing; it performs all conversions immediately. Prefer+-- this version if most of the JSON data needs to be accessed.+json' :: Parser Value+json' = json_ object_' array_'++json_ :: Parser Value -> Parser Value -> Parser Value+json_ obj ary = do+ w <- skipSpace *> A.satisfy (\w -> w == OPEN_CURLY || w == OPEN_SQUARE)+ if w == OPEN_CURLY+ then obj+ else ary+{-# INLINE json_ #-}++object_ :: Parser Value+object_ = {-# SCC "object_" #-} Object <$> objectValues jstring value++object_' :: Parser Value+object_' = {-# SCC "object_'" #-} do+ !vals <- objectValues jstring' value'+ return (Object vals)+ where+ jstring' = do+ !s <- jstring+ return s++objectValues :: Parser Text -> Parser Value -> Parser (H.HashMap Text Value)+objectValues str val = do+ skipSpace+ let pair = liftA2 (,) (str <* skipSpace) (char ':' *> skipSpace *> val)+ H.fromList <$> commaSeparated pair CLOSE_CURLY+{-# INLINE objectValues #-}++array_ :: Parser Value+array_ = {-# SCC "array_" #-} Array <$> arrayValues value++array_' :: Parser Value+array_' = {-# SCC "array_'" #-} do+ !vals <- arrayValues value'+ return (Array vals)++commaSeparated :: Parser a -> Word8 -> Parser [a]+commaSeparated item endByte = do+ w <- A.peekWord8'+ if w == endByte+ then A.anyWord8 >> return []+ else loop+ where+ loop = do+ v <- item <* skipSpace+ ch <- A.satisfy $ \w -> w == COMMA || w == endByte+ if ch == COMMA+ then skipSpace >> (v:) <$> loop+ else return [v]+{-# INLINE commaSeparated #-}++arrayValues :: Parser Value -> Parser (Vector Value)+arrayValues val = do+ skipSpace+ Vector.fromList <$> commaSeparated val CLOSE_SQUARE+{-# INLINE arrayValues #-}++-- | Parse any JSON value. You should usually 'json' in preference to+-- this function, as this function relaxes the object-or-array+-- requirement of RFC 4627.+--+-- In particular, be careful in using this function if you think your+-- code might interoperate with Javascript. A naïve Javascript+-- library that parses JSON data using @eval@ is vulnerable to attack+-- unless the encoded data represents an object or an array. JSON+-- implementations in other languages conform to that same restriction+-- to preserve interoperability and security.+value :: Parser Value+value = do+ w <- A.peekWord8'+ case w of+ DOUBLE_QUOTE -> A.anyWord8 *> (String <$> jstring_)+ OPEN_CURLY -> A.anyWord8 *> object_+ OPEN_SQUARE -> A.anyWord8 *> array_+ C_f -> string "false" *> pure (Bool False)+ C_t -> string "true" *> pure (Bool True)+ C_n -> string "null" *> pure Null+ _ | w >= 48 && w <= 57 || w == 45+ -> Number <$> scientific+ | otherwise -> fail "not a valid json value"++-- | Strict version of 'value'. See also 'json''.+value' :: Parser Value+value' = do+ w <- A.peekWord8'+ case w of+ DOUBLE_QUOTE -> do+ !s <- A.anyWord8 *> jstring_+ return (String s)+ OPEN_CURLY -> A.anyWord8 *> object_'+ OPEN_SQUARE -> A.anyWord8 *> array_'+ C_f -> string "false" *> pure (Bool False)+ C_t -> string "true" *> pure (Bool True)+ C_n -> string "null" *> pure Null+ _ | w >= 48 && w <= 57 || w == 45+ -> do+ !n <- scientific+ return (Number n)+ | otherwise -> fail "not a valid json value"++-- | Parse a quoted JSON string.+jstring :: Parser Text+jstring = A.word8 DOUBLE_QUOTE *> jstring_++-- | Parse a string without a leading quote.+jstring_ :: Parser Text+jstring_ = {-# SCC "jstring_" #-} do+ s <- A.scan False $ \s c -> if s then Just False+ else if c == DOUBLE_QUOTE+ then Nothing+ else Just (c == BACKSLASH)+ _ <- A.word8 DOUBLE_QUOTE+ s1 <- if BACKSLASH `B.elem` s+ then case Z.parse unescape s of+ Right r -> return r+ Left err -> fail err+ else return s++ case decodeUtf8' s1 of+ Right r -> return r+ Left err -> fail $ show err++{-# INLINE jstring_ #-}++unescape :: Z.Parser ByteString+unescape = toByteString <$> go mempty where+ go acc = do+ h <- Z.takeWhile (/=BACKSLASH)+ let rest = do+ start <- Z.take 2+ let !slash = B.unsafeHead start+ !t = B.unsafeIndex start 1+ escape = case B.findIndex (==t) "\"\\/ntbrfu" of+ Just i -> i+ _ -> 255+ if slash /= BACKSLASH || escape == 255+ then fail "invalid JSON escape sequence"+ else do+ let cont m = go (acc `mappend` byteString h `mappend` m)+ {-# INLINE cont #-}+ if t /= 117 -- 'u'+ then cont (word8 (B.unsafeIndex mapping escape))+ else do+ a <- hexQuad+ if a < 0xd800 || a > 0xdfff+ then cont (charUtf8 (chr a))+ else do+ b <- Z.string "\\u" *> hexQuad+ if a <= 0xdbff && b >= 0xdc00 && b <= 0xdfff+ then let !c = ((a - 0xd800) `shiftL` 10) ++ (b - 0xdc00) + 0x10000+ in cont (charUtf8 (chr c))+ else fail "invalid UTF-16 surrogates"+ done <- Z.atEnd+ if done+ then return (acc `mappend` byteString h)+ else rest+ mapping = "\"\\/\n\t\b\r\f"++hexQuad :: Z.Parser Int+hexQuad = do+ s <- Z.take 4+ let hex n | w >= C_0 && w <= C_9 = w - C_0+ | w >= C_a && w <= C_f = w - 87+ | w >= C_A && w <= C_F = w - 55+ | otherwise = 255+ where w = fromIntegral $ B.unsafeIndex s n+ a = hex 0; b = hex 1; c = hex 2; d = hex 3+ if (a .|. b .|. c .|. d) /= 255+ then return $! d .|. (c `shiftL` 4) .|. (b `shiftL` 8) .|. (a `shiftL` 12)+ else fail "invalid hex escape"++decodeWith :: Parser Value -> (Value -> Result a) -> L.ByteString -> Maybe a+decodeWith p to s =+ case L.parse p s of+ L.Done _ v -> case to v of+ Success a -> Just a+ _ -> Nothing+ _ -> Nothing+{-# INLINE decodeWith #-}++decodeStrictWith :: Parser Value -> (Value -> Result a) -> B.ByteString+ -> Maybe a+decodeStrictWith p to s =+ case either Error to (A.parseOnly p s) of+ Success a -> Just a+ Error _ -> Nothing+{-# INLINE decodeStrictWith #-}++eitherDecodeWith :: Parser Value -> (Value -> Result a) -> L.ByteString+ -> Either String a+eitherDecodeWith p to s =+ case L.parse p s of+ L.Done _ v -> case to v of+ Success a -> Right a+ Error msg -> Left msg+ L.Fail _ _ msg -> Left msg+{-# INLINE eitherDecodeWith #-}++eitherDecodeStrictWith :: Parser Value -> (Value -> Result a) -> B.ByteString+ -> Either String a+eitherDecodeStrictWith p to s =+ case either Error to (A.parseOnly p s) of+ Success a -> Right a+ Error msg -> Left msg+{-# INLINE eitherDecodeStrictWith #-}++-- $lazy+--+-- The 'json' and 'value' parsers decouple identification from+-- conversion. Identification occurs immediately (so that an invalid+-- JSON document can be rejected as early as possible), but conversion+-- to a Haskell value is deferred until that value is needed.+--+-- This decoupling can be time-efficient if only a smallish subset of+-- elements in a JSON value need to be inspected, since the cost of+-- conversion is zero for uninspected elements. The trade off is an+-- increase in memory usage, due to allocation of thunks for values+-- that have not yet been converted.++-- $strict+--+-- The 'json'' and 'value'' parsers combine identification with+-- conversion. They consume more CPU cycles up front, but have a+-- smaller memory footprint.++-- | Parse a top-level JSON value followed by optional whitespace and+-- end-of-input. See also: 'json'.+jsonEOF :: Parser Value+jsonEOF = json <* skipSpace <* endOfInput++-- | Parse a top-level JSON value followed by optional whitespace and+-- end-of-input. See also: 'json''.+jsonEOF' :: Parser Value+jsonEOF' = json' <* skipSpace <* endOfInput++toByteString :: Builder -> ByteString+toByteString = L.toStrict . toLazyByteString+{-# INLINE toByteString #-}++aeson :: IO Benchmark+aeson = do+ let path = "json-data"+ names <- sort . filter (`notElem` [".", ".."]) <$> getDirectoryContents path+ benches <- forM names $ \name -> do+ bs <- B.readFile (path </> name)+ return . bench (dropExtension name) $ nf (A.parseOnly jsonEOF') bs+ return $ bgroup "aeson" benches
+ benchmarks/Benchmarks.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE BangPatterns, CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++import Control.Applicative (many)+import Control.DeepSeq (NFData(rnf))+import Criterion.Main (bench, bgroup, defaultMain, nf)+import Data.Bits+import Data.Char (isAlpha)+import Data.Functor ((<$>))+import Data.Word (Word32)+import Data.Word (Word8)+import Numbers (numbers)+import Text.Parsec.Text ()+import Text.Parsec.Text.Lazy ()+import qualified AttoAeson+import qualified PicoAeson+import qualified Data.Attoparsec.ByteString as AB+import qualified Data.Attoparsec.ByteString.Char8 as AC+import qualified Data.Attoparsec.ByteString.Lazy as ABL+import qualified Data.Attoparsec.Text as AT+import qualified Data.Attoparsec.Text.Lazy as ATL+import qualified Data.Picoparsec as AM+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BLC+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified HeadersByteString+import qualified HeadersText+import qualified Links+import qualified Text.Parsec as P++import qualified Data.Monoid.Instances.ByteString.UTF8 as UTF8+import Data.Monoid.Instances.ByteString.Char8 ()++#if !MIN_VERSION_bytestring(0,10,0)+import Data.ByteString.Internal (ByteString(..))+instance NFData ByteString where+ rnf (PS _ _ _) = ()+#endif++instance NFData P.ParseError where+ rnf = rnf . show++chunksOf :: Int -> [a] -> [[a]]+chunksOf k = go+ where go xs = case splitAt k xs of+ ([],_) -> []+ (y, ys) -> y : go ys++main :: IO ()+main = do+ let s = take 1024 . cycle $ ['a'..'z'] ++ ['A'..'Z']+ !b = BC.pack s+ !bl = BL.fromChunks . map BC.pack . chunksOf 4 $ s+ !t = T.pack s+ !tl = TL.fromChunks . map T.pack . chunksOf 4 $ s+ !utf8b = UTF8.ByteStringUTF8 b+ aesonA <- AttoAeson.aeson+ aesonP <- PicoAeson.aeson+ headersBS <- HeadersByteString.headers+ headersT <- HeadersText.headers+ defaultMain [+ bgroup "many" [+ bgroup "attoparsec" [+ bench "B" $ nf (AB.parse (many (AC.satisfy AC.isAlpha_ascii))) b+ , bench "BL" $ nf (ABL.parse (many (AC.satisfy AC.isAlpha_ascii))) bl+ , bench "T" $ nf (AT.parse (many (AT.satisfy AC.isAlpha_ascii))) t+ , bench "TL" $ nf (ATL.parse (many (AT.satisfy AC.isAlpha_ascii))) tl+ ]+ , bgroup "picoparsec" [+ bench "S" $ nf (AM.parse (many (AM.satisfyChar isAlpha))) s+ , bench "B" $ nf (AM.parse (many (AM.satisfy (isAlpha . BC.head)))) b+ , bench "BL" $ nf (AM.parse (many (AM.satisfy (isAlpha . BLC.head)))) bl+ , bench "T" $ nf (AM.parse (many (AM.satisfyChar AC.isAlpha_ascii))) t+ , bench "TL" $ nf (AM.parse (many (AM.satisfyChar AC.isAlpha_ascii))) tl+ ]+ , bgroup "parsec" [+ bench "S" $ nf (P.parse (many (P.satisfy AC.isAlpha_ascii)) "") s+ , bench "B" $ nf (P.parse (many (P.satisfy AC.isAlpha_ascii)) "") b+ , bench "BL" $ nf (P.parse (many (P.satisfy AC.isAlpha_ascii)) "") bl+ , bench "T" $ nf (P.parse (many (P.satisfy AC.isAlpha_ascii)) "") t+ , bench "TL" $ nf (P.parse (many (P.satisfy AC.isAlpha_ascii)) "") tl+ ]+ ]+ , bgroup "comparison" [+ bgroup "many-vs-takeWhile" [+ bgroup "attoparsec" [+ bench "many" $ nf (AB.parse (many (AC.satisfy AC.isAlpha_ascii))) b+ , bench "takeWhile" $ nf (AB.parse (AC.takeWhile AC.isAlpha_ascii)) b+ ]+ , bgroup "picoparsec" [+ bgroup "UTF8" [+ bench "many" $ nf (AM.parse (many (AM.satisfyChar AC.isAlpha_ascii))) utf8b+ , bench "takeWhile" $ nf (AM.parse (AM.takeCharsWhile AC.isAlpha_ascii)) utf8b+ ]+ , bgroup "Char8" [+ bench "many" $ nf (AM.parse (many (AM.satisfyChar AC.isAlpha_ascii))) b+ , bench "takeWhile" $ nf (AM.parse (AM.takeCharsWhile AC.isAlpha_ascii)) b+ ]+ ]+ ]+ , bgroup "letter-vs-isAlpha" [+ bgroup "attoparsec" [+ bench "letter" $ nf (AB.parse (many AC.letter_ascii)) b+ , bench "isAlpha" $ nf (AB.parse (many (AC.satisfy AC.isAlpha_ascii))) b+ ]+ , bgroup "picoparsec" [+ bench "letter" $ nf (AM.parse (AM.takeCharsWhile AC.isAlpha_ascii)) b+ , bench "isAlpha" $ nf (AM.parse (many (AM.satisfyChar isAlpha))) utf8b+ ]+ ]+ ]+ , bgroup "takeWhile" [+ bgroup "attoparsec" [+ bench "isAlpha" $ nf (ABL.parse (AC.takeWhile isAlpha)) bl+ , bench "isAlpha_ascii" $ nf (ABL.parse (AC.takeWhile AC.isAlpha_ascii)) bl+ , bench "isAlpha_iso8859_15" $ nf (ABL.parse (AC.takeWhile AC.isAlpha_iso8859_15)) bl+ ]+ , bgroup "picoparsec" [+ bgroup "UTF8" [+ bench "isAlpha" $ nf (AM.parse (AM.takeCharsWhile isAlpha)) utf8b+ , bench "isAlpha_ascii" $ nf (AM.parse (AM.takeCharsWhile AC.isAlpha_ascii)) utf8b+ , bench "isAlpha_iso8859_15" $ nf (AM.parse (AM.takeCharsWhile AC.isAlpha_iso8859_15)) utf8b+ ]+ , bgroup "Char8" [+ bench "isAlpha" $ nf (AM.parse (AM.takeCharsWhile isAlpha)) b+ , bench "isAlpha_ascii" $ nf (AM.parse (AM.takeCharsWhile AC.isAlpha_ascii)) b+ , bench "isAlpha_iso8859_15" $ nf (AM.parse (AM.takeCharsWhile AC.isAlpha_iso8859_15)) b+ ]+ ]+ ]+ , bgroup "word32LE" [+ bench "attoparsec" $ nf (AB.parse word32LE) b+ , bench "picoparsec" $ nf (AM.parse word32LE') b+ ]+ , bgroup "scan" [+ bench "short" $ nf (AB.parse quotedString) (BC.pack "abcdefghijk\"")+ , bench "long" $ nf (AB.parse quotedString) b+ ]+ , aesonA+ , aesonP+ , headersBS+ , headersT+ , Links.links+ , numbers+ ]++-- Benchmarks bind and (potential) bounds-check merging.+word32LE :: AB.Parser Word32+word32LE = do+ w1 <- AB.anyWord8+ w2 <- AB.anyWord8+ w3 <- AB.anyWord8+ w4 <- AB.anyWord8+ return $! (fromIntegral w1 :: Word32) ++ fromIntegral w2 `unsafeShiftL` 8 ++ fromIntegral w3 `unsafeShiftL` 16 ++ fromIntegral w4 `unsafeShiftL` 32++word32LE' :: AM.Parser B.ByteString Word32+word32LE' = do+ w1 <- B.head <$> AM.anyToken+ w2 <- B.head <$> AM.anyToken+ w3 <- B.head <$> AM.anyToken+ w4 <- B.head <$> AM.anyToken+ return $! (fromIntegral w1 :: Word32) ++ fromIntegral w2 `unsafeShiftL` 8 ++ fromIntegral w3 `unsafeShiftL` 16 ++ fromIntegral w4 `unsafeShiftL` 32++doubleQuote, backslash :: Word8+doubleQuote = 34+backslash = 92+{-# INLINE backslash #-}+{-# INLINE doubleQuote #-}++-- | Parse a string without a leading quote.+quotedString :: AB.Parser B.ByteString+quotedString = AB.scan False $ \s c -> if s then Just False+ else if c == doubleQuote+ then Nothing+ else Just (c == backslash)++#if !MIN_VERSION_base(4,5,0)+unsafeShiftL :: Bits a => a -> Int -> a+unsafeShiftL = shiftL+#endif
+ benchmarks/Data/Monoid/Instances/ByteString/Char8.hs view
@@ -0,0 +1,49 @@+{- + Copyright 2014 Mario Blazevic++ License: BSD3 (see BSD3-LICENSE.txt file)+-}++-- | This module defines the 'ByteStringUTF8' newtype wrapper around 'ByteString', together with its 'TextualMonoid'+-- instance.+-- ++{-# LANGUAGE BangPatterns #-}++module Data.Monoid.Instances.ByteString.Char8 () where++import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as ByteString.Char8+import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as B+import qualified Data.ByteString.Unsafe as B++import Data.Monoid.Textual (TextualMonoid(..))++instance TextualMonoid ByteString where+ singleton = ByteString.Char8.singleton+ splitCharacterPrefix bs = ByteString.Char8.uncons bs+ foldl _ft fc a0 bs = ByteString.Char8.foldl fc a0 bs+ foldl' _ft fc a0 bs = ByteString.Char8.foldl' fc a0 bs+ {-# INLINE foldl' #-}+ foldr _ft fc a0 bs = ByteString.Char8.foldr fc a0 bs+ {-# INLINE foldr #-}+ dropWhile _pt pc bs = ByteString.Char8.dropWhile pc bs+ {-# INLINE dropWhile #-}+ takeWhile _pt pc bs = ByteString.Char8.takeWhile pc bs+ {-# INLINE takeWhile #-}+ span _pt pc bs = ByteString.Char8.span pc bs+ {-# INLINE span #-}+ break _pt pc bs = ByteString.Char8.break pc bs+ {-# INLINE break #-}+ spanMaybe s0 _fb fc bs =+ let inner !i !s+ | i < len =+ case fc s (B.w2c $ B.unsafeIndex bs i)+ of Just s' -> inner (i + 1) s'+ _ -> done i s+ | otherwise = done i s+ done !i !s = (B.unsafeTake i bs, B.unsafeDrop i bs, s)+ !len = B.length bs+ in inner 0 s0+ {-# INLINE spanMaybe #-}
+ benchmarks/HeadersByteString.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module HeadersByteString (headers) where++import Control.Applicative+import Criterion.Main (bench, bgroup, nf)+import Criterion.Types (Benchmark)+import qualified Data.Attoparsec.ByteString.Char8 as B+import qualified Data.ByteString.Char8 as B++header = do+ name <- B.takeWhile1 (B.inClass "a-zA-Z0-9_-") <* B.char ':' <* B.skipSpace+ body <- (:) <$> bodyLine <*> many (B.takeWhile1 B.isSpace *> bodyLine)+ return (name, body)++bodyLine = B.takeTill (\c -> c == '\r' || c == '\n') <* B.endOfLine++requestLine =+ (,,) <$>+ (method <* B.skipSpace) <*>+ (B.takeTill B.isSpace <* B.skipSpace) <*>+ httpVersion+ where method = "GET" <|> "POST"++httpVersion = "HTTP/" *> ((,) <$> (int <* B.char '.') <*> int)++responseLine = (,,) <$>+ (httpVersion <* B.skipSpace) <*>+ (int <* B.skipSpace) <*>+ bodyLine++int :: B.Parser Int+int = B.decimal++request = (,) <$> (requestLine <* B.endOfLine) <*> many header++response = (,) <$> responseLine <*> many header++headers :: IO Benchmark+headers = do+ req <- B.readFile "http-request.txt"+ resp <- B.readFile "http-response.txt"+ return $ bgroup "headersBS" [+ bench "request" $ nf (B.parseOnly request) req+ , bench "response" $ nf (B.parseOnly response) resp+ ]
+ benchmarks/HeadersText.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module HeadersText (headers) where++import Control.Applicative+import Criterion.Main (bench, bgroup, nf)+import Criterion.Types (Benchmark)+import Data.Char (isSpace)+import qualified Data.Attoparsec.Text as T+import qualified Data.Text.IO as T++header = do+ name <- T.takeWhile1 (T.inClass "a-zA-Z0-9_-") <* T.char ':' <* T.skipSpace+ body <- (:) <$> bodyLine <*> many (T.takeWhile1 isSpace *> bodyLine)+ return (name, body)++bodyLine = T.takeTill (\c -> c == '\r' || c == '\n') <* T.endOfLine++requestLine =+ (,,) <$>+ (method <* T.skipSpace) <*>+ (T.takeTill isSpace <* T.skipSpace) <*>+ httpVersion+ where method = "GET" <|> "POST"++httpVersion = "HTTP/" *> ((,) <$> (int <* T.char '.') <*> int)++responseLine = (,,) <$>+ (httpVersion <* T.skipSpace) <*>+ (int <* T.skipSpace) <*>+ bodyLine++int :: T.Parser Int+int = T.decimal++request = (,) <$> (requestLine <* T.endOfLine) <*> many header++response = (,) <$> responseLine <*> many header++headers :: IO Benchmark+headers = do+ req <- T.readFile "http-request.txt"+ resp <- T.readFile "http-response.txt"+ return $ bgroup "headersT" [+ bench "request" $ nf (T.parseOnly request) req+ , bench "response" $ nf (T.parseOnly response) resp+ ]
+ benchmarks/IsSpace.hs view
@@ -0,0 +1,123 @@+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}+{-# LANGUAGE ForeignFunctionInterface #-}+----------------------------------------------------------------+-- 2010.10.09+-- |+-- Module : IsSpace+-- Copyright : Copyright (c) 2010 wren ng thornton+-- License : BSD+-- Maintainer : wren@community.haskell.org+-- Stability : experimental+-- Portability : portable (FFI)+--+-- A benchmark for comparing different definitions of predicates+-- for detecting whitespace. As of the last run the results are:+-- +-- * Data.Char.isSpace : 14.44786 us +/- 258.0377 ns+-- * isSpace_DataChar : 43.25154 us +/- 655.7037 ns+-- * isSpace_Char : 29.26598 us +/- 454.1445 ns+-- * isPerlSpace :+-- * Data.Attoparsec.Char8.isSpace : 81.87335 us +/- 1.195903 us+-- * isSpace_Char8 : 11.84677 us +/- 178.9795 ns+-- * isSpace_w8 : 11.55470 us +/- 133.7644 ns+----------------------------------------------------------------+module IsSpace (main) where++import qualified Data.Char as C+import Data.Word (Word8)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import Foreign.C.Types (CInt)++import Criterion (bench, nf)+import Criterion.Main (defaultMain)++----------------------------------------------------------------+----- Character predicates+-- N.B. \x9..\xD == "\t\n\v\f\r"++-- | Recognize the same characters as Perl's @/\s/@ in Unicode mode.+-- In particular, we recognize POSIX 1003.2 @[[:space:]]@ except+-- @\'\v\'@, and recognize the Unicode @\'\x85\'@, @\'\x2028\'@,+-- @\'\x2029\'@. Notably, @\'\x85\'@ belongs to Latin-1 (but not+-- ASCII) and therefore does not belong to POSIX 1003.2 @[[:space:]]@+-- (nor non-Unicode @/\s/@).+isPerlSpace :: Char -> Bool+isPerlSpace c+ = (' ' == c)+ || ('\t' <= c && c <= '\r' && c /= '\v')+ || ('\x85' == c)+ || ('\x2028' == c)+ || ('\x2029' == c)+{-# INLINE isPerlSpace #-}+++-- | 'Data.Attoparsec.Char8.isSpace', duplicated here because it's+-- not exported. This is the definition as of attoparsec-0.8.1.0.+isSpace :: Char -> Bool+isSpace c = c `B8.elem` spaces+ where+ spaces = B8.pack " \n\r\t\v\f"+ {-# NOINLINE spaces #-}+{-# INLINE isSpace #-}+++-- | An alternate version of 'Data.Attoparsec.Char8.isSpace'.+isSpace_Char8 :: Char -> Bool+isSpace_Char8 c = (' ' == c) || ('\t' <= c && c <= '\r')+{-# INLINE isSpace_Char8 #-}+++-- | An alternate version of 'Data.Char.isSpace'. This uses the+-- same trick as 'isSpace_Char8' but we include Unicode whitespaces+-- too, in order to have the same results as 'Data.Char.isSpace'+-- (whereas 'isSpace_Char8' doesn't recognize Unicode whitespace).+isSpace_Char :: Char -> Bool+isSpace_Char c+ = (' ' == c)+ || ('\t' <= c && c <= '\r')+ || ('\xA0' == c)+ || (iswspace (fromIntegral (C.ord c)) /= 0)+{-# INLINE isSpace_Char #-}++foreign import ccall unsafe "u_iswspace"+ iswspace :: CInt -> CInt++-- | Verbatim version of 'Data.Char.isSpace' (i.e., 'GHC.Unicode.isSpace'+-- as of base-4.2.0.2) in order to try to figure out why 'isSpace_Char'+-- is slower than 'Data.Char.isSpace'. It appears to be something+-- special in how the base library was compiled.+isSpace_DataChar :: Char -> Bool+isSpace_DataChar c =+ c == ' ' ||+ c == '\t' ||+ c == '\n' ||+ c == '\r' ||+ c == '\f' ||+ c == '\v' ||+ c == '\xa0' ||+ iswspace (fromIntegral (C.ord c)) /= 0+{-# INLINE isSpace_DataChar #-}+++-- | A 'Word8' version of 'Data.Attoparsec.Char8.isSpace'.+isSpace_w8 :: Word8 -> Bool+isSpace_w8 w = (w == 32) || (9 <= w && w <= 13)+{-# INLINE isSpace_w8 #-}++----------------------------------------------------------------++main :: IO ()+main = defaultMain+ [ bench "Data.Char.isSpace" $ nf (map C.isSpace) ['\x0'..'\255']+ , bench "isSpace_DataChar" $ nf (map isSpace_DataChar) ['\x0'..'\255']+ , bench "isSpace_Char" $ nf (map isSpace_Char) ['\x0'..'\255']+ , bench "isPerlSpace" $ nf (map isPerlSpace) ['\x0'..'\255']+ , bench "Data.Attoparsec.Char8.isSpace"+ $ nf (map isSpace) ['\x0'..'\255']+ , bench "isSpace_Char8" $ nf (map isSpace_Char8) ['\x0'..'\255']+ , bench "isSpace_w8" $ nf (map isSpace_w8) [0..255]+ ]++----------------------------------------------------------------+----------------------------------------------------------- fin.
+ benchmarks/Links.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}++module Links (links) where++import Control.Applicative+import Control.DeepSeq (NFData(..))+import Criterion.Main (Benchmark, bench, nf)+import Data.Attoparsec.ByteString as A+import Data.Attoparsec.Char8 as A8+import Data.ByteString.Char8 as B8++data Link = Link {+ linkURL :: ByteString+ , linkParams :: [(ByteString, ByteString)]+ } deriving (Eq, Show)++instance NFData Link where+ rnf l = rnf (linkURL l) `seq` rnf (linkParams l)++link :: Parser Link+link = Link <$> url <*> many (char8 ';' *> skipSpace *> param)+ where url = char8 '<' *> A8.takeTill (=='>') <* char8 '>' <* skipSpace++param :: Parser (ByteString, ByteString)+param = do+ name <- paramName+ skipSpace *> "=" *> skipSpace+ c <- peekChar'+ let isTokenChar = A.inClass "!#$%&'()*+./0-9:<=>?@a-zA-Z[]^_`{|}~-"+ val <- case c of+ '"' -> quotedString+ _ -> A.takeWhile isTokenChar+ skipSpace+ return (name, val)++data Quot = Literal | Backslash++quotedString :: Parser ByteString+quotedString = char '"' *> (fixup <$> body) <* char '"'+ where body = A8.scan Literal $ \s c ->+ case (s,c) of+ (Literal, '\\') -> backslash+ (Literal, '"') -> Nothing+ _ -> literal+ literal = Just Literal+ backslash = Just Backslash+ fixup = B8.pack . go . B8.unpack+ where go ('\\' : x@'\\' : xs) = x : go xs+ go ('\\' : x@'"' : xs) = x : go xs+ go (x : xs) = x : go xs+ go xs = xs++paramName :: Parser ByteString+paramName = do+ name <- A.takeWhile1 $ A.inClass "a-zA-Z0-9!#$&+-.^_`|~"+ c <- peekChar+ return $ case c of+ Just '*' -> B8.snoc name '*'+ _ -> name++links :: Benchmark+links = bench "links" $ nf (A.parseOnly link) lnk+ where lnk = "<https://api.github.com/search/code?q=addClass+user%3Amozilla&page=2>; rel=\"next\", <https://api.github.com/search/code?q=addClass+user%3Amozilla&page=34>; rel=\"last\""
+ benchmarks/Makefile view
@@ -0,0 +1,10 @@+all: med.txt tiny++tiny: Tiny.hs+ ghc -O --make -o $@ $<++%: %.bz2+ bunzip2 -k $<++clean:+ -rm -f *.o *.hi tiny
+ benchmarks/Numbers.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE BangPatterns #-}++module Numbers (numbers) where++import Criterion.Main (bench, bgroup, nf)+import Criterion.Types (Benchmark)+import Data.Scientific (Scientific(..))+import Text.Parsec.Text ()+import Text.Parsec.Text.Lazy ()+import qualified Data.Attoparsec.ByteString.Char8 as AC+import qualified Data.Attoparsec.Text as AT+import qualified Data.Picoparsec as P+import qualified Data.Picoparsec.Number as P+import qualified Data.ByteString.Char8 as BC+import qualified Data.Text as T+import Data.Monoid.Instances.ByteString.UTF8 (ByteStringUTF8(..))++strN, strNePos, strNeNeg :: String+strN = "1234.56789"+strNePos = "1234.56789e3"+strNeNeg = "1234.56789e-3"++numbers :: Benchmark+numbers = bgroup "numbers" [+ let !tN = T.pack strN+ !tNePos = T.pack strNePos+ !tNeNeg = T.pack strNeNeg+ in bgroup "Text"+ [ bgroup "attoparsec"+ [+ bgroup "no power"+ [ bench "double" $ nf (AT.parseOnly AT.double) tN+ , bench "number" $ nf (AT.parseOnly AT.number) tN+ , bench "rational" $+ nf (AT.parseOnly (AT.rational :: AT.Parser Rational)) tN+ , bench "scientific" $+ nf (AT.parseOnly (AT.rational :: AT.Parser Scientific)) tN+ ]+ , bgroup "positive power"+ [ bench "double" $ nf (AT.parseOnly AT.double) tNePos+ , bench "number" $ nf (AT.parseOnly AT.number) tNePos+ , bench "rational" $+ nf (AT.parseOnly (AT.rational :: AT.Parser Rational)) tNePos+ , bench "scientific" $+ nf (AT.parseOnly (AT.rational :: AT.Parser Scientific)) tNePos+ ]+ , bgroup "negative power"+ [ bench "double" $ nf (AT.parseOnly AT.double) tNeNeg+ , bench "number" $ nf (AT.parseOnly AT.number) tNeNeg+ , bench "rational" $+ nf (AT.parseOnly (AT.rational :: AT.Parser Rational)) tNeNeg+ , bench "scientific" $+ nf (AT.parseOnly (AT.rational :: AT.Parser Scientific)) tNeNeg+ ]+ ]+ , bgroup "picoparsec"+ [+ bgroup "no power"+ [ bench "double" $ nf (P.parseOnly P.double) tN+ , bench "number" $ nf (P.parseOnly P.number) tN+ , bench "rational" $+ nf (P.parseOnly (P.rational :: P.Parser T.Text Rational)) tN+ , bench "scientific" $+ nf (P.parseOnly (P.rational :: P.Parser T.Text Scientific)) tN+ ]+ , bgroup "positive power"+ [ bench "double" $ nf (P.parseOnly P.double) tNePos+ , bench "number" $ nf (P.parseOnly P.number) tNePos+ , bench "rational" $+ nf (P.parseOnly (P.rational :: P.Parser T.Text Rational)) tNePos+ , bench "scientific" $+ nf (P.parseOnly (P.rational :: P.Parser T.Text Scientific)) tNePos+ ]+ , bgroup "negative power"+ [ bench "double" $ nf (P.parseOnly P.double) tNeNeg+ , bench "number" $ nf (P.parseOnly P.number) tNeNeg+ , bench "rational" $+ nf (P.parseOnly (P.rational :: P.Parser T.Text Rational)) tNeNeg+ , bench "scientific" $+ nf (P.parseOnly (P.rational :: P.Parser T.Text Scientific)) tNeNeg+ ]+ ]+ ]+ , let !bN = BC.pack strN+ !bNePos = BC.pack strNePos+ !bNeNeg = BC.pack strNeNeg+ buN = ByteStringUTF8 bN+ buNePos = ByteStringUTF8 bNePos+ buNeNeg = ByteStringUTF8 bNeNeg+ in bgroup "ByteString"+ [ bgroup "attoparsec"+ [ bgroup "no power"+ [ bench "double" $ nf (AC.parseOnly AC.double) bN+ , bench "number" $ nf (AC.parseOnly AC.number) bN+ , bench "rational" $+ nf (AC.parseOnly (AC.rational :: AC.Parser Rational)) bN+ , bench "scientific" $+ nf (AC.parseOnly (AC.rational :: AC.Parser Scientific)) bN+ ]+ , bgroup "positive power"+ [ bench "double" $ nf (AC.parseOnly AC.double) bNePos+ , bench "number" $ nf (AC.parseOnly AC.number) bNePos+ , bench "rational" $+ nf (AC.parseOnly (AC.rational :: AC.Parser Rational)) bNePos+ , bench "scientific" $+ nf (AC.parseOnly (AC.rational :: AC.Parser Scientific)) bNePos+ ]+ , bgroup "negative power"+ [ bench "double" $ nf (AC.parseOnly AC.double) bNeNeg+ , bench "number" $ nf (AC.parseOnly AC.number) bNeNeg+ , bench "rational" $+ nf (AC.parseOnly (AC.rational :: AC.Parser Rational)) bNeNeg+ , bench "scientific" $+ nf (AC.parseOnly (AC.rational :: AC.Parser Scientific)) bNeNeg+ ]+ ]+ , bgroup "picoparsec"+ [ bgroup "no power"+ [ bench "double" $ nf (P.parseOnly P.double) buN+ , bench "number" $ nf (P.parseOnly P.number) buN+ , bench "rational" $+ nf (P.parseOnly (P.rational :: P.Parser ByteStringUTF8 Rational)) buN+ , bench "scientific" $+ nf (P.parseOnly (P.rational :: P.Parser ByteStringUTF8 Scientific)) buN+ ]+ , bgroup "positive power"+ [ bench "double" $ nf (P.parseOnly P.double) buNePos+ , bench "number" $ nf (P.parseOnly P.number) buNePos+ , bench "rational" $+ nf (P.parseOnly (P.rational :: P.Parser ByteStringUTF8 Rational)) buNePos+ , bench "scientific" $+ nf (P.parseOnly (P.rational :: P.Parser ByteStringUTF8 Scientific)) buNePos+ ]+ , bgroup "negative power"+ [ bench "double" $ nf (P.parseOnly P.double) buNeNeg+ , bench "number" $ nf (P.parseOnly P.number) buNeNeg+ , bench "rational" $+ nf (P.parseOnly (P.rational :: P.Parser ByteStringUTF8 Rational)) buNeNeg+ , bench "scientific" $+ nf (P.parseOnly (P.rational :: P.Parser ByteStringUTF8 Scientific)) buNeNeg+ ]+ ]+ ]+ ]
+ benchmarks/PicoAeson.hs view
@@ -0,0 +1,362 @@+{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}++module PicoAeson+ (+ aeson+ , value'+ ) where++import Control.Applicative ((*>), (<$>), (<*), (<|>), liftA2, pure)+import Control.DeepSeq (NFData(..))+import Control.Monad (forM)+import Data.Picoparsec (Parser, char, endOfInput, string)+import Data.Picoparsec.Number (scientific)+import Data.Bits ((.|.), shiftL)+import Data.Char (chr, digitToInt, isSpace)+import Data.Hashable (Hashable(..))+import Data.List (sort)+import Data.Monoid.Textual (TextualMonoid, singleton)+import qualified Data.Monoid.Textual as Textual+import Data.Monoid.Instances.ByteString.Char8 ()+import Data.Monoid.Instances.ByteString.UTF8 (ByteStringUTF8(..))+import Data.Monoid.Instances.Positioned (OffsetPositioned, LinePositioned, extract) --, position, line, column)+import Data.Monoid.Instances.Stateful (Stateful(Stateful))+import Data.Scientific (Scientific)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Vector as Vector (Vector, foldl', fromList)+import System.Directory (getDirectoryContents)+import System.FilePath ((</>), dropExtension)+import qualified Data.Picoparsec as P+import qualified Data.ByteString as B+import qualified Data.HashMap.Strict as H+import Criterion.Main++data Result a = Error String+ | Success a+ deriving (Eq, Show)+++-- | A JSON \"object\" (key\/value map).+type Object t = H.HashMap t (Value t)++-- | A JSON \"array\" (sequence).+type Array t = Vector (Value t)++-- | A JSON value represented as a Haskell value.+data Value t = Object !(Object t)+ | Array !(Array t)+ | String !t+ | Number !Scientific+ | Bool !Bool+ | Null+ deriving (Eq, Show)++instance NFData t => NFData (Value t) where+ rnf (Object o) = rnf o+ rnf (Array a) = Vector.foldl' (\x y -> rnf y `seq` x) () a+ rnf (String s) = rnf s+ rnf (Number n) = rnf n+ rnf (Bool b) = rnf b+ rnf Null = ()+++instance NFData ByteStringUTF8 where+ rnf (ByteStringUTF8 b) = rnf b++instance Hashable ByteStringUTF8 where+ hashWithSalt i (ByteStringUTF8 b) = hashWithSalt i b+ ++instance NFData a => NFData (OffsetPositioned a) where+ rnf = rnf . extract++instance Hashable a => Hashable (OffsetPositioned a) where+ hashWithSalt i = hashWithSalt i . extract+ ++instance NFData a => NFData (LinePositioned a) where+ rnf = rnf . extract++instance Hashable a => Hashable (LinePositioned a) where+ hashWithSalt i = hashWithSalt i . extract+ +instance (NFData a, NFData b) => NFData (Stateful a b) where+ rnf (Stateful p) = rnf p++instance (Hashable a, Hashable b)=> Hashable (Stateful a b) where+ hashWithSalt i (Stateful p) = hashWithSalt i p+ ++-- | Parse a top-level JSON value. This must be either an object or+-- an array, per RFC 4627.+--+-- The conversion of a parsed value to a Haskell value is deferred+-- until the Haskell value is needed. This may improve performance if+-- only a subset of the results of conversions are needed, but at a+-- cost in thunk allocation.+json :: (Eq t, Hashable t, TextualMonoid t) => Parser t (Value t)+json = json_ object_ array_+{-# INLINABLE json #-}++-- | Parse a top-level JSON value. This must be either an object or+-- an array, per RFC 4627.+--+-- This is a strict version of 'json' which avoids building up thunks+-- during parsing; it performs all conversions immediately. Prefer+-- this version if most of the JSON data needs to be accessed.+json' :: (Eq t, Hashable t, TextualMonoid t) => Parser t (Value t)+json' = json_ object_' array_'+{-# SPECIALIZE json' :: Parser ByteStringUTF8 (Value ByteStringUTF8) #-}+{-# SPECIALIZE json' :: Parser T.Text (Value T.Text) #-}+{-# SPECIALIZE json' :: Parser B.ByteString (Value B.ByteString) #-}++json_ :: (Eq t, TextualMonoid t) => Parser t (Value t) -> Parser t (Value t) -> Parser t (Value t)+json_ obj ary = do+ w <- skipSpace *> P.satisfyChar (\c -> c == '{' || c == '[')+ if w == '{'+ then obj+ else ary+{-# INLINE json_ #-}++object_ :: (Eq t, Hashable t, TextualMonoid t) => Parser t (Value t)+object_ = {-# SCC "object_" #-} Object <$> objectValues jstring value+{-# INLINABLE object_ #-}++object_' :: (Eq t, Hashable t, TextualMonoid t) => Parser t (Value t)+object_' = {-# SCC "object_'" #-} do+ !vals <- objectValues jstring' value'+ return (Object vals)+ where+ jstring' = do+ !s <- jstring+ return s+{-# SPECIALIZE object_' :: Parser ByteStringUTF8 (Value ByteStringUTF8) #-}+{-# SPECIALIZE object_' :: Parser T.Text (Value T.Text) #-}+{-# SPECIALIZE object_' :: Parser B.ByteString (Value B.ByteString) #-}+{-# SPECIALIZE object_' :: Parser (OffsetPositioned B.ByteString) (Value (OffsetPositioned B.ByteString)) #-}+{-# SPECIALIZE object_' :: Parser (LinePositioned B.ByteString) (Value (LinePositioned B.ByteString)) #-}+{-# SPECIALIZE object_' :: Parser (OffsetPositioned T.Text) (Value (OffsetPositioned T.Text)) #-}+{-# SPECIALIZE object_' :: Parser (LinePositioned T.Text) (Value (LinePositioned T.Text)) #-}+{-# SPECIALIZE object_' :: Parser (Stateful [Int] T.Text) (Value (Stateful [Int] T.Text)) #-}+{-# INLINABLE object_' #-}++objectValues :: (Eq t, Hashable t, TextualMonoid t)+ => Parser t t -> Parser t (Value t) -> Parser t (H.HashMap t (Value t))+objectValues str val = do+ skipSpace+ let pair = liftA2 (,) (str <* skipSpace) (char ':' *> skipSpace *> val)+ H.fromList <$> commaSeparated pair '}'+{-# INLINABLE objectValues #-}++array_ :: (Eq t, Hashable t, TextualMonoid t) => Parser t (Value t)+array_ = {-# SCC "array_" #-} Array <$> arrayValues value+{-# INLINABLE array_ #-}++array_' :: (Eq t, Hashable t, TextualMonoid t) => Parser t (Value t)+array_' = {-# SCC "array_'" #-} do+ !vals <- arrayValues value'+ return (Array vals)+{-# INLINABLE array_' #-}++commaSeparated :: (Eq t, TextualMonoid t) => Parser t a -> Char -> Parser t [a]+commaSeparated item end = {-# SCC "commaSeparated" #-} do+ c <- P.peekChar'+ if c == end+ then P.anyToken >> return []+ else loop+ where+ loop = do+ v <- item <* skipSpace+ ch <- P.satisfyChar $ \w -> w == ',' || w == end+ if ch == ','+ then skipSpace >> (v:) <$> loop+ else return [v]+{-# INLINABLE commaSeparated #-}++arrayValues :: (Eq t, TextualMonoid t) => Parser t (Value t) -> Parser t (Vector (Value t))+arrayValues val = {-# SCC "arrayValues" #-} do+ skipSpace+ Vector.fromList <$> commaSeparated val ']'+{-# INLINABLE arrayValues #-}++-- | Parse any JSON value. You should usually 'json' in preference to+-- this function, as this function relaxes the object-or-array+-- requirement of RFC 4627.+--+-- In particular, be careful in using this function if you think your+-- code might interoperate with Javascript. A naïve Javascript+-- library that parses JSON data using @eval@ is vulnerable to attack+-- unless the encoded data represents an object or an array. JSON+-- implementations in other languages conform to that same restriction+-- to preserve interoperability and security.+value :: (Eq t, Hashable t, TextualMonoid t) => Parser t (Value t)+value = do+ c <- P.peekChar'+ case c of+ '"' -> P.anyToken *> (String <$> jstring_)+ '{' -> P.anyToken *> object_+ '[' -> P.anyToken *> array_+ 'f' -> string "false" *> pure (Bool False)+ 't' -> string "true" *> pure (Bool True)+ 'n' -> string "null" *> pure Null+ _ | c >= '0' && c <= '9' || c == '-'+ -> Number <$> scientific+ | otherwise -> fail "not a valid json value"+{-# INLINABLE value #-}++-- | Strict version of 'value'. See also 'json''.+value' :: (Eq t, Hashable t, TextualMonoid t) => Parser t (Value t)+value' = do+ c <- P.peekChar'+ case c of+ '"' -> do+ !s <- P.anyToken *> jstring_+ return (String s)+ '{' -> P.anyToken *> object_'+ '[' -> P.anyToken *> array_'+ 'f' -> string "false" *> pure (Bool False)+ 't' -> string "true" *> pure (Bool True)+ 'n' -> string "null" *> pure Null+ _ | c >= '0' && c <= '9' || c == '-'+ -> do+ !n <- scientific+ return (Number n)+ | otherwise -> fail "not a valid json value"+{-# SPECIALIZE value' :: Parser ByteStringUTF8 (Value ByteStringUTF8) #-}+{-# SPECIALIZE value' :: Parser T.Text (Value T.Text) #-}+{-# SPECIALIZE value' :: Parser B.ByteString (Value B.ByteString) #-}+{-# SPECIALIZE value' :: Parser (OffsetPositioned B.ByteString) (Value (OffsetPositioned B.ByteString)) #-}+{-# SPECIALIZE value' :: Parser (LinePositioned B.ByteString) (Value (LinePositioned B.ByteString)) #-}+{-# SPECIALIZE value' :: Parser (OffsetPositioned T.Text) (Value (OffsetPositioned T.Text)) #-}+{-# SPECIALIZE value' :: Parser (LinePositioned T.Text) (Value (LinePositioned T.Text)) #-}+{-# SPECIALIZE value' :: Parser (Stateful [Int] T.Text) (Value (Stateful [Int] T.Text)) #-}+{-# INLINABLE value' #-}++-- | Parse a quoted JSON string.+jstring :: TextualMonoid t => Parser t t+jstring = char '"' *> jstring_+{-# INLINE jstring #-}++unescape :: TextualMonoid t => Parser t t+unescape = {-# SCC "unescape" #-}+ (P.satisfyChar (`elem` "\"\\/ntbrfu")+ <|> fail "invalid JSON escape sequence")+ >>= \e-> case e+ of '"' -> pure "\""+ '\\' -> pure "\\"+ '/' -> pure "/"+ 'n' -> pure "\n"+ 't' -> pure "\t"+ 'b' -> pure "\b"+ 'r' -> pure "\r"+ 'f' -> pure "\f"+ 'u' -> do a <- hexQuad+ if a < 0xd800 || a > 0xdfff+ then pure (singleton $ chr a)+ else do b <- P.string "\\u" *> hexQuad+ if a <= 0xdbff && b >= 0xdc00 && b <= 0xdfff+ then let !c = ((a - 0xd800) `shiftL` 10) + (b - 0xdc00) + 0x10000+ in pure (singleton $ chr c)+ else fail "invalid UTF-16 surrogates"+ _ -> fail "invalid JSON escape sequence"+{-# INLINE unescape #-}++hexQuad :: TextualMonoid t => Parser t Int+hexQuad = {-# SCC "hexQuad" #-}+ do !s <- P.take 4+ let q = Textual.foldl' (const $ const (-1)) extend 0 s :: Int+ if q < 0 then fail "invalid hex escape" else return q+ where extend n c = {-# SCC "extend" #-} n `shiftL` 4 .|. digitToInt c+{-# INLINE hexQuad #-}++-- | Parse a string without a leading quote.+jstring_ :: TextualMonoid t => Parser t t+jstring_ = {-# SCC "jstring_" #-} do+ s <- P.scanChars False $ \s c -> if s then Just False+ else if c == '"'+ then Nothing+ else Just (c == '\\')+ _ <- P.char '"'+ s1 <- if Textual.elem '\\' s+ then case P.parseOnly unescape s of+ Right r -> return r+ Left err -> fail err+ else return s++ return s1+{-# INLINE jstring_ #-}++-- $lazy+--+-- The 'json' and 'value' parsers decouple identification from+-- conversion. Identification occurs immediately (so that an invalid+-- JSON document can be rejected as early as possible), but conversion+-- to a Haskell value is deferred until that value is needed.+--+-- This decoupling can be time-efficient if only a smallish subset of+-- elements in a JSON value need to be inspected, since the cost of+-- conversion is zero for uninspected elements. The trade off is an+-- increase in memory usage, due to allocation of thunks for values+-- that have not yet been converted.++-- $strict+--+-- The 'json'' and 'value'' parsers combine identification with+-- conversion. They consume more CPU cycles up front, but have a+-- smaller memory footprint.++skipSpace :: TextualMonoid t => Parser t ()+skipSpace = {-# SCC "skipSpace" #-} P.skipCharsWhile isSpace+{-# INLINABLE skipSpace #-}++-- | Parse a top-level JSON value followed by optional whitespace and+-- end-of-input. See also: 'json'.+jsonEOF :: (Eq t, Hashable t, TextualMonoid t) => Parser t (Value t)+jsonEOF = json <* skipSpace <* endOfInput+{-# INLINABLE jsonEOF #-}++-- | Parse a top-level JSON value followed by optional whitespace and+-- end-of-input. See also: 'json''.+jsonEOF' :: (Eq t, Hashable t, TextualMonoid t) => Parser t (Value t)+jsonEOF' = json' <* skipSpace <* endOfInput+{-# INLINE jsonEOF' #-}++aeson :: IO Benchmark+aeson = do+ let path = "json-data"+ names <- sort . filter (`notElem` [".", ".."]) <$> getDirectoryContents path+ benches1 <- forM names $ \name -> do+ bs <- B.readFile (path </> name)+ return . bench (dropExtension name) $ nf (P.parseOnly jsonEOF') $ ByteStringUTF8 bs+ benches2 <- forM names $ \name -> do+ t <- T.readFile (path </> name)+ return . bench (dropExtension name) $ nf (P.parseOnly jsonEOF') t+ benches3 <- forM names $ \name -> do+ bs <- B.readFile (path </> name)+ return . bench (dropExtension name) $ nf (P.parseOnly jsonEOF') bs+ benches4 <- forM names $ \name -> do+ bs <- B.readFile (path </> name)+ return . bench (dropExtension name) $ nf (P.parseOnly jsonEOF') (pure bs :: OffsetPositioned B.ByteString)+ benches5 <- forM names $ \name -> do+ bs <- B.readFile (path </> name)+ return . bench (dropExtension name) $ nf (P.parseOnly jsonEOF') (pure bs :: LinePositioned B.ByteString)+ benches6 <- forM names $ \name -> do+ t <- T.readFile (path </> name)+ return . bench (dropExtension name) $ nf (P.parseOnly jsonEOF') (pure t :: OffsetPositioned T.Text)+ benches7 <- forM names $ \name -> do+ t <- T.readFile (path </> name)+ return . bench (dropExtension name) $ nf (P.parseOnly jsonEOF') (pure t :: LinePositioned T.Text)+ benches8 <- forM names $ \name -> do+ t <- T.readFile (path </> name)+ return . bench (dropExtension name) $ nf (P.parseOnly jsonEOF') (pure t :: Stateful [Int] T.Text)+ return $ bgroup "picoparsec-aeson"+ [ bgroup "ByteStringUTF8" benches1+ , bgroup "Text" benches2+ , bgroup "ByteString.Char8" benches3+ , bgroup "OffsetByteString" benches4+ , bgroup "LinedByteString" benches5+ , bgroup "OffsetText" benches6+ , bgroup "LinedText" benches7+ , bgroup "StatefulText" benches8]
+ benchmarks/Tiny.hs view
@@ -0,0 +1,31 @@+import Control.Applicative ((<|>), many)+import Control.Monad (forM_)+import System.Environment (getArgs)+import qualified Data.Attoparsec.ByteString.Char8 as A+import qualified Data.ByteString.Char8 as B+import qualified Text.Parsec as P+import qualified Text.Parsec.ByteString as P++attoparsec = do+ args <- getArgs+ forM_ args $ \arg -> do+ input <- B.readFile arg+ case A.parse p input `A.feed` B.empty of+ A.Done _ xs -> print (length xs)+ what -> print what+ where+ slow = many (A.many1 A.letter_ascii <|> A.many1 A.digit)+ fast = many (A.takeWhile1 isLetter <|> A.takeWhile1 isDigit)+ isDigit c = c >= '0' && c <= '9'+ isLetter c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')+ p = fast++parsec = do+ args <- getArgs+ forM_ args $ \arg -> do+ input <- readFile arg+ case P.parse (P.many (P.many1 P.letter P.<|> P.many1 P.digit)) "" input of+ Left err -> print err+ Right xs -> print (length xs)++main = attoparsec
+ benchmarks/http-request.txt view
@@ -0,0 +1,14 @@+GET / HTTP/1.1+Host: twitter.com+Accept: text/html, application/xhtml+xml, application/xml; q=0.9,+ image/webp, */*; q=0.8+Accept-Encoding: gzip,deflate,sdch+Accept-Language: en-GB,en-US;q=0.8,en;q=0.6+Cache-Control: max-age=0+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)+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+
+ benchmarks/http-response.txt view
@@ -0,0 +1,16 @@+HTTP/1.1 200 OK+Date: Fri, 09 May 2014 04:24:57 GMT+Expires: -1+Cache-Control: private, max-age=0+Content-Type: text/html; charset=ISO-8859-1+Set-Cookie: PREF=ID=1a871afc4240db5e:FF:LM=1399609497:S=e5MZ0itEekjVwNcU;+ expires=Sun, 08-May-2016 04:24:57 GMT; path=/; domain=.google.com+Set-Cookie: NID=67=-WlfaDG6VSEPk7abAjrK98HBSoCD2ID6JKkUR95tEumzDmg7Fc8pSQ8;+ expires=Sat, 08-Nov-2014 04:24:57 GMT; path=/; domain=.google.com; HttpOnly+P3P: CP="This is not a P3P policy! See http://www.google.com/support/accounts/bin/answer.py?hl=en&answer=151657 for more info."+Server: gws+X-XSS-Protection: 1; mode=block+X-Frame-Options: SAMEORIGIN+Alternate-Protocol: 80:quic+Transfer-Encoding: chunked+
+ benchmarks/med.txt.bz2 view
binary file changed (absent → 518 bytes)
+ benchmarks/picoparsec-benchmarks.cabal view
@@ -0,0 +1,31 @@+-- These benchmarks are not intended to be installed.+-- So don't install 'em.++name: picoparsec-benchmarks+version: 0+cabal-version: >=1.6+build-type: Simple++executable picoparsec-benchmarks+ main-is: Benchmarks.hs+ other-modules:+ HeadersByteString+ HeadersText+ Links+ Numbers+ hs-source-dirs: .. .+ ghc-options: -O2 -Wall+ build-depends:+ array,+ base == 4.*,+ bytestring >= 0.10.4.0,+ criterion >= 0.5,+ deepseq >= 1.1,+ directory,+ filepath,+ monoid-subclasses,+ parsec >= 3.1.2,+ scientific,+ text >= 1.1.1.0,+ unordered-containers,+ vector
+ changelog.md view
@@ -0,0 +1,3 @@+0.1++* Initial commit.
+ examples/Makefile view
@@ -0,0 +1,15 @@+CC := gcc+CFLAGS := -O3 -Wall+# To make the code about 6% faster:+# CFLAGS += -fwhole-program --combine+CPPFLAGS := -I$(HOME)/hg/http-parser++all: c-http++c-http: rfc2616.c http_parser.c+ $(CC) $(CFLAGS) $(CPPFLAGS) -o $@ $^++clean:+ rm -f *.hi *.o c-http++vpath %.c $(HOME)/hg/http-parser
+ examples/Parsec_RFC2616.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE BangPatterns, CPP, FlexibleContexts #-}++module Main (main) where++import Control.Applicative+import Control.Exception (bracket)+import System.Environment (getArgs)+import System.IO (hClose, openFile, IOMode(ReadMode))+import Text.Parsec.Char (anyChar, char, satisfy, string)+import Text.Parsec.Combinator (many1, manyTill, skipMany1)+import Text.Parsec.Prim hiding (many, token, (<|>))+import qualified Data.IntSet as S++#if 1+import Text.Parsec.ByteString.Lazy (Parser, parseFromFile)+import qualified Data.ByteString.Lazy as B+#else+import Text.Parsec.ByteString (Parser, parseFromFile)+import qualified Data.ByteString as B+#endif++token :: Stream s m Char => ParsecT s u m Char+token = satisfy $ \c -> S.notMember (fromEnum c) set+ where set = S.fromList . map fromEnum $ ['\0'..'\31'] ++ "()<>@,;:\\\"/[]?={} \t" ++ ['\128'..'\255']++isHorizontalSpace c = c == ' ' || c == '\t'++skipHSpaces :: Stream s m Char => ParsecT s u m ()+skipHSpaces = skipMany1 (satisfy isHorizontalSpace)++data Request = Request {+ requestMethod :: String+ , requestUri :: String+ , requestProtocol :: String+ } deriving (Eq, Ord, Show)++requestLine :: Stream s m Char => ParsecT s u m Request+requestLine = do+ method <- many1 token <* skipHSpaces+ uri <- many1 (satisfy (not . isHorizontalSpace)) <* skipHSpaces <* string "HTTP/"+ proto <- many httpVersion <* endOfLine+ return $! Request method uri proto+ where+ httpVersion = satisfy $ \c -> c == '1' || c == '0' || c == '.'++endOfLine :: Stream s m Char => ParsecT s u m ()+endOfLine = (string "\r\n" *> pure ()) <|> (char '\n' *> pure ())++data Header = Header {+ headerName :: String+ , headerValue :: [String]+ } deriving (Eq, Ord, Show)++messageHeader :: Stream s m Char => ParsecT s u m Header+messageHeader = do+ header <- many1 token <* char ':' <* skipHSpaces+ body <- manyTill anyChar endOfLine+ conts <- many $ skipHSpaces *> manyTill anyChar endOfLine+ return $! Header header (body:conts)++request :: Stream s m Char => ParsecT s u m (Request, [Header])+request = (,) <$> requestLine <*> many messageHeader <* endOfLine++listy arg = do+ r <- parseFromFile (many request) arg+ case r of+ Left err -> putStrLn $ arg ++ ": " ++ show err+ Right rs -> print (length rs)++chunky arg = bracket (openFile arg ReadMode) hClose $ \h ->+ loop 0 =<< B.hGetContents h+ where+ loop !n bs+ | B.null bs = print n+ | otherwise = case parse myReq arg bs of+ Left err -> putStrLn $ arg ++ ": " ++ show err+ Right (r,bs') -> loop (n+1) bs'+ myReq :: Parser ((Request, [Header]), B.ByteString)+ myReq = liftA2 (,) request getInput++main :: IO ()+main = mapM_ f =<< getArgs+ where+ --f = listy+ f = chunky
+ examples/RFC2616.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedStrings #-}++module RFC2616+ (+ Header(..)+ , Request(..)+ , Response(..)+ , isToken+ , messageHeader+ , request+ , requestLine+ , response+ , responseLine+ , lowerHeader+ , lookupHeader+ ) where++import Control.Applicative+import Data.Attoparsec as P+import qualified Data.Attoparsec.Char8 as P8+import Data.Attoparsec.Char8 (char8, endOfLine, isDigit_w8)+import Data.Word (Word8)+import qualified Data.ByteString.Char8 as B hiding (map)+import qualified Data.ByteString as B (map)++isToken :: Word8 -> Bool+isToken w = w <= 127 && notInClass "\0-\31()<>@,;:\\\"/[]?={} \t" w++skipSpaces :: Parser ()+skipSpaces = satisfy P8.isHorizontalSpace *> skipWhile P8.isHorizontalSpace++data Request = Request {+ requestMethod :: !B.ByteString+ , requestUri :: !B.ByteString+ , requestVersion :: !B.ByteString+ } deriving (Eq, Ord, Show)++httpVersion :: Parser B.ByteString+httpVersion = "HTTP/" *> P.takeWhile (\c -> isDigit_w8 c || c == 46)++requestLine :: Parser Request+requestLine = do+ method <- P.takeWhile1 isToken <* char8 ' '+ uri <- P.takeWhile1 (/=32) <* char8 ' '+ version <- httpVersion <* endOfLine+ return $! Request method uri version++data Header = Header {+ headerName :: !B.ByteString+ , headerValue :: [B.ByteString]+ } deriving (Eq, Ord, Show)++messageHeader :: Parser Header+messageHeader = do+ header <- P.takeWhile isToken <* char8 ':' <* skipWhile P8.isHorizontalSpace+ body <- takeTill P8.isEndOfLine <* endOfLine+ bodies <- many $ skipSpaces *> takeTill P8.isEndOfLine <* endOfLine+ return $! Header header (body:bodies)++request :: Parser (Request, [Header])+request = (,) <$> requestLine <*> many messageHeader <* endOfLine++data Response = Response {+ responseVersion :: !B.ByteString+ , responseCode :: !B.ByteString+ , responseMsg :: !B.ByteString+ } deriving (Eq, Ord, Show)++responseLine :: Parser Response+responseLine = do+ version <- httpVersion <* char8 ' '+ code <- P.takeWhile isDigit_w8 <* char8 ' '+ msg <- P.takeTill P8.isEndOfLine <* endOfLine+ return $! Response version code msg++response :: Parser (Response, [Header])+response = (,) <$> responseLine <*> many messageHeader <* endOfLine++lowerHeader :: Header -> Header+lowerHeader (Header n v) = Header (B.map toLower n) (map (B.map toLower) v)+ where toLower w | w >= 65 && w <= 90 = w + 32+ | otherwise = w++lookupHeader :: B.ByteString -> [Header] -> [B.ByteString]+lookupHeader k = go+ where+ go (Header n v:hs)+ | k == n = v+ | otherwise = go hs+ go _ = []
+ examples/TestRFC2616.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE BangPatterns #-}+import RFC2616+import Control.Monad (forM_)+import System.IO+import Control.Exception (bracket)+import System.Environment+import qualified Data.ByteString.Char8 as B+import Data.Attoparsec++refill h = B.hGet h (4*1024)++listy file h = do+ r <- parseWith (refill h) (many request) =<< refill h+ case r of+ Fail _ _ msg -> hPutStrLn stderr $ file ++ ": " ++ msg+ Done _ reqs -> print (length reqs)+ +incrementy file h = go 0 =<< refill h+ where+ go !n is = do+ r <- parseWith (refill h) request is+ case r of+ Fail _ _ msg -> hPutStrLn stderr $ file ++ ": " ++ msg+ Done bs _req+ | B.null bs -> do+ s <- refill h+ if B.null s+ then print (n+1)+ else go (n+1) s+ | otherwise -> go (n+1) bs+ +main = do+ args <- getArgs+ forM_ args $ \arg ->+ bracket (openFile arg ReadMode) hClose $+ -- listy arg+ incrementy arg
+ examples/rfc2616.c view
@@ -0,0 +1,238 @@+/*+ * This is a simple driver for Ryan Dahl's hand-bummed C http-parser+ * package. It is intended to read one HTTP request after another+ * from a file, nothing more.+ *+ * For "feature parity" with the Haskell code in RFC2616.hs, we+ * allocate and populate a simple structure describing each request,+ * since that's the sort of thing that many real applications would+ * themselves do and the library doesn't do this for us.+ *+ * For the http-parser source, see http://github.com/ry/http-parser/+ */++/*+ * Turn off this preprocessor symbol to have the callbacks do nothing+ * at all, which "improves performance" by about 50%.+ */+#define LOOK_BUSY++#include <assert.h>+#include <fcntl.h>+#include <stdio.h>+#include <stdlib.h>+#include <string.h>+#include <sys/stat.h>+#include <sys/types.h>+#include <unistd.h>++#include "http_parser.h"+ +struct http_string {+ size_t len;+ char value[0];+};+ +struct http_header {+ struct http_string *name;+ struct http_string *value;+ struct http_header *next;+};+ +struct http_request {+ struct http_string *method;+ struct http_string *uri;+ struct http_header *headers, *last;+};++struct data {+ size_t count;+ struct http_request req;+};+ +static void *xmalloc(size_t size)+{+ void *ptr;++ if ((ptr = malloc(size)) == NULL) {+ perror("malloc");+ exit(1);+ }++ return ptr;+}++static struct http_string *xstrdup(const char *src, size_t len, size_t extra)+{+ struct http_string *dst = xmalloc(sizeof(*dst) + len + extra);+ memcpy(dst->value, src, len);+ dst->len = len;+ return dst;+}++static void xstrcat(struct http_string **dst, const char *src, size_t len)+{+ struct http_string *p;++ if (*dst == NULL) {+ *dst = xstrdup(src, len, 0);+ return;+ }+ + p = xstrdup((*dst)->value, (*dst)->len, len);+ memcpy(p->value + (*dst)->len, src, len);+ p->len += len;+ free(*dst);+ *dst = p;+}++static int begin(http_parser *p)+{+ struct data *data = p->data;++ data->count++;++ return 0;+}++static int url(http_parser *p, const char *at, size_t len)+{+#ifdef LOOK_BUSY+ struct data *data = p->data; ++ xstrcat(&data->req.uri, at, len);+#endif++ return 0;+}++static int header_field(http_parser *p, const char *at, size_t len)+{+#ifdef LOOK_BUSY+ struct data *data = p->data;++ if (data->req.last && data->req.last->value == NULL) {+ xstrcat(&data->req.last->name, at, len);+ } else {+ struct http_header *hdr = xmalloc(sizeof(*hdr));++ hdr->name = xstrdup(at, len, 0);+ hdr->value = NULL;+ hdr->next = NULL;+ + if (data->req.last != NULL)+ data->req.last->next = hdr;+ data->req.last = hdr;+ if (data->req.headers == NULL)+ data->req.headers = hdr;+ }+#endif++ return 0;+}++static int header_value(http_parser *p, const char *at, size_t len)+{+#ifdef LOOK_BUSY+ struct data *data = p->data;++ xstrcat(&data->req.last->value, at, len);+#endif++ return 0;+}++static int complete(http_parser *p)+{+#ifdef LOOK_BUSY+ struct data *data = p->data;+ struct http_header *hdr, *next;++ free(data->req.method);+ free(data->req.uri);+ + for (hdr = data->req.headers; hdr != NULL; hdr = next) {+ next = hdr->next;+ free(hdr->name);+ free(hdr->value);+ free(hdr);+ hdr = next;+ }++ data->req.method = NULL;+ data->req.uri = NULL;+ data->req.headers = NULL;+ data->req.last = NULL;+#endif+ + /* Bludgeon http_parser into understanding that we really want to+ * keep parsing after a request that in principle ought to close+ * the "connection". */+ if (!http_should_keep_alive(p)) {+ p->http_major = 1;+ p->http_minor = 1;+ p->flags &= ~6;+ }++ return 0;+}++static void parse(const char *path, int fd)+{+ struct data data;+ http_parser p;+ ssize_t nread;++ http_parser_init(&p, HTTP_REQUEST);+ p.on_message_begin = begin;+ p.on_url = url;+ p.on_header_field = header_field;+ p.on_header_value = header_value;+ p.on_message_complete = complete;+ p.data = &data;+ data.count = 0;+ data.req.method = NULL;+ data.req.uri = NULL;+ data.req.headers = NULL;+ data.req.last = NULL;++ do {+ char buf[HTTP_MAX_HEADER_SIZE];+ size_t np;++ nread = read(fd, buf, sizeof(buf));++ np = http_parser_execute(&p, buf, nread);+ if (np != nread) {+ fprintf(stderr, "%s: parse failed\n", path);+ break;+ }+ } while (nread > 0);++ printf("%ld\n", (unsigned long) data.count);+}++int main(int argc, char **argv)+{+ int i;++ for (i = 1; i < argc; i++) {+ int fd;++ fd = open(argv[i], O_RDONLY);+ if (fd == -1) {+ perror(argv[i]);+ continue;+ }+ parse(argv[i], fd);+ close(fd);+ }++ return 0;+}++/*+ * Local Variables:+ * c-file-style: "stroustrup"+ * End:+ */
+ picoparsec.cabal view
@@ -0,0 +1,119 @@+name: picoparsec+version: 0.1+license: BSD3+license-file: LICENSE+category: Text, Parsing+author: Mario Blažević <blamario@yahoo.com>+maintainer: Mario Blažević <blamario@yahoo.com>+stability: experimental+tested-with: GHC == 7.6, GHC == 7.8+synopsis: Fast combinator parsing for bytestrings and text+cabal-version: >= 1.8+homepage: https://bitbucket.org/blamario/picoparsec+bug-reports: https://bitbucket.org/blamario/picoparsec/issues+build-type: Simple+description:++ A fast and flexible parser combinator library, accepting any input type that is an instance of an appropriate+ monoid subclass.++extra-source-files:+ README.markdown+ benchmarks/*.hs+ benchmarks/*.txt+ benchmarks/Makefile+ benchmarks/picoparsec-benchmarks.cabal+ benchmarks/med.txt.bz2+ changelog.md+ examples/*.c+ examples/*.hs+ examples/Makefile+ tests/*.hs+ tests/Makefile+ tests/QC/*.hs+ tests/TestFastSet.hs++Flag developer+ Description: Whether to build the library in development mode+ Default: False+ Manual: True++library+ build-depends: array,+ base >= 3 && < 5,+ bytestring,+ containers,+ deepseq,+ monoid-subclasses >= 0.4 && < 0.5,+ text >= 0.11.3.1,+ scientific >= 0.3.1 && < 0.4+ if impl(ghc < 7.4)+ build-depends:+ bytestring < 0.10.4.0,+ text < 1.1++ exposed-modules: Data.Picoparsec+ Data.Picoparsec.Combinator+ Data.Picoparsec.Number+ Data.Picoparsec.State+ Data.Picoparsec.Types+ Data.Picoparsec.Zepto+ other-modules: Data.Picoparsec.Monoid.Internal+ Data.Picoparsec.Internal+ Data.Picoparsec.Internal.Types+ Data.Picoparsec.Text.FastSet+ ghc-options: -O2 -Wall++ if flag(developer)+ ghc-prof-options: -auto-all++test-suite tests+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: QC.hs+ other-modules: QC.Monoid++ ghc-options:+ -Wall -threaded -rtsopts++ build-depends:+ picoparsec,+ base >= 4 && < 5,+ bytestring, text,+ monoid-subclasses >= 0.4 && < 0.5,+ QuickCheck == 2.*, quickcheck-instances == 0.3.*, tasty >= 0.7, tasty-quickcheck >= 0.7++benchmark benchmarks+ type: exitcode-stdio-1.0+ hs-source-dirs: benchmarks+ ghc-options: -O2 -Wall+ main-is: Benchmarks.hs+ other-modules:+ Data.Monoid.Instances.ByteString.Char8+ AttoAeson+ PicoAeson+ HeadersByteString+ HeadersText+ Links+ Numbers+ build-depends:+ array,+ attoparsec == 0.11.*,+ base == 4.*,+ bytestring >= 0.10.4.0,+ criterion >= 0.5,+ deepseq >= 1.1,+ directory,+ filepath,+ hashable,+ monoid-subclasses >= 0.4 && < 0.5,+ parsec >= 3.1.2,+ picoparsec,+ scientific >= 0.2,+ text >= 1.1.1.0,+ unordered-containers,+ vector++source-repository head+ type: mercurial+ location: https://bitbucket.org/blamario/picoparsec
+ tests/Makefile view
@@ -0,0 +1,14 @@+all: TestFastSet.out qc.out++%.out: %.exe+ ./$< | tee $<.tmp+ mv $<.tmp $@++qc.exe: QC.hs+ ghc -O -fno-warn-orphans --make -o $@ $<++%.exe: %.hs+ ghc -O -fno-warn-orphans --make -o $@ $<++clean:+ -rm -f *.hi *.o *.exe *.out
+ tests/QC.hs view
@@ -0,0 +1,9 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Main (main) where++import qualified QC.Monoid as Monoid+import Test.Tasty (defaultMain, testGroup)++main = defaultMain tests++tests = testGroup "monoid" Monoid.tests
+ tests/QC/Monoid.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE BangPatterns, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-orphans #-}+module QC.Monoid (tests) where++import Prelude hiding (null, takeWhile)++import Control.Applicative ((<$>), (<*>), (*>), many, pure)+import Data.Monoid (Monoid, Sum(..), mempty, (<>))+import Data.Word (Word8)+import Test.Tasty.QuickCheck (testProperty)+import Test.QuickCheck+import Test.QuickCheck.Modifiers ()+import qualified Data.Picoparsec as P+import qualified Data.Picoparsec.State as PS+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Monoid.Null (null)+import Data.Monoid.Instances.ByteString.UTF8 (ByteStringUTF8(..), decode)++instance Arbitrary B.ByteString where+ arbitrary = B.pack <$> arbitrary++instance Arbitrary L.ByteString where+ arbitrary = sized $ \n -> resize (round (sqrt (toEnum n :: Double)))+ ((L.fromChunks . map (B.pack . nonEmpty)) <$> arbitrary)+ where nonEmpty (NonEmpty a) = a++instance Arbitrary T.Text where+ arbitrary = T.pack <$> arbitrary++-- Naming.++{-+label (NonEmpty s) = case parse (anyToken <?> s) B.empty of+ (_, Left err) -> s `isInfixOf` err+ _ -> False+-}++-- Basic byte-level combinators.++utf8 :: T.Text -> ByteStringUTF8+utf8 = ByteStringUTF8 . TE.encodeUtf8++maybeP :: Monoid t => P.Parser t r -> t -> Maybe r+maybeP p = P.maybeResult . flip P.feed mempty . P.parse p++defP p = flip P.feed mempty . P.parse p++satisfy :: Word8 -> B.ByteString -> Bool+satisfy w s = maybeP (P.satisfy (<=b)) (b <> s) == Just b+ where b = B.singleton w++satisfyChar :: Char -> T.Text -> Bool+satisfyChar c s = maybeP (P.satisfyChar (<=c)) (t <> s) == Just c+ && maybeP (P.satisfyChar (<=c)) (utf8 t <> utf8 s) == Just c+ where t = T.singleton c++satisfyPartialChar c s (NonNegative n) = P.maybeResult p' == Just c+ where b = TE.encodeUtf8 (T.cons c s)+ (b1, b2) = B.splitAt (n `mod` B.length b + 1) b+ (u1, b1') = decode b1+ u2 = ByteStringUTF8 (b1' <> b2)+ p0 = P.satisfyChar (<=c)+ p1 = P.parse p0 u1+ p2 = if null u2 then p1 else P.feed p1 u2+ p' = P.feed p2 mempty++anyToken s+ | L.null s = p == Nothing+ | otherwise = p == Just (L.take 1 s)+ where p = maybeP P.anyToken s++anyChar s+ | T.null s = p == Nothing+ | otherwise = p == Just (T.head s)+ where p = maybeP P.anyChar s++anyPartialChar s (NonNegative n)+ | T.null s = maybeP p0 (ByteStringUTF8 b) == Nothing+ | otherwise = P.maybeResult p' == Just (T.head s)+ where b = TE.encodeUtf8 s+ (b1, b2) = B.splitAt (n `mod` B.length b + 1) b+ (u1, b1') = decode b1+ u2 = ByteStringUTF8 (b1' <> b2)+ p0 = P.anyChar+ p1 = P.parse p0 u1+ p2 = if null u2 then p1 else P.feed p1 u2+ p' = P.feed p2 mempty++peekToken s+ | L.null s = p == Just (L.empty, s)+ | otherwise = p == Just (L.take 1 s, s)+ where p = maybeP ((,) <$> P.peekToken <*> P.takeRest) s++string s t = maybeP (P.string s) (s `L.append` t) == Just s++skipWhile w s =+ let t = L.dropWhile (<= w) s+ in case defP (P.skipWhile (<= L.singleton w)) s of+ P.Done t' () -> t == t'+ _ -> False++takeCount (Positive k) s =+ case maybeP (P.take k) s of+ Nothing -> fromIntegral k > L.length s+ Just s' -> fromIntegral k <= L.length s'++takeWhile w s =+ let (h,t) = L.span (<=w) s+ in case defP (P.takeWhile (<= L.singleton w)) s of+ P.Done t' h' -> t == t' && h == h'+ _ -> False++takeCharsWhile c s =+ let (h,t) = T.span (<=c) s+ in case defP (P.takeCharsWhile (<= c)) s of+ P.Done t' h' -> t == t' && h == h'+ _ -> False++takePartialCharsWhile c s (NonNegative n) = + case p' of+ P.Done t' h' -> utf8 t == t' && utf8 h == h'+ _ -> False+ where (h,t) = T.span (<=c) s+ b = TE.encodeUtf8 s+ (b1, b2) = B.splitAt (if B.null b then 0 else n `mod` B.length b + 1) b+ (u1, b1') = decode b1+ u2 = ByteStringUTF8 (b1' <> b2)+ p0 = P.takeCharsWhile (<= c)+ p1 = P.parse p0 u1+ p2 = if null u2 then p1 else P.feed p1 u2+ p' = P.feed p2 mempty++takeWhile1 w s =+ let s' = L.cons w s+ (h,t) = L.span (<=w) s'+ in case defP (P.takeWhile1 (<= L.singleton w)) s' of+ P.Done t' h' -> t == t' && h == h'+ _ -> False++takeCharsWhile1 c s =+ let s' = T.cons c s+ (h,t) = T.span (<=c) s'+ in case defP (P.takeWhile1 (<= T.singleton c)) s' of+ P.Done t' h' -> t == t' && h == h'+ _ -> False++takePartialCharsWhile1 c s (NonNegative n) = + case p' of+ P.Done t' h' -> utf8 t == t' && utf8 h == h'+ _ -> False+ where b = TE.encodeUtf8 s'+ s' = T.cons c s+ (h,t) = T.span (<=c) s'+ (b1, b2) = B.splitAt (if B.null b then 0 else n `mod` B.length b + 1) b+ (u1, b1') = decode b1+ u2 = ByteStringUTF8 (b1' <> b2)+ p0 = P.takeCharsWhile1 (<= c)+ p1 = P.parse p0 u1+ p2 = if null u2 then p1 else P.feed p1 u2+ p' = P.feed p2 mempty++takeTill w s =+ let (h,t) = L.break (== w) s+ in case defP (P.takeTill (== L.singleton w)) s of+ P.Done t' h' -> t == t' && h == h'+ _ -> False++takeCharsTill c s =+ let (h,t) = T.break (== c) s+ in case defP (P.takeCharsTill (== c)) s of+ P.Done t' h' -> t == t' && h == h'+ _ -> False+takeTillChar c s =+ let (h,t) = T.break (<= c) s+ in case defP (P.takeTillChar (<= c)) s of+ P.Done t' h' -> t == t' && h == h'+ _ -> False++takeTillPartialChar c s (NonNegative n) =+ case p' of+ P.Done t' h' -> utf8 t == t' && utf8 h == h'+ _ -> False+ where (h,t) = T.break (<= c) s+ b = TE.encodeUtf8 s+ (b1, b2) = B.splitAt (if B.null b then 0 else n `mod` B.length b + 1) b+ (u1, b1') = decode b1+ u2 = ByteStringUTF8 (b1' <> b2)+ p0 = P.takeTillChar (<= c)+ p1 = P.parse p0 u1+ p2 = if null u2 then p1 else P.feed p1 u2+ p' = P.feed p2 mempty++takeTillChar1 c s =+ let s' = T.cons c s+ (h,t) = T.break (< c) s'+ in case defP (P.takeTillChar1 (< c)) s' of+ P.Done t' h' -> t == t' && h == h'+ _ -> False++takeTillPartialChar1 c s (NonNegative n) =+ case p' of+ P.Done t' h' -> utf8 t == t' && utf8 h == h'+ _ -> False+ where s' = T.cons c s+ (h,t) = T.break (< c) s'+ b = TE.encodeUtf8 s'+ (b1, b2) = B.splitAt (n `mod` B.length b + 1) b+ (u1, b1') = decode b1+ u2 = ByteStringUTF8 (b1' <> b2)+ p0 = P.takeTillChar1 (< c)+ p1 = P.parse p0 u1+ p2 = if null u2 then p1 else P.feed p1 u2+ p' = P.feed p2 mempty++takeWhile1_empty = maybeP (P.takeWhile1 undefined) L.empty == Nothing++endOfInput s = maybeP P.endOfInput s == if B.null s+ then Just ()+ else Nothing++stateful :: String -> Bool+stateful s = maybeP (many (PS.modifyState (+ (Sum 1)) *> P.anyChar) *> PS.getState) (pure s)+ == Just (Sum (length s))++tests = [+ testProperty "satisfy" satisfy,+ testProperty "satisfyChar" satisfyChar,+ testProperty "satisfyPartialChar" satisfyPartialChar,+ testProperty "anyToken" anyToken,+ testProperty "anyChar" anyChar,+ testProperty "anyPartialChar" anyPartialChar,+ testProperty "peekToken" peekToken,+ testProperty "string" string,+ testProperty "skipWhile" skipWhile,+ testProperty "takeCount" takeCount,+ testProperty "takeWhile" takeWhile,+ testProperty "takeCharsWhile" takeCharsWhile,+ testProperty "takePartialCharsWhile" takePartialCharsWhile,+ testProperty "takeWhile1" takeWhile1,+ testProperty "takeWhile1_empty" takeWhile1_empty,+ testProperty "takeCharsWhile1" takeCharsWhile1,+ testProperty "takePartialCharsWhile1" takePartialCharsWhile1,+ testProperty "takeTill" takeTill,+ testProperty "takeCharsTill" takeCharsTill,+ testProperty "takeTillChar" takeTillChar,+ testProperty "takeTillPartialChar" takeTillPartialChar,+ testProperty "takeTillChar1" takeTillChar1,+ testProperty "takeTillPartialChar1" takeTillPartialChar1,+ testProperty "endOfInput" endOfInput,+ testProperty "stateful" stateful+ ]
+ tests/TestFastSet.hs view
@@ -0,0 +1,25 @@+module Main (main) where++import Data.Word (Word8)+import qualified Data.Picoparsec.FastSet as F+import System.Random (Random(..), RandomGen)+import Test.QuickCheck++integralRandomR :: (Integral a, RandomGen g) => (a, a) -> g -> (a, g)+integralRandomR (a,b) g = case randomR (fromIntegral a :: Int,+ fromIntegral b :: Int) g+ of (x,g') -> (fromIntegral x, g')++instance Random Word8 where+ randomR = integralRandomR+ random = randomR (minBound,maxBound)++instance Arbitrary Word8 where+ arbitrary = choose (minBound, maxBound)++prop_AllMembers s =+ let set = F.fromList s+ in all (`F.memberWord8` set) s++main = do+ quickCheck prop_AllMembers