@@ -0,0 +1,146 @@
1+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}
2+
3+-- |
4+-- Module : Data.Attoparsec.Zepto
5+-- Copyright : Bryan O'Sullivan 2011
6+-- License : BSD3
7+--
8+-- Maintainer : bos@serpentine.com
9+-- Stability : experimental
10+-- Portability : unknown
11+--
12+-- A tiny, highly specialized combinator parser for 'B.ByteString'
13+-- strings.
14+--
15+-- While the main Attoparsec module generally performs well, this
16+-- module is particularly fast for simple non-recursive loops that
17+-- should not normally result in failed parses.
18+--
19+-- /Warning/: on more complex inputs involving recursion or failure,
20+-- parsers based on this module may be as much as /ten times slower/
21+-- than regular Attoparsec! You should /only/ use this module when you
22+-- have benchmarks that prove that its use speeds your code up.
23+module Data.Attoparsec.Zepto
24+ (
25+ Parser
26+ , parse
27+ , atEnd
28+ , string
29+ , take
30+ , takeWhile
31+ ) where
32+
33+import Data.Word (Word8)
34+import Control.Applicative
35+import Control.Monad
36+import Data.Monoid
37+import qualified Data.ByteString as B
38+import qualified Data.ByteString.Unsafe as B
39+import Data.ByteString (ByteString)
40+import Prelude hiding (take, takeWhile)
41+
42+newtype S = S {
43+ input :: ByteString
44+ }
45+
46+data Result a = Fail String
47+ | OK !a
48+
49+-- | A simple parser.
50+--
51+-- This monad is strict in its state, and the monadic bind operator
52+-- ('>>=') evaluates each result to weak head normal form before
53+-- passing it along.
54+newtype Parser a = Parser {
55+ runParser :: S -> (# Result a, S #)
56+ }
57+
58+instance Functor Parser where
59+ fmap f m = Parser $ \s -> case runParser m s of
60+ (# OK a, s' #) -> (# OK (f a), s' #)
61+ (# Fail err, s' #) -> (# Fail err, s' #)
62+ {-# INLINE fmap #-}
63+
64+instance Monad Parser where
65+ return a = Parser $ \s -> (# OK a, s #)
66+ {-# INLINE return #-}
67+
68+ m >>= k = Parser $ \s -> case runParser m s of
69+ (# OK a, s' #) -> runParser (k a) s'
70+ (# Fail err, s' #) -> (# Fail err, s' #)
71+ {-# INLINE (>>=) #-}
72+
73+ fail msg = Parser $ \s -> (# Fail msg, s #)
74+
75+instance MonadPlus Parser where
76+ mzero = fail "mzero"
77+ {-# INLINE mzero #-}
78+
79+ mplus a b = Parser $ \s ->
80+ case runParser a s of
81+ (# ok@(OK _), s' #) -> (# ok, s' #)
82+ (# _, _ #) -> case runParser b s of
83+ (# ok@(OK _), s'' #) -> (# ok, s'' #)
84+ (# err, s'' #) -> (# err, s'' #)
85+ {-# INLINE mplus #-}
86+
87+instance Applicative Parser where
88+ pure = return
89+ (<*>) = ap
90+
91+gets :: (S -> a) -> Parser a
92+gets f = Parser $ \s -> (# OK (f s), s #)
93+{-# INLINE gets #-}
94+
95+put :: S -> Parser ()
96+put s = Parser $ \_ -> (# OK (), s #)
97+{-# INLINE put #-}
98+
99+-- | Run a parser.
100+parse :: Parser a -> ByteString -> Either String a
101+parse p bs = case runParser p (S bs) of
102+ (# OK a, _ #) -> Right a
103+ (# Fail err, _ #) -> Left err
104+
105+instance Monoid (Parser a) where
106+ mempty = fail "mempty"
107+ {-# INLINE mempty #-}
108+ mappend = mplus
109+
110+instance Alternative Parser where
111+ empty = fail "empty"
112+ {-# INLINE empty #-}
113+ (<|>) = mplus
114+
115+-- | Consume input while the predicate returns 'True'.
116+takeWhile :: (Word8 -> Bool) -> Parser ByteString
117+takeWhile p = do
118+ (h,t) <- gets (B.span p . input)
119+ put (S t)
120+ return h
121+{-# INLINE takeWhile #-}
122+
123+-- | Consume @n@ bytes of input.
124+take :: Int -> Parser ByteString
125+take !n = do
126+ s <- gets input
127+ if B.length s >= n
128+ then put (S (B.unsafeDrop n s)) >> return (B.unsafeTake n s)
129+ else fail "insufficient input"
130+{-# INLINE take #-}
131+
132+-- | Match a string exactly.
133+string :: ByteString -> Parser ()
134+string s = do
135+ i <- gets input
136+ if s `B.isPrefixOf` i
137+ then put (S (B.unsafeDrop (B.length s) i)) >> return ()
138+ else fail "string"
139+{-# INLINE string #-}
140+
141+-- | Indicate whether the end of the input has been reached.
142+atEnd :: Parser Bool
143+atEnd = do
144+ i <- gets input
145+ return $! B.null i
146+{-# INLINE atEnd #-}