[Remove all the parser combinator stuff now living in -package polyparse. Malcolm.Wallace@cs.york.ac.uk**20070201162223 Also update the build system to depend on -package polyparse. ] { hunk ./HaXml.cabal 15 - Text.ParserCombinators.HuttonMeijer, - Text.ParserCombinators.HuttonMeijerWallace, - Text.ParserCombinators.Poly, - Text.ParserCombinators.PolyState, - Text.ParserCombinators.PolyLazy, - Text.ParserCombinators.PolyStateLazy, - Text.ParserCombinators.TextParser, hunk ./HaXml.cabal 44 -build-depends: base, haskell98 +build-depends: base, haskell98, polyparse hunk ./Makefile 8 - Text/XML/HaXml/Xtract Text/XML/HaXml/DtdToHaskell \ - Text/ParserCombinators + Text/XML/HaXml/Xtract Text/XML/HaXml/DtdToHaskell hunk ./Makefile 32 - src/Text/ParserCombinators/HuttonMeijer.hs \ - src/Text/ParserCombinators/HuttonMeijerWallace.hs \ - src/Text/ParserCombinators/Poly.hs \ - src/Text/ParserCombinators/PolyState.hs \ - src/Text/ParserCombinators/PolyLazy.hs \ - src/Text/ParserCombinators/PolyStateLazy.hs \ - src/Text/ParserCombinators/TextParser.hs hunk ./Makefile 103 - rm -rf $(SOFTWARE)-$(VERSION)/docs/CVS - rm -rf $(SOFTWARE)-$(VERSION)/examples/CVS - rm -rf $(SOFTWARE)-$(VERSION)/examples/SMIL/CVS - rm -rf $(SOFTWARE)-$(VERSION)/examples/OpenOffice.org/CVS hunk ./Makefile 111 - -rm -rf $(SOFTWARE)-$(VERSION)/docs/CVS - -rm -rf $(SOFTWARE)-$(VERSION)/examples/CVS - -rm -rf $(SOFTWARE)-$(VERSION)/examples/SMIL/CVS - -rm -rf $(SOFTWARE)-$(VERSION)/examples/OpenOffice.org/CVS hunk ./configure 103 - if [ "$GHCNUM" -lt "504" ] - then echo " Warning: HaXml needs ghc-5.04 or later. Ignoring ghc." + if [ "$GHCNUM" -lt "602" ] + then echo " Warning: HaXml needs ghc-6.2 or later. Ignoring ghc." hunk ./configure 135 - if [ "$GHC2NUM" -lt "504" ] - then echo " Warning: HaXml needs ghc-5.04 or later. Ignoring." + if [ "$GHC2NUM" -lt "602" ] + then echo " Warning: HaXml needs ghc-6.2 or later. Ignoring." hunk ./configure 282 - then rm -rf obj/ghc/Text/PrettyPrint - echo "-package base" >obj/ghc/ghcpkgs - else echo "-package lang -package data" >obj/ghc/ghcpkgs + then echo "-package base -package polyparse" >obj/ghc/ghcpkgs + else echo "-package lang -package data -package polyparse" >obj/ghc/ghcpkgs hunk ./configure 297 - echo "-package base" >obj/nhc98/nhc98pkgs + echo "-package base -package polyparse" >obj/nhc98/nhc98pkgs hunk ./docs/changelog.html 15 + +

Changes in 1.18

+

+

hunk ./docs/index.html 166 -To install HaXml, you must have a Haskell compiler: ghc-5.04 +To install HaXml, you must have a Haskell compiler: ghc-6.2 hunk ./docs/index.html 168 -Hugs98 (Sept 2003) or later. For more recent compilers, +Hugs98 (Sept 2003) or later. You must also first download and +install the polyparse +package as a pre-requisite. +

+Then, for more recent compilers, hunk ./docs/index.html 203 +

+Version 1.18 pulled out the parser combinator libraries as a separate +package (called polyparse), which must now be downloaded and installed +before installing HaXml. + hunk ./src/Makefile 23 - Text/ParserCombinators/HuttonMeijer.hs \ - Text/ParserCombinators/HuttonMeijerWallace.hs \ - Text/ParserCombinators/Poly.hs \ - Text/ParserCombinators/PolyState.hs \ - Text/ParserCombinators/PolyLazy.hs \ - Text/ParserCombinators/PolyStateLazy.hs \ - Text/ParserCombinators/TextParser.hs \ hunk ./src/Makefile 48 - -package-name HaXml-$(VERSION) -DVERSION=$(VERSION) + -package-name HaXml-$(VERSION) \ + -package polyparse -DVERSION=$(VERSION) hunk ./src/Makefile 55 - -DVERSION=$(VERSION) + -package polyparse -DVERSION=$(VERSION) hunk ./src/Makefile 97 - echo "depends: base, haskell98" >>$@ + echo "depends: base, haskell98, polyparse" >>$@ hunk ./src/Makefile.nhc98 25 - Text/ParserCombinators/HuttonMeijer.hs \ - Text/ParserCombinators/HuttonMeijerWallace.hs \ - Text/ParserCombinators/Poly.hs \ - Text/ParserCombinators/PolyState.hs \ - Text/ParserCombinators/PolyLazy.hs \ - Text/ParserCombinators/PolyStateLazy.hs \ - Text/ParserCombinators/TextParser.hs \ hunk ./src/Makefile.nhc98 32 - if [ -f Text/PrettyPrint/HughesPJ.hs ]; then mv Text/PrettyPrint/HughesPJ.hs Text/PrettyPrint/HughesPJ.hs.unused; fi hunk ./src/Text/ParserCombinators/HuttonMeijer.hs 1 ------------------------------------------------------------------------------ --- | --- 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 Char -import 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}) - ------------------------------------------------------------------------------- rmfile ./src/Text/ParserCombinators/HuttonMeijer.hs hunk ./src/Text/ParserCombinators/HuttonMeijerWallace.hs 1 -{----------------------------------------------------------------------------- - - 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 a State Transformer 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 Char -import 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)]) - ------------------------------------------------------------------------------- rmfile ./src/Text/ParserCombinators/HuttonMeijerWallace.hs hunk ./src/Text/ParserCombinators/Poly.hs 1 -module Text.ParserCombinators.Poly - ( -- * A Parser datatype parameterised on arbitrary token type - Parser(P) -- datatype, instance of: Functor, Monad - , runParser -- :: Parser t a -> [t] -> (Either String a, [t]) - , failBad -- :: String -> Parser t a - , commit -- :: Parser t a -> Parser t a - -- * Combinators - -- ** primitives - , next -- :: Parser t t - , satisfy -- :: (t->Bool) -> Parser t t - , apply -- :: Parser t (a->b) -> Parser t a -> Parser t b - , discard -- :: Parser t a -> Parser t b -> Parser t a - -- ** error-handling - , adjustErr -- :: Parser t a -> (String->String) -> Parser t a - , adjustErrBad-- :: Parser t a -> (String->String) -> Parser t a - , indent -- :: Int -> String -> String - -- ** choices - , onFail -- :: Parser t a -> Parser t a -> Parser t a - , oneOf -- :: Show t => [Parser t a] -> Parser t a - , oneOf' -- :: [(String,Parser t a)] -> Parser t a - , optional -- :: Parser t a -> Parser t (Maybe a) - -- ** sequences - , many -- :: Parser t a -> Parser t [a] - , many1 -- :: Parser t a -> Parser t [a] - , sepBy -- :: Parser t a -> Parser t sep -> Parser t [a] - , sepBy1 -- :: Parser t a -> Parser t sep -> Parser t [a] - , bracketSep -- :: Parser t bra -> Parser t sep -> Parser t ket - -- -> Parser t a -> Parser t [a] - , bracket -- :: Parser t bra -> Parser t ket -> Parser t a - -- -> Parser t a - , manyFinally -- :: Parser t a -> Parser t z -> Parser t [a] - -- ** re-parsing - , reparse -- :: [t] -> Parser t () - ) where - - --- | The @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 PolyState --- instead) -newtype Parser t a = P ([t] -> (EitherE String a, [t])) - --- A return type like Either, that distinguishes not only between --- right and wrong answers, but also had gradations of wrongness. -type EitherE a b = Either (Bool,a) b - --- | Apply a parser to an input token sequence. -runParser :: Parser t a -> [t] -> (Either String a, [t]) -runParser (P p) = - (\ (e,ts)-> (case e of {Left (_,m)->Left m; Right m->Right m}, ts) ) - . p - -instance Functor (Parser t) where - fmap f (P p) = P (\ts-> case p ts of - (Left msg, ts') -> (Left msg, ts') - (Right x, ts') -> (Right (f x), ts')) -instance Monad (Parser t) where - return x = P (\ts-> (Right x, ts)) - (P f) >>= g = P (\ts-> case f ts of - (Left msg, ts') -> (Left msg, ts') - (Right x, ts') -> let (P g') = g x in g' ts') - fail e = P (\ts-> (Left (False,e), ts)) - --- | When a simple fail is not strong enough, use failBad for emphasis. --- An emphasised (severe) error can propagate out through choice operators. -failBad :: String -> Parser t a -failBad msg = P (\ts-> (Left (True,msg), ts)) - --- | 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 :: Parser t a -> Parser t a -commit (P p) = P (\ts-> case p ts of - (Left (_,e), ts') -> (Left (True,e), ts') - right -> right ) - - --- Combinators - --- | One token -next :: Parser t t -next = P (\ts-> case ts of - [] -> (Left (False,"Ran out of input (EOF)"), []) - (t:ts') -> (Right t, ts') ) - --- | One token satifying a predicate -satisfy :: (t->Bool) -> Parser t t -satisfy p = do{ x <- next - ; if p x then return x else fail "Parse.satisfy: failed" - } - -infixl 3 `apply` --- | Apply a parsed function to a parsed value -apply :: Parser t (a->b) -> Parser t a -> Parser t b -pf `apply` px = do { f <- pf; x <- px; return (f x) } - -infixl 3 `discard` --- | @x `discard` y@ parses both x and y, but discards the result of y -discard :: Parser t a -> Parser t b -> Parser t a -px `discard` py = do { x <- px; _ <- py; return x } - --- | @p `adjustErr` f@ applies the transformation @f@ to any error message --- generated in @p@, having no effect if @p@ succeeds. -adjustErr :: Parser t a -> (String->String) -> Parser t a -(P p) `adjustErr` f = P (\ts-> case p ts of - (Left (b,msg), ts') -> (Left (b,(f msg)), ts') - right -> right ) - --- | @adjustErrBad@ is just like @adjustErr@ except it also raises the --- severity of the error. -adjustErrBad :: Parser t a -> (String->String) -> Parser t a -p `adjustErrBad` f = commit (p `adjustErr` f) - -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-> case p ts of - r@(Left (True,_), _) -> r - (Left _, _) -> q ts - right -> right ) - --- | Parse the first alternative in the list that succeeds. -oneOf :: [Parser t a] -> Parser t a -oneOf [] = do { n <- next - ; fail ("failed to parse any of the possible choices") - } ---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 - --- | 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, Parser t a)] -> Parser t a -oneOf' = accum [] - where accum errs [] = - case filter isBad errs of - [] -> fail ("failed to parse any of the possible choices:\n" - ++indent 2 (concatMap showErr (reverse errs))) - [(_,(_,e))] -> failBad e - es -> failBad ("one of the following failures occurred:\n" - ++indent 2 (concatMap showErr (reverse es))) - accum errs ((e,P p):ps) = - P (\ts-> case p ts of - (Left err,_) -> let (P p) = accum ((e,err):errs) ps - in p ts - right -> right ) - showErr (name,(_,err)) = name++":\n"++indent 2 err - isBad (_,(b,_)) = b - --- | Helper for formatting error messages: indents all lines by a fixed amount. -indent :: Int -> String -> String -indent n = unlines . map (replicate n ' ' ++) . lines - --- | 'optional' indicates whether the parser succeeded through the Maybe type. -optional :: Parser t a -> Parser t (Maybe a) -optional p = fmap Just p `onFail` return Nothing - --- | 'many p' parses a list of elements with individual parser p. --- Cannot fail, since an empty list is a valid return value. -many :: Parser t a -> Parser t [a] -many p = many1 p `onFail` return [] - --- | Parse a non-empty list of items. -many1 :: Parser t a -> Parser t [a] -many1 p = do { x <- p `adjustErr` (("In a sequence:\n"++). indent 2) - ; xs <- many p - ; return (x:xs) - } --- `adjustErr` ("When looking for a non-empty sequence:\n\t"++) - --- | Parse a list of items separated by discarded junk. -sepBy :: Parser t a -> Parser t sep -> Parser t [a] -sepBy p sep = do sepBy1 p sep `onFail` return [] - --- | Parse a non-empty list of items separated by discarded junk. -sepBy1 :: Parser t a -> Parser t sep -> Parser t [a] -sepBy1 p sep = do { x <- p - ; xs <- many (do {sep; p}) - ; return (x:xs) - } - `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 :: Parser t bra -> Parser t sep -> Parser t ket - -> Parser t a -> Parser t [a] -bracketSep open sep close p = - do { open; close; return [] } - `onFail` - do { open `adjustErr` ("Missing opening bracket:\n\t"++) - ; x <- p `adjustErr` ("After first bracket in a group:\n\t"++) - ; xs <- many (do {sep; p}) - ; close `adjustErrBad` ("When looking for closing bracket:\n\t"++) - ; return (x:xs) - } - --- | Parse a bracketed item, discarding the brackets. -bracket :: Parser t bra -> Parser t ket -> Parser t a -> Parser t a -bracket open close p = do - do { open `adjustErr` ("Missing opening bracket:\n\t"++) - ; x <- p - ; close `adjustErrBad` ("Missing closing bracket:\n\t"++) - ; return x - } - --- | 'manyFinally e t' parses a possibly-empty sequence of e's, --- terminated by a t. Any parse failures could be due either to --- a badly-formed terminator or a badly-formed element, so raise --- both possible errors. -manyFinally :: Parser t a -> Parser t z -> Parser t [a] -manyFinally p t = - do { xs <- many p - ; oneOf' [ ("sequence terminator", do { t; return () } ) - , ("item in a sequence", do { p; return () } ) - ] - ; return xs - } - ------------------------------------------------------------------------- --- | 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-> (Right (), ts++inp)) - ------------------------------------------------------------------------- rmfile ./src/Text/ParserCombinators/Poly.hs hunk ./src/Text/ParserCombinators/PolyLazy.hs 1 -module Text.ParserCombinators.PolyLazy - ( -- * A Parser datatype parameterised on arbitrary token type. - -- Parsers do not return explicit failure. An exception is - -- raised instead. This allows partial results to be returned - -- before a full parse is complete. - Parser(P) -- datatype, instance of: Functor, Monad - , runParser -- :: Parser t a -> [t] -> (a, [t]) - , failBad -- :: String -> Parser t a - , commit -- :: Parser t a -> Parser t a - -- * Combinators - -- ** primitives - , next -- :: Parser t t - , satisfy -- :: (t->Bool) -> Parser t t - , apply -- :: Parser t (a->b) -> Parser t a -> Parser t b - , discard -- :: Parser t a -> Parser t b -> Parser t a - -- ** error-handling - , adjustErr -- :: Parser t a -> (String->String) -> Parser t a - , adjustErrBad-- :: Parser t a -> (String->String) -> Parser t a - , indent -- :: Int -> String -> String - -- ** choices - , onFail -- :: Parser t a -> Parser t a -> Parser t a - , oneOf -- :: Show t => [Parser t a] -> Parser t a - , oneOf' -- :: [(String,Parser t a)] -> Parser t a - , optional -- :: Parser t a -> Parser t (Maybe a) - -- ** sequences - , many -- :: Parser t a -> Parser t [a] - , many1 -- :: Parser t a -> Parser t [a] - , sepBy -- :: Parser t a -> Parser t sep -> Parser t [a] - , sepBy1 -- :: Parser t a -> Parser t sep -> Parser t [a] - , bracketSep -- :: Parser t bra -> Parser t sep -> Parser t ket - -- -> Parser t a -> Parser t [a] - , bracket -- :: Parser t bra -> Parser t ket -> Parser t a - -- -> Parser t a - , manyFinally -- :: Parser t a -> Parser t z -> Parser t [a] - -- ** re-parsing - , reparse -- :: [t] -> Parser t () - ) where - -#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 @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 PolyState --- instead.) -newtype Parser t a = P ([t] -> (Either String a, [t])) - --- A return type like Either, that distinguishes not only between --- right and wrong answers, but also had gradations of wrongness. --- Not used in this library. !!!!!!!!!!!!!!!!!!!!!!!!!!! -type EitherE a b = Either (Bool,a) b - --- | Apply a parser to an input token sequence. The parser cannot return --- an error value explicitly, so errors raise an exception. Thus, results --- can be partial (lazily constructed, but containing undefined). -runParser :: Parser t a -> [t] -> (a, [t]) -runParser (P p) = - (\ (e,ts)-> (case e of {Left m->throwE m; Right x->x}, ts) ) - . p - -instance Functor (Parser t) where - fmap f (P p) = P (\ts-> case p ts of - (Left msg, ts') -> (Left msg, ts') - (Right x, ts') -> (Right (f x), ts')) -instance Monad (Parser t) where - return x = P (\ts-> (Right x, ts)) - (P f) >>= g = P (\ts-> case f ts of - (Left msg, ts') -> (Left msg, ts') - (Right x, ts') -> let (P g') = g x in g' ts') - fail e = P (\ts-> (Left e, ts)) - --- | Simple failure can be corrected, but when a simple fail is not strong --- enough, use failBad for emphasis. It guarantees parsing will --- terminate with an exception. - -failBad :: String -> Parser t a -failBad msg = P (\ts-> (throwE msg, ts)) - --- | 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 :: Parser t a -> Parser t a -commit (P p) = P (\ts-> case p ts of - (Left e, ts') -> (throwE e, ts') - right -> right ) - - --- Combinators - --- | One token -next :: Parser t t -next = P (\ts-> case ts of - [] -> (Left "Ran out of input (EOF)", []) - (t:ts') -> (Right t, ts') ) - --- | One token satifying a predicate -satisfy :: (t->Bool) -> Parser t t -satisfy p = do{ x <- next - ; if p x then return x else fail "Parse.satisfy: failed" - } - -infixl 3 `apply` --- | Apply a parsed function to a parsed value -apply :: Parser t (a->b) -> Parser t a -> Parser t b ---pf `apply` px = do { f <- pf; x <- px; return (f x) } --- Needs to be lazier! Must not force the argument value too early. -(P pf) `apply` (P px) = P (\ts-> - case pf ts of - (Left msg, ts') -> (Left msg, ts') - (Right f, ts') -> let (x',ts'') = px ts' - x = case x' of { Right x -> x; Left e -> throwE e } - in (Right (f x), ts'') ) - -infixl 3 `discard` --- | @x `discard` y@ parses both x and y, but discards the result of y -discard :: Parser t a -> Parser t b -> Parser t a -px `discard` py = do { x <- px; _ <- py; return x } - --- | @p `adjustErr` f@ applies the transformation @f@ to any error message --- generated in @p@, having no effect if @p@ succeeds. -adjustErr :: Parser t a -> (String->String) -> Parser t a -(P p) `adjustErr` f = P (\ts-> case p ts of - (Left msg, ts') -> (Left (f msg), ts') - right -> right ) - --- | @adjustErrBad@ is just like @adjustErr@ except it also raises the --- severity of the error. -adjustErrBad :: Parser t a -> (String->String) -> Parser t a -p `adjustErrBad` f = commit (p `adjustErr` f) - -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-> case p ts of - (Left _, _) -> q ts - right -> right ) - --- | Parse the first alternative in the list that succeeds. -oneOf :: [Parser t a] -> Parser t a -oneOf [] = do { n <- next - ; fail ("failed to parse any of the possible choices") - } ---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 - --- | 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, Parser t a)] -> Parser t a -oneOf' ps = accum [] ps - where accum errs [] = - case errs of - [] -> failBad ("internal failure in parser (oneOf'):\n" - ++indent 2 (show (map fst ps))) - [(_,e)] -> fail e - es -> fail ("one of the following failures occurred:\n" - ++indent 2 (concatMap showErr (reverse es))) - accum errs ((e,P p):ps) = - P (\ts-> case p ts of - (Left err,_) -> let (P p) = accum ((e,err):errs) ps - in p ts - right -> right ) - showErr (name,err) = name++":\n"++indent 2 err - --- | Helper for formatting error messages: indents all lines by a fixed amount. -indent :: Int -> String -> String -indent n = unlines . map (replicate n ' ' ++) . lines - --- | 'optional' indicates whether the parser succeeded through the Maybe type. -optional :: Parser t a -> Parser t (Maybe a) -optional p = fmap Just p `onFail` return Nothing - --- | 'many p' parses a list of elements with individual parser p. --- Cannot fail, since an empty list is a valid return value. -many :: Parser t a -> Parser t [a] -many p = many1 p `onFail` return [] - --- | Parse a non-empty list of items. -many1 :: Parser t a -> Parser t [a] -many1 p = do { x <- p `adjustErr` (("In a sequence:\n"++). indent 2) - ; xs <- many p - ; return (x:xs) - } --- `adjustErr` ("When looking for a non-empty sequence:\n\t"++) - --- | Parse a list of items separated by discarded junk. -sepBy :: Parser t a -> Parser t sep -> Parser t [a] -sepBy p sep = do sepBy1 p sep `onFail` return [] - --- | Parse a non-empty list of items separated by discarded junk. -sepBy1 :: Parser t a -> Parser t sep -> Parser t [a] -sepBy1 p sep = do { x <- p - ; xs <- many (do {sep; p}) - ; return (x:xs) - } - `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 :: Parser t bra -> Parser t sep -> Parser t ket - -> Parser t a -> Parser t [a] -bracketSep open sep close p = - do { open; close; return [] } - `onFail` - do { open `adjustErr` ("Missing opening bracket:\n\t"++) - ; x <- p `adjustErr` ("After first bracket in a group:\n\t"++) - ; xs <- many (do {sep; p}) - ; close `adjustErrBad` ("When looking for closing bracket:\n\t"++) - ; return (x:xs) - } - --- | Parse a bracketed item, discarding the brackets. -bracket :: Parser t bra -> Parser t ket -> Parser t a -> Parser t a -bracket open close p = do - do { open `adjustErr` ("Missing opening bracket:\n\t"++) - ; x <- p - ; close `adjustErrBad` ("Missing closing bracket:\n\t"++) - ; return x - } - --- | 'manyFinally e t' parses a possibly-empty sequence of e's, --- terminated by a t. Any parse failures could be due either to --- a badly-formed terminator or a badly-formed element, so raise --- both possible errors. -manyFinally :: Parser t a -> Parser t z -> Parser t [a] -manyFinally pp@(P p) pt@(P t) = P (\ts -> - case p ts of - (Left e, _) -> - case t ts of - (Right _, ts') -> (Right [], ts') - (Left e, ts') -> (Left e, ts') - (Right x, ts') -> - let (tail,ts'') = runParser (manyFinally pp pt) ts' - in (Right (x:tail), ts'') ) - ------------------------------------------------------------------------- --- | 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-> (Right (), ts++inp)) - ------------------------------------------------------------------------- rmfile ./src/Text/ParserCombinators/PolyLazy.hs hunk ./src/Text/ParserCombinators/PolyState.hs 1 -module Text.ParserCombinators.PolyState - ( -- * A Parser datatype parameterised on arbitrary token type and state type - Parser(P) -- datatype, instance of: Functor, Monad - , runParser -- :: Parser s t a -> s -> [t] -> (Either String a, s, [t]) - , failBad -- :: String -> Parser s t a - , commit -- :: Parser s t a -> Parser s t a - -- * Combinators - -- ** primitives - , next -- :: Parser s t t - , satisfy -- :: (t->Bool) -> Parser s t t - , apply -- :: Parser t (a->b) -> Parser s t a -> Parser s t b - , discard -- :: Parser s t a -> Parser s t b -> Parser s t a - -- ** error-handling - , adjustErr -- :: Parser s t a -> (String->String) -> Parser s t a - , adjustErrBad-- :: Parser s t a -> (String->String) -> Parser s t a - , indent -- :: Int -> String -> String - -- ** choices - , onFail -- :: Parser s t a -> Parser s t a -> Parser s t a - , oneOf -- :: [Parser s t a] -> Parser s t a - , oneOf' -- :: [(String, Parser s t a)] -> Parser s t a - -- ** sequences - , many -- :: Parser s t a -> Parser s t [a] - , many1 -- :: Parser s t a -> Parser s t [a] - , sepBy -- :: Parser s t a -> Parser s t sep -> Parser s t [a] - , sepBy1 -- :: Parser s t a -> Parser s t sep -> Parser s t [a] - , bracketSep -- :: Parser s t bra -> Parser s t sep -> Parser s t ket - -- -> Parser s t a -> Parser s t [a] - , bracket -- :: Parser s t bra -> Parser s t ket -> 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 () - ) where - --- | The @Parser@ datatype is a fairly generic parsing monad with error --- reporting and a running state. It can be used for arbitrary token --- types, not just String input. -newtype Parser s t a = P (s -> [t] -> (EitherE String a, s, [t])) - --- | A return type like Either, that distinguishes not only between --- right and wrong answers, but also had gradations of wrongness. -type EitherE a b = Either (Bool,a) b - --- | Apply a parser to an initial state and input token sequence. -runParser :: Parser s t a -> s -> [t] -> (Either String a, s, [t]) -runParser (P p) s = - (\ (e,s,ts)-> (case e of Left (_,m)->Left m; Right m->Right m - ,s,ts)) - . p s - -instance Functor (Parser s t) where - fmap f (P p) = P (\s ts-> case p s ts of - (Left msg, s', ts') -> (Left msg, s', ts') - (Right x, s', ts') -> (Right (f x), s', ts')) -instance Monad (Parser s t) where - return x = P (\s ts-> (Right x, s, ts)) - (P f) >>= g = P (\s ts-> case f s ts of - (Left msg, s', ts') -> (Left msg, s', ts') - (Right x, s', ts') -> let (P g') = g x - in g' s' ts') - fail msg = P (\s ts-> (Left (False,msg), s, ts)) - --- | When a simple fail is not strong enough, use failBad for emphasis. --- An emphasised (severe) error can propagate out through choice operators. -failBad :: String -> Parser s t a -failBad msg = P (\s ts-> (Left (True,msg), s, ts)) - --- | 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 :: Parser s t a -> Parser s t a -commit (P p) = P (\s ts-> case p s ts of - (Left (_,e), s', ts') -> (Left (True,e), s', ts') - right -> right ) - --- Combinators - --- | One token -next :: Parser s t t -next = P (\s ts-> case ts of - [] -> (Left (False,"Ran out of input (EOF)"), s, []) - (t:ts') -> (Right t, s, ts') ) - --- | One token satifying a predicate -satisfy :: (t->Bool) -> Parser s t t -satisfy p = do{ x <- next - ; if p x then return x else fail "Parse.satisfy: failed" - } - -infixl 3 `apply` --- | Apply a parsed function to a parsed value -apply :: Parser s t (a->b) -> Parser s t a -> Parser s t b -pf `apply` px = do { f <- pf; x <- px; return (f x) } - -infixl 3 `discard` --- | @x `discard` y@ parses both x and y, but discards the result of y -discard :: Parser s t a -> Parser s t b -> Parser s t a -px `discard` py = do { x <- px; _ <- py; return x } - --- | @p `adjustErr` f@ applies the transformation @f@ to any error message --- generated in @p@, having no effect if @p@ succeeds. -adjustErr :: Parser s t a -> (String->String) -> Parser s t a -(P p) `adjustErr` f = - P (\s ts-> case p s ts of - (Left (b,msg), s', ts') -> (Left (b,(f msg)), s, ts') - right -> right ) - --- | @adjustErrBad@ is just like @adjustErr@ except it also raises the --- severity of the error. -adjustErrBad :: Parser s t a -> (String->String) -> Parser s t a --- p `adjustErrBad` f = commit (p `adjustErr` f) -(P p) `adjustErrBad` f = - P (\s ts-> case p s ts of - (Left (_,msg), s', ts') -> (Left (True,(f msg)), s, ts') - right -> right ) - -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-> case p s ts of - r@(Left (True,_), _, _) -> r - (Left _, _, _) -> q s ts - right -> right ) - --- | Parse the first alternative in the list that succeeds. -oneOf :: [Parser s t a] -> Parser s t a -oneOf [] = fail ("Failed to parse any of the possible choices") -oneOf (p:ps) = p `onFail` oneOf ps - --- | 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, Parser s t a)] -> Parser s t a -oneOf' = accum [] - where accum errs [] = - case filter isBad errs of - [] -> fail ("failed to parse any of the possible choices:\n" - ++indent 2 (concatMap showErr (reverse errs))) - [(_,(_,e))] -> failBad e - es -> failBad ("one of the following failures occurred:\n" - ++indent 2 (concatMap showErr (reverse es))) - accum errs ((e,P p):ps) = - P (\u ts-> case p u ts of - (Left err,_,_) -> let (P p) = accum ((e,err):errs) ps - in p u ts - right -> right ) - showErr (name,(_,err)) = name++":\n"++indent 2 err - isBad (_,(b,_)) = b - --- | Helper for formatting error messages: indents all lines by a fixed amount. -indent :: Int -> String -> String -indent n = unlines . map (replicate n ' ' ++) . lines - --- | 'many p' parses a list of elements with individual parser p. --- Cannot fail, since an empty list is a valid return value. -many :: Parser s t a -> Parser s t [a] -many p = many1 p `onFail` return [] - --- | Parse a non-empty list of items. -many1 :: Parser s t a -> Parser s t [a] -many1 p = do { x <- p `adjustErr` (("In a sequence:\n"++). indent 2) - ; xs <- many p - ; return (x:xs) - } --- `adjustErr` ("When looking for a non-empty sequence:\n"++) - --- | Parse a list of items separated by discarded junk. -sepBy :: Parser s t a -> Parser s t sep -> Parser s t [a] -sepBy p sep = do sepBy1 p sep `onFail` return [] - --- | Parse a non-empty list of items separated by discarded junk. -sepBy1 :: Parser s t a -> Parser s t sep -> Parser s t [a] -sepBy1 p sep = do { x <- p - ; xs <- many (do {sep; p}) - ; return (x:xs) - } - `adjustErr` ("When looking for a non-empty sequence with separators:\n"++) - --- | Parse a list of items, discarding the start, end, and separator --- items. -bracketSep :: Parser s t bra -> Parser s t sep -> Parser s t ket - -> Parser s t a -> Parser s t [a] -bracketSep open sep close p = - do { open; close; return [] } - `onFail` - do { open `adjustErr` ("Missing opening bracket:\n"++) - ; x <- p `adjustErr` ("After first bracket in a group:\n"++) - ; xs <- many (do {sep; p}) - ; close `adjustErrBad` ("When looking for closing bracket:\n"++) - ; return (x:xs) - } - --- | Parse a bracketed item, discarding the brackets. -bracket :: Parser s t bra -> Parser s t ket -> Parser s t a -> Parser s t a -bracket open close p = do - do { open `adjustErr` ("Missing opening bracket:\n"++) - ; x <- p - ; close `adjustErrBad` ("Missing closing bracket:\n"++) - ; return x - } - --- | 'manyFinally e t' parses a possibly-empty sequence of e's, --- terminated by a t. Any parse failures could be due either to --- a badly-formed terminator or a badly-formed element, so raise --- both possible errors. -manyFinally :: Parser s t a -> Parser s t z -> Parser s t [a] -manyFinally p t = - do { xs <- many p - ; oneOf' [ ("sequence terminator", do { t; return () } ) - , ("item in a sequence", do { p; return () } ) - ] - ; return xs - } - ------------------------------------------------------------------------- --- State handling - --- | Update the internal state. -stUpdate :: (s->s) -> Parser s t () -stUpdate f = P (\s ts-> (Right (), f s, ts)) - --- | Query the internal state. -stQuery :: (s->a) -> Parser s t a -stQuery f = P (\s ts-> (Right (f s), s, ts)) - --- | Deliver the entire internal state. -stGet :: Parser s t s -stGet = P (\s ts-> (Right s, s, ts)) - ------------------------------------------------------------------------- --- | 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-> (Right (), s, ts++inp)) - ------------------------------------------------------------------------- rmfile ./src/Text/ParserCombinators/PolyState.hs hunk ./src/Text/ParserCombinators/PolyStateLazy.hs 1 -module Text.ParserCombinators.PolyStateLazy - ( -- * A Parser datatype parameterised on arbitrary token type and state type. - -- Parsers do not return explicit failure. An exception is raised - -- instead. This allows partial results to be returned before a - -- full parse is complete. - Parser(P) -- datatype, instance of: Functor, Monad - , runParser -- :: Parser s t a -> s -> [t] -> (a, s, [t]) - , failBad -- :: String -> Parser s t a - , commit -- :: Parser s t a -> Parser s t a - -- * Combinators - -- ** primitives - , next -- :: Parser s t t - , satisfy -- :: (t->Bool) -> Parser s t t - , apply -- :: Parser t (a->b) -> Parser s t a -> Parser s t b - , discard -- :: Parser s t a -> Parser s t b -> Parser s t a - -- ** error-handling - , adjustErr -- :: Parser s t a -> (String->String) -> Parser s t a - , adjustErrBad-- :: Parser s t a -> (String->String) -> Parser s t a - , indent -- :: Int -> String -> String - -- ** choices - , onFail -- :: Parser s t a -> Parser s t a -> Parser s t a - , oneOf -- :: [Parser s t a] -> Parser s t a - , oneOf' -- :: [(String, Parser s t a)] -> Parser s t a - , optional -- :: Parser s t a -> Parser s t (Maybe a) - -- ** sequences - , many -- :: Parser s t a -> Parser s t [a] - , many1 -- :: Parser s t a -> Parser s t [a] - , sepBy -- :: Parser s t a -> Parser s t sep -> Parser s t [a] - , sepBy1 -- :: Parser s t a -> Parser s t sep -> Parser s t [a] - , bracketSep -- :: Parser s t bra -> Parser s t sep -> Parser s t ket - -- -> Parser s t a -> Parser s t [a] - , bracket -- :: Parser s t bra -> Parser s t ket -> 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 () - ) where - -#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 @Parser@ datatype is a fairly generic parsing monad with error --- reporting and a running state. It can be used for arbitrary token --- types, not just String input. -newtype Parser s t a = P (s -> [t] -> (Either String a, s, [t])) - --- | A return type like Either, that distinguishes not only between --- right and wrong answers, but also had gradations of wrongness. --- Not used in this library. !!!!!!!!!!!!!!!!!!!!!!!!!! -type EitherE a b = Either (Bool,a) b - --- | Apply a parser to an initial state and input token sequence. --- The parser cannot return an error value explicitly, so errors --- raise an exception. Thus, results can be partial (lazily constructed, --- but containing undefined). -runParser :: Parser s t a -> s -> [t] -> (a, s, [t]) -runParser (P p) s = - (\ (e,s,ts)-> (case e of {Left m->throwE m; Right x->x}, s, ts)) - . p s - -instance Functor (Parser s t) where - fmap f (P p) = P (\s ts-> case p s ts of - (Left msg, s', ts') -> (Left msg, s', ts') - (Right x, s', ts') -> (Right (f x), s', ts')) -instance Monad (Parser s t) where - return x = P (\s ts-> (Right x, s, ts)) - (P f) >>= g = P (\s ts-> case f s ts of - (Left msg, s', ts') -> (Left msg, s', ts') - (Right x, s', ts') -> let (P g') = g x - in g' s' ts') - fail msg = P (\s ts-> (Left msg, s, ts)) - --- | Simple failure can be corrected, but when a simple fail is not strong --- enough, use failBad for emphasis. It guarantees parsing will terminate --- with an exception. -failBad :: String -> Parser s t a -failBad msg = P (\s ts-> (throwE msg, s, ts)) - --- | 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 :: Parser s t a -> Parser s t a -commit (P p) = P (\s ts-> case p s ts of - (Left e, s', ts') -> (throwE e, s', ts') - right -> right ) - --- Combinators - --- | One token -next :: Parser s t t -next = P (\s ts-> case ts of - [] -> (Left "Ran out of input (EOF)", s, []) - (t:ts') -> (Right t, s, ts') ) - --- | One token satifying a predicate -satisfy :: (t->Bool) -> Parser s t t -satisfy p = do{ x <- next - ; if p x then return x else fail "Parse.satisfy: failed" - } - -infixl 3 `apply` --- | Apply a parsed function to a parsed value -apply :: Parser s t (a->b) -> Parser s t a -> Parser s t b ---pf `apply` px = do { f <- pf; x <- px; return (f x) } --- Needs to be lazier! Must not force the argument value too early. -(P pf) `apply` (P px) = P (\s ts-> - case pf s ts of - (Left msg, s', ts') -> (Left msg, s', ts') - (Right f, s', ts') -> let (x',s'',ts'') = px s' ts' - x = case x' of - Right x -> x - Left e -> throwE e - in (Right (f x), s'', ts'')) - -infixl 3 `discard` --- | @x `discard` y@ parses both x and y, but discards the result of y -discard :: Parser s t a -> Parser s t b -> Parser s t a -px `discard` py = do { x <- px; _ <- py; return x } - --- | @p `adjustErr` f@ applies the transformation @f@ to any error message --- generated in @p@, having no effect if @p@ succeeds. -adjustErr :: Parser s t a -> (String->String) -> Parser s t a -(P p) `adjustErr` f = - P (\s ts-> case p s ts of - (Left msg, s', ts') -> (Left (f msg), s, ts') - right -> right ) - --- | @adjustErrBad@ is just like @adjustErr@ except it also raises the --- severity of the error. -adjustErrBad :: Parser s t a -> (String->String) -> Parser s t a --- p `adjustErrBad` f = commit (p `adjustErr` f) -(P p) `adjustErrBad` f = - P (\s ts-> case p s ts of - (Left msg, s', ts') -> (throwE (f msg), s, ts') - right -> right ) - -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-> case p s ts of - (Left _, _, _) -> q s ts - right -> right ) - --- | Parse the first alternative in the list that succeeds. -oneOf :: [Parser s t a] -> Parser s t a -oneOf [] = fail ("Failed to parse any of the possible choices") -oneOf (p:ps) = p `onFail` oneOf ps - --- | 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, Parser s t a)] -> Parser s t a -oneOf' ps = accum [] ps - where accum errs [] = - case errs of - [] -> failBad ("internal failure in parser (oneOf'):\n" - ++indent 2 (show (map fst ps))) - [(_,e)] -> fail e - es -> fail ("one of the following failures occurred:\n" - ++indent 2 (concatMap showErr (reverse es))) - accum errs ((e,P p):ps) = - P (\u ts-> case p u ts of - (Left err,_,_) -> let (P p) = accum ((e,err):errs) ps - in p u ts - right -> right ) - showErr (name,err) = name++":\n"++indent 2 err - --- | Helper for formatting error messages: indents all lines by a fixed amount. -indent :: Int -> String -> String -indent n = unlines . map (replicate n ' ' ++) . lines - --- | 'optional' indicates whether the parser succeeded through the Maybe type. -optional :: Parser s t a -> Parser s t (Maybe a) -optional p = fmap Just p `onFail` return Nothing - --- | 'many p' parses a list of elements with individual parser p. --- Cannot fail, since an empty list is a valid return value. -many :: Parser s t a -> Parser s t [a] -many p = many1 p `onFail` return [] - --- | Parse a non-empty list of items. -many1 :: Parser s t a -> Parser s t [a] -many1 p = do { x <- p `adjustErr` (("In a sequence:\n"++). indent 2) - ; xs <- many p - ; return (x:xs) - } --- `adjustErr` ("When looking for a non-empty sequence:\n"++) - --- | Parse a list of items separated by discarded junk. -sepBy :: Parser s t a -> Parser s t sep -> Parser s t [a] -sepBy p sep = do sepBy1 p sep `onFail` return [] - --- | Parse a non-empty list of items separated by discarded junk. -sepBy1 :: Parser s t a -> Parser s t sep -> Parser s t [a] -sepBy1 p sep = do { x <- p - ; xs <- many (do {sep; p}) - ; return (x:xs) - } - `adjustErr` ("When looking for a non-empty sequence with separators:\n"++) - --- | Parse a list of items, discarding the start, end, and separator --- items. -bracketSep :: Parser s t bra -> Parser s t sep -> Parser s t ket - -> Parser s t a -> Parser s t [a] -bracketSep open sep close p = - do { open; close; return [] } - `onFail` - do { open `adjustErr` ("Missing opening bracket:\n"++) - ; x <- p `adjustErr` ("After first bracket in a group:\n"++) - ; xs <- many (do {sep; p}) - ; close `adjustErrBad` ("When looking for closing bracket:\n"++) - ; return (x:xs) - } - --- | Parse a bracketed item, discarding the brackets. -bracket :: Parser s t bra -> Parser s t ket -> Parser s t a -> Parser s t a -bracket open close p = do - do { open `adjustErr` ("Missing opening bracket:\n"++) - ; x <- p - ; close `adjustErrBad` ("Missing closing bracket:\n"++) - ; return x - } - --- | 'manyFinally e t' parses a possibly-empty sequence of e's, --- terminated by a t. Any parse failures could be due either to --- a badly-formed terminator or a badly-formed element, so raise --- both possible errors. -manyFinally :: Parser s t a -> Parser s t z -> Parser s t [a] -manyFinally pp@(P p) pt@(P t) = P (\s ts -> - case p s ts of - (Left e, _, _) -> - case t s ts of - (Right _, s', ts') -> (Right [], s', ts') - (Left e, s', ts') -> (Left e, s', ts') - (Right x, s', ts') -> - let (tail,s'',ts'') = runParser (manyFinally pp pt) s' ts' - in (Right (x:tail), s'', ts'') ) - ------------------------------------------------------------------------- --- State handling - --- | Update the internal state. -stUpdate :: (s->s) -> Parser s t () -stUpdate f = P (\s ts-> (Right (), f s, ts)) - --- | Query the internal state. -stQuery :: (s->a) -> Parser s t a -stQuery f = P (\s ts-> (Right (f s), s, ts)) - --- | Deliver the entire internal state. -stGet :: Parser s t s -stGet = P (\s ts-> (Right s, s, ts)) - ------------------------------------------------------------------------- --- | 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-> (Right (), s, ts++inp)) - ------------------------------------------------------------------------- rmfile ./src/Text/ParserCombinators/PolyStateLazy.hs hunk ./src/Text/ParserCombinators/TextParser.hs 1 -module Text.ParserCombinators.TextParser - ( -- * The Parse class is a replacement for the Read class. It is a - -- specialisation of the (poly) Parser monad for String input. - 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 - -- ** Combinators specific to string input, lexed haskell-style - , word -- :: TextParser String - , isWord -- :: String -> TextParser () - , optionalParens -- :: TextParser a -> TextParser a - , field -- :: Parse a => String -> TextParser a - , constructors-- :: [(String,TextParser a)] -> TextParser a - , enumeration -- :: Show a => String -> [a] -> TextParser a - -- ** Re-export all the more general combinators too - , module Text.ParserCombinators.Poly - ) where - -import Char (isSpace) -import List (intersperse) -import Text.ParserCombinators.Poly - ------------------------------------------------------------------------- - --- | 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@. -class Parse a where - parse :: TextParser a - parseList :: TextParser [a] -- only to distinguish [] and "" - parseList = do { isWord "[]"; return [] } - `onFail` - do { isWord "["; isWord "]"; return [] } - `onFail` - bracketSep (isWord "[") (isWord ",") (isWord "]") 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. -parseByRead :: Read a => String -> TextParser a -parseByRead name = - P (\s-> case reads s of - [] -> (Left (False,"no parse, expected a "++name), s) - [(a,s')] -> (Right a, s') - _ -> (Left (False,"ambiguous parse, expected a "++name), s) - ) - --- | One lexical chunk (Haskell-style lexing). -word :: TextParser String -word = P (\s-> case lex s of - [] -> (Left (False,"no input? (impossible)"), s) - [("",s')] -> (Left (False,"no input?"), s') - ((x,s'):_) -> (Right x, s') ) - --- | Ensure that the next input word is a 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 true string parens around an item. -optionalParens :: TextParser a -> TextParser a -optionalParens p = bracket (isWord "(") (isWord ")") p `onFail` p - --- | Deal with named field syntax. -field :: Parse a => String -> TextParser a -field name = do { isWord name; commit $ do { isWord "="; parse } } - --- | Parse one of a bunch of alternative constructors. -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). -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. - --- Basic types -instance Parse Int where - parse = parseByRead "Int" -instance Parse Integer where - parse = parseByRead "Integer" -instance Parse Float where - parse = parseByRead "Float" -instance Parse Double where - parse = parseByRead "Double" -instance Parse Char where - parse = parseByRead "Char" - -- parseList = bracket (isWord "\"") (satisfy (=='"')) - -- (many (satisfy (/='"'))) - -- not totally correct for strings... - parseList = do { w <- word; if head w == '"' then return 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 [] = (Left (False,"no input: expected a ()"), []) - p ('(':cs) = case dropWhile isSpace cs of - (')':s) -> (Right (), s) - _ -> (Left (False,"Expected ) after ("), cs) - p (c:cs) | isSpace c = p cs - | otherwise = ( Left (False,"Expected a (), got "++show c) - , (c:cs)) - -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 - parse = do { isWord "Nothing"; return Nothing } - `onFail` - do { isWord "Just" - ; fmap Just $ optionalParens parse - `adjustErrBad` ("but within Just, "++) - } - `adjustErr` (("expected a Maybe (Just or Nothing)\n"++).indent 2) - -instance (Parse a, Parse b) => Parse (Either a b) where - parse = constructors [ ("Left", do { fmap Left $ optionalParens parse } ) - , ("Right", do { fmap Right $ optionalParens parse } ) - ] - -instance Parse a => Parse [a] where - parse = parseList - ------------------------------------------------------------------------- rmfile ./src/Text/ParserCombinators/TextParser.hs rmdir ./src/Text/ParserCombinators hunk ./src/hugs/exclude 1 -Text.PrettyPrint.HughesPJ rmfile ./src/hugs/exclude rmdir ./src/hugs hunk ./src/pkg.conf 11 - , package_deps = ["lang","data","base"] + , package_deps = ["base","polyparse"] }