1 -----------------------------------------------------------------------------
3 -- Module : Text.ParserCombinators.Parsec.Prim
4 -- Copyright : (c) Daan Leijen 1999-2001
5 -- License : BSD-style (see the file libraries/base/LICENSE)
7 -- Maintainer : daan@cs.uu.nl
8 -- Stability : provisional
9 -- Portability : portable
11 -- The primitive parser combinators.
13 -----------------------------------------------------------------------------
15 module Text.ParserCombinators.Parsec.Prim
16 ( -- operators: label a parser, alternative
21 , runParser, parse, parseFromFile, parseTest
24 -- instance Functor Parser : fmap
25 -- instance Monad Parser : return, >>=, fail
26 -- instance MonadPlus Parser : mzero (pzero), mplus (<|>)
27 , token, tokens, tokenPrim
28 , try, label, labels, unexpected, pzero
30 -- primitive because of space behaviour
33 -- user state manipulation
34 , getState, setState, updateState
37 , getPosition, setPosition
39 , getParserState, setParserState
42 import Text.ParserCombinators.Parsec.Pos
43 import Text.ParserCombinators.Parsec.Error
46 {-# INLINE parsecMap #-}
47 {-# INLINE parsecReturn #-}
48 {-# INLINE parsecBind #-}
49 {-# INLINE parsecZero #-}
50 {-# INLINE parsecPlus #-}
52 {-# INLINE tokenPrim #-}
54 -----------------------------------------------------------
56 -- <?> gives a name to a parser (which is used in error messages)
57 -- <|> is the choice operator
58 -----------------------------------------------------------
62 (<?>) :: GenParser tok st a -> String -> GenParser tok st a
63 p <?> msg = label p msg
65 (<|>) :: GenParser tok st a -> GenParser tok st a -> GenParser tok st a
66 p1 <|> p2 = mplus p1 p2
69 -----------------------------------------------------------
70 -- User state combinators
71 -----------------------------------------------------------
72 getState :: GenParser tok st st
73 getState = do{ state <- getParserState
74 ; return (stateUser state)
77 setState :: st -> GenParser tok st ()
78 setState st = do{ updateParserState (\(State input pos _) -> State input pos st)
82 updateState :: (st -> st) -> GenParser tok st ()
83 updateState f = do{ updateParserState (\(State input pos user) -> State input pos (f user))
88 -----------------------------------------------------------
89 -- Parser state combinators
90 -----------------------------------------------------------
91 getPosition :: GenParser tok st SourcePos
92 getPosition = do{ state <- getParserState; return (statePos state) }
94 getInput :: GenParser tok st [tok]
95 getInput = do{ state <- getParserState; return (stateInput state) }
98 setPosition :: SourcePos -> GenParser tok st ()
99 setPosition pos = do{ updateParserState (\(State input _ user) -> State input pos user)
103 setInput :: [tok] -> GenParser tok st ()
104 setInput input = do{ updateParserState (\(State _ pos user) -> State input pos user)
108 getParserState = updateParserState id
109 setParserState st = updateParserState (const st)
114 -----------------------------------------------------------
115 -- Parser definition.
116 -- GenParser tok st a:
117 -- General parser for tokens of type "tok",
118 -- a user state "st" and a result type "a"
119 -----------------------------------------------------------
120 type Parser a = GenParser Char () a
122 newtype GenParser tok st a = Parser (State tok st -> Consumed (Reply tok st a))
125 data Consumed a = Consumed a --input is consumed
126 | Empty !a --no input is consumed
128 data Reply tok st a = Ok a (State tok st) ParseError --parsing succeeded with "a"
129 | Error ParseError --parsing failed
131 data State tok st = State { stateInput :: [tok]
132 , statePos :: SourcePos
137 -----------------------------------------------------------
139 -----------------------------------------------------------
140 parseFromFile :: Parser a -> SourceName -> IO (Either ParseError a)
141 parseFromFile p fname
142 = do{ input <- readFile fname
143 ; return (parse p fname input)
146 parseTest :: Show a => GenParser tok () a -> [tok] -> IO ()
148 = case (runParser p () "" input) of
149 Left err -> do{ putStr "parse error at "
156 = runParser p () name input
159 runParser :: GenParser tok st a -> st -> SourceName -> [tok] -> Either ParseError a
160 runParser p st name input
161 = case parserReply (runP p (State input (initialPos name) st)) of
163 Error err -> Left err
167 Consumed reply -> reply
171 -----------------------------------------------------------
173 -----------------------------------------------------------
174 instance Functor (GenParser tok st) where
175 fmap f p = parsecMap f p
177 parsecMap :: (a -> b) -> GenParser tok st a -> GenParser tok st b
178 parsecMap f (Parser p)
181 Consumed reply -> Consumed (mapReply reply)
182 Empty reply -> Empty (mapReply reply)
187 Ok x state err -> let fx = f x
188 in seq fx (Ok fx state err)
189 Error err -> Error err
192 -----------------------------------------------------------
193 -- Monad: return, sequence (>>=) and fail
194 -----------------------------------------------------------
195 instance Monad (GenParser tok st) where
196 return x = parsecReturn x
197 p >>= f = parsecBind p f
198 fail msg = parsecFail msg
200 parsecReturn :: a -> GenParser tok st a
202 = Parser (\state -> Empty (Ok x state (unknownError state)))
204 parsecBind :: GenParser tok st a -> (a -> GenParser tok st b) -> GenParser tok st b
205 parsecBind (Parser p) f
211 Ok x state1 err1 -> case runP (f x) state1 of
212 Empty reply2 -> mergeErrorReply err1 reply2
213 Consumed reply2 -> reply2
214 Error err1 -> Error err1
218 Ok x state1 err1 -> case runP (f x) state1 of
219 Empty reply2 -> Empty (mergeErrorReply err1 reply2)
221 Error err1 -> Empty (Error err1)
224 mergeErrorReply err1 reply
226 Ok x state err2 -> Ok x state (mergeError err1 err2)
227 Error err2 -> Error (mergeError err1 err2)
230 parsecFail :: String -> GenParser tok st a
233 Empty (Error (newErrorMessage (Message msg) (statePos state))))
236 -----------------------------------------------------------
237 -- MonadPlus: alternative (mplus) and mzero
238 -----------------------------------------------------------
239 instance MonadPlus (GenParser tok st) where
241 mplus p1 p2 = parsecPlus p1 p2
244 pzero :: GenParser tok st a
247 parsecZero :: GenParser tok st a
249 = Parser (\state -> Empty (Error (unknownError state)))
251 parsecPlus :: GenParser tok st a -> GenParser tok st a -> GenParser tok st a
252 parsecPlus (Parser p1) (Parser p2)
255 Empty (Error err) -> case (p2 state) of
256 Empty reply -> Empty (mergeErrorReply err reply)
263 -- variant that favors a consumed reply over an empty one, even it is not the first alternative.
264 empty@(Empty reply) -> case reply of
267 Empty reply -> Empty (mergeErrorReply err reply)
277 -----------------------------------------------------------
278 -- Primitive Parsers:
279 -- try, token(Prim), label, unexpected and updateState
280 -----------------------------------------------------------
281 try :: GenParser tok st a -> GenParser tok st a
283 = Parser (\state@(State input pos user) ->
285 Consumed (Error err) -> Empty (Error (setErrorPos pos err))
286 Consumed ok -> Consumed ok -- was: Empty ok
291 token :: (tok -> String) -> (tok -> SourcePos) -> (tok -> Maybe a) -> GenParser tok st a
292 token show tokpos test
293 = tokenPrim show nextpos test
295 nextpos _ _ (tok:toks) = tokpos tok
296 nextpos _ tok [] = tokpos tok
298 tokenPrim :: (tok -> String) -> (SourcePos -> tok -> [tok] -> SourcePos) -> (tok -> Maybe a) -> GenParser tok st a
299 tokenPrim show nextpos test
300 = Parser (\state@(State input pos user) ->
302 (c:cs) -> case test c of
303 Just x -> let newpos = nextpos pos c cs
304 newstate = State cs newpos user
305 in seq newpos $ seq newstate $
306 Consumed (Ok x newstate (newErrorUnknown newpos))
307 Nothing -> Empty (sysUnExpectError (show c) pos)
308 [] -> Empty (sysUnExpectError "" pos)
312 label :: GenParser tok st a -> String -> GenParser tok st a
316 labels (Parser p) msgs
319 Empty reply -> Empty $
321 Error err -> Error (setExpectErrors err msgs)
322 Ok x state1 err | errorIsUnknown err -> reply
323 | otherwise -> Ok x state1 (setExpectErrors err msgs)
328 updateParserState :: (State tok st -> State tok st) -> GenParser tok st (State tok st)
330 = Parser (\state -> let newstate = f state
332 Empty (Ok state newstate (unknownError newstate)))
335 unexpected :: String -> GenParser tok st a
337 = Parser (\state -> Empty (Error (newErrorMessage (UnExpect msg) (statePos state))))
340 setExpectErrors err [] = setErrorMessage (Expect "") err
341 setExpectErrors err [msg] = setErrorMessage (Expect msg) err
342 setExpectErrors err (msg:msgs) = foldr (\msg err -> addErrorMessage (Expect msg) err)
343 (setErrorMessage (Expect msg) err) msgs
345 sysUnExpectError msg pos = Error (newErrorMessage (SysUnExpect msg) pos)
346 unknownError state = newErrorUnknown (statePos state)
348 -----------------------------------------------------------
349 -- Parsers unfolded for space:
350 -- if many and skipMany are not defined as primitives,
351 -- they will overflow the stack on large inputs
352 -----------------------------------------------------------
353 many :: GenParser tok st a -> GenParser tok st [a]
355 = do{ xs <- manyAccum (:) p
356 ; return (reverse xs)
359 skipMany :: GenParser tok st a -> GenParser tok st ()
361 = do{ manyAccum (\x xs -> []) p
365 manyAccum :: (a -> [a] -> [a]) -> GenParser tok st a -> GenParser tok st [a]
366 manyAccum accum (Parser p)
368 let walk xs state r = case r of
369 Empty (Error err) -> Ok xs state err
370 Empty ok -> error "Text.ParserCombinators.Parsec.Prim.many: combinator 'many' is applied to a parser that accepts an empty string."
371 Consumed (Error err) -> Error err
372 Consumed (Ok x state' err) -> let ys = accum x xs
373 in seq ys (walk ys state' (p state'))
375 Empty reply -> case reply of
376 Ok x state' err -> error "Text.ParserCombinators.Parsec.Prim.many: combinator 'many' is applied to a parser that accepts an empty string."
377 Error err -> Empty (Ok [] state err)
378 consumed -> Consumed $ walk [] state consumed)
382 -----------------------------------------------------------
383 -- Parsers unfolded for speed:
385 -----------------------------------------------------------
387 {- specification of @tokens@:
388 tokens showss nextposs s
392 scan (c:cs) = do{ token show nextpos c <?> shows s; scan cs }
395 nextpos pos c = nextposs pos [c]
398 tokens :: Eq tok => ([tok] -> String) -> (SourcePos -> [tok] -> SourcePos) -> [tok] -> GenParser tok st [tok]
399 tokens shows nextposs s
400 = Parser (\state@(State input pos user) ->
402 ok cs = let newpos = nextposs pos s
403 newstate = State cs newpos user
404 in seq newpos $ seq newstate $
405 (Ok s newstate (newErrorUnknown newpos))
407 errEof = Error (setErrorMessage (Expect (shows s))
408 (newErrorMessage (SysUnExpect "") pos))
409 errExpect c = Error (setErrorMessage (Expect (shows s))
410 (newErrorMessage (SysUnExpect (shows [c])) pos))
414 walk (x:xs) (c:cs)| x == c = walk xs cs
415 | otherwise = errExpect c
417 walk1 [] cs = Empty (ok cs)
418 walk1 xs [] = Empty (errEof)
419 walk1 (x:xs) (c:cs)| x == c = Consumed (walk xs cs)
420 | otherwise = Empty (errExpect c)