Bryan O'Sullivan avatar Bryan O'Sullivan committed 5ba7417

Move combinators into their own module

Comments (0)

Files changed (9)

   extensions:      CPP
   exposed-modules: Data.ParserCombinators.Attoparsec
                    Data.ParserCombinators.Attoparsec.Char8
+                   Data.ParserCombinators.Attoparsec.Combinator
                    Data.ParserCombinators.Attoparsec.Incremental
                    Data.ParserCombinators.Attoparsec.Incremental.Char8
                    Data.ParserCombinators.Attoparsec.FastSet

examples/RFC2616.hs

 
 date = rfc1123Date -- <|> rfc850Date <|> asctimeDate
 
-oneOf :: Alternative f => [f a] -> f a
-oneOf = foldr (<|>) empty
-
 rfc1123Date =
     liftA3 (,,) (wkday <* string ", ") (date <* char ' ') (time <* string " GMT") <?> "RFC1123 date"
   where wkday = oneWord "Mon Tue Wed Thu Fri Sat Sun"

src/Data/ParserCombinators/Attoparsec.hs

 
     -- * Things vaguely like those in @Parsec.Combinator@ (and @Parsec.Prim@)
     , try
-    , many1
-    , manyTill
     , eof
-    , skipMany
-    , skipMany1
-    , count
     , lookAhead
     , peek
-    , sepBy
-    , sepBy1
 
     -- * Things like in @Parsec.Char@
     , satisfy

src/Data/ParserCombinators/Attoparsec/Char8.hs

 
     -- * Things vaguely like those in @Parsec.Combinator@ (and @Parsec.Prim@)
     , try
-    , many1
-    , manyTill
     , eof
-    , skipMany
-    , skipMany1
-    , count
     , lookAhead
     , peek
-    , sepBy
-    , sepBy1
 
     -- * Things like in @Parsec.Char@
     , satisfy
     (FastSet, memberChar, set)
 import qualified Data.ParserCombinators.Attoparsec.Internal as I
 import Data.ParserCombinators.Attoparsec.Internal
-    (Parser, ParseError, (<?>), parse, parseAt, parseTest, try, manyTill, eof,
-     skipMany, skipMany1, count, lookAhead, peek, sepBy, sepBy1, string,
+    (Parser, ParseError, (<?>), parse, parseAt, parseTest, try, eof,
+     lookAhead, peek, string,
      eitherP, getInput, getConsumed, takeAll, takeCount, notEmpty, match,
-     endOfLine, setInput, many1)
+     endOfLine, setInput)
 import Data.ByteString.Lex.Lazy.Double (readDouble)
 import Prelude hiding (takeWhile)
 

src/Data/ParserCombinators/Attoparsec/Combinator.hs

+{-# LANGUAGE BangPatterns, CPP #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.ParserCombinators.Attoparsec.Combinator
+-- Copyright   :  Bryan O'Sullivan 2009
+-- License     :  BSD3
+-- 
+-- Maintainer  :  bos@serpentine.com
+-- Stability   :  experimental
+-- Portability :  unknown
+--
+-- Useful parser combinators, similar to Parsec.
+-- 
+-----------------------------------------------------------------------------
+module Data.ParserCombinators.Attoparsec.Combinator
+    (
+      choice
+    , count
+    , many
+    , many1
+    , manyTill
+    , sepBy
+    , sepBy1
+    , skipMany
+    , skipMany1
+    ) where
+
+import Control.Applicative
+
+choice :: Alternative f => [f a] -> f a
+choice = foldr (<|>) empty
+
+many1 :: Alternative f => f a -> f [a]
+many1 p = liftA2 (:) p (many p)
+
+sepBy :: Alternative f => f a -> f s -> f [a]
+sepBy p s = liftA2 (:) p ((s *> sepBy1 p s) <|> pure []) <|> pure []
+
+sepBy1 :: Alternative f => f a -> f s -> f [a]
+sepBy1 p s = liftA2 (:) p ((s *> sepBy1 p s) <|> pure [])
+
+manyTill :: Alternative f => f a -> f b -> f [a]
+manyTill p end = scan
+    where scan = (end *> pure []) <|> liftA2 (:) p scan
+
+-- | Skip zero or more instances of the parser.
+skipMany :: Alternative f => f a -> f ()
+skipMany p = scan
+    where scan = (p *> scan) <|> pure ()
+
+-- | Skip one or more instances of the parser.
+skipMany1 :: Alternative f => f a -> f ()
+skipMany1 p = p *> skipMany p
+
+-- | Apply the given parser repeatedly, returning every parse result.
+count :: Monad m => Int -> m a -> m [a]
+count n p = sequence (replicate n p)
+{-# INLINE count #-}

src/Data/ParserCombinators/Attoparsec/Incremental.hs

     , Result(..)
     , parse
     , parseWith
+    , parseTest
 
     , (<?>)
     , takeWhile
     , notWord8
     , anyWord8
 
-    , many1
     , skipWhile
-    , skipMany
-    , skipMany1
-    , sepBy
-    , sepBy1
-    , manyTill
-    , count
 
     , yield
     ) where
 data S = S {-# UNPACK #-} !S.ByteString -- ^ first chunk of input
            L.ByteString                 -- ^ rest of input
            [L.ByteString]               -- ^ input acquired during backtracks
+           !Bool                        -- ^ have we hit EOF yet?
            {-# UNPACK #-} !Int          -- ^ failure depth
 
 -- | The result of a partial parse
                 --   parse pass more data to the given continuation
 
 instance (Show a) => Show (Result a) where
-  show (Failed err) = "Failed " ++ err
-  show (Done rest rs) = "Done " ++ show rest ++ " " ++ show rs
-  show (Partial _) = "Partial"
+  show (Failed err)      = "Failed " ++ show err
+  show (Done L.Empty rs) = "Done Empty " ++ show rs
+  show (Done rest rs)    = "Done (" ++ show rest ++ ") " ++ show rs
+  show (Partial _)       = "Partial"
 
 -- | This is the internal version of the above. This is the type which is
 --   actually used by the code, as it has the extra information needed
                | IPartial (L.ByteString -> IResult a)
 
 instance Show (IResult a) where
-  show (IFailed _ err) = "IFailed " ++ err
-  show (IDone _ _) = "IDone"
-  show (IPartial _) = "IPartial"
+  show (IFailed _ err) = "IFailed " ++ show err
+  show (IDone _ _)     = "IDone"
+  show (IPartial _)    = "IPartial"
 
 newtype Parser r a = Parser {
       unParser :: S -> (a -> S -> IResult r) -> IResult r
 cutContinuation :: (a -> S -> IResult r) -> a -> S -> IResult r
 cutContinuation k v s =
   case k v s of
-       IFailed (S lb i adds failDepth) err -> IFailed (S lb i adds (failDepth - 1)) err
+       IFailed (S lb i adds eof failDepth) err -> IFailed (S lb i adds eof (failDepth - 1)) err
        x -> x
 
 appL :: L.ByteString -> L.ByteString -> L.ByteString
 
 plus :: Parser r a -> Parser r a -> Parser r a
 plus p1 p2 =
-  Parser $ \(S sb lb adds failDepth) k ->
+  Parser $ \(S sb lb adds eof failDepth) k ->
     let
-      filt f@(IFailed (S _ _ adds' failDepth') _)
+      filt f@(IFailed (S _ _ adds' eof' failDepth') _)
         | failDepth' == failDepth + 1 =
             let lb' = lb `appL` L.concat (reverse adds')
-            in  unParser p2 (S sb lb' (adds' ++ adds) failDepth) k
+            in  unParser p2 (S sb lb' (adds' ++ adds) eof' failDepth) k
         | otherwise = f
       filt (IPartial cont) = IPartial (filt . cont)
       filt v@(IDone _ _) = v
     in
-      filt $ unParser p1 (S sb lb [] (failDepth + 1)) (cutContinuation k)
+      filt $ unParser p1 (S sb lb [] eof (failDepth + 1)) (cutContinuation k)
 
 instance Functor (Parser r) where
     fmap f m = Parser $ \s cont -> unParser m s (cont . f)
       ok -> ok
 
 initState :: L.ByteString -> S
-initState (L.Chunk sb lb) = S sb lb [] 0
-initState _               = S S.empty L.empty [] 0
+initState (L.Chunk sb lb) = S sb lb [] False 0
+initState _               = S S.empty L.empty [] False 0
 
-mkState :: L.ByteString -> [L.ByteString] -> Int -> S
-mkState bs adds failDepth =
+mkState :: L.ByteString -> [L.ByteString] -> Bool -> Int -> S
+mkState bs adds eof failDepth =
     case bs of
-      L.Empty -> S S.empty L.empty adds failDepth
-      L.Chunk sb lb -> S sb lb adds failDepth
+      L.Empty -> S S.empty L.empty adds eof failDepth
+      L.Chunk sb lb -> S sb lb adds eof failDepth
 
 addX :: L.ByteString -> [L.ByteString] -> [L.ByteString]
 addX s adds | L.null s = adds
             | otherwise = s : adds
 
 yield :: Parser r ()
-yield = Parser $ \(S sb lb adds failDepth) k ->
-  IPartial $ \s -> k () (S sb (lb `appL` s) (addX s adds) failDepth)
+yield = Parser $ \(S sb lb adds eof failDepth) k ->
+  IPartial $ \s -> k () (S sb (lb `appL` s) (addX s adds) eof failDepth)
+
+continue :: (S -> IResult r) -> Parser r a
+         -> (a -> S -> IResult r) -> S -> IResult r
+continue onEOF p k (S _sb _lb adds eof failDepth) =
+    if eof
+    then onEOF (S S.empty L.empty adds True failDepth)
+    else IPartial $ \s -> let st = contState s adds failDepth
+                          in unParser p st k
 
 takeWith :: (L.ByteString -> (L.ByteString, L.ByteString))
          -> Parser r L.ByteString
 takeWith splitf =
-  Parser $ \(S sb lb adds failDepth) k ->
+  Parser $ \st@(S sb lb adds eof failDepth) k ->
   let (left,rest) = splitf (sb +: lb)
-  in case rest of
-       L.Empty -> IPartial $ \s ->
-                  let s' = mkState s (addX s adds) failDepth
-                      k' a = k (appL left a)
-                  in unParser (takeWith splitf) s' k'
-       L.Chunk h t -> k left (S h t adds failDepth)
+  in if L.null rest
+     then continue (k left) (takeWith splitf) (k . appL left) st
+     else k left (mkState rest adds eof failDepth)
     
 takeWhile :: (Word8 -> Bool) -> Parser r L.ByteString
 takeWhile = takeWith . L.span
 
 takeCount :: Int -> Parser r L.ByteString
 takeCount = tc . fromIntegral where
- tc (!n) = Parser $ \(S sb lb adds failDepth) k ->
-           let (h,t) = L.splitAt n (sb +: lb)
-               l = L.length h
-           in if L.length h == n
-              then k h (mkState t adds failDepth)
-              else IPartial $ \s ->
-                   let st = mkState s (addX s adds) failDepth
-                       k' a = k (appL h a)
-                   in unParser (tc (n - l)) st k'
+ tc n = Parser $ \st@(S sb lb adds eof failDepth) k ->
+        let (h,t) = L.splitAt n (sb +: lb)
+            l = L.length h
+        in if L.length h == n
+           then k h (mkState t adds eof failDepth)
+           else continue (`IFailed` "takeCount: EOF")
+                         (tc (n - l)) (k . appL h) st
 
 string :: L.ByteString -> Parser r L.ByteString
 string s =
-  Parser $ \st@(S sb lb adds failDepth) k ->
+  Parser $ \st@(S sb lb adds eof failDepth) k ->
     case L.splitAt (L.length s) (sb +: lb) of
       (h,t)
-        | h == s -> k s (mkState t adds failDepth)
+        | h == s -> k s (mkState t adds eof failDepth)
       (h,L.Empty)
         | h `L.isPrefixOf` s ->
-            IPartial $ \s' ->
-            let st'  = mkState s' (addX s' adds) failDepth
-                k' a = k (appL h a)
-                r'   = L.drop (L.length h) s
-            in unParser (string r') st' k'
+            continue (`IFailed` "string: EOF")
+                     (string (L.drop (L.length h) s))
+                     (k . appL h)
+                     st
       _ -> IFailed st "string failed to match"
 
-emptyState = S S.empty L.empty
+contState :: L.ByteString -> [L.ByteString] -> Int -> S
+contState s adds failDepth
+    | L.null s  = S S.empty L.empty [] True failDepth
+    | otherwise = mkState s (addX s adds) False failDepth
 
 satisfy :: (Word8 -> Bool) -> Parser r Word8
 satisfy p =
-  Parser $ \st@(S sb lb adds failDepth) k ->
+  Parser $ \st@(S sb lb adds eof failDepth) k ->
     case S.uncons sb of
-      Just (w, sb') | p w -> k w (S sb' lb adds failDepth)
+      Just (w, sb') | p w -> k w (S sb' lb adds eof failDepth)
                     | otherwise -> IFailed st "failed to match"
       Nothing -> case L.uncons lb of
-                   Just (w, lb') | p w -> k w (mkState lb' adds failDepth)
+                   Just (w, lb') | p w -> k w (mkState lb' adds eof failDepth)
                                  | otherwise -> IFailed st "failed to match"
-                   Nothing -> IPartial $ \s ->
-                              let st' = emptyState adds failDepth
-                              in if L.null s
-                                 then IFailed st "barf"
-                                 else unParser (satisfy p) st' k
+                   Nothing -> continue (`IFailed` "satisfy: EOF")
+                                       (satisfy p) k st
 
 pushBack :: L.ByteString -> Parser r ()
 pushBack bs =
-    Parser $ \(S sb lb adds failDepth) k ->
-        k () (mkState (bs `appL` (sb +: lb)) adds failDepth)
+    Parser $ \(S sb lb adds eof failDepth) k ->
+        k () (mkState (bs `appL` (sb +: lb)) adds eof failDepth)
 
 toplevelTranslate :: IResult a -> Result a
 toplevelTranslate (IFailed _ err) = Failed err
-toplevelTranslate (IDone (S sb lb _ _) value) = Done (sb +: lb) value
+toplevelTranslate (IDone (S sb lb _ _ _) value) = Done (sb +: lb) value
 toplevelTranslate (IPartial k) = Partial $ toplevelTranslate . k
 
 terminalContinuation :: a -> S -> IResult a
     Partial k -> k <$> refill
     ok        -> pure ok
 
+parseTest :: (Show r) => Parser r r -> L.ByteString -> IO ()
+parseTest p s = print (parse p s)
+
 #define PARSER Parser r
 #include "Word8Boilerplate.h"

src/Data/ParserCombinators/Attoparsec/Incremental/Char8.hs

     , (<?>)
 
     -- * Things vaguely like those in @Parsec.Combinator@ (and @Parsec.Prim@)
-    , many1
-    , manyTill
-    , skipMany
-    , skipMany1
-    , count
-    , sepBy
-    , sepBy1
     , pushBack
 
     -- * Things like in @Parsec.Char@
     (FastSet, memberChar, set)
 import qualified Data.ParserCombinators.Attoparsec.Incremental as I
 import Data.ParserCombinators.Attoparsec.Incremental
-    (Parser, Result(..), (<?>), parse, manyTill, pushBack,
-     skipMany, skipMany1, count, sepBy, sepBy1, string,
-     takeCount, many1)
+    (Parser, Result(..), (<?>), parse, pushBack,
+     string, takeCount)
 import Data.ByteString.Lex.Lazy.Double (readDouble)
 import Prelude hiding (takeWhile)
 

src/Data/ParserCombinators/Attoparsec/Internal.hs

 
     -- * Things vaguely like those in @Parsec.Combinator@ (and @Parsec.Prim@)
     , try
-    , many1
-    , manyTill
     , eof
-    , skipMany
-    , skipMany1
-    , count
     , lookAhead
     , peek
-    , sepBy
-    , sepBy1
 
     -- * Things like in @Parsec.Char@
     , satisfy

src/Data/ParserCombinators/Attoparsec/Word8Boilerplate.h

 skipWhile p = takeWhile p *> pure ()
 {-# INLINE skipWhile #-}
 
-many1 :: PARSER a -> PARSER [a]
-many1 p = liftA2 (:) p (many p)
-
-sepBy :: PARSER a -> PARSER s -> PARSER [a]
-sepBy p s = liftA2 (:) p ((s *> sepBy1 p s) <|> pure []) <|> pure []
-
-sepBy1 :: PARSER a -> PARSER s -> PARSER [a]
-sepBy1 p s = liftA2 (:) p ((s *> sepBy1 p s) <|> pure [])
-
-manyTill :: PARSER a -> PARSER b -> PARSER [a]
-manyTill p end = scan
-    where scan = (end *> pure []) <|> liftA2 (:) p scan
-
--- | Skip zero or more instances of the parser.
-skipMany :: PARSER a -> PARSER ()
-skipMany p = scan
-    where scan = (p >> scan) <|> return ()
-
--- | Skip one or more instances of the parser.
-skipMany1 :: PARSER a -> PARSER ()
-skipMany1 p = p >> skipMany p
-
--- | Apply the given parser repeatedly, returning every parse result.
-count :: Int -> PARSER a -> PARSER [a]
-count n p = sequence (replicate n p)
-{-# INLINE count #-}
-
 anyWord8 :: PARSER Word8
 anyWord8 = satisfy $ const True
 {-# INLINE anyWord8 #-}
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.