polyparse-1.7/0000755000000000000000000000000011601657462011575 5ustar0000000000000000polyparse-1.7/COPYRIGHT0000644000000000000000000000253611601657462013076 0ustar0000000000000000The module Text.ParserCombinators.HuttonMeijer is (c) copyright 1996 Graham Hutton and Erik Meijer The module Text.ParserCombinators.HuttonMeijerWallace is (c) copyright 1996 Graham Hutton and Erik Meijer with modifications (c) copyright 1998-2000 Malcolm Wallace The modules Text.ParserCombinators.Poly* and Text.Parse and Text.Parse.* are (c) copyright 2006-2011 Malcolm Wallace These modules are licensed under the terms of the GNU Lesser General Public Licence (LGPL), which can be found in the file called LICENCE-LGPL, with the following special exception: ---- As a relaxation of clause 6 of the LGPL, the copyright holders of this library give permission to use, copy, link, modify, and distribute, binary-only object-code versions of an executable linked with the original unmodified Library, without requiring the supply of any mechanism to modify or replace the Library and relink (clauses 6a, 6b, 6c, 6d, 6e), provided that all the other terms of clause 6 are complied with. ---- This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Licence for more details. If these licensing terms are not acceptable to you, please contact me for negotiation. :-) Malcolm.Wallace@me.com polyparse-1.7/Setup.hs0000644000000000000000000000005611601657462013232 0ustar0000000000000000import Distribution.Simple main = defaultMain polyparse-1.7/polyparse.cabal0000644000000000000000000000320011601657462014572 0ustar0000000000000000name: polyparse version: 1.7 license: LGPL license-file: COPYRIGHT author: Malcolm Wallace maintainer: author homepage: http://code.haskell.org/~malcolm/polyparse/ category: Text, Parsing synopsis: A variety of alternative parser combinator libraries. description: A variety of alternative parser combinator libraries, including the original HuttonMeijer set. The Poly sets have features like good error reporting, arbitrary token type, running state, lazy parsing, and so on. Finally, Text.Parse is a proposed replacement for the standard Read class, for better deserialisation of Haskell values from Strings. build-type: Simple cabal-version: >=1.2 library hs-source-dirs: src build-depends: base <= 6 exposed-modules: Text.ParserCombinators.HuttonMeijer, Text.ParserCombinators.HuttonMeijerWallace, Text.ParserCombinators.Poly, Text.ParserCombinators.Poly.Base, Text.ParserCombinators.Poly.Result, Text.ParserCombinators.Poly.Parser, Text.ParserCombinators.Poly.Plain, Text.ParserCombinators.Poly.Lazy, Text.ParserCombinators.Poly.StateParser, Text.ParserCombinators.Poly.State, Text.ParserCombinators.Poly.StateLazy, Text.ParserCombinators.Poly.Lex, Text.Parse if impl(ghc) build-depends: bytestring build-depends: text exposed-modules: Text.ParserCombinators.Poly.ByteString Text.Parse.ByteString Text.ParserCombinators.Poly.Text Text.ParserCombinators.Poly.StateText -- Text.Parse.Text cpp-options: -DVERSION="1.7" nhc98-options: -K6M extensions: CPP polyparse-1.7/src/0000755000000000000000000000000011601657462012364 5ustar0000000000000000polyparse-1.7/src/Text/0000755000000000000000000000000011601657462013310 5ustar0000000000000000polyparse-1.7/src/Text/Parse.hs0000644000000000000000000004750611601657462014732 0ustar0000000000000000module Text.Parse ( -- * The Parse class is a replacement for the standard Read class. -- $parser TextParser -- synonym for Parser Char, i.e. string input, no state , Parse(..) -- instances: (), (a,b), (a,b,c), Maybe a, Either a, [a], -- Int, Integer, Float, Double, Char, Bool , parseByRead -- :: Read a => String -> TextParser a , readByParse -- :: TextParser a -> ReadS a , readsPrecByParsePrec -- :: (Int->TextParser a) -> Int -> ReadS a -- ** Combinators specific to string input, lexed haskell-style , word -- :: TextParser String , isWord -- :: String -> TextParser () , optionalParens -- :: TextParser a -> TextParser a , parens -- :: Bool -> TextParser a -> TextParser a , field -- :: Parse a => String -> TextParser a , constructors-- :: [(String,TextParser a)] -> TextParser a , enumeration -- :: Show a => String -> [a] -> TextParser a -- ** Parsers for literal numerics and characters , parseSigned , parseInt , parseDec , parseOct , parseHex , parseFloat , parseLitChar -- ** Re-export all the more general combinators from Poly too , module Text.ParserCombinators.Poly -- ** Strings as whole entities , allAsString ) where import Data.Char as Char (isSpace,toLower,isUpper,isDigit,isOctDigit ,isHexDigit,digitToInt,isAlpha,isAlphaNum,ord,chr) import Data.List (intersperse) import Data.Ratio import Text.ParserCombinators.Poly ------------------------------------------------------------------------ -- $parser -- The Parse class is a replacement for the standard Read class. It is a -- specialisation of the (poly) Parser monad for String input. -- There are instances defined for all Prelude types. -- For user-defined types, you can write your own instance, or use -- DrIFT to generate them automatically, e.g. {-! derive : Parse !-} -- | A synonym for Parser Char, i.e. string input (no state) type TextParser a = Parser Char a -- | The class @Parse@ is a replacement for @Read@, operating over String input. -- Essentially, it permits better error messages for why something failed to -- parse. It is rather important that @parse@ can read back exactly what -- is generated by the corresponding instance of @show@. To apply a parser -- to some text, use @runParser@. class Parse a where -- | A straightforward parser for an item. (A minimal definition of -- a class instance requires either |parse| or |parsePrec|.) parse :: TextParser a parse = parsePrec 0 -- | A straightforward parser for an item, given the precedence of -- any surrounding expression. (Precedence determines whether -- parentheses are mandatory or optional.) parsePrec :: Int -> TextParser a parsePrec _ = optionalParens parse -- | Parsing a list of items by default accepts the [] and comma syntax, -- except when the list is really a character string using \"\". parseList :: TextParser [a] -- only to distinguish [] and "" parseList = do { isWord "[]"; return [] } `onFail` do { isWord "["; isWord "]"; return [] } `onFail` bracketSep (isWord "[") (isWord ",") (isWord "]") (optionalParens parse) `adjustErr` ("Expected a list, but\n"++) -- | If there already exists a Read instance for a type, then we can make -- a Parser for it, but with only poor error-reporting. The string argument -- is the expected type or value (for error-reporting only). parseByRead :: Read a => String -> TextParser a parseByRead name = P (\s-> case reads s of [] -> Failure s ("no parse, expected a "++name) [(a,s')] -> Success s' a _ -> Failure s ("ambiguous parse, expected a "++name) ) -- | If you have a TextParser for a type, you can easily make it into -- a Read instance, by throwing away any error messages. readByParse :: TextParser a -> ReadS a readByParse p = \inp-> case runParser p inp of (Left err, rest) -> [] (Right val, rest) -> [(val,rest)] -- | If you have a TextParser for a type, you can easily make it into -- a Read instance, by throwing away any error messages. readsPrecByParsePrec :: (Int -> TextParser a) -> Int -> ReadS a readsPrecByParsePrec p = \prec inp-> case runParser (p prec) inp of (Left err, rest) -> [] (Right val, rest) -> [(val,rest)] -- | One lexical chunk. This is Haskell'98-style lexing - the result -- should match Prelude.lex apart from better error-reporting. word :: TextParser String word = P p where p "" = Failure "" "end of input" p (c:s) | isSpace c = p (dropWhile isSpace s) p ('\'':s) = let (P lit) = parseLitChar in fmap show (lit ('\'':s)) p ('"':s) = lexString "\"" s where lexString acc ('"':s) = Success s (reverse ('"':acc)) lexString acc ('\\':'"':s) = lexString ("\"\\"++acc) s lexString acc (c:s) = lexString (c:acc) s lexString acc [] = Failure [] ("end of input in " ++"string literal " ++acc) p ('0':'x':s) = Success t ('0':'x':ds) where (ds,t) = span isHexDigit s p ('0':'X':s) = Success t ('0':'X':ds) where (ds,t) = span isHexDigit s p ('0':'o':s) = Success t ('0':'o':ds) where (ds,t) = span isOctDigit s p ('0':'O':s) = Success t ('0':'O':ds) where (ds,t) = span isOctDigit s p (c:s) | isSingle c = Success s [c] | isSym c = let (sym,t) = span isSym s in Success t (c:sym) | isIdInit c = let (nam,t) = span isIdChar s in Success t (c:nam) | isDigit c = let (ds,t) = span isDigit s in lexFracExp (c:ds) t | otherwise = Failure (c:s) ("Bad character: "++show c) where isSingle c = c `elem` ",;()[]{}`" isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~" isIdInit c = isAlpha c || c == '_' isIdChar c = isAlphaNum c || c `elem` "_'" lexFracExp acc ('.':d:s) | isDigit d = lexExp (acc++'.':d:ds) t where (ds,t) = span isDigit s lexFracExp acc s = lexExp acc s lexExp acc (e:s) | e`elem`"eE" = case s of ('+':d:t) | isDigit d -> let (ds,u)=span isDigit t in Success u (acc++"e+"++d:ds) ('-':d:t) | isDigit d -> let (ds,u)=span isDigit t in Success u (acc++"e-"++d:ds) (d:t) |isDigit d -> let (ds,u)=span isDigit t in Success u (acc++"e"++d:ds) _ -> Failure s ("missing +/-/digit " ++"after e in float " ++"literal: " ++show (acc++"e"++"...")) lexExp acc s = Success s acc -- | One lexical chunk (Haskell'98-style lexing - the result should match -- Prelude.lex apart from error-reporting). oldword :: TextParser String oldword = P (\s-> case lex s of [] -> Failure s ("no input? (impossible)") [("","")] -> Failure "" ("no input?") [("",s')] -> Failure s ("lexing failed?") ((x,s'):_) -> Success s' x ) -- | Ensure that the next input word is the given string. (Note the input -- is lexed as haskell, so wordbreaks at spaces, symbols, etc.) isWord :: String -> TextParser String isWord w = do { w' <- word ; if w'==w then return w else fail ("expected "++w++" got "++w') } -- | Allow nested parens around an item. optionalParens :: TextParser a -> TextParser a optionalParens p = parens False p -- | Allow nested parens around an item (one set required when Bool is True). parens :: Bool -> TextParser a -> TextParser a parens True p = bracket (isWord "(") (isWord ")") (parens False p) parens False p = parens True p `onFail` p -- | Deal with named field syntax. The string argument is the field name, -- and the parser returns the value of the field. field :: Parse a => String -> TextParser a field name = do { isWord name; commit $ do { isWord "="; parse } } -- | Parse one of a bunch of alternative constructors. In the list argument, -- the first element of the pair is the constructor name, and -- the second is the parser for the rest of the value. The first matching -- parse is returned. constructors :: [(String,TextParser a)] -> TextParser a constructors cs = oneOf' (map cons cs) where cons (name,p) = ( name , do { isWord name ; p `adjustErrBad` (("got constructor, but within " ++name++",\n")++) } ) -- | Parse one of the given nullary constructors (an enumeration). -- The string argument is the name of the type, and the list argument -- should contain all of the possible enumeration values. enumeration :: (Show a) => String -> [a] -> TextParser a enumeration typ cs = oneOf (map (\c-> do { isWord (show c); return c }) cs) `adjustErr` (++("\n expected "++typ++" value ("++e++")")) where e = concat (intersperse ", " (map show (init cs))) ++ ", or " ++ show (last cs) ------------------------------------------------------------------------ -- Instances for all the Standard Prelude types. -- Numeric types parseSigned :: Real a => TextParser a -> TextParser a parseSigned p = do '-' <- next; commit (fmap negate p) `onFail` do p parseInt :: (Integral a) => String -> a -> (Char -> Bool) -> (Char -> Int) -> TextParser a parseInt base radix isDigit digitToInt = do cs <- many1 (satisfy isDigit) return (foldl1 (\n d-> n*radix+d) (map (fromIntegral.digitToInt) cs)) `adjustErr` (++("\nexpected one or more "++base++" digits")) parseDec, parseOct, parseHex :: (Integral a) => TextParser a parseDec = parseInt "decimal" 10 Char.isDigit Char.digitToInt parseOct = parseInt "octal" 8 Char.isOctDigit Char.digitToInt parseHex = parseInt "hex" 16 Char.isHexDigit Char.digitToInt parseFloat :: (RealFrac a) => TextParser a parseFloat = do ds <- many1 (satisfy isDigit) frac <- (do '.' <- next many (satisfy isDigit) `adjustErrBad` (++"expected digit after .") `onFail` return [] ) exp <- exponent `onFail` return 0 ( return . fromRational . (* (10^^(exp - length frac))) . (%1) . (\ (Right x)->x) . fst . runParser parseDec ) (ds++frac) `onFail` do w <- many (satisfy (not.isSpace)) case map toLower w of "nan" -> return (0/0) "infinity" -> return (1/0) _ -> fail "expected a floating point number" where exponent = do 'e' <- fmap toLower next commit (do '+' <- next; parseDec `onFail` parseSigned parseDec ) parseLitChar :: TextParser Char parseLitChar = do '\'' <- next `adjustErr` (++"expected a literal char") c <- next char <- case c of '\\' -> next >>= escape '\'' -> fail "expected a literal char, got ''" _ -> return c '\'' <- next `adjustErrBad` (++"literal char has no final '") return char where escape 'a' = return '\a' escape 'b' = return '\b' escape 'f' = return '\f' escape 'n' = return '\n' escape 'r' = return '\r' escape 't' = return '\t' escape 'v' = return '\v' escape '\\' = return '\\' escape '"' = return '"' escape '\'' = return '\'' escape '^' = do ctrl <- next if ctrl >= '@' && ctrl <= '_' then return (chr (ord ctrl - ord '@')) else fail ("literal char ctrl-escape malformed: \\^" ++[ctrl]) escape d | isDigit d = fmap chr $ (reparse [d] >> parseDec) escape 'o' = fmap chr $ parseOct escape 'x' = fmap chr $ parseHex escape c | isUpper c = mnemonic c escape c = fail ("unrecognised escape sequence in literal char: \\"++[c]) mnemonic 'A' = do 'C' <- next; 'K' <- next; return '\ACK' `wrap` "'\\ACK'" mnemonic 'B' = do 'E' <- next; 'L' <- next; return '\BEL' `onFail` do 'S' <- next; return '\BS' `wrap` "'\\BEL' or '\\BS'" mnemonic 'C' = do 'R' <- next; return '\CR' `onFail` do 'A' <- next; 'N' <- next; return '\CAN' `wrap` "'\\CR' or '\\CAN'" mnemonic 'D' = do 'E' <- next; 'L' <- next; return '\DEL' `onFail` do 'L' <- next; 'E' <- next; return '\DLE' `onFail` do 'C' <- next; ( do '1' <- next; return '\DC1' `onFail` do '2' <- next; return '\DC2' `onFail` do '3' <- next; return '\DC3' `onFail` do '4' <- next; return '\DC4' ) `wrap` "'\\DEL' or '\\DLE' or '\\DC[1..4]'" mnemonic 'E' = do 'T' <- next; 'X' <- next; return '\ETX' `onFail` do 'O' <- next; 'T' <- next; return '\EOT' `onFail` do 'N' <- next; 'Q' <- next; return '\ENQ' `onFail` do 'T' <- next; 'B' <- next; return '\ETB' `onFail` do 'M' <- next; return '\EM' `onFail` do 'S' <- next; 'C' <- next; return '\ESC' `wrap` "one of '\\ETX' '\\EOT' '\\ENQ' '\\ETB' '\\EM' or '\\ESC'" mnemonic 'F' = do 'F' <- next; return '\FF' `onFail` do 'S' <- next; return '\FS' `wrap` "'\\FF' or '\\FS'" mnemonic 'G' = do 'S' <- next; return '\GS' `wrap` "'\\GS'" mnemonic 'H' = do 'T' <- next; return '\HT' `wrap` "'\\HT'" mnemonic 'L' = do 'F' <- next; return '\LF' `wrap` "'\\LF'" mnemonic 'N' = do 'U' <- next; 'L' <- next; return '\NUL' `onFail` do 'A' <- next; 'K' <- next; return '\NAK' `wrap` "'\\NUL' or '\\NAK'" mnemonic 'R' = do 'S' <- next; return '\RS' `wrap` "'\\RS'" mnemonic 'S' = do 'O' <- next; 'H' <- next; return '\SOH' `onFail` do 'O' <- next; return '\SO' `onFail` do 'T' <- next; 'X' <- next; return '\STX' `onFail` do 'I' <- next; return '\SI' `onFail` do 'Y' <- next; 'N' <- next; return '\SYN' `onFail` do 'U' <- next; 'B' <- next; return '\SUB' `onFail` do 'P' <- next; return '\SP' `wrap` "'\\SOH' '\\SO' '\\STX' '\\SI' '\\SYN' '\\SUB' or '\\SP'" mnemonic 'U' = do 'S' <- next; return '\US' `wrap` "'\\US'" mnemonic 'V' = do 'T' <- next; return '\VT' `wrap` "'\\VT'" wrap p s = p `onFail` fail ("expected literal char "++s) -- Basic types instance Parse Int where -- parse = parseByRead "Int" -- convert from Integer, deals with minInt parse = fmap fromInteger $ do many (satisfy isSpace); parseSigned parseDec instance Parse Integer where -- parse = parseByRead "Integer" parse = do many (satisfy isSpace); parseSigned parseDec instance Parse Float where -- parse = parseByRead "Float" parse = do many (satisfy isSpace); parseSigned parseFloat instance Parse Double where -- parse = parseByRead "Double" parse = do many (satisfy isSpace); parseSigned parseFloat instance Parse Char where -- parse = parseByRead "Char" parse = do many (satisfy isSpace); parseLitChar -- parse = do { w <- word; if head w == '\'' then readLitChar (tail w) -- else fail "expected a char" } -- parseList = bracket (isWord "\"") (satisfy (=='"')) -- (many (satisfy (/='"'))) -- not totally correct for strings... parseList = do { w <- word; if head w == '"' then return (init (tail w)) else fail "not a string" } instance Parse Bool where parse = enumeration "Bool" [False,True] instance Parse Ordering where parse = enumeration "Ordering" [LT,EQ,GT] -- Structural types instance Parse () where parse = P p where p [] = Failure [] "no input: expected a ()" p ('(':cs) = case dropWhile isSpace cs of (')':s) -> Success s () _ -> Failure cs "Expected ) after (" p (c:cs) | isSpace c = p cs | otherwise = Failure (c:cs) ("Expected a (), got "++show c) instance (Parse a, Parse b) => Parse (a,b) where parse = do{ isWord "(" `adjustErr` ("Opening a 2-tuple\n"++) ; x <- parse `adjustErr` ("In 1st item of a 2-tuple\n"++) ; isWord "," `adjustErr` ("Separating a 2-tuple\n"++) ; y <- parse `adjustErr` ("In 2nd item of a 2-tuple\n"++) ; isWord ")" `adjustErr` ("Closing a 2-tuple\n"++) ; return (x,y) } instance (Parse a, Parse b, Parse c) => Parse (a,b,c) where parse = do{ isWord "(" `adjustErr` ("Opening a 3-tuple\n"++) ; x <- parse `adjustErr` ("In 1st item of a 3-tuple\n"++) ; isWord "," `adjustErr` ("Separating(1) a 3-tuple\n"++) ; y <- parse `adjustErr` ("In 2nd item of a 3-tuple\n"++) ; isWord "," `adjustErr` ("Separating(2) a 3-tuple\n"++) ; z <- parse `adjustErr` ("In 3rd item of a 3-tuple\n"++) ; isWord ")" `adjustErr` ("Closing a 3-tuple\n"++) ; return (x,y,z) } instance Parse a => Parse (Maybe a) where parsePrec p = optionalParens (do { isWord "Nothing"; return Nothing }) `onFail` parens (p>9) (do { isWord "Just" ; fmap Just $ parsePrec 10 `adjustErrBad` ("but within Just, "++) }) `adjustErr` (("expected a Maybe (Just or Nothing)\n"++).indent 2) instance (Parse a, Parse b) => Parse (Either a b) where parsePrec p = parens (p>9) $ constructors [ ("Left", do { fmap Left $ parsePrec 10 } ) , ("Right", do { fmap Right $ parsePrec 10 } ) ] instance Parse a => Parse [a] where parse = parseList -- | Simply return the entire remaining input String. allAsString :: TextParser String allAsString = P (\s-> Success [] s) ------------------------------------------------------------------------ polyparse-1.7/src/Text/Parse/0000755000000000000000000000000011601657462014362 5ustar0000000000000000polyparse-1.7/src/Text/Parse/ByteString.hs0000644000000000000000000005501211601657462017013 0ustar0000000000000000module Text.Parse.ByteString ( -- * The Parse class is a replacement for the standard Read class. -- This particular instance reads from ByteString rather than String. -- $parser TextParser -- synonym for Text.ParserCombinators.Poly.ByteString , Parse(..) -- instances: (), (a,b), (a,b,c), Maybe a, Either a, [a], -- Int, Integer, Float, Double, Char, Bool , parseByRead -- :: Read a => String -> TextParser a , readByParse -- :: TextParser a -> ReadS a , readsPrecByParsePrec -- :: (Int->TextParser a) -> Int -> ReadS a -- ** Combinators specific to bytestring input, lexed haskell-style , word -- :: TextParser String , isWord -- :: String -> TextParser () , optionalParens -- :: TextParser a -> TextParser a , parens -- :: Bool -> TextParser a -> TextParser a , field -- :: Parse a => String -> TextParser a , constructors-- :: [(String,TextParser a)] -> TextParser a , enumeration -- :: Show a => String -> [a] -> TextParser a -- ** Parsers for literal numerics and characters , parseSigned , parseInt , parseDec , parseOct , parseHex , parseUnsignedInteger , parseFloat , parseLitChar -- ** Re-export all the more general combinators from Poly too , module Text.ParserCombinators.Poly.ByteString -- ** ByteStrings and Strings as whole entities , allAsByteString , allAsString ) where import Data.Char as Char (isUpper,isDigit,isOctDigit,isHexDigit,digitToInt ,isSpace,isAlpha,isAlphaNum,ord,chr,toLower) import Data.List (intersperse) import Data.Ratio import qualified Data.ByteString.Lazy.Char8 as BS import Data.ByteString.Lazy.Char8 (ByteString) import Text.ParserCombinators.Poly.ByteString ------------------------------------------------------------------------ -- $parser -- The Parse class is a replacement for the standard Read class. It is a -- specialisation of the (poly) Parser monad for ByteString input. -- There are instances defined for all Prelude types. -- For user-defined types, you can write your own instance, or use -- DrIFT to generate them automatically, e.g. {-! derive : Parse !-} -- | A synonym for a ByteString Parser, i.e. bytestring input (no state) type TextParser a = Parser a -- | The class @Parse@ is a replacement for @Read@, operating over String input. -- Essentially, it permits better error messages for why something failed to -- parse. It is rather important that @parse@ can read back exactly what -- is generated by the corresponding instance of @show@. To apply a parser -- to some text, use @runParser@. class Parse a where -- | A straightforward parser for an item. (A minimal definition of -- a class instance requires either |parse| or |parsePrec|. In general, -- for a type that never needs parens, you should define |parse|, but -- for a type that _may_ need parens, you should define |parsePrec|.) parse :: TextParser a parse = parsePrec 0 -- | A straightforward parser for an item, given the precedence of -- any surrounding expression. (Precedence determines whether -- parentheses are mandatory or optional.) parsePrec :: Int -> TextParser a parsePrec _ = optionalParens parse -- | Parsing a list of items by default accepts the [] and comma syntax, -- except when the list is really a character string using \"\". parseList :: TextParser [a] -- only to distinguish [] and "" parseList = do { isWord "[]"; return [] } `onFail` do { isWord "["; isWord "]"; return [] } `onFail` bracketSep (isWord "[") (isWord ",") (isWord "]") (optionalParens parse) `adjustErr` ("Expected a list, but\n"++) -- | If there already exists a Read instance for a type, then we can make -- a Parser for it, but with only poor error-reporting. The string argument -- is the expected type or value (for error-reporting only). Use of this -- wrapper function is NOT recommended with ByteString, because there -- is a lot of inefficiency in repeated conversions to/from String. parseByRead :: Read a => String -> TextParser a parseByRead name = P (\s-> case reads (BS.unpack s) of [] -> Failure s ("no parse, expected a "++name) [(a,s')] -> Success (BS.pack s') a _ -> Failure s ("ambiguous parse, expected a "++name) ) -- | If you have a TextParser for a type, you can easily make it into -- a Read instance, by throwing away any error messages. Use of this -- wrapper function is NOT recommended with ByteString, because there -- is a lot of inefficiency in conversions to/from String. readByParse :: TextParser a -> ReadS a readByParse p = \inp-> case runParser p (BS.pack inp) of (Left err, rest) -> [] (Right val, rest) -> [(val, BS.unpack rest)] -- | If you have a TextParser for a type, you can easily make it into -- a Read instance, by throwing away any error messages. Use of this -- wrapper function is NOT recommended with ByteString, because there -- is a lot of inefficiency in conversions to/from String. readsPrecByParsePrec :: (Int -> TextParser a) -> Int -> ReadS a readsPrecByParsePrec p = \prec inp-> case runParser (p prec) (BS.pack inp) of (Left err, rest) -> [] (Right val, rest) -> [(val, BS.unpack rest)] -- | One lexical chunk (Haskell-style lexing). word :: TextParser String {- word = P (\s-> case lex (BS.unpack s) of [] -> Failure s ("no input? (impossible)") [("","")] -> Failure s ("no input?") [("",_)] -> Failure s ("lexing failed?") ((x,_):_) -> Success (BS.drop (fromIntegral (length x)) s) x ) -} word = P (p . BS.dropWhile isSpace) where p s | BS.null s = Failure BS.empty "end of input" | otherwise = case (BS.head s, BS.tail s) of ('\'',t) -> let (P lit) = parseLitChar in fmap show (lit s) ('\"',t) -> let (str,rest) = BS.span (not . (`elem` "\\\"")) t in litString ('\"': BS.unpack str) rest ('0',s) -> case BS.uncons s of Just ('x',r) -> Success t ("0x"++BS.unpack ds) where (ds,t) = BS.span isHexDigit r Just ('X',r) -> Success t ("0X"++BS.unpack ds) where (ds,t) = BS.span isHexDigit r Just ('o',r) -> Success t ("0o"++BS.unpack ds) where (ds,t) = BS.span isOctDigit r Just ('O',r) -> Success t ("0O"++BS.unpack ds) where (ds,t) = BS.span isOctDigit r _ -> lexFracExp ('0': BS.unpack ds) t where (ds,t) = BS.span isDigit s (c,s) | isIdInit c -> let (nam,t) = BS.span isIdChar s in Success t (c: BS.unpack nam) | isDigit c -> let (ds,t) = BS.span isDigit s in lexFracExp (c: BS.unpack ds) t | isSingle c -> Success s (c:[]) | isSym c -> let (sym,t) = BS.span isSym s in Success t (c: BS.unpack sym) | otherwise -> Failure (BS.cons c s) ("Bad character: "++show c) isSingle c = c `elem` ",;()[]{}`" isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~" isIdInit c = isAlpha c || c == '_' isIdChar c = isAlphaNum c || c `elem` "_'" lexFracExp acc s = case BS.uncons s of Just ('.',s') -> case BS.uncons s' of Just (d,s'') | isDigit d -> let (ds,t) = BS.span isDigit s'' in lexExp (acc++'.':d: BS.unpack ds) t _ -> lexExp acc s' _ -> lexExp acc s lexExp acc s = case BS.uncons s of Just (e,s') | e `elem` "eE" -> case BS.uncons s' of Just (sign,dt) | sign `elem` "+-" -> case BS.uncons dt of Just (d,t) | isDigit d -> let (ds,u) = BS.span isDigit t in Success u (acc++'e': sign: d: BS.unpack ds) | isDigit sign -> let (ds,u) = BS.span isDigit dt in Success u (acc++'e': sign: BS.unpack ds) _ -> Failure s' ("missing +/-/digit " ++"after e in float literal: " ++show (acc++'e':"...")) _ -> Success s acc litString acc s = case BS.uncons s of Nothing -> Failure (BS.empty) ("end of input in string literal "++acc) Just ('\"',r) -> Success r (acc++"\"") Just ('\\',r) -> case BS.uncons r of -- "for vim Just ('\"',t) -> litString (acc++"\\\"") t _ -> litString (acc++"\\") r -- "vim Just (_,r) -> error "Text.Parse.word(litString) - can't happen" -- | Ensure that the next input word is the given string. (Note the input -- is lexed as haskell, so wordbreaks at spaces, symbols, etc.) isWord :: String -> TextParser String isWord w = do { w' <- word ; if w'==w then return w else fail ("expected "++w++" got "++w') } -- | Allow optional nested string parens around an item. optionalParens :: TextParser a -> TextParser a optionalParens p = parens False p -- | Allow nested parens around an item (one set required when Bool is True). parens :: Bool -> TextParser a -> TextParser a parens True p = bracket (isWord "(") (isWord ")") (parens False p) parens False p = parens True p `onFail` p -- | Deal with named field syntax. The string argument is the field name, -- and the parser returns the value of the field. field :: Parse a => String -> TextParser a field name = do { isWord name; commit $ do { isWord "="; parse } } -- | Parse one of a bunch of alternative constructors. In the list argument, -- the first element of the pair is the constructor name, and -- the second is the parser for the rest of the value. The first matching -- parse is returned. constructors :: [(String,TextParser a)] -> TextParser a constructors cs = oneOf' (map cons cs) where cons (name,p) = ( name , do { isWord name ; p `adjustErrBad` (("got constructor, but within " ++name++",\n")++) } ) -- | Parse one of the given nullary constructors (an enumeration). -- The string argument is the name of the type, and the list argument -- should contain all of the possible enumeration values. enumeration :: (Show a) => String -> [a] -> TextParser a enumeration typ cs = oneOf (map (\c-> do { isWord (show c); return c }) cs) `adjustErr` (++("\n expected "++typ++" value ("++e++")")) where e = concat (intersperse ", " (map show (init cs))) ++ ", or " ++ show (last cs) ------------------------------------------------------------------------ -- Instances for all the Standard Prelude types. -- Numeric types -- | For any numeric parser, permit a negation sign in front of it. parseSigned :: Real a => TextParser a -> TextParser a parseSigned p = do '-' <- next; commit (fmap negate p) `onFail` do p -- | Parse any (unsigned) Integral numeric literal. -- Needs a base, radix, isDigit predicate, -- and digitToInt converter, appropriate to the result type. parseInt :: (Integral a) => String -> a -> (Char -> Bool) -> (Char -> Int) -> TextParser a parseInt base radix isDigit digitToInt = do cs <- many1 (satisfy isDigit) return (foldl1 (\n d-> n*radix+d) (map (fromIntegral.digitToInt) cs)) `adjustErr` (++("\nexpected one or more "++base++" digits")) -- | Parse a decimal, octal, or hexadecimal (unsigned) Integral numeric literal. parseDec, parseOct, parseHex :: (Integral a) => TextParser a parseDec = parseInt "decimal" 10 Char.isDigit Char.digitToInt parseOct = parseInt "octal" 8 Char.isOctDigit Char.digitToInt parseHex = parseInt "hex" 16 Char.isHexDigit Char.digitToInt -- | parseUnsignedInteger uses the underlying ByteString readInteger, so -- will be a lot faster than the generic character-by-character parseInt. parseUnsignedInteger :: TextParser Integer parseUnsignedInteger = P (\bs -> case BS.uncons bs of Just (c, _) | Char.isDigit c -> case BS.readInteger bs of Just (i, bs') -> Success bs' i Nothing -> error "XXX Can't happen" _ -> Failure bs "parsing Integer: not a digit") `adjustErr` (++("\nexpected one or more decimal digits")) -- | Parse any (unsigned) Floating numeric literal, e.g. Float or Double. parseFloat :: (RealFrac a) => TextParser a parseFloat = do ds <- many1Satisfy isDigit frac <- (do '.' <- next manySatisfy isDigit `adjustErrBad` (++"expected digit after .") `onFail` return BS.empty ) exp <- exponent `onFail` return 0 ( return . fromRational . (* (10^^(exp - BS.length frac))) . (%1) . (\ (Right x)->x) . fst . runParser parseDec ) (ds `BS.append` frac) `onFail` do w <- manySatisfy isAlpha case map toLower (BS.unpack w) of "nan" -> return (0/0) "infinity" -> return (1/0) _ -> fail "expected a floating point number" where exponent = do 'e' <- fmap toLower next commit (do '+' <- next; parseDec `onFail` parseSigned parseDec ) -- | Parse a Haskell character literal. parseLitChar :: TextParser Char parseLitChar = do '\'' <- next `adjustErr` (++"expected a literal char") c <- next char <- case c of '\\' -> next >>= escape '\'' -> fail "expected a literal char, got ''" _ -> return c '\'' <- next `adjustErrBad` (++"literal char has no final '") return char where escape 'a' = return '\a' escape 'b' = return '\b' escape 'f' = return '\f' escape 'n' = return '\n' escape 'r' = return '\r' escape 't' = return '\t' escape 'v' = return '\v' escape '\\' = return '\\' escape '"' = return '"' escape '\'' = return '\'' escape '^' = do ctrl <- next if ctrl >= '@' && ctrl <= '_' then return (chr (ord ctrl - ord '@')) else fail ("literal char ctrl-escape malformed: \\^" ++[ctrl]) escape d | isDigit d = fmap chr $ (reparse (BS.pack [d]) >> parseDec) escape 'o' = fmap chr $ parseOct escape 'x' = fmap chr $ parseHex escape c | isUpper c = mnemonic c escape c = fail ("unrecognised escape sequence in literal char: \\"++[c]) mnemonic 'A' = do 'C' <- next; 'K' <- next; return '\ACK' `wrap` "'\\ACK'" mnemonic 'B' = do 'E' <- next; 'L' <- next; return '\BEL' `onFail` do 'S' <- next; return '\BS' `wrap` "'\\BEL' or '\\BS'" mnemonic 'C' = do 'R' <- next; return '\CR' `onFail` do 'A' <- next; 'N' <- next; return '\CAN' `wrap` "'\\CR' or '\\CAN'" mnemonic 'D' = do 'E' <- next; 'L' <- next; return '\DEL' `onFail` do 'L' <- next; 'E' <- next; return '\DLE' `onFail` do 'C' <- next; ( do '1' <- next; return '\DC1' `onFail` do '2' <- next; return '\DC2' `onFail` do '3' <- next; return '\DC3' `onFail` do '4' <- next; return '\DC4' ) `wrap` "'\\DEL' or '\\DLE' or '\\DC[1..4]'" mnemonic 'E' = do 'T' <- next; 'X' <- next; return '\ETX' `onFail` do 'O' <- next; 'T' <- next; return '\EOT' `onFail` do 'N' <- next; 'Q' <- next; return '\ENQ' `onFail` do 'T' <- next; 'B' <- next; return '\ETB' `onFail` do 'M' <- next; return '\EM' `onFail` do 'S' <- next; 'C' <- next; return '\ESC' `wrap` "one of '\\ETX' '\\EOT' '\\ENQ' '\\ETB' '\\EM' or '\\ESC'" mnemonic 'F' = do 'F' <- next; return '\FF' `onFail` do 'S' <- next; return '\FS' `wrap` "'\\FF' or '\\FS'" mnemonic 'G' = do 'S' <- next; return '\GS' `wrap` "'\\GS'" mnemonic 'H' = do 'T' <- next; return '\HT' `wrap` "'\\HT'" mnemonic 'L' = do 'F' <- next; return '\LF' `wrap` "'\\LF'" mnemonic 'N' = do 'U' <- next; 'L' <- next; return '\NUL' `onFail` do 'A' <- next; 'K' <- next; return '\NAK' `wrap` "'\\NUL' or '\\NAK'" mnemonic 'R' = do 'S' <- next; return '\RS' `wrap` "'\\RS'" mnemonic 'S' = do 'O' <- next; 'H' <- next; return '\SOH' `onFail` do 'O' <- next; return '\SO' `onFail` do 'T' <- next; 'X' <- next; return '\STX' `onFail` do 'I' <- next; return '\SI' `onFail` do 'Y' <- next; 'N' <- next; return '\SYN' `onFail` do 'U' <- next; 'B' <- next; return '\SUB' `onFail` do 'P' <- next; return '\SP' `wrap` "'\\SOH' '\\SO' '\\STX' '\\SI' '\\SYN' '\\SUB' or '\\SP'" mnemonic 'U' = do 'S' <- next; return '\US' `wrap` "'\\US'" mnemonic 'V' = do 'T' <- next; return '\VT' `wrap` "'\\VT'" wrap p s = p `onFail` fail ("expected literal char "++s) -- Basic types instance Parse Int where parse = fmap fromInteger $ -- convert from Integer, deals with minInt do manySatisfy isSpace; parseSigned parseUnsignedInteger instance Parse Integer where parse = do manySatisfy isSpace; parseSigned parseUnsignedInteger instance Parse Float where parse = do manySatisfy isSpace; parseSigned parseFloat instance Parse Double where parse = do manySatisfy isSpace; parseSigned parseFloat instance Parse Char where parse = do manySatisfy isSpace; parseLitChar -- not totally correct for strings... parseList = do { w <- word; if head w == '"' then return (init (tail w)) else fail "not a string" } instance Parse Bool where parse = enumeration "Bool" [False,True] instance Parse Ordering where parse = enumeration "Ordering" [LT,EQ,GT] -- Structural types instance Parse () where parse = P (p . BS.uncons) where p Nothing = Failure BS.empty "no input: expected a ()" p (Just ('(',cs)) = case BS.uncons (BS.dropWhile isSpace cs) of Just (')',s) -> Success s () _ -> Failure cs "Expected ) after (" p (Just (c,cs)) | isSpace c = p (BS.uncons cs) | otherwise = Failure (BS.cons c cs) ("Expected a (), got "++show c) instance (Parse a, Parse b) => Parse (a,b) where parse = do{ isWord "(" `adjustErr` ("Opening a 2-tuple\n"++) ; x <- parse `adjustErr` ("In 1st item of a 2-tuple\n"++) ; isWord "," `adjustErr` ("Separating a 2-tuple\n"++) ; y <- parse `adjustErr` ("In 2nd item of a 2-tuple\n"++) ; isWord ")" `adjustErr` ("Closing a 2-tuple\n"++) ; return (x,y) } instance (Parse a, Parse b, Parse c) => Parse (a,b,c) where parse = do{ isWord "(" `adjustErr` ("Opening a 3-tuple\n"++) ; x <- parse `adjustErr` ("In 1st item of a 3-tuple\n"++) ; isWord "," `adjustErr` ("Separating(1) a 3-tuple\n"++) ; y <- parse `adjustErr` ("In 2nd item of a 3-tuple\n"++) ; isWord "," `adjustErr` ("Separating(2) a 3-tuple\n"++) ; z <- parse `adjustErr` ("In 3rd item of a 3-tuple\n"++) ; isWord ")" `adjustErr` ("Closing a 3-tuple\n"++) ; return (x,y,z) } instance Parse a => Parse (Maybe a) where parsePrec p = optionalParens (do { isWord "Nothing"; return Nothing }) `onFail` parens (p>9) (do { isWord "Just" ; fmap Just $ parsePrec 10 `adjustErrBad` ("but within Just, "++) }) `adjustErr` (("expected a Maybe (Just or Nothing)\n"++).indent 2) instance (Parse a, Parse b) => Parse (Either a b) where parsePrec p = parens (p>9) $ constructors [ ("Left", do { fmap Left $ parsePrec 10 } ) , ("Right", do { fmap Right $ parsePrec 10 } ) ] instance Parse a => Parse [a] where parse = parseList ------------------------------------------------------------------------ -- ByteStrings as a whole entity. -- | Simply return the remaining input ByteString. allAsByteString :: TextParser ByteString allAsByteString = P (\bs-> Success BS.empty bs) -- | Simply return the remaining input as a String. allAsString :: TextParser String allAsString = fmap BS.unpack allAsByteString ------------------------------------------------------------------------ polyparse-1.7/src/Text/ParserCombinators/0000755000000000000000000000000011601657462016745 5ustar0000000000000000polyparse-1.7/src/Text/ParserCombinators/HuttonMeijer.hs0000644000000000000000000001676411601657462021734 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Text.ParserCombinators.HuttonMeijer -- Copyright : Graham Hutton (University of Nottingham), Erik Meijer (University of Utrecht) -- Licence : BSD -- -- Maintainer : Malcolm Wallace -- Stability : Stable -- Portability : All -- -- A LIBRARY OF MONADIC PARSER COMBINATORS -- -- 29th July 1996 -- -- Graham Hutton Erik Meijer -- University of Nottingham University of Utrecht -- -- This Haskell script defines a library of parser combinators, and is -- taken from sections 1-6 of our article "Monadic Parser Combinators". -- Some changes to the library have been made in the move from Gofer -- to Haskell: -- -- * Do notation is used in place of monad comprehension notation; -- -- * The parser datatype is defined using "newtype", to avoid the overhead -- of tagging and untagging parsers with the P constructor. ----------------------------------------------------------------------------- module Text.ParserCombinators.HuttonMeijer (Parser(..), item, first, papply, (+++), sat, {-tok,-} many, many1, sepby, sepby1, chainl, chainl1, chainr, chainr1, ops, bracket, char, digit, lower, upper, letter, alphanum, string, ident, nat, int, spaces, comment, junk, skip, token, natural, integer, symbol, identifier) where import Data.Char import Control.Monad infixr 5 +++ type Token = Char --------------------------------------------------------- -- | The parser monad newtype Parser a = P ([Token] -> [(a,[Token])]) instance Functor Parser where -- map :: (a -> b) -> (Parser a -> Parser b) fmap f (P p) = P (\inp -> [(f v, out) | (v,out) <- p inp]) instance Monad Parser where -- return :: a -> Parser a return v = P (\inp -> [(v,inp)]) -- >>= :: Parser a -> (a -> Parser b) -> Parser b (P p) >>= f = P (\inp -> concat [papply (f v) out | (v,out) <- p inp]) -- fail :: String -> Parser a fail _ = P (\_ -> []) instance MonadPlus Parser where -- mzero :: Parser a mzero = P (\_ -> []) -- mplus :: Parser a -> Parser a -> Parser a (P p) `mplus` (P q) = P (\inp -> (p inp ++ q inp)) -- ------------------------------------------------------------ -- * Other primitive parser combinators -- ------------------------------------------------------------ item :: Parser Token item = P (\inp -> case inp of [] -> [] (x:xs) -> [(x,xs)]) first :: Parser a -> Parser a first (P p) = P (\inp -> case p inp of [] -> [] (x:_) -> [x]) papply :: Parser a -> [Token] -> [(a,[Token])] papply (P p) inp = p inp -- ------------------------------------------------------------ -- * Derived combinators -- ------------------------------------------------------------ (+++) :: Parser a -> Parser a -> Parser a p +++ q = first (p `mplus` q) sat :: (Token -> Bool) -> Parser Token sat p = do {x <- item; if p x then return x else mzero} --tok :: Token -> Parser Token --tok t = do {x <- item; if t==snd x then return t else mzero} many :: Parser a -> Parser [a] many p = many1 p +++ return [] --many p = force (many1 p +++ return []) many1 :: Parser a -> Parser [a] many1 p = do {x <- p; xs <- many p; return (x:xs)} sepby :: Parser a -> Parser b -> Parser [a] p `sepby` sep = (p `sepby1` sep) +++ return [] sepby1 :: Parser a -> Parser b -> Parser [a] p `sepby1` sep = do {x <- p; xs <- many (do {sep; p}); return (x:xs)} chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a chainl p op v = (p `chainl1` op) +++ return v chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a p `chainl1` op = do {x <- p; rest x} where rest x = do {f <- op; y <- p; rest (f x y)} +++ return x chainr :: Parser a -> Parser (a -> a -> a) -> a -> Parser a chainr p op v = (p `chainr1` op) +++ return v chainr1 :: Parser a -> Parser (a -> a -> a) -> Parser a p `chainr1` op = do {x <- p; rest x} where rest x = do {f <- op; y <- p `chainr1` op; return (f x y)} +++ return x ops :: [(Parser a, b)] -> Parser b ops xs = foldr1 (+++) [do {p; return op} | (p,op) <- xs] bracket :: Parser a -> Parser b -> Parser c -> Parser b bracket open p close = do {open; x <- p; close; return x} -- ------------------------------------------------------------ -- * Useful parsers -- ------------------------------------------------------------ char :: Char -> Parser Char char x = sat (\y -> x == y) digit :: Parser Char digit = sat isDigit lower :: Parser Char lower = sat isLower upper :: Parser Char upper = sat isUpper letter :: Parser Char letter = sat isAlpha alphanum :: Parser Char alphanum = sat isAlphaNum +++ char '_' string :: String -> Parser String string "" = return "" string (x:xs) = do {char x; string xs; return (x:xs)} ident :: Parser String ident = do {x <- lower; xs <- many alphanum; return (x:xs)} nat :: Parser Int nat = do {x <- digit; return (fromEnum x - fromEnum '0')} `chainl1` return op where m `op` n = 10*m + n int :: Parser Int int = do {char '-'; n <- nat; return (-n)} +++ nat -- ------------------------------------------------------------ -- * Lexical combinators -- ------------------------------------------------------------ spaces :: Parser () spaces = do {many1 (sat isSpace); return ()} comment :: Parser () --comment = do {string "--"; many (sat (\x -> x /= '\n')); return ()} --comment = do -- _ <- string "--" -- _ <- many (sat (\x -> x /= '\n')) -- return () comment = do bracket (string "/*") (many item) (string "*/") return () junk :: Parser () junk = do {many (spaces +++ comment); return ()} skip :: Parser a -> Parser a skip p = do {junk; p} token :: Parser a -> Parser a token p = do {v <- p; junk; return v} -- ------------------------------------------------------------ -- * Token parsers -- ------------------------------------------------------------ natural :: Parser Int natural = token nat integer :: Parser Int integer = token int symbol :: String -> Parser String symbol xs = token (string xs) identifier :: [String] -> Parser String identifier ks = token (do {x <- ident; if not (elem x ks) then return x else return mzero}) ------------------------------------------------------------------------------ polyparse-1.7/src/Text/ParserCombinators/HuttonMeijerWallace.hs0000644000000000000000000003050611601657462023213 0ustar0000000000000000{----------------------------------------------------------------------------- A LIBRARY OF MONADIC PARSER COMBINATORS 29th July 1996 Graham Hutton Erik Meijer University of Nottingham University of Utrecht This Haskell 1.3 script defines a library of parser combinators, and is taken from sections 1-6 of our article "Monadic Parser Combinators". Some changes to the library have been made in the move from Gofer to Haskell: * Do notation is used in place of monad comprehension notation; * The parser datatype is defined using "newtype", to avoid the overhead of tagging and untagging parsers with the P constructor. ------------------------------------------------------------------------------ ** Extended to allow a symbol table/state to be threaded through the monad. ** Extended to allow a parameterised token type, rather than just strings. ** Extended to allow error-reporting. (Extensions: 1998-2000 Malcolm.Wallace@cs.york.ac.uk) (More extensions: 2004 gk-haskell@ninebynine.org) ------------------------------------------------------------------------------} -- | This library of monadic parser combinators is based on the ones -- defined by Graham Hutton and Erik Meijer. It has been extended by -- Malcolm Wallace to use an abstract token type (no longer just a -- string) as input, and to incorporate state in the monad, useful -- for symbol tables, macros, and so on. Basic facilities for error -- reporting have also been added, and later extended by Graham Klyne -- to return the errors through an @Either@ type, rather than just -- calling @error@. module Text.ParserCombinators.HuttonMeijerWallace ( -- * The parser monad Parser(..) -- * Primitive parser combinators , item, eof, papply, papply' -- * Derived combinators , (+++), {-sat,-} tok, nottok, many, many1 , sepby, sepby1, chainl, chainl1, chainr, chainr1, ops, bracket , toEOF -- * Error handling , elserror -- * State handling , stupd, stquery, stget -- * Re-parsing , reparse ) where import Data.Char import Control.Monad infixr 5 +++ --- The parser monad --------------------------------------------------------- type ParseResult s t e a = Either e [(a,s,[Either e t])] newtype Parser s t e a = P ( s -> [Either e t] -> ParseResult s t e a ) -- ^ The parser type is parametrised on the types of the state @s@, -- the input tokens @t@, error-type @e@, and the result value @a@. -- The state and remaining input are threaded through the monad. instance Functor (Parser s t e) where -- fmap :: (a -> b) -> (Parser s t e a -> Parser s t e b) fmap f (P p) = P (\st inp -> case p st inp of Right res -> Right [(f v, s, out) | (v,s,out) <- res] Left err -> Left err ) instance Monad (Parser s t e) where -- return :: a -> Parser s t e a return v = P (\st inp -> Right [(v,st,inp)]) -- >>= :: Parser s t e a -> (a -> Parser s t e b) -> Parser s t e b (P p) >>= f = P (\st inp -> case p st inp of Right res -> foldr joinresults (Right []) [ papply' (f v) s out | (v,s,out) <- res ] Left err -> Left err ) -- fail :: String -> Parser s t e a fail err = P (\st inp -> Right []) -- I know it's counterintuitive, but we want no-parse, not an error. instance MonadPlus (Parser s t e) where -- mzero :: Parser s t e a mzero = P (\st inp -> Right []) -- mplus :: Parser s t e a -> Parser s t e a -> Parser s t e a (P p) `mplus` (P q) = P (\st inp -> joinresults (p st inp) (q st inp)) -- joinresults ensures that explicitly raised errors are dominant, -- provided no parse has yet been found. The commented out code is -- a slightly stricter specification of the real code. joinresults :: ParseResult s t e a -> ParseResult s t e a -> ParseResult s t e a {- joinresults (Left p) (Left q) = Left p joinresults (Left p) (Right _) = Left p joinresults (Right []) (Left q) = Left q joinresults (Right p) (Left q) = Right p joinresults (Right p) (Right q) = Right (p++q) -} joinresults (Left p) q = Left p joinresults (Right []) q = q joinresults (Right p) q = Right (p++ case q of Left _ -> [] Right r -> r) --- Primitive parser combinators --------------------------------------------- -- | Deliver the first remaining token. item :: Parser s t e t item = P (\st inp -> case inp of [] -> Right [] (Left e: _) -> Left e (Right x: xs) -> Right [(x,st,xs)] ) -- | Fail if end of input is not reached eof :: Show p => Parser s (p,t) String () eof = P (\st inp -> case inp of [] -> Right [((),st,[])] (Left e:_) -> Left e (Right (p,_):_) -> Left ("End of input expected at " ++show p++"\n but found text") ) {- -- | Ensure the value delivered by the parser is evaluated to WHNF. force :: Parser s t e a -> Parser s t e a force (P p) = P (\st inp -> let Right xs = p st inp h = head xs in h `seq` Right (h: tail xs) ) -- [[[GK]]] ^^^^^^ -- WHNF = Weak Head Normal Form, meaning that it has no top-level redex. -- In this case, I think that means that the first element of the list -- is fully evaluated. -- -- NOTE: the original form of this function fails if there is no parse -- result for p st inp (head xs fails if xs is null), so the modified -- form can assume a Right value only. -- -- Why is this needed? -- It's not exported, and the only use of this I see is commented out. --------------------------------------- -} -- | Deliver the first parse result only, eliminating any backtracking. first :: Parser s t e a -> Parser s t e a first (P p) = P (\st inp -> case p st inp of Right (x:xs) -> Right [x] otherwise -> otherwise ) -- | Apply the parser to some real input, given an initial state value. -- If the parser fails, raise 'error' to halt the program. -- (This is the original exported behaviour - to allow the caller to -- deal with the error differently, see @papply'@.) papply :: Parser s t String a -> s -> [Either String t] -> [(a,s,[Either String t])] papply (P p) st inp = either error id (p st inp) -- | Apply the parser to some real input, given an initial state value. -- If the parser fails, return a diagnostic message to the caller. papply' :: Parser s t e a -> s -> [Either e t] -> Either e [(a,s,[Either e t])] papply' (P p) st inp = p st inp --- Derived combinators ------------------------------------------------------ -- | A choice between parsers. Keep only the first success. (+++) :: Parser s t e a -> Parser s t e a -> Parser s t e a p +++ q = first (p `mplus` q) -- | Deliver the first token if it satisfies a predicate. sat :: (t -> Bool) -> Parser s (p,t) e t sat p = do {(_,x) <- item; if p x then return x else mzero} -- | Deliver the first token if it equals the argument. tok :: Eq t => t -> Parser s (p,t) e t tok t = do {(_,x) <- item; if x==t then return t else mzero} -- | Deliver the first token if it does not equal the argument. nottok :: Eq t => [t] -> Parser s (p,t) e t nottok ts = do {(_,x) <- item; if x `notElem` ts then return x else mzero} -- | Deliver zero or more values of @a@. many :: Parser s t e a -> Parser s t e [a] many p = many1 p +++ return [] --many p = force (many1 p +++ return []) -- | Deliver one or more values of @a@. many1 :: Parser s t e a -> Parser s t e [a] many1 p = do {x <- p; xs <- many p; return (x:xs)} -- | Deliver zero or more values of @a@ separated by @b@'s. sepby :: Parser s t e a -> Parser s t e b -> Parser s t e [a] p `sepby` sep = (p `sepby1` sep) +++ return [] -- | Deliver one or more values of @a@ separated by @b@'s. sepby1 :: Parser s t e a -> Parser s t e b -> Parser s t e [a] p `sepby1` sep = do {x <- p; xs <- many (do {sep; p}); return (x:xs)} chainl :: Parser s t e a -> Parser s t e (a->a->a) -> a -> Parser s t e a chainl p op v = (p `chainl1` op) +++ return v chainl1 :: Parser s t e a -> Parser s t e (a->a->a) -> Parser s t e a p `chainl1` op = do {x <- p; rest x} where rest x = do {f <- op; y <- p; rest (f x y)} +++ return x chainr :: Parser s t e a -> Parser s t e (a->a->a) -> a -> Parser s t e a chainr p op v = (p `chainr1` op) +++ return v chainr1 :: Parser s t e a -> Parser s t e (a->a->a) -> Parser s t e a p `chainr1` op = do {x <- p; rest x} where rest x = do { f <- op ; y <- p `chainr1` op ; return (f x y) } +++ return x ops :: [(Parser s t e a, b)] -> Parser s t e b ops xs = foldr1 (+++) [do {p; return op} | (p,op) <- xs] bracket :: (Show p,Show t) => Parser s (p,t) e a -> Parser s (p,t) e b -> Parser s (p,t) e c -> Parser s (p,t) e b bracket open p close = do { open ; x <- p ; close -- `elserror` "improperly matched construct"; ; return x } -- | Accept a complete parse of the input only, no partial parses. toEOF :: Show p => Parser s (p,t) String a -> Parser s (p,t) String a toEOF p = do { x <- p; eof; return x } --- Error handling ----------------------------------------------------------- -- | Return an error using the supplied diagnostic string, and a token type -- which includes position information. parseerror :: (Show p,Show t) => String -> Parser s (p,t) String a parseerror err = P (\st inp -> case inp of [] -> Left "Parse error: unexpected EOF\n" (Left e:_) -> Left ("Lexical error: "++e) (Right (p,t):_) -> Left ("Parse error: in "++show p++"\n " ++err++"\n "++"Found "++show t) ) -- | If the parser fails, generate an error message. elserror :: (Show p,Show t) => Parser s (p,t) String a -> String -> Parser s (p,t) String a p `elserror` s = p +++ parseerror s --- State handling ----------------------------------------------------------- -- | Update the internal state. stupd :: (s->s) -> Parser s t e () stupd f = P (\st inp-> {-let newst = f st in newst `seq`-} Right [((), f st, inp)]) -- | Query the internal state. stquery :: (s->a) -> Parser s t e a stquery f = P (\st inp-> Right [(f st, st, inp)]) -- | Deliver the entire internal state. stget :: Parser s t e s stget = P (\st inp-> Right [(st, st, inp)]) --- Push some tokens back onto the input stream and reparse ------------------ -- | This is useful for recursively expanding macros. When the -- user-parser recognises a macro use, it can lookup the macro -- expansion from the parse state, lex it, and then stuff the -- lexed expansion back down into the parser. reparse :: [Either e t] -> Parser s t e () reparse ts = P (\st inp-> Right [((), st, ts++inp)]) ------------------------------------------------------------------------------ polyparse-1.7/src/Text/ParserCombinators/Poly.hs0000644000000000000000000000020411601657462020220 0ustar0000000000000000module Text.ParserCombinators.Poly ( module Text.ParserCombinators.Poly.Plain ) where import Text.ParserCombinators.Poly.Plain polyparse-1.7/src/Text/ParserCombinators/Poly/0000755000000000000000000000000011601657462017670 5ustar0000000000000000polyparse-1.7/src/Text/ParserCombinators/Poly/Base.hs0000644000000000000000000002214611601657462021103 0ustar0000000000000000module Text.ParserCombinators.Poly.Base ( -- * The PolyParse classes Commitment(..) -- class of all two-level-error values , PolyParse -- class of all monadic two-level-error parsers -- * Combinators general to all parser types. -- ** Simple combinators , apply -- :: PolyParse p => p (a->b) -> p a -> p b , discard -- :: PolyParse p => p a -> p b -> p a -- ** Error-handling , failBad -- :: PolyParse p => String -> p a , adjustErrBad-- :: PolyParse p => p a -> (String->String) -> p a , indent -- :: Int -> String -> String -- ** Choices , oneOf -- :: PolyParse p => [p a] -> p a -- ** Sequences , exactly -- :: PolyParse p => Int -> p a -> p [a] , upto -- :: PolyParse p => Int -> p a -> p [a] , many1 -- :: PolyParse p => p a -> p [a] , sepBy -- :: PolyParse p => p a -> p sep -> p [a] , sepBy1 -- :: PolyParse p => p a -> p sep -> p [a] , bracketSep -- :: PolyParse p => p bra -> p sep -> p ket -> p a -> p [a] , bracket -- :: PolyParse p => p bra -> p ket -> p a -> p a , manyFinally -- :: PolyParse p => p a -> p z -> p [a] , manyFinally'-- :: PolyParse p => p a -> p z -> p [a] ) where import Control.Applicative #ifdef __NHC__ default (Integer,Double,[]) -- hack to avoid bizarre type defaulting error instance Commitment [] instance PolyParse [] #endif -- | The @Commitment@ class is an abstraction over all the current -- concrete representations of monadic/applicative parser combinators in this -- package. The common feature is two-level error-handling. -- Some primitives must be implemented specific to each parser type -- (e.g. depending on whether the parser has a running state, or -- whether it is lazy). But given those primitives, large numbers of -- combinators do not depend any further on the internal structure of -- the particular parser. class Commitment p where -- | Commit is a way of raising the severity of any errors found within -- its argument. Used in the middle of a parser definition, it means that -- any operations prior to commitment fail softly, but after commitment, -- they fail hard. commit :: p a -> p a -- | @p `adjustErr` f@ applies the transformation @f@ to any error message -- generated in @p@, having no effect if @p@ succeeds. adjustErr :: p a -> (String -> String) -> p a -- | Parse the first alternative that succeeds, but if none succeed, -- report only the severe errors, and if none of those, then report -- all the soft errors. oneOf' :: [(String, p a)] -> p a -- | The @PolyParse@ class is an abstraction gathering all of the common -- features that a two-level error-handling parser requires: -- the applicative parsing interface, the monadic interface, and commitment. -- -- There are two additional basic combinators that we expect to be implemented -- afresh for every concrete type, but which (for technical reasons) -- cannot be class methods. They are @next@ and @satisfy@. class (Functor p, Monad p, Applicative p, Alternative p, Commitment p) => PolyParse p infixl 3 `apply` infixl 3 `discard` -- | Apply a parsed function to a parsed value. -- Rather like ordinary function application lifted into parsers. apply :: PolyParse p => p (a->b) -> p a -> p b apply = (<*>) -- | @x `discard` y@ parses both x and y, but discards the result of y. -- Rather like @const@ lifted into parsers. discard :: PolyParse p => p a -> p b -> p a px `discard` py = do { x <- px; y <- py; y `seq` return x; } {- -- Combinators we expect most concrete parser types to implement. -- For technical reasons, they cannot be class members. -- | Yield the next token next :: PolyParse p => p t -- where t is constrained to be the input token type -- | One token satisfying a predicate. satisfy :: PolyParse p => (t->Bool) -> p t t satisfy p = do{ x <- next ; if p x then return x else fail "Parse.satisfy: failed" } -- note: must be re-defined for each implementation because -- its type cannot be expressed otherwise. -} -- | When a simple fail is not strong enough, use failBad for emphasis. -- An emphasised (severe) error cannot be overridden by choice -- operators. failBad :: PolyParse p => String -> p a failBad e = commit (fail e) -- | @adjustErrBad@ is just like @adjustErr@ except it also raises the -- severity of the error. adjustErrBad :: PolyParse p => p a -> (String->String) -> p a p `adjustErrBad` f = commit (p `adjustErr` f) -- | Parse the first alternative in the list that succeeds. oneOf :: PolyParse p => [p a] -> p a oneOf [] = fail ("failed to parse any of the possible choices") oneOf (p:ps) = p <|> oneOf ps --oneOf :: Show t => [Parser t a] -> Parser t a --oneOf [] = do { n <- next -- ; fail ("failed to parse any of the possible choices" -- ++"\n next token is "++show n) -- } --oneOf (p:ps) = p `onFail` oneOf ps -- | Helper for formatting error messages: indents all lines by a fixed amount. indent :: Int -> String -> String indent n = unlines . map (replicate n ' ' ++) . lines -- | 'exactly n p' parses precisely n items, using the parser p, in sequence. exactly :: PolyParse p => Int -> p a -> p [a] exactly 0 p = return [] exactly n p = return (:) `apply` (p `adjustErr` (("When expecting exactly " ++show n++" more items")++)) `apply` exactly (n-1) p -- | 'upto n p' parses n or fewer items, using the parser p, in sequence. upto :: PolyParse p => Int -> p a -> p [a] upto 0 p = return [] upto n p = do x <- p; return (x:) `apply` upto (n-1) p <|> return [] {- is in Control.Applicative -- | 'optional' indicates whether the parser succeeded through the Maybe type. optional :: PolyParse p => p a -> p (Maybe a) optional p = fmap Just p `onFail` return Nothing -} {- is in Control.Applicative -- | 'many p' parses a list of elements with individual parser p. -- Cannot fail, since an empty list is a valid return value. many :: PolyParse p => p a -> p [a] many p = many1 p `onFail` return [] -} -- | Parse a non-empty list of items. many1 :: PolyParse p => p a -> p [a] many1 p = do { x <- p `adjustErr` (("In a sequence:\n"++). indent 2) ; return (x:) `apply` many p } -- `adjustErr` ("When looking for a non-empty sequence:\n\t"++) -- | Parse a list of items separated by discarded junk. sepBy :: PolyParse p => p a -> p sep -> p [a] sepBy p sep = do sepBy1 p sep <|> return [] -- | Parse a non-empty list of items separated by discarded junk. sepBy1 :: PolyParse p => p a -> p sep -> p [a] sepBy1 p sep = do { x <- p ; return (x:) `apply` many (do {sep; p}) } `adjustErr` ("When looking for a non-empty sequence with separators:\n\t"++) -- | Parse a list of items, discarding the start, end, and separator -- items. bracketSep :: PolyParse p => p bra -> p sep -> p ket -> p a -> p [a] bracketSep open sep close p = do { open; close; return [] } <|> do { open `adjustErr` ("Missing opening bracket:\n\t"++) ; x <- p `adjustErr` ("After first bracket in a group:\n\t"++) ; return (x:) `apply` manyFinally (do {sep; p}) (close `adjustErrBad` ("When looking for closing bracket:\n\t"++)) } -- | Parse a bracketed item, discarding the brackets. bracket :: PolyParse p => p bra -> p ket -> p a -> p a bracket open close p = do do { open `adjustErr` ("Missing opening bracket:\n\t"++) ; p `discard` (close `adjustErrBad` ("Missing closing bracket:\n\t"++)) } -- | @manyFinally e t@ parses a possibly-empty sequence of @e@'s, -- terminated by a @t@. The final @t@ is discarded. Any parse failures -- could be due either to a badly-formed terminator or a badly-formed -- element, so it raises both possible errors. manyFinally :: PolyParse p => p a -> p z -> p [a] manyFinally p t = (many p `discard` t) <|> oneOf' [ ("sequence terminator", do { t; return [] } ) , ("item in a sequence", do { p; return [] } ) ] {- manyFinally p t = do { xs <- many p ; oneOf' [ ("sequence terminator", do { t; return () } ) , ("item in a sequence", do { p; return () } ) ] ; return xs } -} -- | @manyFinally'@ is like @manyFinally@, except when the terminator -- parser overlaps with the element parser. In @manyFinally e t@, -- the parser @t@ is tried only when parser @e@ fails, whereas in -- @manyFinally' e t@, the parser @t@ is always tried first, then -- parser @e@ only if the terminator is not found. For instance, -- @manyFinally (accept "01") (accept "0")@ on input @"0101010"@ returns -- @["01","01","01"]@, whereas @manyFinally'@ with the same arguments -- and input returns @[]@. manyFinally' :: PolyParse p => p a -> p z -> p [a] manyFinally' p t = (do t; return []) <|> (do x <- p; return (x:) `apply` manyFinally' p t) <|> oneOf' [ ("sequence terminator", do { t; return [] } ) , ("item in a sequence", do { p; return [] } ) ] ------------------------------------------------------------------------ polyparse-1.7/src/Text/ParserCombinators/Poly/ByteString.hs0000644000000000000000000001212611601657462022320 0ustar0000000000000000module Text.ParserCombinators.Poly.ByteString ( -- * The Parser datatype Parser(P) , Result(..) , runParser -- ** Basic parsers , next , eof , satisfy , onFail -- ** Derived parsers (but implemented more efficiently) , manySatisfy , many1Satisfy -- ** Re-parsing , reparse -- * Re-export all more general combinators , module Text.ParserCombinators.Poly.Base ) where import Text.ParserCombinators.Poly.Base import Text.ParserCombinators.Poly.Result import qualified Data.ByteString.Lazy.Char8 as BS import Data.ByteString.Lazy.Char8 (ByteString) import Control.Applicative -- | This @Parser@ datatype is a specialised parsing monad with error -- reporting. Whereas the standard version can be used for arbitrary -- token types, this version is specialised to ByteString input only. newtype Parser a = P (ByteString -> Result ByteString a) -- | Apply a parser to an input token sequence. runParser :: Parser a -> ByteString -> (Either String a, ByteString) runParser (P p) = resultToEither . p instance Functor Parser where fmap f (P p) = P (fmap f . p) instance Monad Parser where return x = P (\ts-> Success ts x) fail e = P (\ts-> Failure ts e) (P f) >>= g = P (continue . f) where continue (Success ts x) = let (P g') = g x in g' ts continue (Committed (Committed r)) = continue (Committed r) continue (Committed r) = Committed (continue r) continue (Failure ts e) = Failure ts e instance Commitment Parser where commit (P p) = P (Committed . p) (P p) `adjustErr` f = P (adjust . p) where adjust (Failure z e) = Failure z (f e) adjust (Committed r) = Committed (adjust r) adjust good = good oneOf' = accum [] where accum errs [] = fail ("failed to parse any of the possible choices:\n" ++indent 2 (concatMap showErr (reverse errs))) accum errs ((e,P p):ps) = P (\ts-> case p ts of Failure _ err -> let (P p') = accum ((e,err):errs) ps in p' ts r@(Success _ _) -> r r@(Committed _) -> r ) showErr (name,err) = name++":\n"++indent 2 err instance Applicative Parser where pure f = return f pf <*> px = do { f <- pf; x <- px; return (f x) } #if defined(GLASGOW_HASKELL) && GLASGOW_HASKELL > 610 p <* q = p `discard` q #endif instance Alternative Parser where empty = fail "no parse" p <|> q = p `onFail` q instance PolyParse Parser ------------------------------------------------------------------------ -- | Simply return the next token in the input tokenstream. next :: Parser Char next = P (\bs-> case BS.uncons bs of Nothing -> Failure bs "Ran out of input (EOF)" Just (h, t) -> Success t h ) -- | Succeed if the end of file/input has been reached, fail otherwise. eof :: Parser () eof = P (\bs -> if BS.null bs then Success bs () else Failure bs "Expected end of input (EOF)" ) -- | Return the next token if it satisfies the given predicate. satisfy :: (Char -> Bool) -> Parser Char satisfy f = do { x <- next ; if f x then return x else fail "Parse.satisfy: failed" } -- | @p `onFail` q@ means parse p, unless p fails, in which case -- parse q instead. -- Can be chained together to give multiple attempts to parse something. -- (Note that q could itself be a failing parser, e.g. to change the error -- message from that defined in p to something different.) -- However, a severe failure in p cannot be ignored. onFail :: Parser a -> Parser a -> Parser a (P p) `onFail` (P q) = P (\ts-> continue ts $ p ts) where continue ts (Failure _ _) = q ts -- continue _ (Committed r) = r -- no, remain Committed continue _ r = r ------------------------------------------------------------------------ -- | @manySatisfy p@ is a more efficient fused version of @many (satisfy p)@ manySatisfy :: (Char->Bool) -> Parser ByteString manySatisfy f = P (\bs-> let (pre,suf) = BS.span f bs in Success suf pre) -- | @many1Satisfy p@ is a more efficient fused version of @many1 (satisfy p)@ many1Satisfy :: (Char->Bool) -> Parser ByteString many1Satisfy f = do x <- manySatisfy f if BS.null x then fail "Parse.many1Satisfy: failed" else return x ------------------------------------------------------------------------ -- | Push some tokens back onto the front of the input stream and reparse. -- This is useful e.g. for recursively expanding macros. When the -- user-parser recognises a macro use, it can lookup the macro -- expansion from the parse state, lex it, and then stuff the -- lexed expansion back down into the parser. reparse :: ByteString -> Parser () reparse ts = P (\inp-> Success (ts `BS.append` inp) ()) ------------------------------------------------------------------------ polyparse-1.7/src/Text/ParserCombinators/Poly/Lazy.hs0000644000000000000000000001012511601657462021142 0ustar0000000000000000{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} module Text.ParserCombinators.Poly.Lazy ( -- * The Parser datatype Parser(P) -- datatype, instance of: Functor, Monad, PolyParse , Result(..) -- internal to the parser monad , runParser -- :: Parser t a -> [t] -> (Either String a, [t]) -- ** Basic parsers , next -- :: Parser t t , eof -- :: Parser t () , satisfy -- :: (t->Bool) -> Parser t t , onFail -- :: Parser t a -> Parser t a -> Parser t a -- ** Re-parsing , reparse -- :: [t] -> Parser t () -- * Re-export all more general combinators , module Text.ParserCombinators.Poly.Base , module Control.Applicative ) where import Text.ParserCombinators.Poly.Base import Text.ParserCombinators.Poly.Result import qualified Text.ParserCombinators.Poly.Parser as P import Control.Applicative #if __GLASGOW_HASKELL__ import Control.Exception hiding (bracket) throwE :: String -> a throwE msg = throw (ErrorCall msg) #else throwE :: String -> a throwE msg = error msg #endif -- | The only differences between a Plain and a Lazy parser are the instance -- of Applicative, and the type (and implementation) of runParser. -- We therefore need to /newtype/ the original Parser type, to allow it -- to have a different instance. newtype Parser t a = P (P.Parser t a) #ifdef __GLASGOW_HASKELL__ deriving (Functor,Monad,Commitment) #else instance Functor (Parser t) where fmap f (P p) = P (fmap f p) instance Monad (Parser t) where return x = P (return x) fail e = P (fail e) (P f) >>= g = P (f >>= (\(P g')->g') . g) instance Commitment (Parser t) where commit (P p) = P (commit p) (P p) `adjustErr` f = P (p `adjustErr` f) #endif -- | Apply a parser to an input token sequence. runParser :: Parser t a -> [t] -> (a, [t]) runParser (P (P.P p)) = fromResult . p where fromResult :: Result z a -> (a, z) fromResult (Success z a) = (a, z) fromResult (Failure z e) = throwE e fromResult (Committed r) = fromResult r instance Applicative (Parser t) where pure f = return f -- Apply a parsed function to a parsed value. This version -- is strict in the result of the function parser, but -- lazy in the result of the argument parser. (Argument laziness is -- the distinctive feature over other implementations.) (P (P.P pf)) <*> px = P (P.P (continue . pf)) where continue (Success z f) = let (x,z') = runParser px z in Success z' (f x) continue (Committed r) = Committed (continue r) continue (Failure z e) = Failure z e #if defined(GLASGOW_HASKELL) && GLASGOW_HASKELL > 610 p <* q = p `discard` q #endif instance Alternative (Parser t) where empty = fail "no parse" (P p) <|> (P q) = P (p `P.onFail` q) instance PolyParse (Parser t) ------------------------------------------------------------------------ -- | Simply return the next token in the input tokenstream. next :: Parser t t next = P P.next -- | Succeed if the end of file/input has been reached, fail otherwise. eof :: Parser t () eof = P P.eof -- | Return the next token if it satisfies the given predicate. satisfy :: (t->Bool) -> Parser t t satisfy = P . P.satisfy -- | @p `onFail` q@ means parse p, unless p fails, in which case -- parse q instead. -- Can be chained together to give multiple attempts to parse something. -- (Note that q could itself be a failing parser, e.g. to change the error -- message from that defined in p to something different.) -- However, a severe failure in p cannot be ignored. onFail :: Parser t a -> Parser t a -> Parser t a onFail (P a) (P b) = P (a `P.onFail` b) -- | Push some tokens back onto the front of the input stream and reparse. -- This is useful e.g. for recursively expanding macros. When the -- user-parser recognises a macro use, it can lookup the macro -- expansion from the parse state, lex it, and then stuff the -- lexed expansion back down into the parser. reparse :: [t] -> Parser t () reparse = P . P.reparse ------------------------------------------------------------------------ polyparse-1.7/src/Text/ParserCombinators/Poly/Lex.hs0000644000000000000000000001303111601657462020752 0ustar0000000000000000-- Author: Malcolm Wallace -- | In a strict language, where creating the entire input list of tokens -- in one shot may be infeasible, we can use a lazy "callback" kind of -- architecture instead. The lexer returns a single token at a time, -- together with a continuation. -- -- This module defines a Parser type (capable of use with the Poly -- combinators), specialised to the callback-lexer style of input stream. module Text.ParserCombinators.Poly.Lex ( -- * The Parser datatype LexReturn(..) , Parser(P) , Result(..) , runParser -- ** Basic parsers , next , eof , satisfy , onFail -- ** Re-parsing , reparse -- * Re-export all more general combinators , module Text.ParserCombinators.Poly.Base , module Control.Applicative ) where import Text.ParserCombinators.Poly.Base import Text.ParserCombinators.Poly.Result import Control.Applicative -- | In a strict language, where creating the entire input list of tokens -- in one shot may be infeasible, we can use a lazy "callback" kind of -- architecture instead. The lexer returns a single token at a time, -- together with a continuation. The @next@ parser is responsible for -- pulling on the token stream, applying the continuation where necessary. data LexReturn t = LexReturn t String (String->LexReturn t) | LexFinish -- | This @Parser@ datatype is a specialised parsing monad with error -- reporting. This version is specialised to pre-lexed String input, -- where the lexer has been written to yield a @LexReturn@. newtype Parser t a = P (LexReturn t -> Result (LexReturn t) a) -- | Apply a parser to an input token sequence. runParser :: Parser t a -> LexReturn t -> (Either String a, String) runParser (P p) = (\ (a,b)->(a,stripLex b)) . resultToEither . p where stripLex LexFinish = "" stripLex (LexReturn _ s _) = s instance Functor (Parser t) where fmap f (P p) = P (fmap f . p) instance Monad (Parser t) where return x = P (\ts-> Success ts x) fail e = P (\ts-> Failure ts e) (P f) >>= g = P (continue . f) where continue (Success ts x) = let (P g') = g x in g' ts continue (Committed (Committed r)) = continue (Committed r) continue (Committed r) = Committed (continue r) continue (Failure ts e) = Failure ts e instance Commitment (Parser t) where commit (P p) = P (Committed . p) (P p) `adjustErr` f = P (adjust . p) where adjust (Failure z e) = Failure z (f e) adjust (Committed r) = Committed (adjust r) adjust good = good oneOf' = accum [] where accum errs [] = fail ("failed to parse any of the possible choices:\n" ++(indent 2 . unlines . map showErr . reverse $ errs)) accum errs ((e,P p):ps) = P (\ts-> case p ts of Failure _ err -> let (P p') = accum ((e,err):errs) ps in p' ts r@(Success _ _) -> r r@(Committed _) -> r ) showErr (name,err) = name ++ "\n" ++ indent 2 err infixl 6 `onFail` -- not sure about precedence 6? -- | @p `onFail` q@ means parse p, unless p fails, in which case -- parse q instead. -- Can be chained together to give multiple attempts to parse something. -- (Note that q could itself be a failing parser, e.g. to change the error -- message from that defined in p to something different.) -- However, a severe failure in p cannot be ignored. (P p) `onFail` (P q) = P (\ts-> continue ts $ p ts) where continue ts (Failure _ _) = q ts -- continue _ (Committed r) = r -- no, remain Committed continue _ r = r instance Applicative (Parser t) where pure f = return f pf <*> px = do { f <- pf; x <- px; return (f x) } #if defined(GLASGOW_HASKELL) && GLASGOW_HASKELL > 610 p <* q = p `discard` q #endif instance Alternative (Parser t) where empty = fail "no parse" p <|> q = p `onFail` q instance PolyParse (Parser t) ------------------------------------------------------------------------ -- | Simply return the next token in the input tokenstream. next :: Parser t t next = P (\ts-> case ts of LexFinish -> Failure ts "Ran out of input (EOF)" LexReturn t s k -> Success (k s) t) -- | Succeed if the end of file/input has been reached, fail otherwise. eof :: Parser t () eof = P (\ts -> case ts of LexFinish -> Success ts () LexReturn _ _ _ -> Failure ts "Expected end of input (EOF)" ) -- | Return the next token if it satisfies the given predicate. satisfy :: (t -> Bool) -> Parser t t satisfy f = do { x <- next ; if f x then return x else fail "Parse.satisfy: failed" } ------------------------------------------------------------------------ -- | Push some tokens back onto the front of the input stream and reparse. -- This is useful e.g. for recursively expanding macros. When the -- user-parser recognises a macro use, it can lookup the macro -- expansion from the parse state, lex it, and then stuff the -- lexed expansion back down into the parser. reparse :: [t] -> Parser t () reparse ts = P (\inp-> Success (ts `prefix` inp) ()) where (t:ts) `prefix` k = LexReturn t "" (const (ts `prefix` k)) [] `prefix` k = k ------------------------------------------------------------------------ polyparse-1.7/src/Text/ParserCombinators/Poly/Parser.hs0000644000000000000000000001043711601657462021465 0ustar0000000000000000-- | This module contains the definitions for a generic parser, without -- running state. These are the parts that are shared between the Plain -- and Lazy variations. Do not import this module directly, but only -- via T.P.Poly.Plain or T.P.Poly.Lazy. module Text.ParserCombinators.Poly.Parser ( -- * The Parser datatype Parser(P) -- datatype, instance of: Functor, Monad, PolyParse , Result(..) -- internal to the Parser Monad. -- ** Basic parsers , next -- :: Parser t t , eof -- :: Parser t () , satisfy -- :: (t->Bool) -> Parser t t , onFail -- :: Parser t a -> Parser t a -> Parser t a -- ** Re-parsing , reparse -- :: [t] -> Parser t () ) where import Text.ParserCombinators.Poly.Base import Text.ParserCombinators.Poly.Result -- | This @Parser@ datatype is a fairly generic parsing monad with error -- reporting. It can be used for arbitrary token types, not just -- String input. (If you require a running state, use module Poly.State -- instead) newtype Parser t a = P ([t] -> Result [t] a) instance Functor (Parser t) where fmap f (P p) = P (fmap f . p) instance Monad (Parser t) where return x = P (\ts-> Success ts x) fail e = P (\ts-> Failure ts e) (P f) >>= g = P (continue . f) where continue (Success ts x) = let (P g') = g x in g' ts continue (Committed (Committed r)) = continue (Committed r) continue (Committed r) = Committed (continue r) continue (Failure ts e) = Failure ts e instance Commitment (Parser t) where commit (P p) = P (Committed . p) (P p) `adjustErr` f = P (adjust . p) where adjust (Failure z e) = Failure z (f e) adjust (Committed r) = Committed (adjust r) adjust good = good oneOf' = accum [] where accum errs [] = fail ("failed to parse any of the possible choices:\n" ++indent 2 (concatMap showErr (reverse errs))) accum errs ((e,P p):ps) = P (\ts-> case p ts of Failure _ err -> let (P p) = accum ((e,err):errs) ps in p ts r@(Success z a) -> r r@(Committed _) -> r ) showErr (name,err) = name++":\n"++indent 2 err infixl 6 `onFail` -- not sure about precedence 6? -- | @p `onFail` q@ means parse p, unless p fails, in which case -- parse q instead. -- Can be chained together to give multiple attempts to parse something. -- (Note that q could itself be a failing parser, e.g. to change the error -- message from that defined in p to something different.) -- However, a severe failure in p cannot be ignored. onFail :: Parser t a -> Parser t a -> Parser t a (P p) `onFail` (P q) = P (\ts-> continue ts $ p ts) where continue ts (Failure z e) = q ts -- continue _ (Committed r) = r -- no, remain Committed continue _ r = r ------------------------------------------------------------------------ -- | Simply return the next token in the input tokenstream. next :: Parser t t next = P (\ts-> case ts of [] -> Failure [] "Ran out of input (EOF)" (t:ts') -> Success ts' t ) -- | Succeed if the end of file/input has been reached, fail otherwise. eof :: Parser t () eof = P (\ts-> case ts of [] -> Success [] () (t:ts') -> Failure ts "Expected end of input (EOF)" ) -- | Return the next token if it satisfies the given predicate. satisfy :: (t->Bool) -> Parser t t satisfy pred = do { x <- next ; if pred x then return x else fail "Parse.satisfy: failed" } ------------------------------------------------------------------------ -- | Push some tokens back onto the front of the input stream and reparse. -- This is useful e.g. for recursively expanding macros. When the -- user-parser recognises a macro use, it can lookup the macro -- expansion from the parse state, lex it, and then stuff the -- lexed expansion back down into the parser. reparse :: [t] -> Parser t () reparse ts = P (\inp-> Success (ts++inp) ()) ------------------------------------------------------------------------ polyparse-1.7/src/Text/ParserCombinators/Poly/Plain.hs0000644000000000000000000000267311601657462021277 0ustar0000000000000000module Text.ParserCombinators.Poly.Plain ( -- * The Parser datatype Parser(P) -- datatype, instance of: Functor, Monad, PolyParse , Result(..) -- internal to the Parser Monad. , runParser -- :: Parser t a -> [t] -> (Either String a, [t]) -- ** Basic parsers , next -- :: Parser t t , eof -- :: Parser t () , satisfy -- :: (t->Bool) -> Parser t t , onFail -- :: Parser t a -> Parser t a -> Parser t a -- ** Re-parsing , reparse -- :: [t] -> Parser t () -- * Re-export all more general combinators , module Text.ParserCombinators.Poly.Base , module Control.Applicative ) where import Text.ParserCombinators.Poly.Base import Text.ParserCombinators.Poly.Result import Text.ParserCombinators.Poly.Parser import Control.Applicative -- The only differences between a Plain and a Lazy parser are the instance -- of Applicative, and the type (and implementation) of runParser. -- | Apply a parser to an input token sequence. runParser :: Parser t a -> [t] -> (Either String a, [t]) runParser (P p) = resultToEither . p instance Applicative (Parser t) where pure f = return f pf <*> px = do { f <- pf; x <- px; return (f x) } #if defined(GLASGOW_HASKELL) && GLASGOW_HASKELL > 610 p <* q = p `discard` q #endif instance Alternative (Parser t) where empty = fail "no parse" p <|> q = p `onFail` q instance PolyParse (Parser t) ------------------------------------------------------------------------ polyparse-1.7/src/Text/ParserCombinators/Poly/Result.hs0000644000000000000000000000216511601657462021506 0ustar0000000000000000module Text.ParserCombinators.Poly.Result ( -- * The parsing result type Result(..) -- A parsing result type, with Success, Failure, and Commitment. , resultToEither ) where -- | A return type like Either, that distinguishes not only between -- right and wrong answers, but also has commitment, so that a failure -- cannot be undone. This should only be used for writing very primitive -- parsers - really it is an internal detail of the library. -- The z type is the remaining unconsumed input. data Result z a = Success z a | Failure z String | Committed (Result z a) instance Functor (Result z) where fmap f (Success z a) = Success z (f a) fmap f (Failure z e) = Failure z e fmap f (Committed r) = Committed (fmap f r) -- | Convert a Result to an Either, paired with the remaining unconsumed input. resultToEither :: Result z a -> (Either String a, z) resultToEither (Success z a) = (Right a, z) resultToEither (Failure z e) = (Left e, z) resultToEither (Committed r) = resultToEither r ------------------------------------------------------------------------ polyparse-1.7/src/Text/ParserCombinators/Poly/State.hs0000644000000000000000000000331111601657462021302 0ustar0000000000000000module Text.ParserCombinators.Poly.State ( -- * The Parser datatype Parser(P) -- datatype, instance of: Functor, Monad, PolyParse , Result(..) -- internal to the parser monad , runParser -- :: Parser s t a -> s -> [t] -> (Either String a, s, [t]) -- ** Basic parsers , next -- :: Parser s t t , eof -- :: Parser s t () , satisfy -- :: (t->Bool) -> Parser s t t , onFail -- :: Parser s t a -> Parser s t a -> Parser s t a -- ** State-handling , stUpdate -- :: (s->s) -> Parser s t () , stQuery -- :: (s->a) -> Parser s t a , stGet -- :: Parser s t s -- ** Re-parsing , reparse -- :: [t] -> Parser s t () -- * Re-export all more general combinators , module Text.ParserCombinators.Poly.Base , module Control.Applicative ) where import Text.ParserCombinators.Poly.Base import Text.ParserCombinators.Poly.Result import Text.ParserCombinators.Poly.StateParser import Control.Applicative -- The only differences between a State and a StateLazy parser are the instance -- of Applicative, and the type (and implementation) of runParser. -- | Apply a parser to an input token sequence. runParser :: Parser s t a -> s -> [t] -> (Either String a, s, [t]) runParser (P p) = \s-> reTuple . resultToEither . p s where reTuple (either, (z,s)) = (either, s, z) instance Applicative (Parser s t) where pure f = return f pf <*> px = do { f <- pf; x <- px; return (f x) } #if defined(GLASGOW_HASKELL) && GLASGOW_HASKELL > 610 p <* q = p `discard` q #endif instance Alternative (Parser s t) where empty = fail "no parse" p <|> q = p `onFail` q instance PolyParse (Parser s t) ------------------------------------------------------------------------ polyparse-1.7/src/Text/ParserCombinators/Poly/StateLazy.hs0000644000000000000000000001353411601657462022152 0ustar0000000000000000{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} module Text.ParserCombinators.Poly.StateLazy ( -- * The Parser datatype Parser(P) -- datatype, instance of: Functor, Monad, PolyParse , Result(..) -- internal to the parser monad , runParser -- :: Parser s t a -> s -> [t] -> (Either String a, s, [t]) -- ** Basic parsers , next -- :: Parser s t t , eof -- :: Parser s t () , satisfy -- :: (t->Bool) -> Parser s t t , onFail -- :: Parser s t a -> Parser s t a -> Parser s t a , manyFinally -- :: Parser s t a -> Parser s t z -> Parser s t [a] -- ** State-handling , stUpdate -- :: (s->s) -> Parser s t () , stQuery -- :: (s->a) -> Parser s t a , stGet -- :: Parser s t s -- ** Re-parsing , reparse -- :: [t] -> Parser s t () -- * Re-export all more general combinators , module Text.ParserCombinators.Poly.Base , module Control.Applicative ) where import Text.ParserCombinators.Poly.Base hiding (manyFinally) import Text.ParserCombinators.Poly.Result import qualified Text.ParserCombinators.Poly.StateParser as P import Control.Applicative #if __GLASGOW_HASKELL__ import Control.Exception hiding (bracket) throwE :: String -> a throwE msg = throw (ErrorCall msg) #else throwE :: String -> a throwE msg = error msg #endif -- | The only differences between a State and a StateLazy parser are the -- instance of Applicative, and the type (and implementation) of runParser. -- We therefore need to /newtype/ the original Parser type, to allow it -- to have a different instance. newtype Parser s t a = P (P.Parser s t a) #ifdef __GLASGOW_HASKELL__ deriving (Functor,Monad,Commitment) #else instance Functor (Parser s t) where fmap f (P p) = P (fmap f p) instance Monad (Parser s t) where return x = P (return x) fail e = P (fail e) (P f) >>= g = P (f >>= (\(P g')->g') . g) instance Commitment (Parser s t) where commit (P p) = P (commit p) (P p) `adjustErr` f = P (p `adjustErr` f) #endif -- | Apply a parser to an input token sequence. runParser :: Parser s t a -> s -> [t] -> (a, s, [t]) runParser (P (P.P p)) = \s -> fromResult . p s where fromResult :: Result (z,s) a -> (a, s, z) fromResult (Success (z,s) a) = (a, s, z) fromResult (Failure _ e) = throwE e fromResult (Committed r) = fromResult r instance Applicative (Parser s t) where pure f = return f -- Apply a parsed function to a parsed value. This version -- is strict in the result of the function parser, but -- lazy in the result of the argument parser. (Argument laziness is -- the distinctive feature over other implementations.) (P (P.P pf)) <*> px = P (P.P (\s-> continue . pf s)) where continue (Success (z,s) f) = let (x,s',z') = runParser px s z in Success (z',s') (f x) continue (Failure zs e) = Failure zs e continue (Committed r) = Committed (continue r) #if defined(GLASGOW_HASKELL) && GLASGOW_HASKELL > 610 p <* q = p `discard` q #endif instance Alternative (Parser s t) where empty = fail "no parse" p <|> q = p `onFail` q instance PolyParse (Parser s t) ------------------------------------------------------------------------ -- | Simply return the next token in the input tokenstream. next :: Parser s t t next = P P.next -- | Succeed if the end of file/input has been reached, fail otherwise. eof :: Parser s t () eof = P P.eof -- | Return the next token if it satisfies the given predicate. satisfy :: (t->Bool) -> Parser s t t satisfy = P . P.satisfy -- | @p `onFail` q@ means parse p, unless p fails, in which case -- parse q instead. -- Can be chained together to give multiple attempts to parse something. -- (Note that q could itself be a failing parser, e.g. to change the error -- message from that defined in p to something different.) -- However, a severe failure in p cannot be ignored. onFail :: Parser s t a -> Parser s t a -> Parser s t a onFail (P a) (P b) = P (a `P.onFail` b) -- | Push some tokens back onto the front of the input stream and reparse. -- This is useful e.g. for recursively expanding macros. When the -- user-parser recognises a macro use, it can lookup the macro -- expansion from the parse state, lex it, and then stuff the -- lexed expansion back down into the parser. reparse :: [t] -> Parser s t () reparse = P . P.reparse ------------------------------------------------------------------------ -- State handling -- | Update the internal state. stUpdate :: (s->s) -> Parser s t () stUpdate f = P (P.stUpdate f) -- | Query the internal state. stQuery :: (s->a) -> Parser s t a stQuery f = P (P.stQuery f) -- | Deliver the entire internal state. stGet :: Parser s t s stGet = P (P.stGet) ------------------------------------------------------------------------ manyFinally :: Parser s t a -> Parser s t z -> Parser s t [a] {- manyFinally pp@(P p) pt@(P t) = P (\s ts -> item s ts (p s ts)) where item _ _ (Success ts s x) = success ts s x item s ts (Failure _ _ e) = terminate (t s ts) item s ts (Committed r) = Committed (within r) success ts s x = let (tail,s',ts') = runParser (manyFinally pp pt) s ts in Success ts' s' (x:tail) terminate (Success ts s _) = Success ts s [] terminate (Failure ts s e) = Failure ts s e terminate (Committed r) = Committed (terminate r) within (Success ts s x) = success ts s x within (Failure ts s e) = Failure ts s e within (Committed r) = within r -} manyFinally p z = (do x <- p; return (x:) `apply` manyFinally p z) `onFail` (do z; return []) `onFail` oneOf' [ ("item in sequence", (do p; return [])) , ("sequence terminator", (do z; return [])) ] ------------------------------------------------------------------------ polyparse-1.7/src/Text/ParserCombinators/Poly/StateParser.hs0000644000000000000000000001204311601657462022461 0ustar0000000000000000-- | This module contains the definitions for a generic parser, with -- running state. These are the parts that are shared between the State -- and StateLazy variations. Do not import this module directly, but only -- via T.P.Poly.State or T.P.Poly.StateLazy. module Text.ParserCombinators.Poly.StateParser ( -- * The Parser datatype Parser(P) -- datatype, instance of: Functor, Monad, PolyParse , Result(..) -- internal to the parser monad -- ** basic parsers , next -- :: Parser s t t , eof -- :: Parser s t () , satisfy -- :: (t->Bool) -> Parser s t t , onFail -- :: Parser s t a -> Parser s t a -> Parser s t a -- ** State-handling , stUpdate -- :: (s->s) -> Parser s t () , stQuery -- :: (s->a) -> Parser s t a , stGet -- :: Parser s t s -- ** re-parsing , reparse -- :: [t] -> Parser s t () ) where import Text.ParserCombinators.Poly.Base import Text.ParserCombinators.Poly.Result -- | This @Parser@ datatype is a fairly generic parsing monad with error -- reporting, and running state. -- It can be used for arbitrary token types, not just String input. -- (If you do not require a running state, use module Poly.Plain instead) newtype Parser s t a = P (s -> [t] -> Result ([t],s) a) instance Functor (Parser s t) where fmap f (P p) = P (\s-> fmap f . p s) instance Monad (Parser s t) where return x = P (\s ts-> Success (ts,s) x) fail e = P (\s ts-> Failure (ts,s) e) (P f) >>= g = P (\s-> continue . f s) where continue (Success (ts,s) x) = let (P g') = g x in g' s ts continue (Committed (Committed r)) = continue (Committed r) continue (Committed r) = Committed (continue r) continue (Failure tss e) = Failure tss e instance Commitment (Parser s t) where commit (P p) = P (\s-> Committed . p s) (P p) `adjustErr` f = P (\s-> adjust . p s) where adjust (Failure zs e) = Failure zs (f e) adjust (Committed r) = Committed (adjust r) adjust good = good oneOf' = accum [] where accum errs [] = fail ("failed to parse any of the possible choices:\n" ++indent 2 (concatMap showErr (reverse errs))) accum errs ((e,P p):ps) = P (\s ts-> case p s ts of Failure _ err -> let (P p) = accum ((e,err):errs) ps in p s ts r@(Success _ a) -> r r@(Committed _) -> r ) showErr (name,err) = name++":\n"++indent 2 err infixl 6 `onFail` -- not sure about precedence 6? -- | @p `onFail` q@ means parse p, unless p fails, in which case -- parse q instead. -- Can be chained together to give multiple attempts to parse something. -- (Note that q could itself be a failing parser, e.g. to change the error -- message from that defined in p to something different.) -- However, a severe failure in p cannot be ignored. onFail :: Parser s t a -> Parser s t a -> Parser s t a (P p) `onFail` (P q) = P (\s ts-> continue s ts $ p s ts) where continue s ts (Failure _ _) = q s ts -- continue _ _ (Committed r) = r -- no, remain Committed continue _ _ r = r ------------------------------------------------------------------------ -- | Simply return the next token in the input tokenstream. next :: Parser s t t next = P (\s ts-> case ts of [] -> Failure ([],s) "Ran out of input (EOF)" (t:ts') -> Success (ts',s) t ) -- | Succeed if the end of file/input has been reached, fail otherwise. eof :: Parser s t () eof = P (\s ts-> case ts of [] -> Success ([],s) () (t:ts') -> Failure (ts,s) "Expected end of input (eof)" ) -- | Return the next token if it satisfies the given predicate. satisfy :: (t->Bool) -> Parser s t t satisfy pred = do { x <- next ; if pred x then return x else fail "Parse.satisfy: failed" } ------------------------------------------------------------------------ -- State handling -- | Update the internal state. stUpdate :: (s->s) -> Parser s t () stUpdate f = P (\s ts-> Success (ts, f s) ()) -- | Query the internal state. stQuery :: (s->a) -> Parser s t a stQuery f = P (\s ts-> Success (ts,s) (f s)) -- | Deliver the entire internal state. stGet :: Parser s t s stGet = P (\s ts-> Success (ts,s) s) ------------------------------------------------------------------------ -- | Push some tokens back onto the front of the input stream and reparse. -- This is useful e.g. for recursively expanding macros. When the -- user-parser recognises a macro use, it can lookup the macro -- expansion from the parse state, lex it, and then stuff the -- lexed expansion back down into the parser. reparse :: [t] -> Parser s t () reparse ts = P (\s inp-> Success ((ts++inp),s) ()) ------------------------------------------------------------------------ polyparse-1.7/src/Text/ParserCombinators/Poly/StateText.hs0000644000000000000000000001352511601657462022157 0ustar0000000000000000module Text.ParserCombinators.Poly.StateText ( -- * The Parser datatype Parser(P) , Result(..) , runParser -- ** Basic parsers , next , eof , satisfy , onFail -- ** Derived parsers (but implemented more efficiently) , manySatisfy , many1Satisfy -- ** State-handling , stUpdate -- :: (s->s) -> Parser s t () , stQuery -- :: (s->a) -> Parser s t a , stGet -- :: Parser s t s -- ** Re-parsing , reparse -- * Re-export all more general combinators , module Text.ParserCombinators.Poly.Base , module Control.Applicative ) where import Text.ParserCombinators.Poly.Base import Text.ParserCombinators.Poly.Result import qualified Data.Text.Lazy as T import Data.Text.Lazy (Text) import Control.Applicative -- | This @Parser@ datatype is a specialised parsing monad with error -- reporting. Whereas the standard version can be used for arbitrary -- token types, this version is specialised to Text input only. newtype Parser s a = P (s -> Text -> Result (Text,s) a) -- | Apply a parser to an input token sequence. runParser :: Parser s a -> s -> Text -> (Either String a, s, Text) runParser (P p) = \s -> reTuple . resultToEither . p s where reTuple (either, (z,s)) = (either, s, z) instance Functor (Parser s) where fmap f (P p) = P (\s-> fmap f . p s) instance Monad (Parser s) where return x = P (\s ts-> Success (ts,s) x) fail e = P (\s ts-> Failure (ts,s) e) (P f) >>= g = P (\s-> continue . f s) where continue (Success (ts,s) x) = let (P g') = g x in g' s ts continue (Committed (Committed r)) = continue (Committed r) continue (Committed r) = Committed (continue r) continue (Failure ts e) = Failure ts e instance Commitment (Parser s) where commit (P p) = P (\s-> Committed . p s) (P p) `adjustErr` f = P (\s-> adjust . p s) where adjust (Failure z e) = Failure z (f e) adjust (Committed r) = Committed (adjust r) adjust good = good oneOf' = accum [] where accum errs [] = fail ("failed to parse any of the possible choices:\n" ++indent 2 (concatMap showErr (reverse errs))) accum errs ((e,P p):ps) = P (\s ts-> case p s ts of Failure _ err -> let (P p') = accum ((e,err):errs) ps in p' s ts r@(Success _ _) -> r r@(Committed _) -> r ) showErr (name,err) = name++":\n"++indent 2 err instance Applicative (Parser s) where pure f = return f pf <*> px = do { f <- pf; x <- px; return (f x) } #if defined(GLASGOW_HASKELL) && GLASGOW_HASKELL > 610 p <* q = p `discard` q #endif instance Alternative (Parser s) where empty = fail "no parse" p <|> q = p `onFail` q instance PolyParse (Parser s) ------------------------------------------------------------------------ -- | Simply return the next token in the input tokenstream. next :: Parser s Char next = P (\s bs-> case T.uncons bs of Nothing -> Failure (bs,s) "Ran out of input (EOF)" Just (c, bs') -> Success (bs',s) c ) -- | Succeed if the end of file/input has been reached, fail otherwise. eof :: Parser s () eof = P (\s bs -> if T.null bs then Success (bs,s) () else Failure (bs,s) "Expected end of input (EOF)" ) -- | Return the next token if it satisfies the given predicate. satisfy :: (Char -> Bool) -> Parser s Char satisfy f = do { x <- next ; if f x then return x else fail "Parse.satisfy: failed" } -- | @p `onFail` q@ means parse p, unless p fails, in which case -- parse q instead. -- Can be chained together to give multiple attempts to parse something. -- (Note that q could itself be a failing parser, e.g. to change the error -- message from that defined in p to something different.) -- However, a severe failure in p cannot be ignored. onFail :: Parser s a -> Parser s a -> Parser s a (P p) `onFail` (P q) = P (\s ts-> continue s ts $ p s ts) where continue s ts (Failure _ _) = q s ts -- continue _ _ (Committed r) = r -- no, remain Committed continue _ _ r = r ------------------------------------------------------------------------ -- | @manySatisfy p@ is a more efficient fused version of @many (satisfy p)@ manySatisfy :: (Char->Bool) -> Parser s Text manySatisfy f = P (\s bs-> let (pre,suf) = T.span f bs in Success (suf,s) pre) -- | @many1Satisfy p@ is a more efficient fused version of @many1 (satisfy p)@ many1Satisfy :: (Char->Bool) -> Parser s Text many1Satisfy f = do x <- manySatisfy f if T.null x then fail "Parse.many1Satisfy: failed" else return x ------------------------------------------------------------------------ -- State handling -- | Update the internal state. stUpdate :: (s->s) -> Parser s () stUpdate f = P (\s bs-> Success (bs, f s) ()) -- | Query the internal state. stQuery :: (s->a) -> Parser s a stQuery f = P (\s bs-> Success (bs,s) (f s)) -- | Deliver the entire internal state. stGet :: Parser s s stGet = P (\s bs-> Success (bs,s) s) ------------------------------------------------------------------------ -- | Push some tokens back onto the front of the input stream and reparse. -- This is useful e.g. for recursively expanding macros. When the -- user-parser recognises a macro use, it can lookup the macro -- expansion from the parse state, lex it, and then stuff the -- lexed expansion back down into the parser. reparse :: Text -> Parser s () reparse ts = P (\s inp-> Success (ts `T.append` inp,s) ()) ------------------------------------------------------------------------ polyparse-1.7/src/Text/ParserCombinators/Poly/Text.hs0000644000000000000000000001204011601657462021145 0ustar0000000000000000module Text.ParserCombinators.Poly.Text ( -- * The Parser datatype Parser(P) , Result(..) , runParser -- ** Basic parsers , next , eof , satisfy , onFail -- ** Derived parsers (but implemented more efficiently) , manySatisfy , many1Satisfy -- ** Re-parsing , reparse -- * Re-export all more general combinators , module Text.ParserCombinators.Poly.Base , module Control.Applicative ) where import Text.ParserCombinators.Poly.Base import Text.ParserCombinators.Poly.Result import qualified Data.Text.Lazy as T import Data.Text.Lazy (Text) import Control.Applicative -- | This @Parser@ datatype is a specialised parsing monad with error -- reporting. Whereas the standard version can be used for arbitrary -- token types, this version is specialised to Text input only. newtype Parser a = P (Text -> Result Text a) -- | Apply a parser to an input token sequence. runParser :: Parser a -> Text -> (Either String a, Text) runParser (P p) = resultToEither . p instance Functor Parser where fmap f (P p) = P (fmap f . p) instance Monad Parser where return x = P (\ts-> Success ts x) fail e = P (\ts-> Failure ts e) (P f) >>= g = P (continue . f) where continue (Success ts x) = let (P g') = g x in g' ts continue (Committed (Committed r)) = continue (Committed r) continue (Committed r) = Committed (continue r) continue (Failure ts e) = Failure ts e instance Commitment Parser where commit (P p) = P (Committed . p) (P p) `adjustErr` f = P (adjust . p) where adjust (Failure z e) = Failure z (f e) adjust (Committed r) = Committed (adjust r) adjust good = good oneOf' = accum [] where accum errs [] = fail ("failed to parse any of the possible choices:\n" ++indent 2 (concatMap showErr (reverse errs))) accum errs ((e,P p):ps) = P (\ts-> case p ts of Failure _ err -> let (P p') = accum ((e,err):errs) ps in p' ts r@(Success _ _) -> r r@(Committed _) -> r ) showErr (name,err) = name++":\n"++indent 2 err instance Applicative Parser where pure f = return f pf <*> px = do { f <- pf; x <- px; return (f x) } #if defined(GLASGOW_HASKELL) && GLASGOW_HASKELL > 610 p <* q = p `discard` q #endif instance Alternative Parser where empty = fail "no parse" p <|> q = p `onFail` q instance PolyParse Parser ------------------------------------------------------------------------ -- | Simply return the next token in the input tokenstream. next :: Parser Char next = P (\bs-> case T.uncons bs of Nothing -> Failure bs "Ran out of input (EOF)" Just (c, bs') -> Success bs' c ) -- | Succeed if the end of file/input has been reached, fail otherwise. eof :: Parser () eof = P (\bs -> if T.null bs then Success bs () else Failure bs "Expected end of input (EOF)" ) -- | Return the next token if it satisfies the given predicate. satisfy :: (Char -> Bool) -> Parser Char satisfy f = do { x <- next ; if f x then return x else fail "Parse.satisfy: failed" } -- | @p `onFail` q@ means parse p, unless p fails, in which case -- parse q instead. -- Can be chained together to give multiple attempts to parse something. -- (Note that q could itself be a failing parser, e.g. to change the error -- message from that defined in p to something different.) -- However, a severe failure in p cannot be ignored. onFail :: Parser a -> Parser a -> Parser a (P p) `onFail` (P q) = P (\ts-> continue ts $ p ts) where continue ts (Failure _ _) = q ts -- continue _ (Committed r) = r -- no, remain Committed continue _ r = r ------------------------------------------------------------------------ -- | @manySatisfy p@ is a more efficient fused version of @many (satisfy p)@ manySatisfy :: (Char->Bool) -> Parser Text manySatisfy f = P (\bs-> let (pre,suf) = T.span f bs in Success suf pre) -- | @many1Satisfy p@ is a more efficient fused version of @many1 (satisfy p)@ many1Satisfy :: (Char->Bool) -> Parser Text many1Satisfy f = do x <- manySatisfy f if T.null x then fail "Parse.many1Satisfy: failed" else return x ------------------------------------------------------------------------ -- | Push some tokens back onto the front of the input stream and reparse. -- This is useful e.g. for recursively expanding macros. When the -- user-parser recognises a macro use, it can lookup the macro -- expansion from the parse state, lex it, and then stuff the -- lexed expansion back down into the parser. reparse :: Text -> Parser () reparse ts = P (\inp-> Success (ts `T.append` inp) ()) ------------------------------------------------------------------------