diff --git a/Data/Attoparsec.hs b/Data/Attoparsec.hs --- a/Data/Attoparsec.hs +++ b/Data/Attoparsec.hs @@ -1,59 +1,226 @@ ------------------------------------------------------------------------------ -- | -- Module : Data.Attoparsec --- Copyright : Daan Leijen 1999-2001, Jeremy Shaw 2006, Bryan O'Sullivan 2007-2008 +-- Copyright : Bryan O'Sullivan 2007-2010 -- License : BSD3 -- -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : unknown -- --- Simple, efficient parser combinators for lazy 'ByteString' --- strings, loosely based on 'Text.ParserCombinators.Parsec'. --- ------------------------------------------------------------------------------ +-- Simple, efficient combinator parsing for 'B.ByteString' strings, +-- loosely based on the Parsec library. + module Data.Attoparsec ( + -- * Differences from Parsec + -- $parsec + + -- * Performance considerations + -- $performance + -- * Parser types - ParseError - , Parser + I.Parser + , Result(..) + -- ** Typeclass instances + -- $instances + -- * Running parsers , parse - , parseAt + , feed + , parseWith , parseTest + -- ** Result conversion + , maybeResult + , eitherResult + -- * Combinators - , () - , try + , (I.) + , I.try , module Data.Attoparsec.Combinator -- * Parsing individual bytes - , anyWord8 - , notWord8 - , word8 - , satisfy + , I.word8 + , I.anyWord8 + , I.notWord8 + , I.satisfy + , I.satisfyWith - -- * Efficient string handling - , string - , skipWhile - , stringTransform - , takeAll - , takeTill - , takeWhile - , takeWhile1 + -- ** Byte classes + , I.inClass + , I.notInClass - -- ** Combinators - , match - , notEmpty + -- * Efficient string handling + , I.string + , I.skipWhile + , I.take + , I.takeWhile + , I.takeWhile1 + , I.takeTill - -- * State observation functions - , endOfInput - , getConsumed - , getInput - , lookAhead + -- * State observation and manipulation functions + , I.endOfInput + , I.ensure ) where import Data.Attoparsec.Combinator -import Data.Attoparsec.Internal import Prelude hiding (takeWhile) +import qualified Data.Attoparsec.Internal as I +import qualified Data.ByteString as B + +-- $parsec +-- +-- Compared to Parsec 3, Attoparsec makes several tradeoffs. It is +-- not intended for, or ideal for, all possible uses. +-- +-- * While Attoparsec 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 Attoparsec 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 really isn't much performance difference the +-- two libraries. +-- +-- * Unlike Parsec 3, Attoparsec does not support being used as a +-- monad transformer. This is mostly a matter of the implementor +-- not having needed that functionality. +-- +-- * Attoparsec is specialised to deal only with strict 'B.ByteString' +-- input. Efficiency concernts rule out both lists and lazy +-- bytestrings. The usual use for lazy bytestrings would be to +-- allow consumption of very large input without a large footprint. +-- For this need, Attoparsec's incremental input provides an +-- excellent substitute, with much more control over when input +-- takes place. +-- +-- * Parsec parsers can produce more helpful error messages than +-- Attoparsec parsers. This is a matter of focus: Attoparsec avoids +-- the extra book-keeping in favour of higher performance. + +-- $performance +-- +-- If you write an Attoparsec-based parser carefully, it can be +-- realistic to expect it to perform within a factor of 2 of a +-- hand-rolled C parser (measuring megabytes parsed per second). +-- +-- To actually achieve high performance, there are a few guidelines +-- that it is useful to follow. +-- +-- Use the 'B.ByteString'-oriented parsers whenever possible, +-- e.g. 'I.takeWhile1' instead of 'many1' 'I.anyWord8'. There is +-- about a factor of 100 difference in performance between the two +-- kinds of parser. +-- +-- For very simple byte-testing predicates, write them by hand instead +-- of using 'I.inClass' or 'I.notInClass'. For instance, both of +-- these predicates test for an end-of-line byte, but the first is +-- much faster than the second: +-- +-- >endOfLine_fast w = w == 13 || w == 10 +-- >endOfLine_slow = inClass "\r\n" +-- +-- Make active use of benchmarking and profiling tools to measure, +-- find the problems with, and improve the performance of your parser. + +-- $instances +-- +-- The 'I.Parser' 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. +-- +-- * 'Alternative', which follows 'MonadPlus'. +-- +-- The 'Result' type is an instance of 'Functor', where 'fmap' +-- transforms the value in a 'Done' result. + +-- | The result of a parse. +data Result r = Fail !B.ByteString [String] String + -- ^ The parse failed. The 'B.ByteString' 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 (B.ByteString -> Result r) + -- ^ Supply this continuation with more input so that + -- the parser can resume. To indicate that no more + -- input is available, use an 'B.empty' string. + | Done !B.ByteString r + -- ^ The parse succeeded. The 'B.ByteString' is the + -- input that had not yet been consumed (if any) when + -- the parse succeeded. + +instance Show r => Show (Result r) where + show (Fail bs stk msg) = + "Fail " ++ show bs ++ " " ++ show stk ++ " " ++ show msg + show (Partial _) = "Partial _" + show (Done bs r) = "Done " ++ show bs ++ " " ++ show r + +-- | If a parser has returned a 'Partial' result, supply it with more +-- input. +feed :: Result r -> B.ByteString -> Result r +feed f@(Fail _ _ _) _ = f +feed (Partial k) d = k d +feed (Done bs r) d = Done (B.append bs d) r + +fmapR :: (a -> b) -> Result a -> Result b +fmapR _ (Fail st stk msg) = Fail st stk msg +fmapR f (Partial k) = Partial (fmapR f . k) +fmapR f (Done bs r) = Done bs (f r) + +instance Functor Result where + fmap = fmapR + +-- | Run a parser and print its result to standard output. +parseTest :: (Show a) => I.Parser a -> B.ByteString -> IO () +parseTest p s = print (parse p s) + +translate :: I.Result a -> Result a +translate (I.Fail st stk msg) = Fail (I.input st) stk msg +translate (I.Partial k) = Partial (translate . k) +translate (I.Done st r) = Done (I.input st) r + +-- | Run a parser and return its result. +parse :: I.Parser a -> B.ByteString -> Result a +parse m s = translate (I.parse m s) +{-# INLINE parse #-} + +-- | Run a parser with an initial input string, and a monadic action +-- that can supply more input if needed. +parseWith :: Monad m => + (m B.ByteString) + -- ^ An action that will be executed to provide the parser + -- with more input, if necessary. The action must return an + -- 'B.empty' string when there is no more input available. + -> I.Parser a + -> B.ByteString + -- ^ Initial input for the parser. + -> m (Result a) +parseWith refill p s = step $ I.parse p s + where step (I.Fail st stk msg) = return $! Fail (I.input st) stk msg + step (I.Partial k) = (step . k) =<< refill + step (I.Done st r) = return $! Done (I.input st) r + +-- | Convert a 'Result' value to a 'Maybe' value. A 'Partial' result +-- is treated as failure. +maybeResult :: Result r -> Maybe r +maybeResult (Done _ r) = Just r +maybeResult _ = Nothing + +-- | Convert a 'Result' value to an 'Either' value. A 'Partial' result +-- is treated as failure. +eitherResult :: Result r -> Either String r +eitherResult (Done _ r) = Right r +eitherResult (Fail _ _ msg) = Left msg +eitherResult _ = Left "Result: incomplete input" diff --git a/Data/Attoparsec/Char8.hs b/Data/Attoparsec/Char8.hs --- a/Data/Attoparsec/Char8.hs +++ b/Data/Attoparsec/Char8.hs @@ -1,125 +1,320 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ -- | -- Module : Data.Attoparsec.Char8 --- Copyright : Daan Leijen 1999-2001, Jeremy Shaw 2006, Bryan O'Sullivan 2007-2009 +-- Copyright : Bryan O'Sullivan 2007-2010 -- License : BSD3 -- -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : unknown -- --- Simple, efficient, character-oriented parser combinators for lazy --- 'LB.ByteString' strings, loosely based on the Parsec library. --- --- /Note/: This module is intended for parsing text that is --- represented using an 8-bit character set, e.g. ASCII or --- ISO-8859-15. It /does not/ deal with character encodings, --- multibyte characters, or wide characters. Any attempts to use --- characters above code point 255 will give wrong answers. ------------------------------------------------------------------------------ +-- Simple, efficient, character-oriented combinator parsing for +-- 'B.ByteString' strings, loosely based on the Parsec library. + module Data.Attoparsec.Char8 ( + -- * Character encodings + -- $encodings + -- * Parser types - ParseError - , Parser + Parser + , A.Result(..) -- * Running parsers - , parse - , parseAt - , parseTest + , A.parse + , A.parseTest + , A.feed -- * Combinators - , () - , try + , (I.) + , I.try + , module Data.Attoparsec.Combinator -- * Parsing individual characters - , anyChar + , satisfy , char - , digit - , letter + , anyChar + , char8 , notChar + + -- ** Special character parsers + , digit + , letter_iso8859_15 + , letter_ascii , space - , satisfy - -- ** Character classes + -- ** Fast predicates + , isDigit + , isAlpha_iso8859_15 + , isAlpha_ascii + + -- *** Character classes , inClass , notInClass -- * Efficient string handling - , string + , I.string , stringCI , skipSpace , skipWhile - , takeAll - , takeCount + , I.take , takeTill , takeWhile , takeWhile1 - -- ** Combinators - , match - , notEmpty - -- * Text parsing - , endOfLine + , I.endOfLine + , isEndOfLine + , isHorizontalSpace -- * Numeric parsers - , int - , integer - , double - - -- * State observation functions - , endOfInput - , getConsumed - , getInput - , lookAhead + , decimal + , hexadecimal + , signed + --, double - -- * Combinators - , module Data.Attoparsec.Combinator + -- * State observation and manipulation functions + , I.endOfInput + , I.ensure ) where -import qualified Data.ByteString.Lazy.Char8 as LB -import Data.ByteString.Internal (w2c) -import Data.Char (isDigit, isLetter, isSpace, toLower) -import Data.Attoparsec.FastSet (charClass, memberChar) -import qualified Data.Attoparsec.Internal as I +import Control.Applicative ((*>), (<$>), (<|>)) import Data.Attoparsec.Combinator -import Data.Attoparsec.Internal - (Parser, ParseError, (), parse, parseAt, parseTest, try, endOfInput, - lookAhead, string, - getInput, getConsumed, takeAll, takeCount, notEmpty, match, - endOfLine, setInput) -import Data.ByteString.Lex.Lazy.Double (readDouble) +import Data.Attoparsec.FastSet (charClass, memberChar) +import Data.Attoparsec.Internal (Parser, ()) +import Data.ByteString.Internal (c2w, w2c) +import Data.Word (Word8) import Prelude hiding (takeWhile) +import qualified Data.Attoparsec as A +import qualified Data.Attoparsec.Internal as I +import qualified Data.ByteString as B8 +import qualified Data.ByteString.Char8 as B +-- $encodings +-- +-- This module is intended for parsing text that is +-- represented using an 8-bit character set, e.g. ASCII or +-- ISO-8859-15. It /does not/ make any attempt to deal with character +-- encodings, multibyte characters, or wide characters. In +-- particular, all attempts to use characters above code point U+00FF +-- will give wrong answers. +-- +-- Code points below U+0100 are simply translated to and from their +-- numeric values, so e.g. the code point U+00A4 becomes the byte +-- @0xA4@ (which is the Euro symbol in ISO-8859-15, but the generic +-- currency sign in ISO-8859-1). Haskell 'Char' values above U+00FF +-- are truncated, so e.g. U+1D6B7 is truncated to the byte @0xB7@. + +-- ASCII-specific but fast, oh yes. +toLower :: Word8 -> Word8 +toLower w | w >= 65 && w <= 90 = w + 32 + | otherwise = w + -- | Satisfy a literal string, ignoring case. -stringCI :: LB.ByteString -> Parser LB.ByteString -stringCI = I.stringTransform (LB.map toLower) +stringCI :: B.ByteString -> Parser B.ByteString +stringCI = I.stringTransform (B8.map toLower) {-# INLINE stringCI #-} -takeWhile1 :: (Char -> Bool) -> Parser LB.ByteString +-- | 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 byte +-- of input: it will fail if the predicate never returns 'True' or if +-- there is no input left. +takeWhile1 :: (Char -> Bool) -> Parser B.ByteString takeWhile1 p = I.takeWhile1 (p . w2c) {-# INLINE takeWhile1 #-} -numeric :: String -> (LB.ByteString -> Maybe (a,LB.ByteString)) -> Parser a -numeric desc f = do - s <- getInput - case f s of - Nothing -> fail desc - Just (i,s') -> setInput s' >> return i - --- | Parse an integer. The position counter is not updated. -int :: Parser Int -int = numeric "Int" LB.readInt +-- | The parser @satisfy p@ succeeds for any byte for which the +-- predicate @p@ returns 'True'. Returns the byte that is actually +-- parsed. +-- +-- >digit = satisfy isDigit +-- > where isDigit c = c >= '0' && c <= '9' +satisfy :: (Char -> Bool) -> Parser Char +satisfy = I.satisfyWith w2c +{-# INLINE satisfy #-} --- | Parse an integer. The position counter is not updated. -integer :: Parser Integer -integer = numeric "Integer" LB.readInteger +-- | Match a letter, in the ISO-8859-15 encoding. +letter_iso8859_15 :: Parser Char +letter_iso8859_15 = satisfy isAlpha_iso8859_15 "letter_iso8859_15" +{-# INLINE letter_iso8859_15 #-} +-- | Match a letter, in the ASCII encoding. +letter_ascii :: Parser Char +letter_ascii = satisfy isAlpha_ascii "letter_ascii" +{-# INLINE letter_ascii #-} + +-- | A fast alphabetic predicate for the ISO-8859-15 encoding +-- +-- /Note/: For all character encodings other than ISO-8859-15, and +-- almost all Unicode code points above U+00A3, this predicate gives +-- /wrong answers/. +isAlpha_iso8859_15 :: Char -> Bool +isAlpha_iso8859_15 c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || + (c >= '\166' && moby c) + where moby = notInClass "\167\169\171-\179\182\183\185\187\191\215\247" + {-# NOINLINE moby #-} +{-# INLINE isAlpha_iso8859_15 #-} + +-- | A fast alphabetic predicate for the ASCII encoding +-- +-- /Note/: For all character encodings other than ASCII, and +-- almost all Unicode code points above U+007F, this predicate gives +-- /wrong answers/. +isAlpha_ascii :: Char -> Bool +isAlpha_ascii c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') +{-# INLINE isAlpha_ascii #-} + +-- | Parse a single digit. +digit :: Parser Char +digit = satisfy isDigit "digit" +{-# INLINE digit #-} + +-- | A fast digit predicate. +isDigit :: Char -> Bool +isDigit c = c >= '0' && c <= '9' +{-# INLINE isDigit #-} + +-- | Match any character. +anyChar :: Parser Char +anyChar = satisfy $ const True +{-# INLINE anyChar #-} + +-- | Fast predicate for matching a space character. +-- +-- /Note/: This predicate only gives correct answers for the ASCII +-- encoding. For instance, it does not recognise U+00A0 (non-breaking +-- space) as a space character, even though it is a valid ISO-8859-15 +-- byte. +isSpace :: Char -> Bool +isSpace c = c `B.elem` spaces + where spaces = B.pack " \n\r\t\v\f" + {-# NOINLINE spaces #-} +{-# INLINE isSpace #-} + +-- | Parse a space character. +-- +-- /Note/: This parser only gives correct answers for the ASCII +-- encoding. For instance, it does not recognise U+00A0 (non-breaking +-- space) as a space character, even though it is a valid ISO-8859-15 +-- byte. +space :: Parser Char +space = satisfy isSpace "space" +{-# INLINE space #-} + +-- | Match a specific character. +char :: Char -> Parser Char +char c = satisfy (== c) [c] +{-# INLINE char #-} + +-- | Match a specific character, but return its 'Word8' value. +char8 :: Char -> Parser Word8 +char8 c = I.satisfy (== c2w c) [c] +{-# INLINE char8 #-} + +-- | Match any character except the given one. +notChar :: Char -> Parser Char +notChar c = satisfy (/= c) "not " ++ [c] +{-# INLINE notChar #-} + +-- | Match any character in a set. +-- +-- >vowel = inClass "aeiou" +-- +-- Range notation is supported. +-- +-- >halfAlphabet = inClass "a-nA-N" +-- +-- To add a literal \'-\' to a set, place it at the beginning or end +-- of the string. +inClass :: String -> Char -> Bool +inClass s = (`memberChar` mySet) + where mySet = charClass s +{-# INLINE inClass #-} + +-- | Match any character not in a set. +notInClass :: String -> Char -> Bool +notInClass s = not . inClass s +{-# INLINE notInClass #-} + +-- | 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 byte of 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. +takeWhile :: (Char -> Bool) -> Parser B.ByteString +takeWhile p = I.takeWhile (p . w2c) +{-# INLINE takeWhile #-} + +-- | 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 byte of 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. +takeTill :: (Char -> Bool) -> Parser B.ByteString +takeTill p = I.takeTill (p . w2c) +{-# INLINE takeTill #-} + +-- | Skip past input for as long as the predicate returns 'True'. +skipWhile :: (Char -> Bool) -> Parser () +skipWhile p = I.skipWhile (p . w2c) +{-# INLINE skipWhile #-} + +-- | Skip over white space. +skipSpace :: Parser () +skipSpace = skipWhile isSpace >> return () +{-# INLINE skipSpace #-} + +-- | A predicate that matches either a carriage return @\'\\r\'@ or +-- newline @\'\\n\'@ character. +isEndOfLine :: Word8 -> Bool +isEndOfLine w = w == 13 || w == 10 +{-# INLINE isEndOfLine #-} + +-- | A predicate that matches either a space @\' \'@ or horizontal tab +-- @\'\\t\'@ character. +isHorizontalSpace :: Word8 -> Bool +isHorizontalSpace w = w == 32 || w == 9 +{-# INLINE isHorizontalSpace #-} + +{- -- | Parse a Double. The position counter is not updated. double :: Parser Double double = numeric "Double" readDouble +-} -#define PARSER Parser -#include "Char8Boilerplate.h" +-- | 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 :: Integral a => Parser a +{-# SPECIALISE hexadecimal :: Parser Int #-} +hexadecimal = B8.foldl' step 0 `fmap` I.takeWhile1 isHexDigit + where isHexDigit w = (w >= 48 && w <= 57) || (x >= 97 && x <= 102) + where x = toLower w + step a w | w >= 48 && w <= 57 = a * 16 + fromIntegral (w - 48) + | otherwise = a * 16 + fromIntegral (x - 87) + where x = toLower w + +-- | Parse and decode an unsigned decimal number. +decimal :: Integral a => Parser a +{-# SPECIALISE decimal :: Parser Int #-} +decimal = B8.foldl' step 0 `fmap` I.takeWhile1 isDig + where isDig w = w >= 48 && w <= 57 + step a w = a * 10 + fromIntegral (w - 48) + +-- | Parse a number with an optional leading @\'+\'@ or @\'-\'@ sign +-- character. +signed :: Num a => Parser a -> Parser a +{-# SPECIALISE signed :: Parser Int -> Parser Int #-} +signed p = (negate <$> char8 '-' *> p) + <|> (char8 '+' *> p) + <|> p diff --git a/Data/Attoparsec/Char8Boilerplate.h b/Data/Attoparsec/Char8Boilerplate.h deleted file mode 100644 --- a/Data/Attoparsec/Char8Boilerplate.h +++ /dev/null @@ -1,72 +0,0 @@ --- -*- haskell -*- - --- | Character parser. -satisfy :: (Char -> Bool) -> PARSER Char -satisfy p = w2c <$> I.satisfy (p . w2c) -{-# INLINE satisfy #-} - -letter :: PARSER Char -letter = satisfy isLetter "letter" -{-# INLINE letter #-} - -digit :: PARSER Char -digit = satisfy isDigit "digit" -{-# INLINE digit #-} - -anyChar :: PARSER Char -anyChar = satisfy $ const True -{-# INLINE anyChar #-} - -space :: PARSER Char -space = satisfy isSpace "space" -{-# INLINE space #-} - --- | Match a specific character. -char :: Char -> PARSER Char -char c = satisfy (== c) [c] -{-# INLINE char #-} - --- | Match any character except the given one. -notChar :: Char -> PARSER Char -notChar c = satisfy (/= c) "not " ++ [c] -{-# INLINE notChar #-} - --- | Match any character in a set. --- --- > vowel = inClass "aeiou" --- --- Range notation is supported. --- --- > halfAlphabet = inClass "a-nA-N" --- --- To add a literal \'-\' to a set, place it at the beginning or end --- of the string. -inClass :: String -> Char -> Bool -inClass s = (`memberChar` mySet) - where mySet = charClass s -{-# INLINE inClass #-} - --- | Match any character not in a set. -notInClass :: String -> Char -> Bool -notInClass s = not . inClass s -{-# INLINE notInClass #-} - --- | Consume characters while the predicate succeeds. -takeWhile :: (Char -> Bool) -> PARSER LB.ByteString -takeWhile p = I.takeWhile (p . w2c) -{-# INLINE takeWhile #-} - --- | Consume characters while the predicate fails. -takeTill :: (Char -> Bool) -> PARSER LB.ByteString -takeTill p = I.takeTill (p . w2c) -{-# INLINE takeTill #-} - --- | Skip over characters while the predicate succeeds. -skipWhile :: (Char -> Bool) -> PARSER () -skipWhile p = I.skipWhile (p . w2c) -{-# INLINE skipWhile #-} - --- | Skip over white space. -skipSpace :: PARSER () -skipSpace = takeWhile isSpace >> return () -{-# INLINE skipSpace #-} diff --git a/Data/Attoparsec/Combinator.hs b/Data/Attoparsec/Combinator.hs --- a/Data/Attoparsec/Combinator.hs +++ b/Data/Attoparsec/Combinator.hs @@ -1,8 +1,7 @@ {-# LANGUAGE BangPatterns, CPP #-} ------------------------------------------------------------------------------ -- | -- Module : Data.Attoparsec.Combinator --- Copyright : Daan Leijen 1999-2001, Bryan O'Sullivan 2009 +-- Copyright : Daan Leijen 1999-2001, Bryan O'Sullivan 2009-2010 -- License : BSD3 -- -- Maintainer : bos@serpentine.com @@ -10,8 +9,6 @@ -- Portability : portable -- -- Useful parser combinators, similar to those provided by Parsec. --- ------------------------------------------------------------------------------ module Data.Attoparsec.Combinator ( choice @@ -24,10 +21,18 @@ , skipMany , skipMany1 , eitherP - , module Control.Applicative + + -- * Inlined implementations of existing functions + -- + -- These are exact duplicates of functions already exported by the + -- 'Control.Applicative' module, but whose definitions are + -- inlined. In many cases, this leads to 2x performance + -- improvements. + , many ) where -import Control.Applicative +import Control.Applicative (Alternative, Applicative(..), empty, liftA2, + (<|>), (*>), (<$>)) -- | @choice ps@ tries to apply the actions in the list @ps@ in order, -- until one of them succeeds. Returns the value of the succeeding @@ -49,6 +54,7 @@ -- > word = many1 letter many1 :: Alternative f => f a -> f [a] many1 p = liftA2 (:) 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@. @@ -95,3 +101,10 @@ eitherP :: (Alternative f) => f a -> f b -> f (Either a b) eitherP a b = (Left <$> a) <|> (Right <$> b) {-# INLINE eitherP #-} + +-- | Zero or more. +many :: (Alternative f) => f a -> f [a] +many v = many_v + where many_v = some_v <|> pure [] + some_v = (:) <$> v <*> many_v +{-# INLINE many #-} diff --git a/Data/Attoparsec/FastSet.hs b/Data/Attoparsec/FastSet.hs --- a/Data/Attoparsec/FastSet.hs +++ b/Data/Attoparsec/FastSet.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, MagicHash #-} ----------------------------------------------------------------------------- -- | @@ -32,16 +32,17 @@ , charClass ) where -import Data.Bits ((.&.), (.|.), shiftL, shiftR) -import qualified Data.ByteString.Char8 as B8 +import Data.Bits ((.&.), (.|.)) +import Foreign.Storable (peekByteOff, pokeByteOff) +import GHC.Base (Int(I#), iShiftRA#, narrow8Word#, shiftL#) +import GHC.Word (Word8(W8#)) import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Internal as I import qualified Data.ByteString.Unsafe as U -import Data.Word (Word8) -import Foreign.Storable (peekByteOff, pokeByteOff) -data FastSet = Sorted { fromSet :: {-# UNPACK #-} !B.ByteString } - | Table { fromSet :: {-# UNPACK #-} !B.ByteString } +data FastSet = Sorted { fromSet :: !B.ByteString } + | Table { fromSet :: !B.ByteString } deriving (Eq, Ord) instance Show FastSet where @@ -61,14 +62,23 @@ fromList :: [Word8] -> FastSet fromList = set . B.pack -index :: Int -> (Int, Word8) -index i = (i `shiftR` 3, 1 `shiftL` (i .&. 7)) +data I = I {-# UNPACK #-} !Int {-# UNPACK #-} !Word8 +shiftR :: Int -> Int -> Int +shiftR (I# x#) (I# i#) = I# (x# `iShiftRA#` i#) + +shiftL :: Word8 -> Int -> Word8 +shiftL (W8# x#) (I# i#) = W8# (narrow8Word# (x# `shiftL#` i#)) + +index :: Int -> I +index i = I (i `shiftR` 3) (1 `shiftL` (i .&. 7)) +{-# INLINE index #-} + -- | Check the set for membership. memberWord8 :: Word8 -> FastSet -> Bool memberWord8 w (Table t) = - let (byte,bit) = index (fromIntegral w) - in U.unsafeIndex t byte .&. bit /= 0 + let I byte bit = index (fromIntegral w) + in U.unsafeIndex t byte .&. bit /= 0 memberWord8 w (Sorted s) = search 0 (B.length s - 1) where search lo hi | hi < lo = False @@ -83,6 +93,7 @@ -- characters above code point 255 will give wrong answers. memberChar :: Char -> FastSet -> Bool memberChar c = memberWord8 (I.c2w c) +{-# INLINE memberChar #-} mkTable :: B.ByteString -> B.ByteString mkTable s = I.unsafeCreate 32 $ \t -> do @@ -91,7 +102,7 @@ let loop n | n == l = return () | otherwise = do c <- peekByteOff p n :: IO Word8 - let (byte,bit) = index (fromIntegral c) + let I byte bit = index (fromIntegral c) prev <- peekByteOff t byte :: IO Word8 pokeByteOff t byte (prev .|. bit) loop (n + 1) diff --git a/Data/Attoparsec/Incremental.hs b/Data/Attoparsec/Incremental.hs deleted file mode 100644 --- a/Data/Attoparsec/Incremental.hs +++ /dev/null @@ -1,328 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Attoparsec.Incremental --- Copyright : Bryan O'Sullivan 2009 --- License : BSD3 --- --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : unknown --- --- Simple, efficient, and incremental parser combinators for lazy --- 'L.ByteString' strings, loosely based on the Parsec library. --- --- This module is heavily influenced by Adam Langley's incremental --- parser in his @binary-strict@ package. --- ------------------------------------------------------------------------------ -module Data.Attoparsec.Incremental - ( - -- * Incremental parsing - -- $incremental - - -- * Parser types - Parser - , Result(..) - - -- * Running parsers - , parse - , parseWith - , parseTest - - -- * Combinators - , () - , try - - -- * Parsing individual bytes - , word8 - , notWord8 - , anyWord8 - , satisfy - - -- * Efficient string handling - , string - , skipWhile - , takeCount - , takeTill - , takeWhile - - -- * State observation and manipulation functions - , endOfInput - , pushBack - , yield - - -- * Combinators - , module Data.Attoparsec.Combinator - ) where - -import Data.Attoparsec.Combinator -import Control.Monad (MonadPlus(..), ap) -import Data.Attoparsec.Internal ((+:)) -import Data.Word (Word8) -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Internal as L -import Prelude hiding (takeWhile) - --- $incremental --- Incremental parsing makes it possible to supply a parser with only --- a limited amount of input. If the parser cannot complete due to --- lack of data, it will return a 'Partial' result with a continuation --- to which more input can be supplied, as follows: --- --- > case parse myParser someInput of --- > Partial k -> k moreInput --- --- To signal that no more input is available, pass an empty --- string to this continuation. - -data S = S {-# UNPACK #-} !S.ByteString -- first chunk of input - L.ByteString -- rest of input - [L.ByteString] -- input acquired during backtracks - !Bool -- have we hit EOF yet? - {-# UNPACK #-} !Int -- failure depth - --- | The result of a partial parse. -data Result a = Failed String - -- ^ The parse failed, with the given error message. - | Done L.ByteString a - -- ^ The parse succeeded, producing the given - -- result. The 'L.ByteString' contains any unconsumed - -- input. - | Partial (L.ByteString -> Result a) - -- ^ The parse ran out of data before finishing. To - -- resume the parse, pass more data to the given - -- continuation. - -instance (Show a) => Show (Result a) where - show (Failed err) = "Failed " ++ show err - show (Done L.Empty rs) = "Done Empty " ++ show rs - show (Done rest rs) = "Done (" ++ show rest ++ ") " ++ show rs - show (Partial _) = "Partial" - --- | This is the internal version of the above. This is the type which --- is actually used by the code, as it has the extra information --- needed for backtracking. This is converted to a friendly 'Result' --- type just before giving it to the outside world. -data IResult a = IFailed S String - | IDone S a - | IPartial (L.ByteString -> IResult a) - -instance Show (IResult a) where - show (IFailed _ err) = "IFailed " ++ show err - show (IDone _ _) = "IDone" - show (IPartial _) = "IPartial" - --- | The parser type. -newtype Parser r a = Parser { - unParser :: S -> (a -> S -> IResult r) -> IResult r - } - -instance Monad (Parser r) where - return a = Parser $ \s k -> k a s - m >>= k = Parser $ \s cont -> unParser m s $ \a s' -> unParser (k a) s' cont - fail err = Parser $ \s -> const $ IFailed s err - -zero :: Parser r a -zero = fail "" - --- | I'm not sure if this is a huge bodge or not. It probably is. --- --- When performing a choice (in @plus@), the failure depth in the --- current state is incremented. If a failure is generated inside the --- attempted path, the state carried in the IFailure will have this --- incremented failure depth. However, we don't want to backtrack --- after the attempted path has completed. Thus we insert this cut --- continuation, which decrements the failure count of any failure --- passing though, thus it would be caught in @plus@ and doesn't --- trigger a backtrack. -cutContinuation :: (a -> S -> IResult r) -> a -> S -> IResult r -cutContinuation k v s = - case k v s of - IFailed (S lb i adds eof failDepth) err -> IFailed (S lb i adds eof (failDepth - 1)) err - x -> x - -appL :: L.ByteString -> L.ByteString -> L.ByteString -appL xs L.Empty = xs -appL L.Empty ys = ys -appL xs ys = xs `L.append` ys - -plus :: Parser r a -> Parser r a -> Parser r a -plus p1 p2 = - Parser $ \(S sb lb adds eof failDepth) k -> - let - filt f@(IFailed (S _ _ adds' eof' failDepth') _) - | failDepth' == failDepth + 1 = - let lb' = lb `appL` L.concat (reverse adds') - in unParser p2 (S sb lb' (adds' ++ adds) eof' failDepth) k - | otherwise = f - filt (IPartial cont) = IPartial (filt . cont) - filt v@(IDone _ _) = v - in - filt $ unParser p1 (S sb lb [] eof (failDepth + 1)) (cutContinuation k) - --- | This is a no-op combinator for compatibility. -try :: Parser r a -> Parser r a -try p = p - -instance Functor (Parser r) where - fmap f m = Parser $ \s cont -> unParser m s (cont . f) - -infix 0 - --- | Name the parser, in case failure occurs. -() :: Parser r a - -> String -- ^ the name to use if parsing fails - -> Parser r a -{-# INLINE () #-} -p msg = - Parser $ \st k -> - case unParser p st k of - IFailed st' _ -> IFailed st' msg - ok -> ok - -initState :: L.ByteString -> S -initState (L.Chunk sb lb) = S sb lb [] False 0 -initState _ = S S.empty L.empty [] False 0 - -mkState :: L.ByteString -> [L.ByteString] -> Bool -> Int -> S -mkState bs adds eof failDepth = - case bs of - L.Empty -> S S.empty L.empty adds eof failDepth - L.Chunk sb lb -> S sb lb adds eof failDepth - -addX :: L.ByteString -> [L.ByteString] -> [L.ByteString] -addX s adds | L.null s = adds - | otherwise = s : adds - --- | Resume our caller, handing back a 'Partial' result. This function --- is probably not useful, but provided for completeness. -yield :: Parser r () -yield = Parser $ \(S sb lb adds eof failDepth) k -> - IPartial $ \s -> k () (S sb (lb `appL` s) (addX s adds) eof failDepth) - -continue :: (S -> IResult r) -> Parser r a - -> (a -> S -> IResult r) -> S -> IResult r -continue onEOF p k (S _sb _lb adds eof failDepth) = - if eof - then onEOF (S S.empty L.empty adds True failDepth) - else IPartial $ \s -> let st = contState s adds failDepth - in unParser p st k - -takeWith :: (L.ByteString -> (L.ByteString, L.ByteString)) - -> Parser r L.ByteString -takeWith splitf = - Parser $ \st@(S sb lb adds eof failDepth) k -> - let (left,rest) = splitf (sb +: lb) - in if L.null rest - then continue (k left) (takeWith splitf) (k . appL left) st - else k left (mkState rest adds eof failDepth) - --- | Consume bytes while the predicate succeeds. -takeWhile :: (Word8 -> Bool) -> Parser r L.ByteString -takeWhile = takeWith . L.span - --- | Consume bytes while the predicate fails. If the predicate never --- succeeds, the entire input string is returned. -takeTill :: (Word8 -> Bool) -> Parser r L.ByteString -takeTill = takeWith . L.break - --- | Return exactly the given number of bytes. If not enough are --- available, fail. -takeCount :: Int -> Parser r L.ByteString -takeCount = tc . fromIntegral where - tc n = Parser $ \st@(S sb lb adds eof failDepth) k -> - let (h,t) = L.splitAt n (sb +: lb) - l = L.length h - in if L.length h == n - then k h (mkState t adds eof failDepth) - else continue (`IFailed` "takeCount: EOF") - (tc (n - l)) (k . appL h) st - --- | Match a literal string exactly. -string :: L.ByteString -> Parser r L.ByteString -string s = - Parser $ \st@(S sb lb adds eof failDepth) k -> - case L.splitAt (L.length s) (sb +: lb) of - (h,t) - | h == s -> k s (mkState t adds eof failDepth) - (h,L.Empty) - | h `L.isPrefixOf` s -> - continue (`IFailed` "string: EOF") - (string (L.drop (L.length h) s)) - (k . appL h) - st - _ -> IFailed st "string failed to match" - -contState :: L.ByteString -> [L.ByteString] -> Int -> S -contState s adds failDepth - | L.null s = S S.empty L.empty [] True failDepth - | otherwise = mkState s (addX s adds) False failDepth - --- | Match a single byte based on the given predicate. -satisfy :: (Word8 -> Bool) -> Parser r Word8 -satisfy p = - Parser $ \st@(S sb lb adds eof failDepth) k -> - case S.uncons sb of - Just (w, sb') | p w -> k w (S sb' lb adds eof failDepth) - | otherwise -> IFailed st "failed to match" - Nothing -> case L.uncons lb of - Just (w, lb') | p w -> k w (mkState lb' adds eof failDepth) - | otherwise -> IFailed st "failed to match" - Nothing -> continue (`IFailed` "satisfy: EOF") - (satisfy p) k st - --- | Force the given string to appear next in the input stream. -pushBack :: L.ByteString -> Parser r () -pushBack bs = - Parser $ \(S sb lb adds eof failDepth) k -> - k () (mkState (bs `appL` (sb +: lb)) adds eof failDepth) - --- | Succeed if we have reached the end of the input string. -endOfInput :: Parser r () -endOfInput = Parser $ \st@(S sb lb _adds _eof _failDepth) k -> - if not (S.null sb) || not (L.null lb) - then IFailed st "endOfInput: not EOF" - else continue (k ()) endOfInput k st - -toplevelTranslate :: IResult a -> Result a -toplevelTranslate (IFailed _ err) = Failed err -toplevelTranslate (IDone (S sb lb _ _ _) value) = Done (sb +: lb) value -toplevelTranslate (IPartial k) = Partial $ toplevelTranslate . k - -terminalContinuation :: a -> S -> IResult a -terminalContinuation v s = IDone s v - --- | Run a parser. -parse :: Parser r r -> L.ByteString -> Result r -parse m input = - toplevelTranslate $ unParser m (initState input) terminalContinuation - --- | Run a parser, using the given function to resupply it with input. --- --- Here's an example that shows how to parse data from a socket, using --- Johan Tibbell's @network-bytestring@ package. --- --- > import qualified Data.ByteString.Lazy as L --- > import Data.Attoparsec.Incremental (Parser, Result, parseWith) --- > import Network.Socket.ByteString.Lazy (recv_) --- > import Network.Socket (Socket) --- > --- > netParse :: Parser r r -> Socket -> IO (Result r) --- > netParse p sock = parseWith (recv_ sock 65536) p L.empty -parseWith :: Applicative f => f L.ByteString -- ^ resupply parser with input - -> Parser r r -- ^ parser to run - -> L.ByteString -- ^ initial input - -> f (Result r) -parseWith refill p s = - case parse p s of - Partial k -> k <$> refill - ok -> pure ok - --- | Try out a parser, and print its result. -parseTest :: (Show r) => Parser r r -> L.ByteString -> IO () -parseTest p s = print (parse p s) - -#define PARSER Parser r -#include "Word8Boilerplate.h" diff --git a/Data/Attoparsec/Incremental/Char8.hs b/Data/Attoparsec/Incremental/Char8.hs deleted file mode 100644 --- a/Data/Attoparsec/Incremental/Char8.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Attoparsec.Incremental.Char8 --- Copyright : Bryan O'Sullivan 2009 --- License : BSD3 --- --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : unknown --- --- Simple, efficient, character-oriented, and incremental parser --- combinators for lazy 'L.ByteString' strings, loosely based on the --- Parsec library. --- --- /Note/: This module is intended for parsing text that is --- represented using an 8-bit character set, e.g. ASCII or --- ISO-8859-15. It /does not/ deal with character encodings, --- multibyte characters, or wide characters. Any attempts to use --- characters above code point 255 will give wrong answers. ------------------------------------------------------------------------------ -module Data.Attoparsec.Incremental.Char8 - ( - -- * Parser types - Parser - , Result(..) - - -- * Running parsers - , parse - , parseWith - , parseTest - - -- * Combinators - , () - , try - - -- * Parsing individual characters - , satisfy - , letter - , digit - , anyChar - , space - , char - , notChar - - -- ** Character classes - , inClass - , notInClass - - -- * Efficient string handling - , string - , skipSpace - , skipWhile - , takeCount - , takeTill - , takeWhile - - -- * Text parsing - , endOfLine - - -- * Numeric parsers - , int - , integer - , double - - -- * State observation and manipulation functions - , endOfInput - , pushBack - , yield - - -- * Combinators - , module Data.Attoparsec.Combinator - ) where - -import qualified Data.ByteString.Lazy.Char8 as LB -import Data.ByteString.Internal (w2c) -import Data.Char (isDigit, isLetter, isSpace) -import Data.Attoparsec.FastSet (charClass, memberChar) -import qualified Data.Attoparsec.Incremental as I -import Data.Attoparsec.Incremental - (Parser, Result(..), (), endOfInput, parse, parseWith, parseTest, - pushBack, string, takeCount, try, yield) -import Data.ByteString.Lex.Lazy.Double (readDouble) -import Prelude hiding (takeWhile) -import Data.Attoparsec.Combinator - -numeric :: String -> (Char -> Bool) - -> (LB.ByteString -> Maybe (a,LB.ByteString)) -> Parser r a -numeric desc p f = do - s <- takeWhile p - case f s of - Nothing -> pushBack s >> fail desc - Just (i,s') -> pushBack s' >> return i - -isIntegral :: Char -> Bool -isIntegral c = isDigit c || c == '-' - --- | Parse an 'Int'. -int :: Parser r Int -int = numeric "Int" isIntegral LB.readInt - --- | Parse an 'Integer'. -integer :: Parser r Integer -integer = numeric "Integer" isIntegral LB.readInteger - --- | Parse a 'Double'. -double :: Parser r Double -double = numeric "Double" isDouble readDouble - where isDouble c = isIntegral c || c == 'e' || c == '+' - --- | Match the end of a line. This may be any of a newline character, --- a carriage return character, or a carriage return followed by a newline. -endOfLine :: Parser r () -endOfLine = (char '\n' *> pure ()) <|> (string crlf *> pure ()) - where crlf = LB.pack "\r\n" - -#define PARSER Parser r -#include "../Char8Boilerplate.h" diff --git a/Data/Attoparsec/Internal.hs b/Data/Attoparsec/Internal.hs --- a/Data/Attoparsec/Internal.hs +++ b/Data/Attoparsec/Internal.hs @@ -1,337 +1,441 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ +{-# LANGUAGE Rank2Types, RecordWildCards #-} -- | -- Module : Data.Attoparsec.Internal --- Copyright : Daan Leijen 1999-2001, Jeremy Shaw 2006, Bryan O'Sullivan 2007-2008 +-- Copyright : Bryan O'Sullivan 2007-2010 -- License : BSD3 -- -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : unknown -- --- Simple, efficient parser combinators for lazy 'LB.ByteString' --- strings, loosely based on 'Text.ParserCombinators.Parsec'. --- ------------------------------------------------------------------------------ +-- Simple, efficient parser combinators for 'B.ByteString' strings, +-- loosely based on the Parsec library. + module Data.Attoparsec.Internal ( -- * Parser types - ParseError - , Parser + Parser + , Result(..) + , S(input) -- * Running parsers , parse - , parseAt - , parseTest -- * Combinators , () , try + , module Data.Attoparsec.Combinator -- * Parsing individual bytes , satisfy + , satisfyWith , anyWord8 , word8 , notWord8 + -- ** Byte classes + , inClass + , notInClass + + -- * Parsing more complicated structures + , storable + -- * Efficient string handling - , match - , notEmpty , skipWhile , string , stringTransform - , takeAll - , takeCount - , takeTill + , take , takeWhile , takeWhile1 + , takeTill - -- * State observation functions + -- * State observation and manipulation functions , endOfInput - , getConsumed - , getInput - , lookAhead - , setInput + , ensure -- * Utilities , endOfLine - , (+:) ) where -import Control.Applicative - (Alternative(..), Applicative(..), (*>)) -import Control.Monad (MonadPlus(..), ap) -import Control.Monad.Fix (MonadFix(..)) -import qualified Data.ByteString as SB -import qualified Data.ByteString.Lazy as LB -import qualified Data.ByteString.Lazy.Char8 as L8 -import qualified Data.ByteString.Unsafe as U -import qualified Data.ByteString.Internal as I -import qualified Data.ByteString.Lazy.Internal as LB -import Data.Int (Int64) +import Control.Applicative (Alternative(..), Applicative(..), (<$>)) +import Control.Monad (MonadPlus(..), when) +import Data.Attoparsec.Combinator +import Data.Attoparsec.FastSet (charClass, memberWord8) +import Data.Monoid (Monoid(..)) import Data.Word (Word8) -import Prelude hiding (takeWhile) - --- ^ A description of a parsing error. -type ParseError = String +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr (castPtr, plusPtr) +import Foreign.Storable (Storable(peek, sizeOf)) +import Prelude hiding (getChar, take, takeWhile) +import qualified Data.ByteString as B8 +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Unsafe as B --- State invariants: --- * If both strict and lazy bytestrings are empty, the entire input --- is considered to be empty. -data S = S {-# UNPACK #-} !SB.ByteString - LB.ByteString - {-# UNPACK #-} !Int64 +data Result r = Fail S [String] String + | Partial (B.ByteString -> Result r) + | Done S r --- ^ A parser that produces a result of type @a@. +-- | The 'Parser' type is a monad. newtype Parser a = Parser { - unParser :: S -> Either (LB.ByteString, [String]) (a, S) + runParser :: forall r. S + -> Failure r + -> Success a r + -> Result r } -instance Functor Parser where - fmap f p = - Parser $ \s -> - case unParser p s of - Right (a, s') -> Right (f a, s') - Left err -> Left err +type Failure r = S -> [String] -> String -> Result r +type Success a r = S -> a -> Result r -instance Monad Parser where - return a = Parser $ \s -> Right (a, s) - m >>= f = Parser $ \s -> - case unParser m s of - Right (a, s') -> unParser (f a) s' - Left (s', msgs) -> Left (s', msgs) - fail err = Parser $ \(S sb lb _) -> Left (sb +: lb, [err]) +-- | Have we read all available input? +data More = Complete | Incomplete + deriving (Eq, Show) -instance MonadFix Parser where - mfix f = Parser $ \s -> - let r = case r of - Right (a, _) -> unParser (f a) s - err -> err - in r +plusMore :: More -> More -> More +plusMore Complete _ = Complete +plusMore _ Complete = Complete +plusMore _ _ = Incomplete +{-# INLINE plusMore #-} -zero :: Parser a -zero = Parser $ \(S sb lb _) -> Left (sb +: lb, []) -{-# INLINE zero #-} +instance Monoid More where + mempty = Incomplete + mappend = plusMore +data S = S { + input :: !B.ByteString + , _added :: !B.ByteString + , more :: !More + } deriving (Show) + +instance Show r => Show (Result r) where + show (Fail _ stack msg) = "Fail " ++ show stack ++ " " ++ show msg + show (Partial _) = "Partial _" + show (Done bs r) = "Done " ++ show bs ++ " " ++ show r + +addS :: S -> S -> S +addS (S s0 a0 c0) (S _s1 a1 c1) = S (s0 +++ a1) (a0 +++ a1) (mappend c0 c1) +{-# INLINE addS #-} + +instance Monoid S where + mempty = S B.empty B.empty Incomplete + mappend = addS + +bindP :: Parser a -> (a -> Parser b) -> Parser b +bindP m g = + Parser (\st0 kf ks -> runParser m st0 kf (\s a -> runParser (g a) s kf ks)) +{-# INLINE bindP #-} + +returnP :: a -> Parser a +returnP a = Parser (\st0 _kf ks -> ks st0 a) +{-# INLINE returnP #-} + +instance Monad Parser where + return = returnP + (>>=) = bindP + fail = failDesc + +noAdds :: S -> S +noAdds (S s0 _a0 c0) = S s0 B.empty c0 +{-# INLINE noAdds #-} + plus :: Parser a -> Parser a -> Parser a -plus p1 p2 = - Parser $ \s@(S sb lb _) -> - case unParser p1 s of - Left (_, msgs1) -> - case unParser p2 s of - Left (_, msgs2) -> Left (sb +: lb, (msgs1 ++ msgs2)) - ok -> ok - ok -> ok +plus a b = Parser $ \st0 kf ks -> + let kf' st1 _ _ = runParser b (mappend st0 st1) kf ks + !st2 = noAdds st0 + in runParser a st2 kf' ks {-# INLINE plus #-} -mkState :: LB.ByteString -> Int64 -> S -mkState s = case s of - LB.Empty -> S SB.empty s - LB.Chunk x xs -> S x xs +instance MonadPlus Parser where + mzero = failDesc "mzero" + mplus = plus --- | Turn our split representation back into a normal lazy ByteString. -(+:) :: SB.ByteString -> LB.ByteString -> LB.ByteString -sb +: lb | SB.null sb = lb - | otherwise = LB.Chunk sb lb -{-# INLINE (+:) #-} +fmapP :: (a -> b) -> Parser a -> Parser b +fmapP p m = Parser (\st0 f k -> runParser m st0 f (\s a -> k s (p a))) +{-# INLINE fmapP #-} -infix 0 +instance Functor Parser where + fmap = fmapP --- | Name the parser, in case failure occurs. -() :: Parser a - -> String -- ^ the name to use if parsing fails - -> Parser a -p msg = - Parser $ \s@(S sb lb _) -> - case unParser p s of - (Left _) -> Left (sb +: lb, [msg]) - ok -> ok -{-# INLINE () #-} +apP :: Parser (a -> b) -> Parser a -> Parser b +apP d e = do + b <- d + a <- e + return (b a) +{-# INLINE apP #-} -nextChunk :: Parser () -nextChunk = Parser $ \(S _ lb n) -> - case lb of - LB.Chunk sb' lb' -> Right ((), S sb' lb' n) - LB.Empty -> Left (lb, []) +instance Applicative Parser where + pure = returnP + (<*>) = apP --- | Get remaining input. -getInput :: Parser LB.ByteString -getInput = Parser $ \s@(S sb lb _) -> Right (sb +: lb, s) +instance Alternative Parser where + empty = failDesc "empty" + (<|>) = plus --- | Set the remaining input. -setInput :: LB.ByteString -> Parser () -setInput bs = Parser $ \(S _ _ n) -> Right ((), mkState bs n) +failDesc :: String -> Parser a +failDesc err = Parser (\st0 kf _ks -> kf st0 [] msg) + where msg = "Failed reading: " ++ err +{-# INLINE failDesc #-} --- | Get number of bytes consumed so far. -getConsumed :: Parser Int64 -getConsumed = Parser $ \s@(S _ _ n) -> Right (n, s) +-- | Succeed only if at least @n@ bytes of input are available. +ensure :: Int -> Parser () +ensure n = Parser $ \st0@(S s0 _a0 _c0) kf ks -> + if B.length s0 >= n + then ks st0 () + else runParser (demandInput >> ensure n) st0 kf ks --- | Match a single byte based on the given predicate. -satisfy :: (Word8 -> Bool) -> Parser Word8 -satisfy p = - Parser $ \s@(S sb lb n) -> - case SB.uncons sb of - Just (c, sb') | p c -> Right (c, mkState (sb' +: lb) (n + 1)) - | otherwise -> Left (sb +: lb, []) - Nothing -> unParser (nextChunk >> satisfy p) s -{-# INLINE satisfy #-} +-- | Immediately demand more input via a 'Partial' continuation +-- result. +demandInput :: Parser () +demandInput = Parser $ \st0@(S s0 a0 c0) kf ks -> + if c0 == Complete + then kf st0 ["demandInput"] "not enough bytes" + else Partial $ \s -> + if B.null s + then kf (S s0 a0 Complete) ["demandInput"] "not enough bytes" + else let st1 = S (s0 +++ s) (a0 +++ s) Incomplete + in ks st1 () --- | Match a literal string exactly. -string :: LB.ByteString -> Parser LB.ByteString -string s = Parser $ \(S sb lb n) -> - let bs = sb +: lb - l = LB.length s - (h,t) = LB.splitAt l bs - in if s == h - then Right (s, mkState t (n + l)) - else Left (bs, []) -{-# INLINE string #-} +-- | 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 :: Parser Bool +wantInput = Parser $ \st0@(S s0 a0 c0) _kf ks -> + case undefined of + _ | not (B.null s0) -> ks st0 True + | c0 == Complete -> ks st0 False + | otherwise -> Partial $ \s -> + if B.null s + then ks st0 False + else let st1 = S (s0 +++ s) (a0 +++ s) Incomplete + in ks st1 True --- | Match the end of a line. This may be any of a newline character, --- a carriage return character, or a carriage return followed by a newline. -endOfLine :: Parser () -endOfLine = Parser $ \(S sb lb n) -> - let bs = sb +: lb - in if SB.null sb - then Left (bs, ["EOL"]) - else case I.w2c (U.unsafeHead sb) of - '\n' -> Right ((), mkState (LB.tail bs) (n + 1)) - '\r' -> let (h,t) = LB.splitAt 2 bs - rn = L8.pack "\r\n" - in if h == rn - then Right ((), mkState t (n + 2)) - else Right ((), mkState (LB.tail bs) (n + 1)) - _ -> Left (bs, ["EOL"]) +get :: Parser B.ByteString +get = Parser (\st0 _kf ks -> ks st0 (input st0)) --- | Match a literal string, after applying a transformation to both --- it and the matching text. Useful for e.g. case insensitive string --- comparison. -stringTransform :: (LB.ByteString -> LB.ByteString) -> LB.ByteString - -> Parser LB.ByteString -stringTransform f s = Parser $ \(S sb lb n) -> - let bs = sb +: lb - l = LB.length s - (h, t) = LB.splitAt l bs - in if fs == f h - then Right (s, mkState t (n + l)) - else Left (bs, []) - where fs = f s -{-# INLINE stringTransform #-} +put :: B.ByteString -> Parser () +put s = Parser (\(S _s0 a0 c0) _kf ks -> ks (S s a0 c0) ()) --- | Attempt a parse, but do not consume any input if the parse fails. +(+++) :: B.ByteString -> B.ByteString -> B.ByteString +(+++) = B.append +{-# INLINE (+++) #-} + +-- | Attempt a parse, and if it fails, rewind the input so that no +-- input appears to have been consumed. +-- +-- This combinator is useful in cases where a parser might consume +-- some input before failing, i.e. the parser needs arbitrary +-- lookahead. The downside to using this combinator is that it can +-- retain input for longer than is desirable. try :: Parser a -> Parser a -try p = Parser $ \s@(S sb lb _) -> - case unParser p s of - Left (_, msgs) -> Left (sb +: lb, msgs) - ok -> ok +try p = Parser $ \st0 kf ks -> + runParser p (noAdds st0) (kf . mappend st0) ks --- | Succeed if we have reached the end of the input string. -endOfInput :: Parser () -endOfInput = Parser $ \s@(S sb lb _) -> if SB.null sb && LB.null lb - then Right ((), s) - else Left (sb +: lb, ["EOF"]) +-- | The parser @satisfy p@ succeeds for any byte for which the +-- predicate @p@ returns 'True'. Returns the byte that is actually +-- parsed. +-- +-- >digit = satisfy isDigit +-- > where isDigit w = w >= 48 && w <= 57 +satisfy :: (Word8 -> Bool) -> Parser Word8 +satisfy p = do + ensure 1 + s <- get + let w = B.unsafeHead s + if p w + then put (B.unsafeTail s) >> return w + else fail "satisfy" --- | Return all of the remaining input as a single string. -takeAll :: Parser LB.ByteString -takeAll = Parser $ \(S sb lb n) -> - let bs = sb +: lb - in Right (bs, mkState LB.empty (n + LB.length bs)) +-- | The parser @satisfyWith f p@ transforms a byte, and succeeds if +-- the predicate @p@ returns 'True' on the transformed value. The +-- parser returns the transformed byte that was parsed. +satisfyWith :: (Word8 -> a) -> (a -> Bool) -> Parser a +satisfyWith f p = do + ensure 1 + s <- get + let c = f (B.unsafeHead s) + if p c + then put (B.unsafeTail s) >> return c + else fail "satisfyWith" --- | Return exactly the given number of bytes. If not enough are --- available, fail. -takeCount :: Int -> Parser LB.ByteString -takeCount k = - Parser $ \(S sb lb n) -> - let bs = sb +: lb - k' = fromIntegral k - (h,t) = LB.splitAt k' bs - in if LB.length h == k' - then Right (h, mkState t (n + k')) - else Left (bs, [show k ++ " bytes"]) +storable :: Storable a => Parser a +storable = hack undefined + where + hack :: Storable b => b -> Parser b + hack dummy = do + (fp,o,_) <- B.toForeignPtr `fmapP` take (sizeOf dummy) + return . B.inlinePerformIO . withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o) --- | Consume bytes while the predicate succeeds. -takeWhile :: (Word8 -> Bool) -> Parser LB.ByteString -takeWhile p = - Parser $ \(S sb lb n) -> - let (h,t) = LB.span p (sb +: lb) - in Right (h, mkState t (n + LB.length h)) -{-# INLINE takeWhile #-} +-- | Consume @n@ bytes of input, but succeed only if the predicate +-- returns 'True'. +takeWith :: Int -> (B.ByteString -> Bool) -> Parser B.ByteString +takeWith n p = do + ensure n + s <- get + let (h,t) = B.splitAt n s + if p h + then put t >> return h + else failDesc "takeWith" --- | Consume bytes while the predicate fails. If the predicate never --- succeeds, the entire input string is returned. -takeTill :: (Word8 -> Bool) -> Parser LB.ByteString -takeTill p = - Parser $ \(S sb lb n) -> - let (h,t) = LB.break p (sb +: lb) - in Right (h, mkState t (n + LB.length h)) +-- | Consume exactly @n@ bytes of input. +take :: Int -> Parser B.ByteString +take n = takeWith n (const True) +{-# INLINE take #-} + +-- | @string s@ parses a sequence of bytes that identically match +-- @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 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 :: B.ByteString -> Parser B.ByteString +string s = takeWith (B.length s) (==s) +{-# INLINE string #-} + +stringTransform :: (B.ByteString -> B.ByteString) -> B.ByteString + -> Parser B.ByteString +stringTransform f s = takeWith (B.length s) ((==s) . f) +{-# INLINE stringTransform #-} + +-- | Skip past input for as long as the predicate returns 'True'. +skipWhile :: (Word8 -> Bool) -> Parser () +skipWhile p = go + where + go = do + input <- wantInput + when input $ do + t <- B8.dropWhile p <$> get + put t + when (B.null t) go + +-- | 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 byte of 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. +takeTill :: (Word8 -> Bool) -> Parser B.ByteString +takeTill p = takeWhile (not . p) {-# INLINE takeTill #-} --- | Consume bytes while the predicate is true. Fails if the --- predicate fails on the first byte. -takeWhile1 :: (Word8 -> Bool) -> Parser LB.ByteString -takeWhile1 p = - Parser $ \(S sb lb n) -> - case LB.span p (sb +: lb) of - (h,t) | LB.null h -> Left (t, []) - | otherwise -> Right (h, mkState t (n + LB.length h)) -{-# INLINE takeWhile1 #-} +-- | 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 byte of 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. +takeWhile :: (Word8 -> Bool) -> Parser B.ByteString +takeWhile p = go + where + go = do + input <- wantInput + if input + then do + (h,t) <- B8.span p <$> get + put t + if B.null t + then (h+++) `fmapP` go + else return h + else return B.empty --- | Test that a parser returned a non-null 'LB.ByteString'. -notEmpty :: Parser LB.ByteString -> Parser LB.ByteString -notEmpty p = Parser $ \s -> - case unParser p s of - o@(Right (a, _)) -> - if LB.null a - then Left (a, ["notEmpty"]) - else o - x -> x +-- | 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 byte +-- of input: it will fail if the predicate never returns 'True' or if +-- there is no input left. +takeWhile1 :: (Word8 -> Bool) -> Parser B.ByteString +takeWhile1 p = do + (`when` demandInput) =<< B.null <$> get + (h,t) <- B8.span p <$> get + when (B.null h) $ failDesc "takeWhile1" + put t + if B.null t + then (h+++) `fmapP` takeWhile p + else return h --- | Parse some input with the given parser, and return the input it --- consumed as a string. -match :: Parser a -> Parser LB.ByteString -match p = do bs <- getInput - start <- getConsumed - p - end <- getConsumed - return (LB.take (end - start) bs) +-- | Match any byte in a set. +-- +-- >vowel = inClass "aeiou" +-- +-- Range notation is supported. +-- +-- >halfAlphabet = inClass "a-nA-N" +-- +-- To add a literal @\'-\'@ to a set, place it at the beginning or end +-- of the string. +inClass :: String -> Word8 -> Bool +inClass s = (`memberWord8` mySet) + where mySet = charClass s +{-# INLINE inClass #-} --- | Apply a parser without consuming any input. -lookAhead :: Parser a -> Parser a -lookAhead p = Parser $ \s -> - case unParser p s of - Right (m, _) -> Right (m, s) - err -> err +-- | Match any byte not in a set. +notInClass :: String -> Word8 -> Bool +notInClass s = not . inClass s +{-# INLINE notInClass #-} --- | Run a parser. The 'Int64' value is used as a base to count the --- number of bytes consumed. -parseAt :: Parser a -- ^ parser to run - -> LB.ByteString -- ^ input to parse - -> Int64 -- ^ offset to count input from - -> (LB.ByteString, Either ParseError (a, Int64)) -parseAt p bs n = - case unParser p (mkState bs n) of - Left (bs', msg) -> (bs', Left $ showError msg) - Right (a, ~(S sb lb n')) -> (sb +: lb, Right (a, n')) - where - showError [""] = "Parser error\n" - showError [msg] = "Parser error, expected:\n" ++ msg ++ "\n" - showError [] = "Parser error\n" - showError msgs = "Parser error, expected one of:\n" ++ unlines msgs +-- | Match any byte. +anyWord8 :: Parser Word8 +anyWord8 = satisfy $ const True +{-# INLINE anyWord8 #-} --- | Run a parser. -parse :: Parser a -- ^ parser to run - -> LB.ByteString -- ^ input to parse - -> (LB.ByteString, Either ParseError a) -parse p bs = case parseAt p bs 0 of - (bs', Right (a, _)) -> (bs', Right a) - (bs', Left err) -> (bs', Left err) +-- | Match a specific byte. +word8 :: Word8 -> Parser Word8 +word8 c = satisfy (== c) show c +{-# INLINE word8 #-} --- | Try out a parser, and print its result. -parseTest :: (Show a) => Parser a -> LB.ByteString -> IO () -parseTest p s = - case parse p s of - (st, Left msg) -> putStrLn $ msg ++ "\nGot:\n" ++ show st - (_, Right r) -> print r +-- | Match any byte except the given one. +notWord8 :: Word8 -> Parser Word8 +notWord8 c = satisfy (/= c) "not " ++ show c +{-# INLINE notWord8 #-} -#define PARSER Parser -#include "Word8Boilerplate.h" +-- | Match only if all input has been consumed. +endOfInput :: Parser () +endOfInput = Parser $ \st0@S{..} kf ks -> + if B.null input + then if more == Complete + then ks st0 () + else let kf' st1 _ _ = ks (mappend st0 st1) () + ks' st1 _ = kf (mappend st0 st1) [] "endOfInput" + in runParser demandInput st0 kf' ks' + else kf st0 [] "endOfInput" + +-- | Match either a single newline character @\'\\n\'@, or a carriage +-- return followed by a newline character @\"\\r\\n\"@. +endOfLine :: Parser () +endOfLine = (word8 10 >> return ()) <|> (string (B.pack "\r\n") >> return ()) + +--- | Name the parser, in case failure occurs. +() :: Parser a + -> String -- ^ the name to use if parsing fails + -> Parser a +p _msg = p +{-# INLINE () #-} +infix 0 + +-- | Terminal failure continuation. +failK :: Failure a +failK st0 stack msg = Fail st0 stack msg + +-- | Terminal success continuation. +successK :: Success a a +successK state a = Done state a + +-- | Run a parser. +parse :: Parser a -> B.ByteString -> Result a +parse m s = runParser m (S s B.empty Incomplete) failK successK +{-# INLINE parse #-} diff --git a/Data/Attoparsec/Lazy.hs b/Data/Attoparsec/Lazy.hs new file mode 100644 --- /dev/null +++ b/Data/Attoparsec/Lazy.hs @@ -0,0 +1,91 @@ +-- | +-- Module : Data.Attoparsec.Lazy +-- Copyright : Bryan O'Sullivan 2010 +-- License : BSD3 +-- +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : unknown +-- +-- Simple, efficient combinator parsing for lazy 'ByteString' +-- strings, loosely based on the Parsec library. +-- +-- This is essentially the same code as in the 'Data.Attoparsec' +-- module, only with a 'parse' function that can consume a lazy +-- 'ByteString' incrementally, and a 'Result' type that does not allow +-- more input to be fed in. Think of this as suitable for use with a +-- lazily read file, e.g. via 'L.readFile' or 'L.hGetContents'. +-- +-- Behind the scenes, strict 'B.ByteString' values are still used +-- internally to store parser input and manipulate it efficiently. +-- High-performance parsers such as 'string' still expect strict +-- 'B.ByteString' parameters. + +module Data.Attoparsec.Lazy + ( + Result(..) + , module Data.Attoparsec + -- * Running parsers + , parse + , parseTest + -- ** Result conversion + , maybeResult + , eitherResult + ) where + +import Data.ByteString.Lazy.Internal (ByteString(..), chunk) +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as B +import qualified Data.Attoparsec as A +import Data.Attoparsec hiding (Result(..), eitherResult, maybeResult, + parse, parseWith, parseTest) + +-- | The result of a parse. +data Result r = Fail ByteString [String] String + -- ^ The parse failed. The 'ByteString' 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. + | Done ByteString r + -- ^ The parse succeeded. The 'ByteString' is the + -- input that had not yet been consumed (if any) when + -- the parse succeeded. + +instance Show r => Show (Result r) where + show (Fail bs stk msg) = + "Fail " ++ show bs ++ " " ++ show stk ++ " " ++ show msg + show (Done bs r) = "Done " ++ show bs ++ " " ++ show r + +fmapR :: (a -> b) -> Result a -> Result b +fmapR _ (Fail st stk msg) = Fail st stk msg +fmapR f (Done bs r) = Done bs (f r) + +instance Functor Result where + fmap = fmapR + +-- | Run a parser and return its result. +parse :: A.Parser a -> ByteString -> Result a +parse p s = case s of + Chunk x xs -> go (A.parse p x) xs + empty -> go (A.parse p B.empty) empty + where + go (A.Fail x stk msg) ys = Fail (chunk x ys) stk msg + go (A.Done x r) ys = Done (chunk x ys) r + go (A.Partial k) (Chunk y ys) = go (k y) ys + go (A.Partial k) empty = go (k B.empty) empty + +-- | Run a parser and print its result to standard output. +parseTest :: (Show a) => A.Parser a -> ByteString -> IO () +parseTest p s = print (parse p s) + +-- | Convert a 'Result' value to a 'Maybe' value. +maybeResult :: Result r -> Maybe r +maybeResult (Done _ r) = Just r +maybeResult _ = Nothing + +-- | Convert a 'Result' value to an 'Either' value. +eitherResult :: Result r -> Either String r +eitherResult (Done _ r) = Right r +eitherResult (Fail _ _ msg) = Left msg +eitherResult _ = Left "Result: incomplete input" diff --git a/Data/Attoparsec/Word8Boilerplate.h b/Data/Attoparsec/Word8Boilerplate.h deleted file mode 100644 --- a/Data/Attoparsec/Word8Boilerplate.h +++ /dev/null @@ -1,34 +0,0 @@ --- -*- haskell -*- --- This file is intended to be #included by other source files. - -instance MonadPlus (PARSER) where - mzero = zero - mplus = plus - -instance Applicative (PARSER) where - pure = return - (<*>) = ap - -instance Alternative (PARSER) where - empty = zero - (<|>) = plus - --- | Skip over bytes while the predicate is true. -skipWhile :: (Word8 -> Bool) -> PARSER () -skipWhile p = takeWhile p *> pure () -{-# INLINE skipWhile #-} - --- | Match any byte. -anyWord8 :: PARSER Word8 -anyWord8 = satisfy $ const True -{-# INLINE anyWord8 #-} - --- | Match a specific byte. -word8 :: Word8 -> PARSER Word8 -word8 c = satisfy (== c) show c -{-# INLINE word8 #-} - --- | Match any byte except the given one. -notWord8 :: Word8 -> PARSER Word8 -notWord8 c = satisfy (/= c) "not " ++ show c -{-# INLINE notWord8 #-} diff --git a/attoparsec.cabal b/attoparsec.cabal --- a/attoparsec.cabal +++ b/attoparsec.cabal @@ -1,20 +1,32 @@ name: attoparsec -version: 0.7.2 +version: 0.8.0.0 license: BSD3 license-file: LICENSE category: Text, Parsing author: Bryan O'Sullivan maintainer: Bryan O'Sullivan stability: experimental -tested-with: GHC == 6.8.3, GHC == 6.10.1 -synopsis: Fast combinator parsing with Data.ByteString.Lazy -description: Fast combinator parsing with Data.ByteString.Lazy +tested-with: GHC == 6.10.4, GHC == 6.12.1 +synopsis: Fast combinator parsing for bytestrings cabal-version: >= 1.2 build-type: Simple -description: Fast, flexible text-oriented parsing of lazy ByteStrings. +description: + A fast parser combinator library, aimed particularly at dealing + efficiently with network protocols and complicated text/binary + file formats. extra-source-files: - Data/Attoparsec/Char8Boilerplate.h - Data/Attoparsec/Word8Boilerplate.h + benchmarks/Makefile + benchmarks/Tiny.hs + benchmarks/med.txt.bz2 + tests/Makefile + tests/QC.hs + tests/QCSupport.hs + tests/TestFastSet.hs + examples/Makefile + examples/Parsec_RFC2616.hs + examples/RFC2616.hs + examples/TestRFC2616.hs + examples/rfc2616.c flag split-base flag applicative-in-base @@ -24,7 +36,7 @@ -- bytestring was in base-2.0 and 2.1.1 build-depends: base >= 2.0 && < 2.2 else - -- in base 1.0 and 3.0 bytestring is a separate package + -- in base 1.0 and >= 3.0 bytestring is a separate package build-depends: base < 2.0 || >= 3, bytestring >= 0.9, containers >= 0.1.0.1 if flag(applicative-in-base) @@ -33,15 +45,12 @@ else build-depends: base < 2.0 - build-depends: bytestring-lexing >= 0.2 - extensions: CPP exposed-modules: Data.Attoparsec Data.Attoparsec.Char8 Data.Attoparsec.Combinator - Data.Attoparsec.Incremental - Data.Attoparsec.Incremental.Char8 Data.Attoparsec.FastSet + Data.Attoparsec.Lazy other-modules: Data.Attoparsec.Internal - ghc-options: -O2 -Wall -funbox-strict-fields - -fliberate-case-threshold=1000 + ghc-options: -Wall + ghc-prof-options: -auto-all diff --git a/benchmarks/Makefile b/benchmarks/Makefile new file mode 100644 --- /dev/null +++ b/benchmarks/Makefile @@ -0,0 +1,10 @@ +all: med.txt tiny + +tiny: Tiny.hs + ghc -O --make -o $@ $< + +%: %.bz2 + bunzip2 -k $< + +clean: + -rm -f *.o *.hi tiny diff --git a/benchmarks/Tiny.hs b/benchmarks/Tiny.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Tiny.hs @@ -0,0 +1,31 @@ +import Control.Applicative ((<|>)) +import Control.Monad (forM_) +import System.Environment (getArgs) +import qualified Data.Attoparsec.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 = A.many (A.many1 A.letter <|> A.many1 A.digit) + fast = A.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 diff --git a/benchmarks/med.txt.bz2 b/benchmarks/med.txt.bz2 new file mode 100644 Binary files /dev/null and b/benchmarks/med.txt.bz2 differ diff --git a/examples/Makefile b/examples/Makefile new file mode 100644 --- /dev/null +++ b/examples/Makefile @@ -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 diff --git a/examples/Parsec_RFC2616.hs b/examples/Parsec_RFC2616.hs new file mode 100644 --- /dev/null +++ b/examples/Parsec_RFC2616.hs @@ -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 diff --git a/examples/RFC2616.hs b/examples/RFC2616.hs new file mode 100644 --- /dev/null +++ b/examples/RFC2616.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +module RFC2616 + ( + Request(..) + , Header(..) + , isToken + , requestLine + , messageHeader + , request + ) where + +import Control.Applicative hiding (many) +import Data.Attoparsec as P +import Data.Attoparsec.Char8 (char8, endOfLine, isEndOfLine, isHorizontalSpace) +import Data.Word (Word8) +import qualified Data.ByteString.Char8 as B + +isToken :: Word8 -> Bool +isToken w = notInClass "\0-\31()<>@,;:\\\"/[]?={} \t\128-\255" w + +skipHSpaces :: Parser () +skipHSpaces = satisfy isHorizontalSpace *> skipWhile isHorizontalSpace + +data Request = Request { + requestMethod :: !B.ByteString + , requestUri :: !B.ByteString + , requestProtocol :: !B.ByteString + } deriving (Eq, Ord, Show) + +requestLine :: Parser Request +requestLine = do + method <- P.takeWhile1 isToken <* skipHSpaces + uri <- P.takeWhile1 (not . isHorizontalSpace) <* skipHSpaces <* string "HTTP/" + proto <- P.takeWhile1 isHttpVersion <* endOfLine + return $! Request method uri proto + where + isHttpVersion w = w == 46 || w == 48 || w == 49 + +data Header = Header { + headerName :: !B.ByteString + , headerValue :: [B.ByteString] + } deriving (Eq, Ord, Show) + +messageHeader :: Parser Header +messageHeader = do + header <- P.takeWhile1 isToken <* char8 ':' <* skipHSpaces + body <- takeTill isEndOfLine <* endOfLine + conts <- many $ skipHSpaces *> takeTill isEndOfLine <* endOfLine + return $! Header header (body:conts) + +request :: Parser (Request, [Header]) +request = (,) <$> requestLine <*> many messageHeader <* endOfLine diff --git a/examples/TestRFC2616.hs b/examples/TestRFC2616.hs new file mode 100644 --- /dev/null +++ b/examples/TestRFC2616.hs @@ -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 diff --git a/examples/rfc2616.c b/examples/rfc2616.c new file mode 100644 --- /dev/null +++ b/examples/rfc2616.c @@ -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 +#include +#include +#include +#include +#include +#include +#include + +#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: + */ diff --git a/tests/Makefile b/tests/Makefile new file mode 100644 --- /dev/null +++ b/tests/Makefile @@ -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 diff --git a/tests/QC.hs b/tests/QC.hs new file mode 100644 --- /dev/null +++ b/tests/QC.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Control.Monad (forM_) +import Data.Maybe (isJust) +import Data.Word (Word8) +import Prelude hiding (takeWhile) +import QCSupport +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck hiding (NonEmpty) +import qualified Data.Attoparsec as P +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C + +-- Make sure that structures whose types claim they are non-empty +-- really are. + +nonEmptyList l = length (nonEmpty l) > 0 + where types = l :: NonEmpty [Int] +nonEmptyBS l = B.length (nonEmpty l) > 0 + +-- Naming. + +{- +label (NonEmpty s) = case parse (anyWord8 s) B.empty of + (_, Left err) -> s `isInfixOf` err + _ -> False +-} + +-- Basic byte-level combinators. + +maybeP p s = case P.parse p s `P.feed` B.empty of + P.Done _ i -> Just i + _ -> Nothing + +defP p s = P.parse p s `P.feed` B.empty + +satisfy w s = maybeP (P.satisfy (<=w)) (B.cons w s) == Just w + +word8 w s = maybeP (P.word8 w) (B.cons w s) == Just w + +anyWord8 s = maybeP P.anyWord8 s == if B.null s + then Nothing + else Just (B.head s) + +notWord8 w (NonEmpty s) = maybeP (P.notWord8 w) s == if v == w + then Nothing + else Just v + where v = B.head s + +string s = maybeP (P.string s) s == Just s + +skipWhile w s = + let t = B.dropWhile (<=w) s + in case defP (P.skipWhile (<=w)) s of + P.Done t' () -> t == t' + _ -> False + +takeCount (Positive k) s = + case maybeP (P.take k) s of + Nothing -> k > B.length s + Just s' -> k <= B.length s + +takeWhile w s = + let (h,t) = B.span (==w) s + in case defP (P.takeWhile (==w)) s of + P.Done t' h' -> t == t' && h == h' + _ -> False + +takeWhile1 w s = + let s' = B.cons w s + (h,t) = B.span (<=w) s' + in case defP (P.takeWhile1 (<=w)) s' of + P.Done t' h' -> t == t' && h == h' + _ -> False + +takeTill w s = + let (h,t) = B.break (==w) s + in case defP (P.takeTill (==w)) s of + P.Done t' h' -> t == t' && h == h' + _ -> False + +ensure n s = case defP (P.ensure m) s of + P.Done _ () -> B.length s >= m + _ -> B.length s < m + where m = (n `mod` 220) - 20 + +takeWhile1_empty = maybeP (P.takeWhile1 undefined) B.empty == Nothing + +endOfInput s = maybeP P.endOfInput s == if B.null s + then Just () + else Nothing + +main = defaultMain tests + +tests = [ + testGroup "fnord" [ + testProperty "nonEmptyList" nonEmptyList, + testProperty "nonEmptyBS" nonEmptyBS, + testProperty "satisfy" satisfy, + testProperty "word8" word8, + testProperty "notWord8" notWord8, + testProperty "anyWord8" anyWord8, + testProperty "string" string, + testProperty "skipWhile" skipWhile, + testProperty "takeCount" takeCount, + testProperty "takeWhile" takeWhile, + testProperty "takeWhile1" takeWhile1, + testProperty "takeWhile1_empty" takeWhile1_empty, + testProperty "takeTill" takeTill, + testProperty "endOfInput" endOfInput, + testProperty "ensure" ensure + ] + + ] diff --git a/tests/QCSupport.hs b/tests/QCSupport.hs new file mode 100644 --- /dev/null +++ b/tests/QCSupport.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} +module QCSupport + ( + NonEmpty(..) + ) where + +import Control.Applicative +import Data.Attoparsec +import Data.Word (Word8) +import System.Random (RandomGen, Random(..)) +import Test.QuickCheck hiding (NonEmpty) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g) +integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer, + fromIntegral b :: Integer) g of + (x,g') -> (fromIntegral x, g') + +newtype NonEmpty a = NonEmpty { nonEmpty :: a } + deriving (Eq, Ord, Read, Show) + +instance Functor NonEmpty where + fmap f (NonEmpty a) = NonEmpty (f a) + +instance Applicative NonEmpty where + NonEmpty f <*> NonEmpty a = NonEmpty (f a) + pure a = NonEmpty a + +instance Arbitrary a => Arbitrary (NonEmpty [a]) where + arbitrary = NonEmpty <$> sized (\n -> choose (1,n+1) >>= vector) + +instance Arbitrary S.ByteString where + arbitrary = S.pack <$> arbitrary + +instance Arbitrary (NonEmpty S.ByteString) where + arbitrary = fmap S.pack <$> arbitrary + +instance Arbitrary L.ByteString where + arbitrary = sized $ \n -> resize (round (sqrt (toEnum n :: Double))) + ((L.fromChunks . map nonEmpty) <$> arbitrary) + +instance Arbitrary (NonEmpty L.ByteString) where + arbitrary = sized $ \n -> resize (round (sqrt (toEnum n :: Double))) + (fmap (L.fromChunks . map nonEmpty) <$> arbitrary) + +instance Random Word8 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Arbitrary Word8 where + arbitrary = choose (minBound, maxBound) diff --git a/tests/TestFastSet.hs b/tests/TestFastSet.hs new file mode 100644 --- /dev/null +++ b/tests/TestFastSet.hs @@ -0,0 +1,25 @@ +module Main (main) where + +import Data.Word (Word8) +import qualified Data.Attoparsec.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