diff --git a/Data/Picoparsec.hs b/Data/Picoparsec.hs new file mode 100644 --- /dev/null +++ b/Data/Picoparsec.hs @@ -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" diff --git a/Data/Picoparsec/Combinator.hs b/Data/Picoparsec/Combinator.hs new file mode 100644 --- /dev/null +++ b/Data/Picoparsec/Combinator.hs @@ -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ć 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 "") +-- +-- (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 "") +-- +-- (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 #-} diff --git a/Data/Picoparsec/Internal.hs b/Data/Picoparsec/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/Picoparsec/Internal.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE BangPatterns, Haskell2010 #-} +-- | +-- Module : Data.Picoparsec.Internal +-- Copyright : Bryan O'Sullivan 2012, Mario Blažević 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 #-} diff --git a/Data/Picoparsec/Internal/Types.hs b/Data/Picoparsec/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/Data/Picoparsec/Internal/Types.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE BangPatterns, CPP, Haskell2010, Rank2Types, Safe #-} +-- | +-- Module : Data.Picoparsec.Internal.Types +-- Copyright : Bryan O'Sullivan 2007-2011, Mario Blažević 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 #-} diff --git a/Data/Picoparsec/Monoid/Internal.hs b/Data/Picoparsec/Monoid/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/Picoparsec/Monoid/Internal.hs @@ -0,0 +1,610 @@ +{-# LANGUAGE BangPatterns, CPP, Rank2Types, OverloadedStrings #-} +-- | +-- Module : Data.Picoparsec.Monoid.Internal +-- 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 +-- 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 #-} diff --git a/Data/Picoparsec/Number.hs b/Data/Picoparsec/Number.hs new file mode 100644 --- /dev/null +++ b/Data/Picoparsec/Number.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, Haskell2010, OverloadedStrings #-} +-- | +-- Module : Data.Picoparsec.Number +-- Copyright : Bryan O'Sullivan 2011, Mario Blažević 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 #-} diff --git a/Data/Picoparsec/State.hs b/Data/Picoparsec/State.hs new file mode 100644 --- /dev/null +++ b/Data/Picoparsec/State.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE Haskell2010 #-} +-- | +-- Module : Data.Picoparsec.Number +-- Copyright : Mario Blažević 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) diff --git a/Data/Picoparsec/Text/FastSet.hs b/Data/Picoparsec/Text/FastSet.hs new file mode 100644 --- /dev/null +++ b/Data/Picoparsec/Text/FastSet.hs @@ -0,0 +1,63 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Picoparsec.FastSet +-- Copyright : Felipe Lessa 2010, Bryan O'Sullivan 2008, Mario Blažević 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 _ = "" diff --git a/Data/Picoparsec/Types.hs b/Data/Picoparsec/Types.hs new file mode 100644 --- /dev/null +++ b/Data/Picoparsec/Types.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE Haskell2010 #-} +-- | +-- Module : Data.Picoparsec.Types +-- Copyright : Bryan O'Sullivan 2011, Mario Blažević 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(..)) diff --git a/Data/Picoparsec/Zepto.hs b/Data/Picoparsec/Zepto.hs new file mode 100644 --- /dev/null +++ b/Data/Picoparsec/Zepto.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE BangPatterns, Haskell2010, MagicHash, UnboxedTuples #-} + +-- | +-- Module : Data.Picoparsec.Zepto +-- Copyright : Bryan O'Sullivan 2011, Mario Blažević 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 #-} diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -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, . diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/benchmarks/Alternative.hs b/benchmarks/Alternative.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Alternative.hs @@ -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" diff --git a/benchmarks/AttoAeson.hs b/benchmarks/AttoAeson.hs new file mode 100644 --- /dev/null +++ b/benchmarks/AttoAeson.hs @@ -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 diff --git a/benchmarks/Benchmarks.hs b/benchmarks/Benchmarks.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Benchmarks.hs @@ -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 diff --git a/benchmarks/Data/Monoid/Instances/ByteString/Char8.hs b/benchmarks/Data/Monoid/Instances/ByteString/Char8.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Data/Monoid/Instances/ByteString/Char8.hs @@ -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 #-} diff --git a/benchmarks/HeadersByteString.hs b/benchmarks/HeadersByteString.hs new file mode 100644 --- /dev/null +++ b/benchmarks/HeadersByteString.hs @@ -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 + ] diff --git a/benchmarks/HeadersText.hs b/benchmarks/HeadersText.hs new file mode 100644 --- /dev/null +++ b/benchmarks/HeadersText.hs @@ -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 + ] diff --git a/benchmarks/IsSpace.hs b/benchmarks/IsSpace.hs new file mode 100644 --- /dev/null +++ b/benchmarks/IsSpace.hs @@ -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. diff --git a/benchmarks/Links.hs b/benchmarks/Links.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Links.hs @@ -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 = "; rel=\"next\", ; rel=\"last\"" 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/Numbers.hs b/benchmarks/Numbers.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Numbers.hs @@ -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 + ] + ] + ] + ] diff --git a/benchmarks/PicoAeson.hs b/benchmarks/PicoAeson.hs new file mode 100644 --- /dev/null +++ b/benchmarks/PicoAeson.hs @@ -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] 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 ((<|>), 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 diff --git a/benchmarks/http-request.txt b/benchmarks/http-request.txt new file mode 100644 --- /dev/null +++ b/benchmarks/http-request.txt @@ -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 + diff --git a/benchmarks/http-response.txt b/benchmarks/http-response.txt new file mode 100644 --- /dev/null +++ b/benchmarks/http-response.txt @@ -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 + 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/benchmarks/picoparsec-benchmarks.cabal b/benchmarks/picoparsec-benchmarks.cabal new file mode 100644 --- /dev/null +++ b/benchmarks/picoparsec-benchmarks.cabal @@ -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 diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,3 @@ +0.1 + +* Initial commit. 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,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 _ = [] 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/picoparsec.cabal b/picoparsec.cabal new file mode 100644 --- /dev/null +++ b/picoparsec.cabal @@ -0,0 +1,119 @@ +name: picoparsec +version: 0.1 +license: BSD3 +license-file: LICENSE +category: Text, Parsing +author: Mario Blažević +maintainer: Mario Blažević +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 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,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 diff --git a/tests/QC/Monoid.hs b/tests/QC/Monoid.hs new file mode 100644 --- /dev/null +++ b/tests/QC/Monoid.hs @@ -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 + ] 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.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