63d0900 · typeable/attoparsec

git.iko.soy/typeable/attoparsec

on master help sign in

Move combinators into their own module

63d0900Bryan O'Sullivan18 years ago

attoparsec.cabal+1

compare with master

unifiedsplit

@@ -38,6 +38,7 @@ library

38 extensions: CPP

39 exposed-modules: Data.ParserCombinators.Attoparsec

40 Data.ParserCombinators.Attoparsec.Char8

41+ Data.ParserCombinators.Attoparsec.Combinator

41 Data.ParserCombinators.Attoparsec.Incremental

42 Data.ParserCombinators.Attoparsec.Incremental

42 Data.ParserCombinators.Attoparsec.Incremental.Char8

43 Data.ParserCombinators.Attoparsec.Incremental.Char8

43 Data.ParserCombinators.Attoparsec.FastSet

44 Data.ParserCombinators.Attoparsec.FastSet

examples/RFC2616.hs−3

@@ -12,9 +12,6 @@ import Prelude hiding (takeWhile)

13date = rfc1123Date -- <|> rfc850Date <|> asctimeDate

15−oneOf :: Alternative f => [f a] -> f a

16−oneOf = foldr (<|>) empty

17−

18rfc1123Date =

15rfc1123Date =

19 liftA3 (,,) (wkday <* string ", ") (date <* char ' ') (time <* string " GMT") <?> "RFC1123 date"

16 liftA3 (,,) (wkday <* string ", ") (date <* char ' ') (time <* string " GMT") <?> "RFC1123 date"

20 where wkday = oneWord "Mon Tue Wed Thu Fri Sat Sun"

17 where wkday = oneWord "Mon Tue Wed Thu Fri Sat Sun"

src/Data/ParserCombinators/Attoparsec.hs−7

@@ -28,16 +28,9 @@ module Data.ParserCombinators.Attoparsec

29 -- * Things vaguely like those in @Parsec.Combinator@ (and @Parsec.Prim@)

30 , try

31− , many1

32− , manyTill

33 , eof

31 , eof

34− , skipMany

35− , skipMany1

36− , count

37 , lookAhead

32 , lookAhead

38 , peek

33 , peek

39− , sepBy

40− , sepBy1

42 -- * Things like in @Parsec.Char@

35 -- * Things like in @Parsec.Char@

43 , satisfy

36 , satisfy

src/Data/ParserCombinators/Attoparsec/Char8.hs+3−10

@@ -29,16 +29,9 @@ module Data.ParserCombinators.Attoparsec.Char8

30 -- * Things vaguely like those in @Parsec.Combinator@ (and @Parsec.Prim@)

31 , try

32− , many1

33− , manyTill

34 , eof

32 , eof

35− , skipMany

36− , skipMany1

37− , count

38 , lookAhead

33 , lookAhead

39 , peek

34 , peek

40− , sepBy

41− , sepBy1

43 -- * Things like in @Parsec.Char@

36 -- * Things like in @Parsec.Char@

44 , satisfy

37 , satisfy

@@ -85,10 +78,10 @@ import Data.ParserCombinators.Attoparsec.FastSet

85 (FastSet, memberChar, set)

78 (FastSet, memberChar, set)

86import qualified Data.ParserCombinators.Attoparsec.Internal as I

79import qualified Data.ParserCombinators.Attoparsec.Internal as I

87import Data.ParserCombinators.Attoparsec.Internal

80import Data.ParserCombinators.Attoparsec.Internal

88− (Parser, ParseError, (<?>), parse, parseAt, parseTest, try, manyTill, eof,

81+ (Parser, ParseError, (<?>), parse, parseAt, parseTest, try, eof,

89− skipMany, skipMany1, count, lookAhead, peek, sepBy, sepBy1, string,

82+ lookAhead, peek, string,

90 eitherP, getInput, getConsumed, takeAll, takeCount, notEmpty, match,

83 eitherP, getInput, getConsumed, takeAll, takeCount, notEmpty, match,

91− endOfLine, setInput, many1)

84+ endOfLine, setInput)

92import Data.ByteString.Lex.Lazy.Double (readDouble)

85import Data.ByteString.Lex.Lazy.Double (readDouble)

93import Prelude hiding (takeWhile)

86import Prelude hiding (takeWhile)

src/Data/ParserCombinators/Attoparsec/Combinator.hsnew file+58

@@ -0,0 +1,58 @@

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

2+-----------------------------------------------------------------------------

3+-- |

4+-- Module : Data.ParserCombinators.Attoparsec.Combinator

5+-- Copyright : Bryan O'Sullivan 2009

6+-- License : BSD3

7+--

8+-- Maintainer : bos@serpentine.com

9+-- Stability : experimental

10+-- Portability : unknown

11+--

12+-- Useful parser combinators, similar to Parsec.

13+--

14+-----------------------------------------------------------------------------

15+module Data.ParserCombinators.Attoparsec.Combinator

16+ (

17+ choice

18+ , count

19+ , many

20+ , many1

21+ , manyTill

22+ , sepBy

23+ , sepBy1

24+ , skipMany

25+ , skipMany1

26+ ) where

27+

28+import Control.Applicative

29+

30+choice :: Alternative f => [f a] -> f a

31+choice = foldr (<|>) empty

32+

33+many1 :: Alternative f => f a -> f [a]

34+many1 p = liftA2 (:) p (many p)

35+

36+sepBy :: Alternative f => f a -> f s -> f [a]

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

38+

39+sepBy1 :: Alternative f => f a -> f s -> f [a]

40+sepBy1 p s = liftA2 (:) p ((s *> sepBy1 p s) <|> pure [])

41+

42+manyTill :: Alternative f => f a -> f b -> f [a]

43+manyTill p end = scan

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

45+

46+-- | Skip zero or more instances of the parser.

47+skipMany :: Alternative f => f a -> f ()

48+skipMany p = scan

49+ where scan = (p *> scan) <|> pure ()

50+

51+-- | Skip one or more instances of the parser.

52+skipMany1 :: Alternative f => f a -> f ()

53+skipMany1 p = p *> skipMany p

54+

55+-- | Apply the given parser repeatedly, returning every parse result.

56+count :: Monad m => Int -> m a -> m [a]

57+count n p = sequence (replicate n p)

58+{-# INLINE count #-}

src/Data/ParserCombinators/Attoparsec/Incremental.hs+62−61

@@ -22,6 +22,7 @@ module Data.ParserCombinators.Attoparsec.Incremental

22 , Result(..)

23 , parse

24 , parseWith

25+ , parseTest

26 , (<?>)

27 , (<?>)

27 , takeWhile

28 , takeWhile

@@ -35,14 +36,7 @@ module Data.ParserCombinators.Attoparsec.Incremental

35 , notWord8

36 , notWord8

36 , anyWord8

37 , anyWord8

38− , many1

39 , skipWhile

40− , skipMany

41− , skipMany1

42− , sepBy

43− , sepBy1

44− , manyTill

45− , count

47 , yield

41 , yield

48 ) where

42 ) where

@@ -59,6 +53,7 @@ import Prelude hiding (takeWhile)

59data S = S {-# UNPACK #-} !S.ByteString -- ^ first chunk of input

53data S = S {-# UNPACK #-} !S.ByteString -- ^ first chunk of input

60 L.ByteString -- ^ rest of input

54 L.ByteString -- ^ rest of input

61 [L.ByteString] -- ^ input acquired during backtracks

55 [L.ByteString] -- ^ input acquired during backtracks

56+ !Bool -- ^ have we hit EOF yet?

62 {-# UNPACK #-} !Int -- ^ failure depth

57 {-# UNPACK #-} !Int -- ^ failure depth

64-- | The result of a partial parse

59-- | The result of a partial parse

@@ -73,9 +68,10 @@ data Result a = Failed String

73 -- parse pass more data to the given continuation

68 -- parse pass more data to the given continuation

75instance (Show a) => Show (Result a) where

70instance (Show a) => Show (Result a) where

76− show (Failed err) = "Failed " ++ err

71+ show (Failed err) = "Failed " ++ show err

72+ show (Done L.Empty rs) = "Done Empty " ++ show rs

77− show (Done rest rs) = "Done " ++ show rest ++ " " ++ show rs

73+ show (Done rest rs) = "Done (" ++ show rest ++ ") " ++ show rs

78− show (Partial _) = "Partial"

74+ show (Partial _) = "Partial"

80-- | This is the internal version of the above. This is the type which is

76-- | This is the internal version of the above. This is the type which is

81-- actually used by the code, as it has the extra information needed

77-- actually used by the code, as it has the extra information needed

@@ -86,9 +82,9 @@ data IResult a = IFailed S String

86 | IPartial (L.ByteString -> IResult a)

82 | IPartial (L.ByteString -> IResult a)

88instance Show (IResult a) where

84instance Show (IResult a) where

89− show (IFailed _ err) = "IFailed " ++ err

85+ show (IFailed _ err) = "IFailed " ++ show err

90− show (IDone _ _) = "IDone"

86+ show (IDone _ _) = "IDone"

91− show (IPartial _) = "IPartial"

87+ show (IPartial _) = "IPartial"

93newtype Parser r a = Parser {

89newtype Parser r a = Parser {

94 unParser :: S -> (a -> S -> IResult r) -> IResult r

90 unParser :: S -> (a -> S -> IResult r) -> IResult r

@@ -115,7 +111,7 @@ zero = fail ""

115cutContinuation :: (a -> S -> IResult r) -> a -> S -> IResult r

111cutContinuation :: (a -> S -> IResult r) -> a -> S -> IResult r

116cutContinuation k v s =

112cutContinuation k v s =

117 case k v s of

113 case k v s of

118− IFailed (S lb i adds failDepth) err -> IFailed (S lb i adds (failDepth - 1)) err

114+ IFailed (S lb i adds eof failDepth) err -> IFailed (S lb i adds eof (failDepth - 1)) err

119 x -> x

115 x -> x

120

116

121appL :: L.ByteString -> L.ByteString -> L.ByteString

117appL :: L.ByteString -> L.ByteString -> L.ByteString

@@ -125,17 +121,17 @@ appL xs ys = xs `L.append` ys

125

121

126plus :: Parser r a -> Parser r a -> Parser r a

122plus :: Parser r a -> Parser r a -> Parser r a

127plus p1 p2 =

123plus p1 p2 =

128− Parser $ \(S sb lb adds failDepth) k ->

124+ Parser $ \(S sb lb adds eof failDepth) k ->

129 let

125 let

130− filt f@(IFailed (S _ _ adds' failDepth') _)

126+ filt f@(IFailed (S _ _ adds' eof' failDepth') _)

131 | failDepth' == failDepth + 1 =

127 | failDepth' == failDepth + 1 =

132 let lb' = lb `appL` L.concat (reverse adds')

128 let lb' = lb `appL` L.concat (reverse adds')

133− in unParser p2 (S sb lb' (adds' ++ adds) failDepth) k

129+ in unParser p2 (S sb lb' (adds' ++ adds) eof' failDepth) k

134 | otherwise = f

130 | otherwise = f

135 filt (IPartial cont) = IPartial (filt . cont)

131 filt (IPartial cont) = IPartial (filt . cont)

136 filt v@(IDone _ _) = v

132 filt v@(IDone _ _) = v

137 in

133 in

138− filt $ unParser p1 (S sb lb [] (failDepth + 1)) (cutContinuation k)

134+ filt $ unParser p1 (S sb lb [] eof (failDepth + 1)) (cutContinuation k)

139

135

140instance Functor (Parser r) where

136instance Functor (Parser r) where

141 fmap f m = Parser $ \s cont -> unParser m s (cont . f)

137 fmap f m = Parser $ \s cont -> unParser m s (cont . f)

@@ -152,34 +148,39 @@ p <?> msg =

152 ok -> ok

148 ok -> ok

153

149

154initState :: L.ByteString -> S

150initState :: L.ByteString -> S

155−initState (L.Chunk sb lb) = S sb lb [] 0

151+initState (L.Chunk sb lb) = S sb lb [] False 0

156−initState _ = S S.empty L.empty [] 0

152+initState _ = S S.empty L.empty [] False 0

157

153

158−mkState :: L.ByteString -> [L.ByteString] -> Int -> S

154+mkState :: L.ByteString -> [L.ByteString] -> Bool -> Int -> S

159−mkState bs adds failDepth =

155+mkState bs adds eof failDepth =

160 case bs of

156 case bs of

161− L.Empty -> S S.empty L.empty adds failDepth

157+ L.Empty -> S S.empty L.empty adds eof failDepth

162− L.Chunk sb lb -> S sb lb adds failDepth

158+ L.Chunk sb lb -> S sb lb adds eof failDepth

163

159

164addX :: L.ByteString -> [L.ByteString] -> [L.ByteString]

160addX :: L.ByteString -> [L.ByteString] -> [L.ByteString]

165addX s adds | L.null s = adds

161addX s adds | L.null s = adds

166 | otherwise = s : adds

162 | otherwise = s : adds

167

163

168yield :: Parser r ()

164yield :: Parser r ()

169−yield = Parser $ \(S sb lb adds failDepth) k ->

165+yield = Parser $ \(S sb lb adds eof failDepth) k ->

170− IPartial $ \s -> k () (S sb (lb `appL` s) (addX s adds) failDepth)

166+ IPartial $ \s -> k () (S sb (lb `appL` s) (addX s adds) eof failDepth)

167+

168+continue :: (S -> IResult r) -> Parser r a

169+ -> (a -> S -> IResult r) -> S -> IResult r

170+continue onEOF p k (S _sb _lb adds eof failDepth) =

171+ if eof

172+ then onEOF (S S.empty L.empty adds True failDepth)

173+ else IPartial $ \s -> let st = contState s adds failDepth

174+ in unParser p st k

171

175

172takeWith :: (L.ByteString -> (L.ByteString, L.ByteString))

176takeWith :: (L.ByteString -> (L.ByteString, L.ByteString))

173 -> Parser r L.ByteString

177 -> Parser r L.ByteString

174takeWith splitf =

178takeWith splitf =

175− Parser $ \(S sb lb adds failDepth) k ->

179+ Parser $ \st@(S sb lb adds eof failDepth) k ->

176 let (left,rest) = splitf (sb +: lb)

180 let (left,rest) = splitf (sb +: lb)

177− in case rest of

181+ in if L.null rest

178− L.Empty -> IPartial $ \s ->

179− let s' = mkState s (addX s adds) failDepth

180− k' a = k (appL left a)

181− in unParser (takeWith splitf) s' k'

182+ then continue (k left) (takeWith splitf) (k . appL left) st

182− L.Chunk h t -> k left (S h t adds failDepth)

183+ else k left (mkState rest adds eof failDepth)

183

184

184takeWhile :: (Word8 -> Bool) -> Parser r L.ByteString

185takeWhile :: (Word8 -> Bool) -> Parser r L.ByteString

185takeWhile = takeWith . L.span

186takeWhile = takeWith . L.span

@@ -189,56 +190,53 @@ takeTill = takeWith . L.break

189

190

190takeCount :: Int -> Parser r L.ByteString

191takeCount :: Int -> Parser r L.ByteString

191takeCount = tc . fromIntegral where

192takeCount = tc . fromIntegral where

192− tc (!n) = Parser $ \(S sb lb adds failDepth) k ->

193+ tc n = Parser $ \st@(S sb lb adds eof failDepth) k ->

193− let (h,t) = L.splitAt n (sb +: lb)

194+ let (h,t) = L.splitAt n (sb +: lb)

194− l = L.length h

195+ l = L.length h

195− in if L.length h == n

196+ in if L.length h == n

196− then k h (mkState t adds failDepth)

197+ then k h (mkState t adds eof failDepth)

197− else IPartial $ \s ->

198+ else continue (`IFailed` "takeCount: EOF")

198− let st = mkState s (addX s adds) failDepth

199+ (tc (n - l)) (k . appL h) st

199− k' a = k (appL h a)

200− in unParser (tc (n - l)) st k'

201

200

202string :: L.ByteString -> Parser r L.ByteString

201string :: L.ByteString -> Parser r L.ByteString

203string s =

202string s =

204− Parser $ \st@(S sb lb adds failDepth) k ->

203+ Parser $ \st@(S sb lb adds eof failDepth) k ->

205 case L.splitAt (L.length s) (sb +: lb) of

204 case L.splitAt (L.length s) (sb +: lb) of

206 (h,t)

205 (h,t)

207− | h == s -> k s (mkState t adds failDepth)

206+ | h == s -> k s (mkState t adds eof failDepth)

208 (h,L.Empty)

207 (h,L.Empty)

209 | h `L.isPrefixOf` s ->

208 | h `L.isPrefixOf` s ->

210− IPartial $ \s' ->

209+ continue (`IFailed` "string: EOF")

211− let st' = mkState s' (addX s' adds) failDepth

212− k' a = k (appL h a)

213− r' = L.drop (L.length h) s

210+ (string (L.drop (L.length h) s))

214− in unParser (string r') st' k'

211+ (k . appL h)

212+ st

215 _ -> IFailed st "string failed to match"

213 _ -> IFailed st "string failed to match"

216

214

215+contState :: L.ByteString -> [L.ByteString] -> Int -> S

216+contState s adds failDepth

217−emptyState = S S.empty L.empty

217+ | L.null s = S S.empty L.empty [] True failDepth

218+ | otherwise = mkState s (addX s adds) False failDepth

218

219

219satisfy :: (Word8 -> Bool) -> Parser r Word8

220satisfy :: (Word8 -> Bool) -> Parser r Word8

220satisfy p =

221satisfy p =

221− Parser $ \st@(S sb lb adds failDepth) k ->

222+ Parser $ \st@(S sb lb adds eof failDepth) k ->

222 case S.uncons sb of

223 case S.uncons sb of

223− Just (w, sb') | p w -> k w (S sb' lb adds failDepth)

224+ Just (w, sb') | p w -> k w (S sb' lb adds eof failDepth)

224 | otherwise -> IFailed st "failed to match"

225 | otherwise -> IFailed st "failed to match"

225 Nothing -> case L.uncons lb of

226 Nothing -> case L.uncons lb of

226− Just (w, lb') | p w -> k w (mkState lb' adds failDepth)

227+ Just (w, lb') | p w -> k w (mkState lb' adds eof failDepth)

227 | otherwise -> IFailed st "failed to match"

228 | otherwise -> IFailed st "failed to match"

228− Nothing -> IPartial $ \s ->

229+ Nothing -> continue (`IFailed` "satisfy: EOF")

229− let st' = emptyState adds failDepth

230− in if L.null s

231− then IFailed st "barf"

232− else unParser (satisfy p) st' k

230+ (satisfy p) k st

233

231

234pushBack :: L.ByteString -> Parser r ()

232pushBack :: L.ByteString -> Parser r ()

235pushBack bs =

233pushBack bs =

236− Parser $ \(S sb lb adds failDepth) k ->

234+ Parser $ \(S sb lb adds eof failDepth) k ->

237− k () (mkState (bs `appL` (sb +: lb)) adds failDepth)

235+ k () (mkState (bs `appL` (sb +: lb)) adds eof failDepth)

238

236

239toplevelTranslate :: IResult a -> Result a

237toplevelTranslate :: IResult a -> Result a

240toplevelTranslate (IFailed _ err) = Failed err

238toplevelTranslate (IFailed _ err) = Failed err

241−toplevelTranslate (IDone (S sb lb _ _) value) = Done (sb +: lb) value

239+toplevelTranslate (IDone (S sb lb _ _ _) value) = Done (sb +: lb) value

242toplevelTranslate (IPartial k) = Partial $ toplevelTranslate . k

240toplevelTranslate (IPartial k) = Partial $ toplevelTranslate . k

243

241

244terminalContinuation :: a -> S -> IResult a

242terminalContinuation :: a -> S -> IResult a

@@ -255,5 +253,8 @@ parseWith refill p s =

255 Partial k -> k <$> refill

253 Partial k -> k <$> refill

256 ok -> pure ok

254 ok -> pure ok

257

255

256+parseTest :: (Show r) => Parser r r -> L.ByteString -> IO ()

257+parseTest p s = print (parse p s)

258+

258#define PARSER Parser r

259#define PARSER Parser r

259#include "Word8Boilerplate.h"

260#include "Word8Boilerplate.h"

src/Data/ParserCombinators/Attoparsec/Incremental/Char8.hs+2−10

@@ -26,13 +26,6 @@ module Data.ParserCombinators.Attoparsec.Incremental.Char8

26 , (<?>)

28 -- * Things vaguely like those in @Parsec.Combinator@ (and @Parsec.Prim@)

29− , many1

30− , manyTill

31− , skipMany

32− , skipMany1

33− , count

34− , sepBy

35− , sepBy1

36 , pushBack

29 , pushBack

38 -- * Things like in @Parsec.Char@

31 -- * Things like in @Parsec.Char@

@@ -69,9 +62,8 @@ import Data.ParserCombinators.Attoparsec.FastSet

69 (FastSet, memberChar, set)

62 (FastSet, memberChar, set)

70import qualified Data.ParserCombinators.Attoparsec.Incremental as I

63import qualified Data.ParserCombinators.Attoparsec.Incremental as I

71import Data.ParserCombinators.Attoparsec.Incremental

64import Data.ParserCombinators.Attoparsec.Incremental

72− (Parser, Result(..), (<?>), parse, manyTill, pushBack,

65+ (Parser, Result(..), (<?>), parse, pushBack,

73− skipMany, skipMany1, count, sepBy, sepBy1, string,

74− takeCount, many1)

66+ string, takeCount)

75import Data.ByteString.Lex.Lazy.Double (readDouble)

67import Data.ByteString.Lex.Lazy.Double (readDouble)

76import Prelude hiding (takeWhile)

68import Prelude hiding (takeWhile)

src/Data/ParserCombinators/Attoparsec/Internal.hs−7

@@ -29,16 +29,9 @@ module Data.ParserCombinators.Attoparsec.Internal

30 -- * Things vaguely like those in @Parsec.Combinator@ (and @Parsec.Prim@)

31 , try

32− , many1

33− , manyTill

34 , eof

32 , eof

35− , skipMany

36− , skipMany1

37− , count

38 , lookAhead

33 , lookAhead

39 , peek

34 , peek

40− , sepBy

41− , sepBy1

43 -- * Things like in @Parsec.Char@

36 -- * Things like in @Parsec.Char@

44 , satisfy

37 , satisfy

src/Data/ParserCombinators/Attoparsec/Word8Boilerplate.h−27

@@ -18,33 +18,6 @@ skipWhile :: (Word8 -> Bool) -> PARSER ()

18skipWhile p = takeWhile p *> pure ()

19{-# INLINE skipWhile #-}

21−many1 :: PARSER a -> PARSER [a]

22−many1 p = liftA2 (:) p (many p)

23−

24−sepBy :: PARSER a -> PARSER s -> PARSER [a]

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

26−

27−sepBy1 :: PARSER a -> PARSER s -> PARSER [a]

28−sepBy1 p s = liftA2 (:) p ((s *> sepBy1 p s) <|> pure [])

29−

30−manyTill :: PARSER a -> PARSER b -> PARSER [a]

31−manyTill p end = scan

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

33−

34−-- | Skip zero or more instances of the parser.

35−skipMany :: PARSER a -> PARSER ()

36−skipMany p = scan

37− where scan = (p >> scan) <|> return ()

38−

39−-- | Skip one or more instances of the parser.

40−skipMany1 :: PARSER a -> PARSER ()

41−skipMany1 p = p >> skipMany p

42−

43−-- | Apply the given parser repeatedly, returning every parse result.

44−count :: Int -> PARSER a -> PARSER [a]

45−count n p = sequence (replicate n p)

46−{-# INLINE count #-}

47−

48anyWord8 :: PARSER Word8

21anyWord8 :: PARSER Word8

49anyWord8 = satisfy $ const True

22anyWord8 = satisfy $ const True

50{-# INLINE anyWord8 #-}

23{-# INLINE anyWord8 #-}