-----------------------------------------------------------------------------
-- |
-- Module : Text.ParserCombinators.Parsec.Prim
-- Copyright : (c) Daan Leijen 1999-2001
-- License : BSD-style (see the file libraries/parsec/LICENSE)
--
-- Maintainer : daan@cs.uu.nl
-- 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, unexpected, pzero
-- primitive because of space behaviour
, many, skipMany
-- user state manipulation
, getState, setState, updateState
-- state manipulation
, getPosition, setPosition
, getInput, setInput
, State(..), getParserState, setParserState
) where
import Prelude
import Text.ParserCombinators.Parsec.Pos
import Text.ParserCombinators.Parsec.Error
import Control.Monad
{-# INLINE parsecMap #-}
{-# INLINE parsecReturn #-}
{-# INLINE parsecBind #-}
{-# INLINE parsecZero #-}
{-# INLINE parsecPlus #-}
{-# INLINE token #-}
{-# INLINE tokenPrim #-}
-----------------------------------------------------------
-- Operators:
-- <?> gives a name to a parser (which is used in error messages)
-- <|> is the choice operator
-----------------------------------------------------------
infix 0 <?>
infixr 1 <|>
(<?>) :: GenParser tok st a -> String -> GenParser tok st a
p <?> msg = label p msg
(<|>) :: GenParser tok st a -> GenParser tok st a -> GenParser tok st a
p1 <|> p2 = mplus p1 p2
-----------------------------------------------------------
-- User state combinators
-----------------------------------------------------------
getState :: GenParser tok st st
getState = do{ state <- getParserState
; return (stateUser state)
}
setState :: st -> GenParser tok st ()
setState st = do{ updateParserState (\(State input pos _) -> State input pos st)
; return ()
}
updateState :: (st -> st) -> GenParser tok st ()
updateState f = do{ updateParserState (\(State input pos user) -> State input pos (f user))
; return ()
}
-----------------------------------------------------------
-- Parser state combinators
-----------------------------------------------------------
getPosition :: GenParser tok st SourcePos
getPosition = do{ state <- getParserState; return (statePos state) }
getInput :: GenParser tok st [tok]
getInput = do{ state <- getParserState; return (stateInput state) }
setPosition :: SourcePos -> GenParser tok st ()
setPosition pos = do{ updateParserState (\(State input _ user) -> State input pos user)
; return ()
}
setInput :: [tok] -> GenParser tok st ()
setInput input = do{ updateParserState (\(State _ pos user) -> State input pos user)
; return ()
}
getParserState :: GenParser tok st (State tok st)
getParserState = updateParserState id
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
data Consumed a = Consumed a --input is consumed
| Empty !a --no input is consumed
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
-----------------------------------------------------------
parseFromFile :: Parser a -> SourceName -> IO (Either ParseError a)
parseFromFile p fname
= do{ input <- readFile fname
; return (parse p fname input)
}
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
parse :: GenParser tok () a -> SourceName -> [tok] -> Either ParseError a
parse p name input
= runParser p () name 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 result
= case result of
Consumed reply -> reply
Empty reply -> reply
-----------------------------------------------------------
-- Functor: fmap
-----------------------------------------------------------
instance Functor (GenParser tok st) where
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
-----------------------------------------------------------
-- Monad: return, sequence (>>=) and fail
-----------------------------------------------------------
instance Monad (GenParser tok st) where
return x = parsecReturn x
p >>= f = parsecBind p f
fail msg = parsecFail msg
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)
)
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))))
-----------------------------------------------------------
-- MonadPlus: alternative (mplus) and mzero
-----------------------------------------------------------
instance MonadPlus (GenParser tok st) where
mzero = parsecZero
mplus p1 p2 = parsecPlus p1 p2
pzero :: GenParser tok st a
pzero = parsecZero
parsecZero :: GenParser tok st a
parsecZero
= Parser (\state -> Empty (Error (unknownError state)))
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
)
{-
-- 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
-}
-----------------------------------------------------------
-- Primitive Parsers:
-- try, token(Prim), label, unexpected and updateState
-----------------------------------------------------------
try :: GenParser tok st a -> GenParser tok st a
try (Parser p)
= Parser (\state@(State input pos user) ->
case (p state) of
Consumed (Error err) -> Empty (Error (setErrorPos pos err))
Consumed ok -> Consumed ok -- was: Empty ok
empty -> empty
)
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
tokenPrim :: (tok -> String) -> (SourcePos -> tok -> [tok] -> SourcePos) -> (tok -> Maybe a) -> GenParser tok st a
tokenPrim show nextpos test
= tokenPrimEx show nextpos Nothing test
-- | 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)
)
label :: GenParser tok st a -> String -> GenParser tok st a
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
)
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)))
unexpected :: String -> GenParser tok st a
unexpected msg
= Parser (\state -> Empty (Error (newErrorMessage (UnExpect msg) (statePos state))))
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 msg pos = Error (newErrorMessage (SysUnExpect msg) pos)
unknownError state = newErrorUnknown (statePos state)
-----------------------------------------------------------
-- Parsers unfolded for space:
-- if many and skipMany are not defined as primitives,
-- they will overflow the stack on large inputs
-----------------------------------------------------------
many :: GenParser tok st a -> GenParser tok st [a]
many p
= do{ xs <- manyAccum (:) p
; return (reverse xs)
}
skipMany :: GenParser tok st a -> GenParser tok st ()
skipMany p
= do{ manyAccum (\x xs -> []) p
; return ()
}
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)
-----------------------------------------------------------
-- Parsers unfolded for speed:
-- tokens
-----------------------------------------------------------
{- specification of @tokens@:
tokens showss nextposs s
= scan s
where
scan [] = return s
scan (c:cs) = do{ token show nextpos c <?> shows s; scan cs }
show c = shows [c]
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 c = Error (setErrorMessage (Expect (shows s))
(newErrorMessage (SysUnExpect (shows [c])) pos))
walk [] cs = ok cs
walk xs [] = errEof
walk (x:xs) (c:cs)| x == c = walk xs cs
| otherwise = errExpect c
walk1 [] cs = Empty (ok cs)
walk1 xs [] = Empty (errEof)
walk1 (x:xs) (c:cs)| x == c = Consumed (walk xs cs)
| otherwise = Empty (errExpect c)
in walk1 s input)
|
