Text/ParserCombinators/Parsec/Prim.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Text.ParserCombinators.Parsec.Prim
   4 -- Copyright   :  (c) Daan Leijen 1999-2001
   5 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   6 --
   7 -- Maintainer  :  daan@cs.uu.nl
   8 -- Stability   :  provisional
   9 -- Portability :  portable
  10 --
  11 -- The primitive parser combinators.
  12 --
  13 -----------------------------------------------------------------------------
  14
  15 module Text.ParserCombinators.Parsec.Prim
  16                    ( -- operators: label a parser, alternative
  17                      (<?>), (<|>)
  18
  19                    -- basic types
  20                    , Parser, GenParser
  21                    , runParser, parse, parseFromFile, parseTest
  22
  23                    -- primitive parsers:
  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
  29
  30                    -- primitive because of space behaviour
  31                    , many, skipMany
  32
  33                    -- user state manipulation
  34                    , getState, setState, updateState
  35
  36                    -- state manipulation
  37                    , getPosition, setPosition
  38                    , getInput, setInput
  39                    , getParserState, setParserState
  40                  ) where
  41
  42 import Text.ParserCombinators.Parsec.Pos
  43 import Text.ParserCombinators.Parsec.Error
  44 import Control.Monad
  45
  46 {-# INLINE parsecMap    #-}
  47 {-# INLINE parsecReturn #-}
  48 {-# INLINE parsecBind   #-}
  49 {-# INLINE parsecZero   #-}
  50 {-# INLINE parsecPlus   #-}
  51 {-# INLINE token        #-}
  52 {-# INLINE tokenPrim    #-}
  53
  54 -----------------------------------------------------------
  55 -- Operators:
  56 -- <?>  gives a name to a parser (which is used in error messages)
  57 -- <|>  is the choice operator
  58 -----------------------------------------------------------
  59 infix  0 <?>
  60 infixr 1 <|>
  61
  62 (<?>) :: GenParser tok st a -> String -> GenParser tok st a
  63 p <?> msg           = label p msg
  64
  65 (<|>) :: GenParser tok st a -> GenParser tok st a -> GenParser tok st a
  66 p1 <|> p2           = mplus p1 p2
  67
  68
  69 -----------------------------------------------------------
  70 -- User state combinators
  71 -----------------------------------------------------------
  72 getState :: GenParser tok st st
  73 getState        = do{ state <- getParserState
  74                     ; return (stateUser state)
  75                     }
  76
  77 setState :: st -> GenParser tok st ()
  78 setState st     = do{ updateParserState (\(State input pos _) -> State input pos st)
  79                     ; return ()
  80                     }
  81
  82 updateState :: (st -> st) -> GenParser tok st ()
  83 updateState f   = do{ updateParserState (\(State input pos user) -> State input pos (f user))
  84                     ; return ()
  85                     }
  86
  87
  88 -----------------------------------------------------------
  89 -- Parser state combinators
  90 -----------------------------------------------------------
  91 getPosition :: GenParser tok st SourcePos
  92 getPosition         = do{ state <- getParserState; return (statePos state) }
  93
  94 getInput :: GenParser tok st [tok]
  95 getInput            = do{ state <- getParserState; return (stateInput state) }
  96
  97
  98 setPosition :: SourcePos -> GenParser tok st ()
  99 setPosition pos     = do{ updateParserState (\(State input _ user) -> State input pos user)
 100                         ; return ()
 101                         }
 102
 103 setInput :: [tok] -> GenParser tok st ()
 104 setInput input      = do{ updateParserState (\(State _ pos user) -> State input pos user)
 105                         ; return ()
 106                         }
 107
 108 getParserState      = updateParserState id
 109 setParserState st   = updateParserState (const st)
 110
 111
 112
 113
 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
 121
 122 newtype GenParser tok st a = Parser (State tok st -> Consumed (Reply tok st a))
 123 runP (Parser p)            = p
 124
 125 data Consumed a         = Consumed a                --input is consumed
 126                         | Empty !a                  --no input is consumed
 127
 128 data Reply tok st a     = Ok a (State tok st) ParseError      --parsing succeeded with "a"
 129                         | Error ParseError                    --parsing failed
 130
 131 data State tok st       = State { stateInput :: [tok]
 132                                 , statePos   :: SourcePos
 133                                 , stateUser  :: !st
 134                                 }
 135
 136
 137 -----------------------------------------------------------
 138 -- run a parser
 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)
 144         }
 145
 146 parseTest :: Show a => GenParser tok () a -> [tok] -> IO ()
 147 parseTest p input
 148     = case (runParser p () "" input) of
 149         Left err -> do{ putStr "parse error at "
 150                       ; print err
 151                       }
 152         Right x  -> print x
 153
 154
 155 parse p name input
 156     = runParser p () name input
 157
 158
 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
 162         Ok x _ _    -> Right x
 163         Error err   -> Left err
 164
 165 parserReply result
 166     = case result of
 167         Consumed reply -> reply
 168         Empty reply    -> reply
 169
 170
 171 -----------------------------------------------------------
 172 -- Functor: fmap
 173 -----------------------------------------------------------
 174 instance Functor (GenParser tok st) where
 175   fmap f p  = parsecMap f p
 176
 177 parsecMap :: (a -> b) -> GenParser tok st a -> GenParser tok st b
 178 parsecMap f (Parser p)
 179     = Parser (\state ->
 180         case (p state) of
 181           Consumed reply -> Consumed (mapReply reply)
 182           Empty    reply -> Empty    (mapReply reply)
 183       )
 184     where
 185       mapReply reply
 186         = case reply of
 187             Ok x state err -> let fx = f x
 188                               in seq fx (Ok fx state err)
 189             Error err      -> Error err
 190
 191
 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
 199
 200 parsecReturn :: a -> GenParser tok st a
 201 parsecReturn x
 202   = Parser (\state -> Empty (Ok x state (unknownError state)))
 203
 204 parsecBind :: GenParser tok st a -> (a -> GenParser tok st b) -> GenParser tok st b
 205 parsecBind (Parser p) f
 206     = Parser (\state ->
 207         case (p state) of
 208           Consumed reply1
 209             -> Consumed $
 210                case (reply1) of
 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
 215
 216           Empty reply1
 217             -> case (reply1) of
 218                  Ok x state1 err1 -> case runP (f x) state1 of
 219                                        Empty reply2 -> Empty (mergeErrorReply err1 reply2)
 220                                        other        -> other
 221                  Error err1       -> Empty (Error err1)
 222       )
 223
 224 mergeErrorReply err1 reply
 225   = case reply of
 226       Ok x state err2 -> Ok x state (mergeError err1 err2)
 227       Error err2      -> Error (mergeError err1 err2)
 228
 229
 230 parsecFail :: String -> GenParser tok st a
 231 parsecFail msg
 232   = Parser (\state ->
 233       Empty (Error (newErrorMessage (Message msg) (statePos state))))
 234
 235
 236 -----------------------------------------------------------
 237 -- MonadPlus: alternative (mplus) and mzero
 238 -----------------------------------------------------------
 239 instance MonadPlus (GenParser tok st) where
 240   mzero         = parsecZero
 241   mplus p1 p2   = parsecPlus p1 p2
 242
 243
 244 pzero :: GenParser tok st a
 245 pzero = parsecZero
 246
 247 parsecZero :: GenParser tok st a
 248 parsecZero
 249     = Parser (\state -> Empty (Error (unknownError state)))
 250
 251 parsecPlus :: GenParser tok st a -> GenParser tok st a -> GenParser tok st a
 252 parsecPlus (Parser p1) (Parser p2)
 253     = Parser (\state ->
 254         case (p1 state) of
 255           Empty (Error err) -> case (p2 state) of
 256                                  Empty reply -> Empty (mergeErrorReply err reply)
 257                                  consumed    -> consumed
 258           other             -> other
 259       )
 260
 261
 262 {-
 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
 265                                    Error err ->
 266                                      case (p2 state) of
 267                                        Empty reply -> Empty (mergeErrorReply err reply)
 268                                        consumed    -> consumed
 269                                    ok ->
 270                                      case (p2 state) of
 271                                        Empty reply -> empty
 272                                        consumed    -> consumed
 273           consumed  -> consumed
 274 -}
 275
 276
 277 -----------------------------------------------------------
 278 -- Primitive Parsers:
 279 --  try, token(Prim), label, unexpected and updateState
 280 -----------------------------------------------------------
 281 try :: GenParser tok st a -> GenParser tok st a
 282 try (Parser p)
 283     = Parser (\state@(State input pos user) ->
 284         case (p state) of
 285           Consumed (Error err)  -> Empty (Error (setErrorPos pos err))
 286           Consumed ok           -> Consumed ok    -- was: Empty ok
 287           empty                 -> empty
 288       )
 289
 290
 291 token :: (tok -> String) -> (tok -> SourcePos) -> (tok -> Maybe a) -> GenParser tok st a
 292 token show tokpos test
 293   = tokenPrim show nextpos test
 294   where
 295     nextpos _ _   (tok:toks)  = tokpos tok
 296     nextpos _ tok []          = tokpos tok
 297
 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) ->
 301         case input of
 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)
 309       )
 310
 311
 312 label :: GenParser tok st a -> String -> GenParser tok st a
 313 label p msg
 314   = labels p [msg]
 315
 316 labels (Parser p) msgs
 317     = Parser (\state ->
 318         case (p state) of
 319           Empty reply -> Empty $
 320                          case (reply) of
 321                            Error err        -> Error (setExpectErrors err msgs)
 322                            Ok x state1 err  | errorIsUnknown err -> reply
 323                                             | otherwise -> Ok x state1 (setExpectErrors err msgs)
 324           other       -> other
 325       )
 326
 327
 328 updateParserState :: (State tok st -> State tok st) -> GenParser tok st (State tok st)
 329 updateParserState f
 330     = Parser (\state -> let newstate = f state
 331                         in seq newstate $
 332                            Empty (Ok state newstate (unknownError newstate)))
 333
 334
 335 unexpected :: String -> GenParser tok st a
 336 unexpected msg
 337     = Parser (\state -> Empty (Error (newErrorMessage (UnExpect msg) (statePos state))))
 338
 339
 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
 344
 345 sysUnExpectError msg pos  = Error (newErrorMessage (SysUnExpect msg) pos)
 346 unknownError state        = newErrorUnknown (statePos state)
 347
 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]
 354 many p
 355   = do{ xs <- manyAccum (:) p
 356       ; return (reverse xs)
 357       }
 358
 359 skipMany :: GenParser tok st a -> GenParser tok st ()
 360 skipMany p
 361   = do{ manyAccum (\x xs -> []) p
 362       ; return ()
 363       }
 364
 365 manyAccum :: (a -> [a] -> [a]) -> GenParser tok st a -> GenParser tok st [a]
 366 manyAccum accum (Parser p)
 367   = Parser (\state ->
 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'))
 374     in case (p state) of
 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)
 379
 380
 381
 382 -----------------------------------------------------------
 383 -- Parsers unfolded for speed:
 384 --  tokens
 385 -----------------------------------------------------------
 386
 387 {- specification of @tokens@:
 388 tokens showss nextposs s
 389   = scan s
 390   where
 391     scan []       = return s
 392     scan (c:cs)   = do{ token show nextpos c <?> shows s; scan cs }
 393
 394     show c        = shows [c]
 395     nextpos pos c = nextposs pos [c]
 396 -}
 397
 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) ->
 401        let
 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))
 406
 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))
 411
 412         walk [] cs        = ok cs
 413         walk xs []        = errEof
 414         walk (x:xs) (c:cs)| x == c        = walk xs cs
 415                           | otherwise     = errExpect c
 416
 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)
 421
 422        in walk1 s input)
 423
 424