diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,21 +1,29 @@ -Copyright 1999-2000, Daan Leijen. All rights reserved. +BSD 3-Clause License +Copyright (c) 1999-2000, Daan Leijen, 2021 Christian Maeder +All rights reserved. + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: -* Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. -* Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. -This software is provided by the copyright holders "as is" and any express or -implied warranties, including, but not limited to, the implied warranties of -merchantability and fitness for a particular purpose are disclaimed. In no -event shall the copyright holders be liable for any direct, indirect, -incidental, special, exemplary, or consequential damages (including, but not -limited to, procurement of substitute goods or services; loss of use, data, -or profits; or business interruption) however caused and on any theory of -liability, whether in contract, strict liability, or tort (including -negligence or otherwise) arising in any way out of the use of this software, -even if advised of the possibility of such damage. +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Text/ParserCombinators/Parsec.hs b/Text/ParserCombinators/Parsec.hs --- a/Text/ParserCombinators/Parsec.hs +++ b/Text/ParserCombinators/Parsec.hs @@ -1,54 +1,54 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.ParserCombinators.Parsec --- Copyright : (c) Daan Leijen 1999-2001 --- License : BSD-style (see the file libraries/parsec/LICENSE) --- --- Maintainer : Antoine Latter --- Stability : provisional --- Portability : portable --- --- Parsec, the Fast Monadic Parser combinator library, see --- . --- --- Inspired by: --- --- * Graham Hutton and Erik Meijer: --- Monadic Parser Combinators. --- Technical report NOTTCS-TR-96-4. --- Department of Computer Science, University of Nottingham, 1996. --- --- --- * Andrew Partridge, David Wright: --- Predictive parser combinators need four values to report errors. --- Journal of Functional Programming 6(2): 355-364, 1996 --- --- This helper module exports elements from the basic libraries. --- ------------------------------------------------------------------------------ +{- | +Module : Text.ParserCombinators.Parsec +Copyright : (c) Daan Leijen 1999-2001 +License : BSD-style (see the file libraries/parsec/LICENSE) -module Text.ParserCombinators.Parsec - ( -- complete modules - module Text.ParserCombinators.Parsec.Prim - , module Text.ParserCombinators.Parsec.Combinator - , module Text.ParserCombinators.Parsec.Char - - -- module Text.ParserCombinators.Parsec.Error - , ParseError - , errorPos - - -- module Text.ParserCombinators.Parsec.Pos - , SourcePos - , SourceName, Line, Column - , sourceName, sourceLine, sourceColumn - , incSourceLine, incSourceColumn - , setSourceLine, setSourceColumn, setSourceName +Maintainer : Christian Maeder +Stability : provisional +Portability : portable - ) where +Parsec, the Fast Monadic Parser combinator library. -import Text.ParserCombinators.Parsec.Pos -- textual positions -import Text.ParserCombinators.Parsec.Error -- parse errors -import Text.ParserCombinators.Parsec.Prim -- primitive combinators -import Text.ParserCombinators.Parsec.Combinator -- derived combinators -import Text.ParserCombinators.Parsec.Char -- character parsers +Inspired by: +Graham Hutton and Erik Meijer: +Monadic Parser Combinators. +Technical report NOTTCS-TR-96-4. +Department of Computer Science, University of Nottingham, 1996. + + +Andrew Partridge, David Wright: +Predictive parser combinators need four values to report errors. +Journal of Functional Programming 6(2): 355-364, 1996 + +This helper module exports elements from the basic libraries. +-} + +module Text.ParserCombinators.Parsec + ( -- complete modules + module Text.ParserCombinators.Parsec.Char + , module Text.ParserCombinators.Parsec.Combinator + , module Text.ParserCombinators.Parsec.Prim + -- module Text.ParserCombinators.Parsec.Error + , ParseError + , errorPos + -- module Text.ParserCombinators.Parsec.Pos + , Column + , Line + , SourceName + , SourcePos + , incSourceColumn + , incSourceLine + , setSourceColumn + , setSourceLine + , setSourceName + , sourceColumn + , sourceLine + , sourceName + ) where + +import Text.ParserCombinators.Parsec.Char +import Text.ParserCombinators.Parsec.Combinator +import Text.ParserCombinators.Parsec.Error +import Text.ParserCombinators.Parsec.Pos +import Text.ParserCombinators.Parsec.Prim diff --git a/Text/ParserCombinators/Parsec/Char.hs b/Text/ParserCombinators/Parsec/Char.hs --- a/Text/ParserCombinators/Parsec/Char.hs +++ b/Text/ParserCombinators/Parsec/Char.hs @@ -1,139 +1,148 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.ParserCombinators.Parsec.Char --- Copyright : (c) Daan Leijen 1999-2001 --- License : BSD-style (see the file libraries/parsec/LICENSE) --- --- Maintainer : Antoine Latter --- Stability : provisional --- Portability : portable --- --- Commonly used character parsers. --- ------------------------------------------------------------------------------ +{- | +Module : Text.ParserCombinators.Parsec.Char +Copyright : (c) Daan Leijen 1999-2001 +License : BSD-style (see the file LICENSE) +Maintainer : Christian Maeder +Stability : provisional +Portability : portable + +Commonly used character parsers +-} + module Text.ParserCombinators.Parsec.Char - ( CharParser - , spaces, space - , newline, tab - , upper, lower, alphaNum, letter - , digit, hexDigit, octDigit - , char, string - , anyChar, oneOf, noneOf - , satisfy - ) where + ( CharParser + , alphaNum + , anyChar + , char + , digit + , hexDigit + , letter + , lower + , newline + , noneOf + , octDigit + , oneOf + , satisfy + , space + , spaces + , string + , tab + , upper + ) where -import Prelude import Data.Char -import Text.ParserCombinators.Parsec.Pos( updatePosChar, updatePosString ) + +import Text.ParserCombinators.Parsec.Pos (updatePosChar, updatePosString) import Text.ParserCombinators.Parsec.Prim ------------------------------------------------------------ --- Type of character parsers ------------------------------------------------------------ -type CharParser st a = GenParser Char st a +{- --------------------------------------------------------- +Type of character parsers +--------------------------------------------------------- -} +type CharParser st a = GenParser Char st a ------------------------------------------------------------ --- Character parsers ------------------------------------------------------------ +{- --------------------------------------------------------- +Character parsers +--------------------------------------------------------- -} --- | @oneOf cs@ succeeds if the current character is in the supplied --- list of characters @cs@. Returns the parsed character. See also --- 'satisfy'. --- --- > vowel = oneOf "aeiou" +{- | @oneOf cs@ succeeds if the current character is in the supplied +list of characters @cs@. Returns the parsed character. See also +'satisfy'. + +> vowel = oneOf "aeiou" -} oneOf :: [Char] -> CharParser st Char -oneOf cs = satisfy (\c -> elem c cs) +oneOf cs = satisfy (`elem` cs) --- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current --- character /not/ in the supplied list of characters @cs@. Returns the --- parsed character. --- --- > consonant = noneOf "aeiou" +{- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current +character /not/ in the supplied list of characters @cs@. Returns the +parsed character. + +> consonant = noneOf "aeiou" -} noneOf :: [Char] -> CharParser st Char -noneOf cs = satisfy (\c -> not (elem c cs)) +noneOf cs = satisfy (`notElem` cs) -- | Skips /zero/ or more white space characters. See also 'skipMany'. spaces :: CharParser st () -spaces = skipMany space "white space" +spaces = skipMany space "white space" --- | Parses a white space character (any character which satisfies 'isSpace') --- Returns the parsed character. +{- | Parses a white space character (any character which satisfies 'isSpace') +Returns the parsed character. -} space :: CharParser st Char -space = satisfy (isSpace) "space" +space = satisfy isSpace "space" -- | Parses a newline character (\'\\n\'). Returns a newline character. newline :: CharParser st Char -newline = char '\n' "new-line" +newline = char '\n' "new-line" -- | Parses a tab character (\'\\t\'). Returns a tab character. tab :: CharParser st Char -tab = char '\t' "tab" +tab = char '\t' "tab" --- | Parses an upper case letter (a character between \'A\' and \'Z\'). --- Returns the parsed character. +{- | Parses an upper case letter according to 'isUpper'. +Returns the parsed character. -} upper :: CharParser st Char -upper = satisfy (isUpper) "uppercase letter" +upper = satisfy isUpper "uppercase letter" --- | Parses a lower case character (a character between \'a\' and \'z\'). --- Returns the parsed character. +{- | Parses a lower case character according to 'isLower'. +Returns the parsed character. -} lower :: CharParser st Char -lower = satisfy (isLower) "lowercase letter" +lower = satisfy isLower "lowercase letter" --- | Parses a letter or digit (a character between \'0\' and \'9\'). --- Returns the parsed character. +{- | Parses an alphabetic or numeric Unicode characters according to +'isAlphaNum'. Returns the parsed character. -} alphaNum :: CharParser st Char -alphaNum = satisfy (isAlphaNum) "letter or digit" +alphaNum = satisfy isAlphaNum "letter or digit" --- | Parses a letter (an upper case or lower case character). Returns the --- parsed character. +{- | Parses an alphabetic Unicode characters according to 'isAlpha'. +Returns the parsed character. -} letter :: CharParser st Char -letter = satisfy (isAlpha) "letter" +letter = satisfy isAlpha "letter" --- | Parses a digit. Returns the parsed character. +{- | Parses a digit (\'0\' ... \'9\') according to 'isDigit'. +Returns the parsed character. -} digit :: CharParser st Char -digit = satisfy (isDigit) "digit" +digit = satisfy isDigit "digit" --- | Parses a hexadecimal digit (a digit or a letter between \'a\' and --- \'f\' or \'A\' and \'F\'). Returns the parsed character. +{- | Parses a hexadecimal digit (a digit or a letter between \'a\' and +\'f\' or \'A\' and \'F\'). Returns the parsed character. -} hexDigit :: CharParser st Char -hexDigit = satisfy (isHexDigit) "hexadecimal digit" +hexDigit = satisfy isHexDigit "hexadecimal digit" --- | Parses an octal digit (a character between \'0\' and \'7\'). Returns --- the parsed character. +{- | Parses an octal digit (\'0\' ... \'7\') according to 'isOctDigit'. +Returns the parsed character. -} octDigit :: CharParser st Char -octDigit = satisfy (isOctDigit) "octal digit" +octDigit = satisfy isOctDigit "octal digit" --- | @char c@ parses a single character @c@. Returns the parsed --- character (i.e. @c@). --- --- > semiColon = char ';' +{- | @char c@ parses a single character @c@. Returns the parsed +character (i.e. @c@). + +> semiColon = char ';' -} char :: Char -> CharParser st Char -char c = satisfy (==c) show [c] +char c = satisfy (== c) show [c] -- | This parser succeeds for any character. Returns the parsed character. anyChar :: CharParser st Char -anyChar = satisfy (const True) +anyChar = satisfy (const True) ------------------------------------------------------------ --- Primitive character parsers ------------------------------------------------------------ +{- --------------------------------------------------------- +Primitive character parsers +--------------------------------------------------------- -} --- | The parser @satisfy f@ succeeds for any character for which the --- supplied function @f@ returns 'True'. Returns the character that is --- actually parsed. --- --- > digit = satisfy isDigit --- > oneOf cs = satisfy (\c -> c `elem` cs) +{- | The parser @satisfy f@ succeeds for any character for which the +supplied function @f@ returns 'True'. Returns the character that is +actually parsed. + +> digit = satisfy isDigit +> oneOf cs = satisfy (`elem` cs) -} satisfy :: (Char -> Bool) -> CharParser st Char -satisfy f = tokenPrim (\c -> show [c]) - (\pos c cs -> updatePosChar pos c) - (\c -> if f c then Just c else Nothing) +satisfy f = tokenPrim (\ c -> show [c]) + (\ pos c _ -> updatePosChar pos c) + (\ c -> if f c then Just c else Nothing) --- | @string s@ parses a sequence of characters given by @s@. Returns --- the parsed string (i.e. @s@). --- --- > divOrMod = string "div" --- > <|> string "mod" +{- | @string s@ parses a sequence of characters given by @s@. Returns +the parsed string (i.e. @s@). + +> divOrMod = string "div" +> <|> string "mod" -} string :: String -> CharParser st String -string s = tokens show updatePosString s +string = tokens show updatePosString diff --git a/Text/ParserCombinators/Parsec/Combinator.hs b/Text/ParserCombinators/Parsec/Combinator.hs --- a/Text/ParserCombinators/Parsec/Combinator.hs +++ b/Text/ParserCombinators/Parsec/Combinator.hs @@ -1,258 +1,254 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.ParserCombinators.Parsec.Combinator --- Copyright : (c) Daan Leijen 1999-2001 --- License : BSD-style (see the file libraries/parsec/LICENSE) --- --- Maintainer : Antoine Latter --- Stability : provisional --- Portability : portable --- --- Commonly used generic combinators --- ------------------------------------------------------------------------------ +{- | +Module : Text.ParserCombinators.Parsec.Combinator +Copyright : (c) Daan Leijen 1999-2001 +License : BSD-style (see the file LICENSE) -module Text.ParserCombinators.Parsec.Combinator - ( choice - , count - , between - , option, optionMaybe, optional - , skipMany1 - , many1 - , sepBy, sepBy1 - , endBy, endBy1 - , sepEndBy, sepEndBy1 - , chainl, chainl1 - , chainr, chainr1 - , eof, notFollowedBy +Maintainer : Christian Maeder +Stability : provisional +Portability : portable - -- tricky combinators - , manyTill, lookAhead, anyToken - ) where +Commonly used generic combinators +-} +module Text.ParserCombinators.Parsec.Combinator + ( between + , chainl + , chainl1 + , chainr + , chainr1 + , choice + , count + , endBy + , endBy1 + , eof + , many1 + , notFollowedBy + , option + , optionMaybe + , optional + , sepBy + , sepBy1 + , sepEndBy + , sepEndBy1 + , skipMany1 + -- tricky combinators + , anyToken + , lookAhead + , manyTill + ) where + import Control.Monad import Text.ParserCombinators.Parsec.Prim --- | @choice ps@ tries to apply the parsers in the list @ps@ in order, --- until one of them succeeds. Returns the value of the succeeding --- parser. +{- | @choice ps@ tries to apply the parsers in the list @ps@ in order, +until one of them succeeds. Returns the value of the succeeding +parser. -} choice :: [GenParser tok st a] -> GenParser tok st a -choice ps = foldr (<|>) mzero ps +choice = foldr (<|>) mzero --- | @option x p@ tries to apply parser @p@. If @p@ fails without --- consuming input, it returns the value @x@, otherwise the value --- returned by @p@. --- --- > priority = option 0 (do{ d <- digit --- > ; return (digitToInt d) --- > }) +{- | @option x p@ tries to apply parser @p@. If @p@ fails without +consuming input, it returns the value @x@, otherwise the value +returned by @p@. + +> priority = option 0 (digitToInt <$> digit) -} option :: a -> GenParser tok st a -> GenParser tok st a -option x p = p <|> return x +option x p = p <|> return x --- | @optionMaybe p@ tries to apply parser @p@. If @p@ fails without --- consuming input, it return 'Nothing', otherwise it returns --- 'Just' the value returned by @p@. +{- | @optionMaybe p@ tries to apply parser @p@. If @p@ fails without +consuming input, it return 'Nothing', otherwise it returns +'Just' the value returned by @p@. -} optionMaybe :: GenParser tok st a -> GenParser tok st (Maybe a) -optionMaybe p = option Nothing (liftM Just p) +optionMaybe p = option Nothing (fmap Just p) --- | @optional p@ tries to apply parser @p@. It will parse @p@ or nothing. --- It only fails if @p@ fails after consuming input. It discards the result --- of @p@. +{- | @optional p@ tries to apply parser @p@. It will parse @p@ or nothing. +It only fails if @p@ fails after consuming input. It discards the result +of @p@. -} optional :: GenParser tok st a -> GenParser tok st () -optional p = do{ p; return ()} <|> return () +optional p = () <$ p <|> return () --- | @between open close p@ parses @open@, followed by @p@ and @close@. --- Returns the value returned by @p@. --- --- > braces = between (symbol "{") (symbol "}") +{- | @between open close p@ parses @open@, followed by @p@ and @close@. +Returns the value returned by @p@. + +> braces = between (symbol "{") (symbol "}") -} between :: GenParser tok st open -> GenParser tok st close -> GenParser tok st a -> GenParser tok st a -between open close p - = do{ open; x <- p; close; return x } - +between open close p = open *> p <* close --- | @skipMany1 p@ applies the parser @p@ /one/ or more times, skipping --- its result. +{- | @skipMany1 p@ applies the parser @p@ /one/ or more times, skipping +its result. -} skipMany1 :: GenParser tok st a -> GenParser tok st () -skipMany1 p = do{ p; skipMany p } -{- -skipMany p = scan - where - scan = do{ p; scan } <|> return () --} +skipMany1 p = p *> skipMany p --- | @many1 p@ applies the parser @p@ /one/ or more times. Returns a --- list of the returned values of @p@. --- --- > word = many1 letter +{- | @many1 p@ applies the parser @p@ /one/ or more times. Returns a +list of the returned values of @p@. + +> word = many1 letter -} many1 :: GenParser tok st a -> GenParser tok st [a] -many1 p = do{ x <- p; xs <- many p; return (x:xs) } -{- -many p = scan id - where - scan f = do{ x <- p - ; scan (\tail -> f (x:tail)) - } - <|> return (f []) --} +many1 p = do + x <- p + xs <- many p + return (x : xs) --- | @sepBy p sep@ parses /zero/ or more occurrences of @p@, separated --- by @sep@. Returns a list of values returned by @p@. --- --- > commaSep p = p `sepBy` (symbol ",") +{- | @sepBy p sep@ parses /zero/ or more occurrences of @p@, separated +by @sep@. Returns a list of values returned by @p@. + +> commaSep p = p `sepBy` (symbol ",") -} sepBy :: GenParser tok st a -> GenParser tok st sep -> GenParser tok st [a] -sepBy p sep = sepBy1 p sep <|> return [] +sepBy p sep = sepBy1 p sep <|> return [] --- | @sepBy1 p sep@ parses /one/ or more occurrences of @p@, separated --- by @sep@. Returns a list of values returned by @p@. +{- | @sepBy1 p sep@ parses /one/ or more occurrences of @p@, separated +by @sep@. Returns a list of values returned by @p@. -} sepBy1 :: GenParser tok st a -> GenParser tok st sep -> GenParser tok st [a] -sepBy1 p sep = do{ x <- p - ; xs <- many (sep >> p) - ; return (x:xs) - } +sepBy1 p sep = do + x <- p + xs <- many (sep *> p) + return (x : xs) --- | @sepEndBy1 p sep@ parses /one/ or more occurrences of @p@, --- separated and optionally ended by @sep@. Returns a list of values --- returned by @p@. +{- | @sepEndBy1 p sep@ parses /one/ or more occurrences of @p@, +separated and optionally ended by @sep@. Returns a list of values +returned by @p@. -} sepEndBy1 :: GenParser tok st a -> GenParser tok st sep -> GenParser tok st [a] -sepEndBy1 p sep = do{ x <- p - ; do{ sep - ; xs <- sepEndBy p sep - ; return (x:xs) - } - <|> return [x] - } +sepEndBy1 p sep = do + x <- p + do + xs <- sep *> sepEndBy p sep + return (x : xs) + <|> return [x] --- | @sepEndBy p sep@ parses /zero/ or more occurrences of @p@, --- separated and optionally ended by @sep@, ie. haskell style --- statements. Returns a list of values returned by @p@. --- --- > haskellStatements = haskellStatement `sepEndBy` semi +{- | @sepEndBy p sep@ parses /zero/ or more occurrences of @p@, +separated and optionally ended by @sep@, ie. haskell style +statements. Returns a list of values returned by @p@. + +> haskellStatements = haskellStatement `sepEndBy` semi -} sepEndBy :: GenParser tok st a -> GenParser tok st sep -> GenParser tok st [a] -sepEndBy p sep = sepEndBy1 p sep <|> return [] +sepEndBy p sep = sepEndBy1 p sep <|> return [] --- | @endBy1 p sep@ parses /one/ or more occurrences of @p@, seperated --- and ended by @sep@. Returns a list of values returned by @p@. +{- | @endBy1 p sep@ parses /one/ or more occurrences of @p@, seperated +and ended by @sep@. Returns a list of values returned by @p@. -} endBy1 :: GenParser tok st a -> GenParser tok st sep -> GenParser tok st [a] -endBy1 p sep = many1 (do{ x <- p; sep; return x }) +endBy1 p sep = many1 (p <* sep) --- | @endBy p sep@ parses /zero/ or more occurrences of @p@, seperated --- and ended by @sep@. Returns a list of values returned by @p@. --- --- > cStatements = cStatement `endBy` semi +{- | @endBy p sep@ parses /zero/ or more occurrences of @p@, seperated +and ended by @sep@. Returns a list of values returned by @p@. + +> cStatements = cStatement `endBy` semi -} endBy :: GenParser tok st a -> GenParser tok st sep -> GenParser tok st [a] -endBy p sep = many (do{ x <- p; sep; return x }) +endBy p sep = many (p <* sep) --- | @count n p@ parses @n@ occurrences of @p@. If @n@ is smaller or --- equal to zero, the parser equals to @return []@. Returns a list of --- @n@ values returned by @p@. +{- | @count n p@ parses @n@ occurrences of @p@. If @n@ is smaller or +equal to zero, the parser equals to @return []@. Returns a list of +@n@ values returned by @p@. -} count :: Int -> GenParser tok st a -> GenParser tok st [a] -count n p | n <= 0 = return [] - | otherwise = sequence (replicate n p) +count n p | n <= 0 = return [] + | otherwise = replicateM n p --- | @chainr p op x@ parser /zero/ or more occurrences of @p@, --- separated by @op@ Returns a value obtained by a /right/ associative --- application of all functions returned by @op@ to the values returned --- by @p@. If there are no occurrences of @p@, the value @x@ is --- returned. -chainr :: GenParser tok st a -> GenParser tok st (a -> a -> a) -> a -> GenParser tok st a -chainr p op x = chainr1 p op <|> return x +{- | @chainr p op x@ parser /zero/ or more occurrences of @p@, +separated by @op@ Returns a value obtained by a /right/ associative +application of all functions returned by @op@ to the values returned +by @p@. If there are no occurrences of @p@, the value @x@ is +returned. -} +chainr :: GenParser tok st a -> GenParser tok st (a -> a -> a) -> a + -> GenParser tok st a +chainr p op x = chainr1 p op <|> return x --- | @chainl p op x@ parser /zero/ or more occurrences of @p@, --- separated by @op@. Returns a value obtained by a /left/ associative --- application of all functions returned by @op@ to the values returned --- by @p@. If there are zero occurrences of @p@, the value @x@ is --- returned. -chainl :: GenParser tok st a -> GenParser tok st (a -> a -> a) -> a -> GenParser tok st a -chainl p op x = chainl1 p op <|> return x +{- | @chainl p op x@ parser /zero/ or more occurrences of @p@, +separated by @op@. Returns a value obtained by a /left/ associative +application of all functions returned by @op@ to the values returned +by @p@. If there are zero occurrences of @p@, the value @x@ is +returned. -} +chainl :: GenParser tok st a -> GenParser tok st (a -> a -> a) -> a + -> GenParser tok st a +chainl p op x = chainl1 p op <|> return x --- | @chainl1 p op x@ parser /one/ or more occurrences of @p@, --- separated by @op@ Returns a value obtained by a /left/ associative --- application of all functions returned by @op@ to the values returned --- by @p@. . This parser can for example be used to eliminate left --- recursion which typically occurs in expression grammars. --- --- > expr = term `chainl1` addop --- > term = factor `chainl1` mulop --- > factor = parens expr <|> integer --- > --- > mulop = do{ symbol "*"; return (*) } --- > <|> do{ symbol "/"; return (div) } --- > --- > addop = do{ symbol "+"; return (+) } --- > <|> do{ symbol "-"; return (-) } -chainl1 :: GenParser tok st a -> GenParser tok st (a -> a -> a) -> GenParser tok st a -chainl1 p op = do{ x <- p; rest x } - where - rest x = do{ f <- op - ; y <- p - ; rest (f x y) - } - <|> return x +{- | @chainl1 p op x@ parser /one/ or more occurrences of @p@, +separated by @op@ Returns a value obtained by a /left/ associative +application of all functions returned by @op@ to the values returned +by @p@. This parser can for example be used to eliminate left +recursion which typically occurs in expression grammars. --- | @chainr1 p op x@ parser /one/ or more occurrences of |p|, --- separated by @op@ Returns a value obtained by a /right/ associative --- application of all functions returned by @op@ to the values returned --- by @p@. -chainr1 :: GenParser tok st a -> GenParser tok st (a -> a -> a) -> GenParser tok st a -chainr1 p op = scan +> expr = term `chainl1` addop +> term = factor `chainl1` mulop +> factor = parens expr <|> integer +> +> mulop = symbol "*" *> return (*) +> <|> symbol "/" *> return (div) +> +> addop = symbol "+" *> return (+) +> <|> symbol "-" *> return (-) -} +chainl1 :: GenParser tok st a -> GenParser tok st (a -> a -> a) + -> GenParser tok st a +chainl1 p op = do + x <- p + rest x + where + rest x = do + f <- op + y <- p + rest (f x y) + <|> return x + +{- | @chainr1 p op x@ parser /one/ or more occurrences of |p|, +separated by @op@ Returns a value obtained by a /right/ associative +application of all functions returned by @op@ to the values returned +by @p@. -} +chainr1 :: GenParser tok st a -> GenParser tok st (a -> a -> a) + -> GenParser tok st a +chainr1 p op = scan where - scan = do{ x <- p; rest x } + scan = do + x <- p + rest x - rest x = do{ f <- op - ; y <- scan - ; return (f x y) - } - <|> return x + rest x = do + f <- op + f x <$> scan + <|> return x ------------------------------------------------------------ --- Tricky combinators ------------------------------------------------------------ +{- --------------------------------------------------------- +Tricky combinators +--------------------------------------------------------- -} --- | The parser @anyToken@ accepts any kind of token. It is for example --- used to implement 'eof'. Returns the accepted token. +{- | The parser @anyToken@ accepts any kind of token. It is for example +used to implement 'eof'. Returns the accepted token. -} anyToken :: Show tok => GenParser tok st tok -anyToken = tokenPrim show (\pos tok toks -> pos) Just +anyToken = tokenPrim show (\ pos _tok _toks -> pos) Just --- | This parser only succeeds at the end of the input. This is not a --- primitive parser but it is defined using 'notFollowedBy'. --- --- > eof = notFollowedBy anyToken "end of input" +{- | This parser only succeeds at the end of the input. This is not a +primitive parser but it is defined using 'notFollowedBy'. + +> eof = notFollowedBy anyToken "end of input" -} eof :: Show tok => GenParser tok st () -eof = notFollowedBy anyToken "end of input" +eof = notFollowedBy anyToken "end of input" --- | @notFollowedBy p@ only succeeds when parser @p@ fails. This parser --- does not consume any input. This parser can be used to implement the --- \'longest match\' rule. For example, when recognizing keywords (for --- example @let@), we want to make sure that a keyword is not followed --- by a legal identifier character, in which case the keyword is --- actually an identifier (for example @lets@). We can program this --- behaviour as follows: --- --- > keywordLet = try (do{ string "let" --- > ; notFollowedBy alphaNum --- > }) +{- | @notFollowedBy p@ only succeeds when parser @p@ fails. This parser +does not consume any input. This parser can be used to implement the +\'longest match\' rule. For example, when recognizing keywords (for +example @let@), we want to make sure that a keyword is not followed +by a legal identifier character, in which case the keyword is +actually an identifier (for example @lets@). We can program this +behaviour as follows: + +> keywordLet = try (string "let" <* notFollowedBy alphaNum) -} notFollowedBy :: Show a => GenParser tok st a -> GenParser tok st () -notFollowedBy p = try (do{ c <- p; unexpected (show c) } - <|> return () - ) +notFollowedBy p = try $ do + c <- p + unexpected (show c) + <|> return () --- | @manyTill p end@ applies parser @p@ /zero/ or more times until --- parser @end@ succeeds. Returns the list of values returned by @p@. --- This parser can be used to scan comments: --- --- > simpleComment = do{ string "")) --- > } --- --- Note the overlapping parsers @anyChar@ and @string \"")) + +Note the overlapping parsers @anyChar@ and @string \"-->\"@, and +therefore the use of the 'try' combinator. -} manyTill :: GenParser tok st a -> GenParser tok st end -> GenParser tok st [a] -manyTill p end = scan - where - scan = do{ end; return [] } - <|> - do{ x <- p; xs <- scan; return (x:xs) } +manyTill p end = scan where + scan = [] <$ end <|> do + x <- p + xs <- scan + return (x : xs) diff --git a/Text/ParserCombinators/Parsec/Error.hs b/Text/ParserCombinators/Parsec/Error.hs --- a/Text/ParserCombinators/Parsec/Error.hs +++ b/Text/ParserCombinators/Parsec/Error.hs @@ -1,133 +1,132 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.ParserCombinators.Parsec.Error --- Copyright : (c) Daan Leijen 1999-2001 --- License : BSD-style (see the file libraries/parsec/LICENSE) --- --- Maintainer : Antoine Latter --- Stability : provisional --- Portability : portable --- --- Parse errors --- ------------------------------------------------------------------------------ +{- | +Module : Text.ParserCombinators.Parsec.Error +Copyright : (c) Daan Leijen 1999-2001 +License : BSD-style (see the file LICENSE) -module Text.ParserCombinators.Parsec.Error - ( Message(SysUnExpect,UnExpect,Expect,Message) - , messageString, messageCompare, messageEq +Maintainer : Christian Maeder +Stability : provisional +Portability : portable - , ParseError, errorPos, errorMessages, errorIsUnknown - , showErrorMessages +Parse errors +-} - , newErrorMessage, newErrorUnknown - , addErrorMessage, setErrorPos, setErrorMessage - , mergeError - ) - where +module Text.ParserCombinators.Parsec.Error + ( Message (SysUnExpect, UnExpect, Expect, Message) + , ParseError + , addErrorMessage + , errorIsUnknown + , errorMessages + , errorPos + , mergeError + , messageCompare + , messageEq + , messageString + , newErrorMessage + , newErrorUnknown + , setErrorMessage + , setErrorPos + , showErrorMessages + ) where -import Prelude -import Data.List (nub,sortBy) +import Data.List (nub, sortBy) + import Text.ParserCombinators.Parsec.Pos --- | This abstract data type represents parse error messages. There are --- four kinds of messages: --- --- > data Message = SysUnExpect String --- > | UnExpect String --- > | Expect String --- > | Message String --- --- The fine distinction between different kinds of parse errors allows --- the system to generate quite good error messages for the user. It --- also allows error messages that are formatted in different --- languages. Each kind of message is generated by different combinators: --- --- * A 'SysUnExpect' message is automatically generated by the --- 'Text.Parsec.Combinator.satisfy' combinator. The argument is the --- unexpected input. --- --- * A 'UnExpect' message is generated by the 'Text.Parsec.Prim.unexpected' --- combinator. The argument describes the --- unexpected item. --- --- * A 'Expect' message is generated by the 'Text.Parsec.Prim.' --- combinator. The argument describes the expected item. --- --- * A 'Message' message is generated by the 'fail' --- combinator. The argument is some general parser message. -data Message = SysUnExpect !String --library generated unexpect - | UnExpect !String --unexpected something - | Expect !String --expecting something - | Message !String --raw message +{- | This abstract data type represents parse error messages. There are +four kinds of messages: -messageToEnum msg - = case msg of SysUnExpect _ -> 0 - UnExpect _ -> 1 - Expect _ -> 2 - Message _ -> 3 +> data Message = SysUnExpect String +> | UnExpect String +> | Expect String +> | Message String +The fine distinction between different kinds of parse errors allows +the system to generate quite good error messages for the user. It +also allows error messages that are formatted in different +languages. Each kind of message is generated by different combinators: + +A 'SysUnExpect' message is automatically generated by the +'Text.Parsec.Combinator.satisfy' combinator. The argument is the +unexpected input. + +A 'UnExpect' message is generated by the 'Text.Parsec.Prim.unexpected' +combinator. The argument describes the +unexpected item. + +A 'Expect' message is generated by the 'Text.Parsec.Prim.' +combinator. The argument describes the expected item. + +A 'Message' message is generated by the 'fail' +combinator. The argument is some general parser message. -} +data Message + = SysUnExpect !String -- library generated unexpect + | UnExpect !String -- unexpected something + | Expect !String -- expecting something + | Message !String -- raw message + deriving Eq + +messageToEnum :: Message -> Int +messageToEnum msg = case msg of + SysUnExpect _ -> 0 + UnExpect _ -> 1 + Expect _ -> 2 + Message _ -> 3 + messageCompare :: Message -> Message -> Ordering messageCompare msg1 msg2 = compare (messageToEnum msg1) (messageToEnum msg2) -- | Extract the message string from an error message messageString :: Message -> String -messageString msg - = case msg of SysUnExpect s -> s - UnExpect s -> s - Expect s -> s - Message s -> s +messageString msg = case msg of + SysUnExpect s -> s + UnExpect s -> s + Expect s -> s + Message s -> s messageEq :: Message -> Message -> Bool messageEq msg1 msg2 - = (messageCompare msg1 msg2 == EQ) + = messageCompare msg1 msg2 == EQ --- | The abstract data type @ParseError@ represents parse errors. It --- provides the source position ('SourcePos') of the error --- and a list of error messages ('Message'). A @ParseError@ --- can be returned by the function 'Text.Parsec.Prim.parse'. @ParseError@ is an --- instance of the 'Show' class. -data ParseError = ParseError !SourcePos [Message] +{- | The abstract data type @ParseError@ represents parse errors. It +provides the source position ('SourcePos') of the error +and a list of error messages ('Message'). A @ParseError@ +can be returned by the function 'Text.Parsec.Prim.parse'. @ParseError@ is an +instance of the 'Show' class. -} +data ParseError = ParseError !SourcePos [Message] deriving Eq -- | Extracts the source position from the parse error errorPos :: ParseError -> SourcePos -errorPos (ParseError pos msgs) - = pos +errorPos (ParseError pos _msgs) = pos -- | Extracts the list of error messages from the parse error errorMessages :: ParseError -> [Message] -errorMessages (ParseError pos msgs) - = sortBy messageCompare msgs +errorMessages (ParseError _pos msgs) = sortBy messageCompare msgs errorIsUnknown :: ParseError -> Bool -errorIsUnknown (ParseError pos msgs) - = null msgs +errorIsUnknown (ParseError _pos msgs) = null msgs ------------------------------------------------------------ --- Create parse errors ------------------------------------------------------------ +{- --------------------------------------------------------- +Create parse errors +--------------------------------------------------------- -} newErrorUnknown :: SourcePos -> ParseError -newErrorUnknown pos - = ParseError pos [] +newErrorUnknown pos = ParseError pos [] newErrorMessage :: Message -> SourcePos -> ParseError -newErrorMessage msg pos - = ParseError pos [msg] +newErrorMessage msg pos = ParseError pos [msg] addErrorMessage :: Message -> ParseError -> ParseError -addErrorMessage msg (ParseError pos msgs) - = ParseError pos (msg:msgs) +addErrorMessage msg (ParseError pos msgs) = ParseError pos (msg : msgs) setErrorPos :: SourcePos -> ParseError -> ParseError -setErrorPos pos (ParseError _ msgs) - = ParseError pos msgs +setErrorPos pos (ParseError _ msgs) = ParseError pos msgs setErrorMessage :: Message -> ParseError -> ParseError setErrorMessage msg (ParseError pos msgs) - = ParseError pos (msg:filter (not . messageEq msg) msgs) + = ParseError pos (msg : filter (not . messageEq msg) msgs) mergeError :: ParseError -> ParseError -> ParseError @@ -142,57 +141,54 @@ GT -> e1 LT -> e2 ------------------------------------------------------------ --- Show Parse Errors ------------------------------------------------------------ +{- --------------------------------------------------------- +Show Parse Errors +--------------------------------------------------------- -} instance Show ParseError where - show err - = show (errorPos err) ++ ":" ++ + show err = show (errorPos err) ++ ":" ++ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages err) - -- | Language independent show function showErrorMessages :: String -> String -> String -> String -> String -> [Message] -> String showErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs | null msgs = msgUnknown - | otherwise = concat $ map ("\n"++) $ clean $ - [showSysUnExpect,showUnExpect,showExpect,showMessages] + | otherwise = concatMap ("\n" ++) $ clean + [showSysUnExpect, showUnExpect, showExpect, showMessages] where - (sysUnExpect,msgs1) = span (messageEq (SysUnExpect "")) msgs - (unExpect,msgs2) = span (messageEq (UnExpect "")) msgs1 - (expect,messages) = span (messageEq (Expect "")) msgs2 - - showExpect = showMany msgExpecting expect - showUnExpect = showMany msgUnExpected unExpect - showSysUnExpect | not (null unExpect) || - null sysUnExpect = "" - | null firstMsg = msgUnExpected ++ " " ++ msgEndOfInput - | otherwise = msgUnExpected ++ " " ++ firstMsg - where - firstMsg = messageString (head sysUnExpect) - - showMessages = showMany "" messages + (sysUnExpect, msgs1) = span (messageEq (SysUnExpect "")) msgs + (unExpect, msgs2) = span (messageEq (UnExpect "")) msgs1 + (expect, messages) = span (messageEq (Expect "")) msgs2 + showExpect = showMany msgExpecting expect + showUnExpect = showMany msgUnExpected unExpect + showSysUnExpect + | not (null unExpect) || null sysUnExpect = "" + | null firstMsg = msgUnExpected ++ " " ++ msgEndOfInput + | otherwise = msgUnExpected ++ " " ++ firstMsg + where + firstMsg = messageString (head sysUnExpect) - --helpers - showMany pre msgs = case (clean (map messageString msgs)) of - [] -> "" - ms | null pre -> commasOr ms - | otherwise -> pre ++ " " ++ commasOr ms + showMessages = showMany "" messages - commasOr [] = "" - commasOr [m] = m - commasOr ms = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms + -- helpers + showMany pre es = case clean (map messageString es) of + [] -> "" + ms | null pre -> commasOr ms + | otherwise -> pre ++ " " ++ commasOr ms - commaSep = seperate ", " . clean - semiSep = seperate "; " . clean + commasOr ms = case ms of + [] -> "" + [m] -> m + _ -> commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms - seperate sep [] = "" - seperate sep [m] = m - seperate sep (m:ms) = m ++ sep ++ seperate sep ms + commaSep = seperate ", " . clean - clean = nub . filter (not.null) + seperate sep ms = case ms of + [] -> "" + [m] -> m + m : rs -> m ++ sep ++ seperate sep rs + clean = nub . filter (not . null) diff --git a/Text/ParserCombinators/Parsec/Pos.hs b/Text/ParserCombinators/Parsec/Pos.hs --- a/Text/ParserCombinators/Parsec/Pos.hs +++ b/Text/ParserCombinators/Parsec/Pos.hs @@ -1,114 +1,107 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.ParserCombinators.Parsec.Pos --- Copyright : (c) Daan Leijen 1999-2001 --- License : BSD-style (see the file libraries/parsec/LICENSE) --- --- Maintainer : Antoine Latter --- Stability : provisional --- Portability : portable --- --- Textual source positions. --- ------------------------------------------------------------------------------ +{- | +Module : Text.ParserCombinators.Parsec.Pos +Copyright : (c) Daan Leijen 1999-2001 +License : BSD-style (see the file LICENSE) +Maintainer : Christian Maeder +Stability : provisional +Portability : portable + +Textual source positions +-} + module Text.ParserCombinators.Parsec.Pos - ( SourceName, Line, Column - , SourcePos - , sourceLine, sourceColumn, sourceName - , incSourceLine, incSourceColumn - , setSourceLine, setSourceColumn, setSourceName - , newPos, initialPos - , updatePosChar, updatePosString - ) where + ( Column + , Line + , SourceName + , SourcePos + , incSourceColumn + , incSourceLine + , initialPos + , newPos + , setSourceColumn + , setSourceLine + , setSourceName + , sourceColumn + , sourceLine + , sourceName + , updatePosChar + , updatePosString + ) where ------------------------------------------------------------ --- Source Positions, a file name, a line and a column. --- upper left is (1,1) ------------------------------------------------------------ -type SourceName = String -type Line = Int -type Column = Int +{- --------------------------------------------------------- +Source Positions, a file name, a line and a column. +upper left is (1,1) +--------------------------------------------------------- -} +type SourceName = String +type Line = Int +type Column = Int --- | The abstract data type @SourcePos@ represents source positions. It --- contains the name of the source (i.e. file name), a line number and --- a column number. @SourcePos@ is an instance of the 'Show', 'Eq' and --- 'Ord' class. -data SourcePos = SourcePos SourceName !Line !Column - deriving (Eq,Ord) +{- | The abstract data type @SourcePos@ represents source positions. It +contains the name of the source (i.e. file name), a line number and +a column number. @SourcePos@ is an instance of the 'Show', 'Eq' and +'Ord' class. -} +data SourcePos = SourcePos + { sourceName :: SourceName -- ^ the name of the source from a position + , sourceLine :: !Line -- ^ the line number from a source position + , sourceColumn :: !Column -- ^ the column number from a source position + } deriving (Eq, Ord) --- | Create a new 'SourcePos' with the given source name, --- line number and column number. +{- | Create a new 'SourcePos' with the given source name, +line number and column number. -} newPos :: SourceName -> Line -> Column -> SourcePos -newPos sourceName line column - = SourcePos sourceName line column +newPos = SourcePos --- | Create a new 'SourcePos' with the given source name, --- and line number and column number set to 1, the upper left. +{- | Create a new 'SourcePos' with the given source name, +and line number and column number set to 1, the upper left. -} initialPos :: SourceName -> SourcePos -initialPos sourceName - = newPos sourceName 1 1 - --- | Extracts the name of the source from a source position. -sourceName :: SourcePos -> SourceName -sourceName (SourcePos name line column) = name - --- | Extracts the line number from a source position. -sourceLine :: SourcePos -> Line -sourceLine (SourcePos name line column) = line - --- | Extracts the column number from a source position. -sourceColumn :: SourcePos -> Column -sourceColumn (SourcePos name line column) = column +initialPos name = newPos name 1 1 -- | Increments the line number of a source position. incSourceLine :: SourcePos -> Line -> SourcePos -incSourceLine (SourcePos name line column) n = SourcePos name (line+n) column +incSourceLine (SourcePos name line column) n + = SourcePos name (line + n) column -- | Increments the column number of a source position. incSourceColumn :: SourcePos -> Column -> SourcePos -incSourceColumn (SourcePos name line column) n = SourcePos name line (column+n) +incSourceColumn (SourcePos name line column) n + = SourcePos name line (column + n) -- | Set the name of the source. setSourceName :: SourcePos -> SourceName -> SourcePos -setSourceName (SourcePos name line column) n = SourcePos n line column +setSourceName (SourcePos _name line column) n = SourcePos n line column -- | Set the line number of a source position. setSourceLine :: SourcePos -> Line -> SourcePos -setSourceLine (SourcePos name line column) n = SourcePos name n column +setSourceLine (SourcePos name _line column) n = SourcePos name n column -- | Set the column number of a source position. setSourceColumn :: SourcePos -> Column -> SourcePos -setSourceColumn (SourcePos name line column) n = SourcePos name line n +setSourceColumn (SourcePos name line _column) = SourcePos name line --- | The expression @updatePosString pos s@ updates the source position --- @pos@ by calling 'updatePosChar' on every character in @s@, ie. --- @foldl updatePosChar pos string@. +{- | The expression @updatePosString pos s@ updates the source position +@pos@ by calling 'updatePosChar' on every character in @s@, ie. +@foldl updatePosChar pos string@. -} updatePosString :: SourcePos -> String -> SourcePos -updatePosString pos string - = forcePos (foldl updatePosChar pos string) - -updatePosChar :: SourcePos -> Char -> SourcePos -updatePosChar pos@(SourcePos name line column) c - = forcePos $ - case c of - '\n' -> SourcePos name (line+1) 1 - '\t' -> SourcePos name line (column + 8 - ((column-1) `mod` 8)) - _ -> SourcePos name line (column + 1) +updatePosString pos string = forcePos (foldl updatePosChar pos string) +updatePosChar :: SourcePos -> Char -> SourcePos +updatePosChar (SourcePos name line column) c = forcePos $ case c of + '\n' -> SourcePos name (line + 1) 1 + '\t' -> SourcePos name line (column + 8 - ((column - 1) `mod` 8)) + _ -> SourcePos name line (column + 1) forcePos :: SourcePos -> SourcePos -forcePos pos@(SourcePos name line column) - = seq line (seq column (pos)) +forcePos pos@(SourcePos _name line column) = seq line (seq column pos) ------------------------------------------------------------ --- Show positions ------------------------------------------------------------ +{- --------------------------------------------------------- +Show positions +--------------------------------------------------------- -} instance Show SourcePos where show (SourcePos name line column) | null name = showLineColumn | otherwise = "\"" ++ name ++ "\" " ++ showLineColumn where - showLineColumn = "(line " ++ show line ++ + showLineColumn = "(line " ++ show line ++ ", column " ++ show column ++ ")" diff --git a/Text/ParserCombinators/Parsec/Prim.hs b/Text/ParserCombinators/Parsec/Prim.hs --- a/Text/ParserCombinators/Parsec/Prim.hs +++ b/Text/ParserCombinators/Parsec/Prim.hs @@ -1,560 +1,512 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.ParserCombinators.Parsec.Prim --- Copyright : (c) Daan Leijen 1999-2001 --- License : BSD-style (see the file libraries/parsec/LICENSE) --- --- Maintainer : Antoine Latter --- Stability : provisional --- Portability : portable --- --- The primitive parser combinators. --- ------------------------------------------------------------------------------ - -module Text.ParserCombinators.Parsec.Prim - ( -- operators: label a parser, alternative - (), (<|>) - - -- basic types - , Parser, GenParser - , runParser, parse, parseFromFile, parseTest - - -- primitive parsers: - -- instance Functor Parser : fmap - -- instance Monad Parser : return, >>=, fail - -- instance MonadPlus Parser : mzero (pzero), mplus (<|>) - , token, tokens, tokenPrim, tokenPrimEx - , try, label, labels, lookAhead, unexpected, pzero +{-# LANGUAGE CPP #-} +{- | +Module : Text.ParserCombinators.Parsec.Prim +Copyright : (c) Daan Leijen 1999-2001 +License : BSD-style (see the file LICENSE) - -- primitive because of space behaviour - , many, skipMany +Maintainer : Christian Maeder +Stability : provisional +Portability : portable - -- user state manipulation - , getState, setState, updateState +The primitive parser combinators. +-} - -- state manipulation - , getPosition, setPosition - , getInput, setInput - , State(..), getParserState, setParserState - ) where +module Text.ParserCombinators.Parsec.Prim + ( -- operators: label a parser, alternative + (*>) + , (<$) + , (<$>) + , (<*) + , (<*>) + , () + , (<|>) + -- basic types + , GenParser + , Parser + , parse + , parseFromFile + , parseTest + , runParser + -- primitive parsers + , label + , labels + , lookAhead + , pzero + , token + , tokenPrim + , tokenPrimEx + , tokens + , try + , unexpected + -- primitive because of space behaviour + , many + , skipMany + -- user state manipulation + , getState + , setState + , updateState + -- state manipulation + , State (..) + , getInput + , getParserState + , getPosition + , setInput + , setParserState + , setPosition + ) where -import Prelude -import Text.ParserCombinators.Parsec.Pos import Text.ParserCombinators.Parsec.Error +import Text.ParserCombinators.Parsec.Pos + import Control.Applicative import Control.Monad + +#if __GLASGOW_HASKELL__ >= 801 import Control.Monad.Fail +#endif ------------------------------------------------------------ --- Operators: --- gives a name to a parser (which is used in error messages) --- <|> is the choice operator ------------------------------------------------------------ -infix 0 +infix 0 --- | The parser @p msg@ behaves as parser @p@, but whenever the --- parser @p@ fails /without consuming any input/, it replaces expect --- error messages with the expect error message @msg@. --- --- This is normally used at the end of a set alternatives where we want --- to return an error message in terms of a higher level construct --- rather than returning all possible characters. For example, if the --- @expr@ parser from the 'try' example would fail, the error --- message is: '...: expecting expression'. Without the @(\)@ --- combinator, the message would be like '...: expecting \"let\" or --- letter', which is less friendly. +{- | The parser @p msg@ behaves as parser @p@, but whenever the +parser @p@ fails /without consuming any input/, it replaces expect +error messages with the expect error message @msg@. + +This is normally used at the end of a set alternatives where we want +to return an error message in terms of a higher level construct +rather than returning all possible characters. For example, if the +@expr@ parser from the 'try' example would fail, the error +message is: '...: expecting expression'. Without the @(\)@ +combinator, the message would be like '...: expecting \"let\" or +letter', which is less friendly. -} () :: GenParser tok st a -> String -> GenParser tok st a -p msg = label p msg +p msg = label p msg ------------------------------------------------------------ --- User state combinators ------------------------------------------------------------ +{- --------------------------------------------------------- +User state combinators +--------------------------------------------------------- -} -- | Returns the current user state. getState :: GenParser tok st st -getState = do{ state <- getParserState - ; return (stateUser state) - } +getState = stateUser <$> getParserState -- | @setState st@ set the user state to @st@. setState :: st -> GenParser tok st () -setState st = do{ updateParserState (\(State input pos _) -> State input pos st) - ; return () - } +setState st = + () <$ updateParserState (\ (State input pos _) -> State input pos st) --- | @updateState f@ applies function @f@ to the user state. Suppose --- that we want to count identifiers in a source, we could use the user --- state as: --- --- > expr = do{ x <- identifier --- > ; updateState (+1) --- > ; return (Id x) --- > } -updateState :: (st -> st) -> GenParser tok st () -updateState f = do{ updateParserState (\(State input pos user) -> State input pos (f user)) - ; return () - } +{- | @updateState f@ applies function @f@ to the user state. Suppose +that we want to count identifiers in a source, we could use the user +state as: +> expr = do +> x <- identifier +> updateState (+1) +> return (Id x) -} +updateState :: (st -> st) -> GenParser tok st () +updateState f = + () <$ updateParserState (\ (State input pos user) -> State input pos (f user)) ------------------------------------------------------------ --- Parser state combinators ------------------------------------------------------------ +{- --------------------------------------------------------- +Parser state combinators +--------------------------------------------------------- -} -- | Returns the current source position. See also 'SourcePos'. getPosition :: GenParser tok st SourcePos -getPosition = do{ state <- getParserState; return (statePos state) } +getPosition = statePos <$> getParserState -- | Returns the current input getInput :: GenParser tok st [tok] -getInput = do{ state <- getParserState; return (stateInput state) } - +getInput = stateInput <$> getParserState -- | @setPosition pos@ sets the current source position to @pos@. setPosition :: SourcePos -> GenParser tok st () -setPosition pos = do{ updateParserState (\(State input _ user) -> State input pos user) - ; return () - } +setPosition pos = + () <$ updateParserState (\ (State input _ user) -> State input pos user) -- | @setInput input@ continues parsing with @input@. setInput :: [tok] -> GenParser tok st () -setInput input = do{ updateParserState (\(State _ pos user) -> State input pos user) - ; return () - } +setInput input = + () <$ updateParserState (\ (State _ pos user) -> State input pos user) -- | Returns the full parser state as a 'State' record. -getParserState :: GenParser tok st (State tok st) -getParserState = updateParserState id +getParserState :: GenParser tok st (State tok st) +getParserState = updateParserState id -- | @setParserState st@ set the full parser state to @st@. -setParserState :: State tok st -> GenParser tok st (State tok st) -setParserState st = updateParserState (const st) - - +setParserState :: State tok st -> GenParser tok st (State tok st) +setParserState st = updateParserState (const st) ------------------------------------------------------------ --- Parser definition. --- GenParser tok st a: --- General parser for tokens of type "tok", --- a user state "st" and a result type "a" ------------------------------------------------------------ -type Parser a = GenParser Char () a - -newtype GenParser tok st a = Parser (State tok st -> Consumed (Reply tok st a)) -runP (Parser p) = p +{- --------------------------------------------------------- +Parser definition. +GenParser tok st a: +General parser for tokens of type "tok", +a user state "st" and a result type "a" +--------------------------------------------------------- -} +type Parser a = GenParser Char () a -data Consumed a = Consumed a --input is consumed - | Empty !a --no input is consumed +newtype GenParser tok st a = Parser + { runP :: State tok st -> Consumed (Reply tok st a) } -data Reply tok st a = Ok !a !(State tok st) ParseError --parsing succeeded with "a" - | Error ParseError --parsing failed +data Consumed a + = Consumed a -- input is consumed + | Empty !a -- no input is consumed -data State tok st = State { stateInput :: [tok] - , statePos :: !SourcePos - , stateUser :: !st - } +data Reply tok st a + = Ok !a !(State tok st) ParseError -- parsing succeeded with "a" + | Error ParseError -- parsing failed +data State tok st = State + { stateInput :: [tok] + , statePos :: !SourcePos + , stateUser :: !st } ------------------------------------------------------------ --- run a parser ------------------------------------------------------------ +{- --------------------------------------------------------- +run a parser +--------------------------------------------------------- -} parseFromFile :: Parser a -> SourceName -> IO (Either ParseError a) -parseFromFile p fname - = do{ input <- readFile fname - ; return (parse p fname input) - } +parseFromFile p fname = do + input <- readFile fname + return $ parse p fname input --- | The expression @parseTest p input@ applies a parser @p@ against --- input @input@ and prints the result to stdout. Used for testing --- parsers. +{- | The expression @parseTest p input@ applies a parser @p@ against +input @input@ and prints the result to stdout. Used for testing +parsers. -} parseTest :: Show a => GenParser tok () a -> [tok] -> IO () -parseTest p input - = case (runParser p () "" input) of - Left err -> do{ putStr "parse error at " - ; print err - } - Right x -> print x +parseTest p input = case runParser p () "" input of + Left err -> putStr "parse error at " >> print err + Right x -> print x --- | @parse p filePath input@ runs a parser @p@ without user --- state. The @filePath@ is only used in error messages and may be the --- empty string. Returns either a 'ParseError' ('Left') --- or a value of type @a@ ('Right'). --- --- > main = case (parse numbers "" "11, 2, 43") of --- > Left err -> print err --- > Right xs -> print (sum xs) --- > --- > numbers = commaSep integer +{- | @parse p filePath input@ runs a parser @p@ without user +state. The @filePath@ is only used in error messages and may be the +empty string. Returns either a 'ParseError' ('Left') +or a value of type @a@ ('Right'). + +> main = case parse numbers "" "11, 2, 43" of +> Left err -> print err +> Right xs -> print (sum xs) +> +> numbers = commaSep integer -} parse :: GenParser tok () a -> SourceName -> [tok] -> Either ParseError a -parse p name input - = runParser p () name input +parse p = runParser p () --- | The most general way to run a parser. @runParser p state filePath --- input@ runs parser @p@ on the input list of tokens @input@, --- obtained from source @filePath@ with the initial user state @st@. --- The @filePath@ is only used in error messages and may be the empty --- string. Returns either a 'ParseError' ('Left') or a --- value of type @a@ ('Right'). --- --- > parseFromFile p fname --- > = do{ input <- readFile fname --- > ; return (runParser p () fname input) --- > } -runParser :: GenParser tok st a -> st -> SourceName -> [tok] -> Either ParseError a -runParser p st name input - = case parserReply (runP p (State input (initialPos name) st)) of - Ok x _ _ -> Right x - Error err -> Left err +{- | The most general way to run a parser. @runParser p state filePath +input@ runs parser @p@ on the input list of tokens @input@, +obtained from source @filePath@ with the initial user state @st@. +The @filePath@ is only used in error messages and may be the empty +string. Returns either a 'ParseError' ('Left') or a +value of type @a@ ('Right'). -parserReply result - = case result of - Consumed reply -> reply - Empty reply -> reply +> parseFromFile p fname = do +> input <- readFile fname +> return (runParser p () fname input) -} +runParser :: GenParser tok st a -> st -> SourceName -> [tok] + -> Either ParseError a +runParser p st name input = + case parserReply . runP p $ State input (initialPos name) st of + Ok x _ _ -> Right x + Error err -> Left err +parserReply :: Consumed p -> p +parserReply result = case result of + Consumed reply -> reply + Empty reply -> reply ------------------------------------------------------------ --- Functor: fmap ------------------------------------------------------------ + +{- --------------------------------------------------------- +Functor: fmap +--------------------------------------------------------- -} instance Functor (GenParser tok st) where - fmap f p = parsecMap f p + fmap f p = parsecMap f p parsecMap :: (a -> b) -> GenParser tok st a -> GenParser tok st b -parsecMap f (Parser p) - = Parser (\state -> - case (p state) of - Consumed reply -> Consumed (mapReply reply) - Empty reply -> Empty (mapReply reply) - ) - where - mapReply reply - = case reply of - Ok x state err -> let fx = f x - in seq fx (Ok fx state err) - Error err -> Error err +parsecMap f (Parser p) = Parser $ \ state -> case p state of + Consumed reply -> Consumed $ mapReply reply + Empty reply -> Empty $ mapReply reply + where + mapReply reply = case reply of + Ok x state err -> let fx = f x in seq fx $ Ok fx state err + Error err -> Error err +{- --------------------------------------------------------- +Monad: return, sequence (>>=) and fail +--------------------------------------------------------- -} +instance Monad (GenParser tok st) where + return = parsecReturn + (>>=) = parsecBind + (>>) = (*>) +#if !MIN_VERSION_base (4, 13, 0) + fail = parsecFail +#endif ------------------------------------------------------------ --- Monad: return, sequence (>>=) and fail ------------------------------------------------------------ +#if __GLASGOW_HASKELL__ >= 801 instance MonadFail (GenParser tok st) where fail = parsecFail - -instance Monad (GenParser tok st) where - return x = parsecReturn x - p >>= f = parsecBind p f +#endif instance Applicative (GenParser tok st) where - pure = return + pure = parsecReturn (<*>) = ap + p1 *> p2 = p1 >>= const p2 + p1 <* p2 = p1 >>= (<$ p2) parsecReturn :: a -> GenParser tok st a -parsecReturn x - = Parser (\state -> Empty (Ok x state (unknownError state))) - -parsecBind :: GenParser tok st a -> (a -> GenParser tok st b) -> GenParser tok st b -parsecBind (Parser p) f - = Parser (\state -> - case (p state) of - Consumed reply1 - -> Consumed $ - case (reply1) of - Ok x state1 err1 -> case runP (f x) state1 of - Empty reply2 -> mergeErrorReply err1 reply2 - Consumed reply2 -> reply2 - Error err1 -> Error err1 - - Empty reply1 - -> case (reply1) of - Ok x state1 err1 -> case runP (f x) state1 of - Empty reply2 -> Empty (mergeErrorReply err1 reply2) - other -> other - Error err1 -> Empty (Error err1) - ) +parsecReturn x = Parser $ \ state -> Empty . Ok x state $ unknownError state -mergeErrorReply err1 reply - = case reply of - Ok x state err2 -> Ok x state (mergeError err1 err2) - Error err2 -> Error (mergeError err1 err2) +parsecBind :: GenParser tok st a -> (a -> GenParser tok st b) + -> GenParser tok st b +parsecBind (Parser p) f = Parser $ \ state -> case p state of + Consumed reply1 -> Consumed $ case reply1 of + Ok x state1 err1 -> case runP (f x) state1 of + Empty reply2 -> mergeErrorReply err1 reply2 + Consumed reply2 -> reply2 + Error err1 -> Error err1 + Empty reply1 -> case reply1 of + Ok x state1 err1 -> case runP (f x) state1 of + Empty reply2 -> Empty (mergeErrorReply err1 reply2) + other -> other + Error err1 -> Empty (Error err1) +mergeErrorReply :: ParseError -> Reply tok st a -> Reply tok st a +mergeErrorReply err1 reply = case reply of + Ok x state err2 -> Ok x state (mergeError err1 err2) + Error err2 -> Error (mergeError err1 err2) parsecFail :: String -> GenParser tok st a -parsecFail msg - = Parser (\state -> - Empty (Error (newErrorMessage (Message msg) (statePos state)))) - +parsecFail msg = + Parser $ Empty . Error . newErrorMessage (Message msg) . statePos ------------------------------------------------------------ --- MonadPlus: alternative (mplus) and mzero ------------------------------------------------------------ +{- --------------------------------------------------------- +MonadPlus: alternative (mplus) and mzero +--------------------------------------------------------- -} instance MonadPlus (GenParser tok st) where - mzero = parsecZero - mplus p1 p2 = parsecPlus p1 p2 + mzero = parsecZero + mplus p1 p2 = parsecPlus p1 p2 instance Alternative (GenParser tok st) where - (<|>) = mplus - empty = mzero - many = manyAux + (<|>) = mplus + empty = mzero + many = manyAux pzero :: GenParser tok st a pzero = parsecZero --- | @parsecZero@ always fails without consuming any input. @parsecZero@ is defined --- equal to the 'mzero' member of the 'MonadPlus' class and to the 'Control.Applicative.empty' member --- of the 'Control.Applicative.Applicative' class. +{- | @parsecZero@ always fails without consuming any input. @parsecZero@ is +defined equal to the 'mzero' member of the 'MonadPlus' class and to the +'Control.Applicative.empty' member of the 'Control.Applicative.Applicative' +class. -} parsecZero :: GenParser tok st a -parsecZero - = Parser (\state -> Empty (Error (unknownError state))) +parsecZero = Parser $ Empty . Error . unknownError parsecPlus :: GenParser tok st a -> GenParser tok st a -> GenParser tok st a -parsecPlus (Parser p1) (Parser p2) - = Parser (\state -> - case (p1 state) of - Empty (Error err) -> case (p2 state) of - Empty reply -> Empty (mergeErrorReply err reply) - consumed -> consumed - other -> other - ) +parsecPlus (Parser p1) (Parser p2) = Parser $ \ state -> case p1 state of + Empty (Error err) -> case p2 state of + Empty reply -> Empty $ mergeErrorReply err reply + consumed -> consumed + other -> other +{- | The parser @try p@ behaves like parser @p@, except that it +pretends that it hasn't consumed any input when an error occurs. -{- --- variant that favors a consumed reply over an empty one, even it is not the first alternative. - empty@(Empty reply) -> case reply of - Error err -> - case (p2 state) of - Empty reply -> Empty (mergeErrorReply err reply) - consumed -> consumed - ok -> - case (p2 state) of - Empty reply -> empty - consumed -> consumed - consumed -> consumed --} +This combinator is used whenever arbitrary look ahead is needed. +Since it pretends that it hasn't consumed any input when @p@ fails, +the ('<|>') combinator will try its second alternative even when the +first parser failed while consuming input. +The @try@ combinator can for example be used to distinguish +identifiers and reserved words. Both reserved words and identifiers +are a sequence of letters. Whenever we expect a certain reserved +word where we can also expect an identifier we have to use the @try@ +combinator. Suppose we write: --- | The parser @try p@ behaves like parser @p@, except that it --- pretends that it hasn't consumed any input when an error occurs. --- --- This combinator is used whenever arbitrary look ahead is needed. --- Since it pretends that it hasn't consumed any input when @p@ fails, --- the ('<|>') combinator will try its second alternative even when the --- first parser failed while consuming input. --- --- The @try@ combinator can for example be used to distinguish --- identifiers and reserved words. Both reserved words and identifiers --- are a sequence of letters. Whenever we expect a certain reserved --- word where we can also expect an identifier we have to use the @try@ --- combinator. Suppose we write: --- --- > expr = letExpr <|> identifier "expression" --- > --- > letExpr = do{ string "let"; ... } --- > identifier = many1 letter --- --- If the user writes \"lexical\", the parser fails with: @unexpected --- \'x\', expecting \'t\' in \"let\"@. Indeed, since the ('<|>') combinator --- only tries alternatives when the first alternative hasn't consumed --- input, the @identifier@ parser is never tried (because the prefix --- \"le\" of the @string \"let\"@ parser is already consumed). The --- right behaviour can be obtained by adding the @try@ combinator: --- --- > expr = letExpr <|> identifier "expression" --- > --- > letExpr = do{ try (string "let"); ... } --- > identifier = many1 letter +> expr = letExpr <|> identifier "expression" +> +> letExpr = string "let" *> ... +> identifier = many1 letter + +If the user writes \"lexical\", the parser fails with: @unexpected +\'x\', expecting \'t\' in \"let\"@. Indeed, since the ('<|>') combinator +only tries alternatives when the first alternative hasn't consumed +input, the @identifier@ parser is never tried (because the prefix +\"le\" of the @string \"let\"@ parser is already consumed). The +right behaviour can be obtained by adding the @try@ combinator: + +> expr = letExpr <|> identifier "expression" +> +> letExpr = try (string "let") *> +> identifier = many1 letter -} try :: GenParser tok st a -> GenParser tok st a -try (Parser p) - = Parser (\state -> - case (p state) of - Consumed (Error err) -> Empty (Error err) - Consumed ok -> Consumed ok -- was: Empty ok - empty -> empty - ) +try (Parser p) = Parser $ \ state -> case p state of + Consumed (Error err) -> Empty (Error err) + Consumed ok -> Consumed ok -- was: Empty ok + mty -> mty -- | @lookAhead p@ parses @p@ without consuming any input. lookAhead :: GenParser tok st a -> GenParser tok st a -lookAhead p = do{ state <- getParserState - ; x <- p' - ; setParserState state - ; return x - } - where p' = Parser $ \ state -> case runP p state of - Consumed ok@Ok{} -> Empty ok - reply -> reply +lookAhead p = Parser $ \ state -> case runP p state of + Consumed (Ok r _ _) -> Empty $ Ok r state $ unknownError state + reply -> reply --- | The parser @token showTok posFromTok testTok@ accepts a token @t@ --- with result @x@ when the function @testTok t@ returns @'Just' x@. The --- source position of the @t@ should be returned by @posFromTok t@ and --- the token can be shown using @showTok t@. --- --- This combinator is expressed in terms of 'tokenPrim'. --- It is used to accept user defined token streams. For example, --- suppose that we have a stream of basic tokens tupled with source --- positions. We can than define a parser that accepts single tokens as: --- --- > mytoken x --- > = token showTok posFromTok testTok --- > where --- > showTok (pos,t) = show t --- > posFromTok (pos,t) = pos --- > testTok (pos,t) = if x == t then Just t else Nothing -token :: (tok -> String) -> (tok -> SourcePos) -> (tok -> Maybe a) -> GenParser tok st a -token show tokpos test - = tokenPrim show nextpos test - where - nextpos _ _ (tok:toks) = tokpos tok - nextpos _ tok [] = tokpos tok +{- | The parser @token showTok posFromTok testTok@ accepts a token @t@ +with result @x@ when the function @testTok t@ returns @'Just' x@. The +source position of the @t@ should be returned by @posFromTok t@ and +the token can be shown using @showTok t@. --- | The parser @token showTok nextPos testTok@ accepts a token @t@ --- with result @x@ when the function @testTok t@ returns @'Just' x@. The --- token can be shown using @showTok t@. The position of the /next/ --- token should be returned when @nextPos@ is called with the current --- source position @pos@, the current token @t@ and the rest of the --- tokens @toks@, @nextPos pos t toks@. --- --- This is the most primitive combinator for accepting tokens. For --- example, the 'Text.Parsec.Char.char' parser could be implemented as: --- --- > char c --- > = tokenPrim showChar nextPos testChar --- > where --- > showChar x = "'" ++ x ++ "'" --- > testChar x = if x == c then Just x else Nothing --- > nextPos pos x xs = updatePosChar pos x -tokenPrim :: (tok -> String) -> (SourcePos -> tok -> [tok] -> SourcePos) -> (tok -> Maybe a) -> GenParser tok st a -tokenPrim show nextpos test - = tokenPrimEx show nextpos Nothing test +This combinator is expressed in terms of 'tokenPrim'. +It is used to accept user defined token streams. For example, +suppose that we have a stream of basic tokens tupled with source +positions. We can than define a parser that accepts single tokens as: --- | The most primitive token recogniser. The expression @tokenPrimEx show nextpos mbnextstate test@, --- recognises tokens when @test@ returns @Just x@ (and returns the value @x@). Tokens are shown in --- error messages using @show@. The position is calculated using @nextpos@, and finally, @mbnextstate@, --- can hold a function that updates the user state on every token recognised (nice to count tokens :-). --- The function is packed into a 'Maybe' type for performance reasons. -tokenPrimEx :: (tok -> String) -> - (SourcePos -> tok -> [tok] -> SourcePos) -> - Maybe (SourcePos -> tok -> [tok] -> st -> st) -> - (tok -> Maybe a) -> - GenParser tok st a -tokenPrimEx show nextpos mbNextState test - = case mbNextState of - Nothing - -> Parser (\state@(State input pos user) -> - case input of - (c:cs) -> case test c of - Just x -> let newpos = nextpos pos c cs - newstate = State cs newpos user - in seq newpos $ seq newstate $ - Consumed (Ok x newstate (newErrorUnknown newpos)) - Nothing -> Empty (sysUnExpectError (show c) pos) - [] -> Empty (sysUnExpectError "" pos) - ) - Just nextState - -> Parser (\state@(State input pos user) -> - case input of - (c:cs) -> case test c of - Just x -> let newpos = nextpos pos c cs - newuser = nextState pos c cs user - newstate = State cs newpos newuser - in seq newpos $ seq newstate $ - Consumed (Ok x newstate (newErrorUnknown newpos)) - Nothing -> Empty (sysUnExpectError (show c) pos) - [] -> Empty (sysUnExpectError "" pos) - ) +> mytoken x +> = token showTok posFromTok testTok +> where +> showTok (pos,t) = show t +> posFromTok (pos,t) = pos +> testTok (pos,t) = if x == t then Just t else Nothing -} +token :: (tok -> String) -> (tok -> SourcePos) -> (tok -> Maybe a) + -> GenParser tok st a +token shw tokpos = tokenPrim shw nextpos where + nextpos _ tok ts = case ts of + t : _ -> tokpos t + _ -> tokpos tok +{- | The parser @token showTok nextPos testTok@ accepts a token @t@ +with result @x@ when the function @testTok t@ returns @'Just' x@. The +token can be shown using @showTok t@. The position of the /next/ +token should be returned when @nextPos@ is called with the current +source position @pos@, the current token @t@ and the rest of the +tokens @toks@, @nextPos pos t toks@. +This is the most primitive combinator for accepting tokens. For +example, the 'Text.Parsec.Char.char' parser could be implemented as: + +> char c +> = tokenPrim showChar nextPos testChar +> where +> showChar x = "'" ++ x ++ "'" +> testChar x = if x == c then Just x else Nothing +> nextPos pos x xs = updatePosChar pos x -} +tokenPrim :: (tok -> String) -> (SourcePos -> tok -> [tok] -> SourcePos) + -> (tok -> Maybe a) -> GenParser tok st a +tokenPrim shw nextpos = tokenPrimEx shw nextpos Nothing + +{- | The most primitive token recogniser. The expression +@tokenPrimEx show nextpos mbnextstate test@, recognises tokens when @test@ +returns @Just x@ (and returns the value @x@). Tokens are shown in error +messages using @show@. The position is calculated using @nextpos@, and finally, +@mbnextstate@, can hold a function that updates the user state on every token +recognised (nice to count tokens :-). +The function is packed into a 'Maybe' type for performance reasons. -} +tokenPrimEx :: (tok -> String) -> (SourcePos -> tok -> [tok] -> SourcePos) + -> Maybe (SourcePos -> tok -> [tok] -> st -> st) -> (tok -> Maybe a) + -> GenParser tok st a +tokenPrimEx shw nextpos mbNextState test = case mbNextState of + Nothing -> Parser $ \ (State input pos user) -> case input of + c : cs -> case test c of + Just x -> let + newpos = nextpos pos c cs + newstate = State cs newpos user + in seq newpos . seq newstate . + Consumed . Ok x newstate $ newErrorUnknown newpos + Nothing -> Empty (sysUnExpectError (shw c) pos) + [] -> Empty (sysUnExpectError "" pos) + Just nextState -> Parser $ \ (State input pos user) -> case input of + c : cs -> case test c of + Just x -> let + newpos = nextpos pos c cs + newuser = nextState pos c cs user + newstate = State cs newpos newuser + in seq newpos . seq newstate . + Consumed . Ok x newstate $ newErrorUnknown newpos + Nothing -> Empty $ sysUnExpectError (shw c) pos + [] -> Empty $ sysUnExpectError "" pos + label :: GenParser tok st a -> String -> GenParser tok st a -label p msg - = labels p [msg] +label p msg = labels p [msg] labels :: GenParser tok st a -> [String] -> GenParser tok st a -labels (Parser p) msgs - = Parser (\state -> - case (p state) of - Empty reply -> Empty $ - case (reply) of - Error err -> Error (setExpectErrors err msgs) - Ok x state1 err | errorIsUnknown err -> reply - | otherwise -> Ok x state1 (setExpectErrors err msgs) - other -> other - ) - +labels (Parser p) msgs = Parser $ \ state -> case p state of + Empty reply -> Empty $ case reply of + Error err -> Error $ setExpectErrors err msgs + Ok x state1 err -> if errorIsUnknown err then reply else + Ok x state1 $ setExpectErrors err msgs + other -> other -- | @updateParserState f@ applies function @f@ to the parser state. -updateParserState :: (State tok st -> State tok st) -> GenParser tok st (State tok st) -updateParserState f - = Parser (\state -> let newstate = f state - in Empty (Ok state newstate (unknownError newstate))) +updateParserState :: (State tok st -> State tok st) + -> GenParser tok st (State tok st) +updateParserState f = Parser $ \ state -> let newstate = f state in + Empty . Ok state newstate $ unknownError newstate --- | The parser @unexpected msg@ always fails with an unexpected error --- message @msg@ without consuming any input. --- --- The parsers 'fail', ('') and @unexpected@ are the three parsers --- used to generate error messages. Of these, only ('') is commonly --- used. For an example of the use of @unexpected@, see the definition --- of 'Text.Parsec.Combinator.notFollowedBy'. +{- | The parser @unexpected msg@ always fails with an unexpected error +message @msg@ without consuming any input. + +The parsers @fail@, ('') and @unexpected@ are the three parsers +used to generate error messages. Of these, only ('') is commonly +used. For an example of the use of @unexpected@, see the definition +of 'Text.ParserCombinators.Parsec.Combinator.notFollowedBy'. -} unexpected :: String -> GenParser tok st a -unexpected msg - = Parser (\state -> Empty (Error (newErrorMessage (UnExpect msg) (statePos state)))) +unexpected msg = + Parser $ Empty . Error . newErrorMessage (UnExpect msg) . statePos +setExpectErrors :: ParseError -> [String] -> ParseError +setExpectErrors err ms = case ms of + [] -> setErrorMessage (Expect "") err + [msg] -> setErrorMessage (Expect msg) err + msg : msgs -> foldr (addErrorMessage . Expect) + (setErrorMessage (Expect msg) err) msgs -setExpectErrors err [] = setErrorMessage (Expect "") err -setExpectErrors err [msg] = setErrorMessage (Expect msg) err -setExpectErrors err (msg:msgs) = foldr (\msg err -> addErrorMessage (Expect msg) err) - (setErrorMessage (Expect msg) err) msgs +sysUnExpectError :: String -> SourcePos -> Reply tok st a +sysUnExpectError msg = Error . newErrorMessage (SysUnExpect msg) -sysUnExpectError msg pos = Error (newErrorMessage (SysUnExpect msg) pos) -unknownError state = newErrorUnknown (statePos state) +unknownError :: State tok st -> ParseError +unknownError = newErrorUnknown . statePos ------------------------------------------------------------ --- Parsers unfolded for space: --- if many and skipMany are not defined as primitives, --- they will overflow the stack on large inputs ------------------------------------------------------------ +{- --------------------------------------------------------- +Parsers unfolded for space: +if many and skipMany are not defined as primitives, +they will overflow the stack on large inputs +--------------------------------------------------------- -} --- | @manyAux p@ applies the parser @p@ /zero/ or more times. Returns a --- list of the returned values of @p@. --- --- > identifier = do{ c <- letter --- > ; cs <- many (alphaNum <|> char '_') --- > ; return (c:cs) --- > } +{- | @manyAux p@ applies the parser @p@ /zero/ or more times. Returns a +list of the returned values of @p@. + +> identifier = do +> c <- letter +> cs <- many (alphaNum <|> char '_') +> return (c : cs) -} manyAux :: GenParser tok st a -> GenParser tok st [a] -manyAux p - = do{ xs <- manyAccum (:) p - ; return (reverse xs) - } +manyAux p = do + xs <- manyAccum (:) p + return (reverse xs) --- | @skipMany p@ applies the parser @p@ /zero/ or more times, skipping --- its result. --- --- > spaces = skipMany space +{- | @skipMany p@ applies the parser @p@ /zero/ or more times, skipping +its result. + +> spaces = skipMany space -} skipMany :: GenParser tok st a -> GenParser tok st () -skipMany p - = do{ manyAccum (\x xs -> []) p - ; return () - } +skipMany p = () <$ manyAccum (\ _ _ -> []) p manyAccum :: (a -> [a] -> [a]) -> GenParser tok st a -> GenParser tok st [a] -manyAccum accum (Parser p) - = Parser (\state -> - let walk xs state r = case r of - Empty (Error err) -> Ok xs state err - Empty ok -> error "Text.ParserCombinators.Parsec.Prim.many: combinator 'many' is applied to a parser that accepts an empty string." - Consumed (Error err) -> Error err - Consumed (Ok x state' err) -> let ys = accum x xs - in seq ys (walk ys state' (p state')) - in case (p state) of - Empty reply -> case reply of - Ok x state' err -> error "Text.ParserCombinators.Parsec.Prim.many: combinator 'many' is applied to a parser that accepts an empty string." - Error err -> Empty (Ok [] state err) - consumed -> Consumed $ walk [] state consumed) - - +manyAccum accum (Parser p) = Parser $ \ state -> let + errMty = error $ "Text.ParserCombinators.Parsec.Prim.many: combinator " + ++ "'many' is applied to a parser that accepts an empty string." + walk xs st r = case r of + Empty (Error err) -> Ok xs st err + Empty _ -> errMty + Consumed (Error err) -> Error err + Consumed (Ok x state' _) -> let ys = accum x xs in + seq ys . walk ys state' $ p state' + in case p state of + Empty reply -> case reply of + Ok {} -> errMty + Error err -> Empty (Ok [] state err) + consumed -> Consumed $ walk [] state consumed ------------------------------------------------------------ --- Parsers unfolded for speed: --- tokens ------------------------------------------------------------ +{- --------------------------------------------------------- +Parsers unfolded for speed: +tokens +--------------------------------------------------------- -} {- specification of @tokens@: tokens showss nextposs s @@ -567,28 +519,27 @@ nextpos pos c = nextposs pos [c] -} -tokens :: Eq tok => ([tok] -> String) -> (SourcePos -> [tok] -> SourcePos) -> [tok] -> GenParser tok st [tok] -tokens shows nextposs s - = Parser (\state@(State input pos user) -> - let - ok cs = let newpos = nextposs pos s - newstate = State cs newpos user - in seq newpos $ seq newstate $ - (Ok s newstate (newErrorUnknown newpos)) - - errEof = Error (setErrorMessage (Expect (shows s)) - (newErrorMessage (SysUnExpect "") pos)) - errExpect r = Error $ setErrorMessage (Expect (shows s)) - $ newErrorMessage (SysUnExpect $ shows $ reverse r) pos - - walk _ [] cs = ok cs - walk r xs [] = errExpect r - walk r (x:xs) (c:cs)| x == c = walk (x : r) xs cs - | otherwise = errExpect $ c : r - - walk1 [] cs = Empty (ok cs) - walk1 xs [] = Empty (errEof) - walk1 (x:xs) (c:cs)| x == c = Consumed (walk [x] xs cs) - | otherwise = Empty (errExpect [c] ) +tokens :: Eq tok => ([tok] -> String) -> (SourcePos -> [tok] -> SourcePos) + -> [tok] -> GenParser tok st [tok] +tokens shws nextposs s = Parser $ \ (State input pos user) -> let + ok cs = let + newpos = nextposs pos s + newstate = State cs newpos user + in seq newpos . seq newstate . Ok s newstate $ newErrorUnknown newpos + errMsg m = Error . setErrorMessage (Expect (shws s)) $ newErrorMessage + (SysUnExpect m) pos + errEof = errMsg "" + errExpect = errMsg . shws . reverse + walk r xs cs = case xs of + [] -> ok cs + x : rs -> case cs of + [] -> errExpect r + c : ss -> if x == c then walk (x : r) rs ss else errExpect $ c : r - in walk1 s input) + walk1 xs cs = case xs of + [] -> Empty $ ok cs + x : rs -> case cs of + [] -> Empty errEof + c : ss -> + if x == c then Consumed $ walk [x] rs ss else Empty $ errExpect [c] + in walk1 s input diff --git a/parsec1.cabal b/parsec1.cabal --- a/parsec1.cabal +++ b/parsec1.cabal @@ -1,5 +1,5 @@ name: parsec1 -version: 1.0.0.7 +version: 1.0.0.8 license: BSD3 license-file: LICENSE maintainer: chr.maeder@web.de @@ -13,13 +13,15 @@ This package is the core haskell98 part of the parsec2 package as originally created by Daan Leijen. It is intended to preserve its simplicity and portability. - . - This version differs from the pervious one only by a MonadFail - instance to let it compile with ghc-8.8. build-type: Simple -cabal-version: >= 1.6 -library { +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/cmaeder/parsec1 + +library exposed-modules: Text.ParserCombinators.Parsec.Error, Text.ParserCombinators.Parsec.Char, @@ -27,5 +29,6 @@ Text.ParserCombinators.Parsec.Pos, Text.ParserCombinators.Parsec.Prim, Text.ParserCombinators.Parsec - build-depends: base >= 4.9 && < 5 -} + build-depends: base < 5 + other-extensions: CPP + default-language: Haskell98